├── .gitignore ├── BeautifulFolding.hs ├── YonedaIsFunctor.coq ├── CodensitySet.hs ├── LICENSE ├── Delcont.hs ├── Generics3.hs ├── GeneralisedApplicative.hs ├── ArrayTraversal.hs ├── DeforestFree.hs ├── OperationalSearchApplicative.hs ├── ANormalisation.hs ├── StreamFusionReassoc.hs ├── ArrowNormalisation.hs ├── Generics4.hs ├── ListMonads.hs ├── GADTZipper.hs ├── DelayedApplicative.hs ├── Generics1.hs ├── DelayedApplicativeGADT.hs ├── DelayedApplicativeGADTModular.hs ├── Cont.hs ├── DelayedApplicativeGADTModular2.hs ├── IdiomNormalisation.hs ├── Generics2.hs ├── 0CFA.hs ├── BFS-DFS.hs ├── Graphs.hs └── Mother.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # Build artifacts 2 | *.hi 3 | *.o 4 | StreamFusionReassoc 5 | DeforestFree 6 | 7 | -------------------------------------------------------------------------------- /BeautifulFolding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | 3 | -- Data type from Max Rabkin's "Beautiful Folding" (http://squing.blogspot.com/2008/11/beautiful-folding.html): 4 | -- Fold over list of type |[b]| with result of type |c| 5 | data Fold b c = forall a. F (a -> b -> a) a (a -> c) 6 | 7 | 8 | -- Data type after existential elimination, Oleg-style: 9 | data Fold' b c = F' (b -> Fold' b c) c 10 | 11 | back :: Fold' b c -> Fold b c 12 | back f' = F (\(F' x _) b -> x b) f' (\(F' _ y) -> y) 13 | 14 | forth :: Fold b c -> Fold' b c 15 | forth (F x a y) = F' (\b -> forth (F x (x a b) y)) (y a) 16 | 17 | 18 | main :: IO () 19 | main = return () 20 | -------------------------------------------------------------------------------- /YonedaIsFunctor.coq: -------------------------------------------------------------------------------- 1 | Section YonedaIsFunctor. 2 | 3 | Inductive yoneda (F : Set -> Set) (A : Set) : Type := 4 | | yonedak : (forall (B : Set), (A -> B) -> F B) -> yoneda F A. 5 | 6 | Definition fmap (F : Set -> Set) (A : Set) (B : Set) (f : A -> B) (m : yoneda F A) 7 | := yonedak F B (fun (C : Set) (k : (B -> C)) => match m with 8 | | yonedak m => m C (fun (x : A) => k (f x)) 9 | end). 10 | 11 | Definition id (A : Set) (x : A) := x. 12 | 13 | Theorem first_law : 14 | forall (F : Set -> Set) (A : Set) (m : yoneda F A), 15 | fmap F A A (id A) m = m. 16 | 17 | Theorem second_law : 18 | forall (F : Set -> Set) (A B C : Set) (f : B -> C) (g : A -> B) (m : yoneda F A), 19 | fmap F B C f (fmap F A B g m) = fmap F A C (fun (x : A) => f (g x)) m. 20 | -------------------------------------------------------------------------------- /CodensitySet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | import Control.Applicative 3 | 4 | import Data.Set (Set) 5 | import qualified Data.Set as S 6 | 7 | 8 | newtype CodensityOrd m a = CodensityOrd { runCodensityOrd :: forall b. Ord b => (a -> m b) -> m b } 9 | 10 | -- liftCodensityOrd :: Monad m => m a -> CodensityOrd m a 11 | -- liftCodensityOrd m = CodensityOrd ((>>=) m) 12 | -- 13 | -- lowerCodensityOrd :: (Ord a, Monad m) => CodensityOrd m a -> m a 14 | -- lowerCodensityOrd m = runCodensityOrd m return 15 | 16 | instance Functor (CodensityOrd f) where 17 | fmap f m = CodensityOrd (\k -> runCodensityOrd m (k . f)) 18 | 19 | instance Applicative (CodensityOrd f) where 20 | pure x = CodensityOrd (\k -> k x) 21 | mf <*> mx = CodensityOrd (\k -> runCodensityOrd mf (\f -> runCodensityOrd mx (\x -> k (f x)))) 22 | 23 | instance Monad (CodensityOrd f) where 24 | return = pure 25 | m >>= k = CodensityOrd (\c -> runCodensityOrd m (\a -> runCodensityOrd (k a) c)) 26 | 27 | 28 | liftSet :: Ord a => Set a -> CodensityOrd Set a 29 | liftSet m = CodensityOrd (bind m) 30 | where bind :: (Ord a, Ord b) => Set a -> (a -> Set b) -> Set b 31 | mx `bind` fxmy = S.fold (\x my -> fxmy x `S.union` my) S.empty mx 32 | 33 | lowerSet :: Ord a => CodensityOrd Set a -> Set a 34 | lowerSet m = runCodensityOrd m S.singleton 35 | 36 | 37 | main = print $ lowerSet $ monadicPlus (liftSet $ S.fromList [1, 2, 3]) (liftSet $ S.fromList [1, 2, 3]) 38 | 39 | monadicPlus :: Monad m => m Int -> m Int -> m Int 40 | monadicPlus mx my = do 41 | x <- mx 42 | y <- my 43 | return (x + y) 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Max Bolingbroke 2009-2010. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Max Bolingbroke nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Delcont.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} 2 | module Delcont where 3 | 4 | import Control.Monad 5 | 6 | 7 | newtype Cont r a = Cont { unCont :: (a -> r) -> r } 8 | 9 | runCont :: Cont r r -> r 10 | runCont mx = unCont mx id 11 | 12 | instance Monad (Cont r) where 13 | return x = Cont $ \k -> k x 14 | mx >>= fxmy = Cont $ \k -> unCont mx $ \x -> unCont (fxmy x) k 15 | 16 | callCC :: ((forall b. a -> Cont r b) -> Cont r a) -> Cont r a 17 | callCC f = Cont $ \k -> unCont (f (\x -> Cont $ \_k' -> k x)) k 18 | 19 | shift :: ((forall r'. a -> Cont r' r) -> Cont r r) -> Cont r a 20 | shift f = Cont $ \k -> unCont (f (\x -> Cont $ \k' -> k' (k x))) id 21 | 22 | reset :: Cont a a -> Cont r a 23 | reset mx = Cont $ \k -> k (unCont mx id) 24 | 25 | contTest1 = runCont (callCC (\k -> k 1337) :: Cont Int Int) 26 | 27 | -- ((1 + 1) + (2 + 1)) + 10 28 | -- = 15 29 | contTest2 = runCont (liftM2 (+) (reset (liftM (1+) (shift $ \k -> liftM2 (+) (k 1) (k 2)))) 30 | (reset (liftM (1+) (shift $ \k -> return 10)))) 31 | 32 | 33 | type State r s a = Cont (s -> r) a 34 | 35 | -- We don't need the "reset"s in our translations of the standard definitions in Haskell, 36 | -- since the Cont monad we implemented above has an implicit top-level reset which will do nicely 37 | 38 | runState :: State a s a -> s -> a 39 | runState mx s = runCont (liftM (\x _ -> x) mx) s 40 | 41 | writeCell :: s -> State r s () 42 | writeCell s' = shift $ \f -> return $ \_ -> runCont (f ()) s' 43 | 44 | readCell :: State r s s 45 | readCell = shift $ \f -> return $ \s -> runCont (f s) s 46 | 47 | stateTest1 = runState readCell 1337 48 | stateTest2 = runState (do { writeCell 11; x <- readCell; writeCell (x + 1); readCell }) 10 49 | 50 | -- I don't think you can implement this monad in terms of callCC, this just causes writeCell to abort: 51 | brokenWriteCell :: s -> State r s () 52 | brokenWriteCell _s' = callCC $ \f -> f () 53 | -------------------------------------------------------------------------------- /Generics3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, EmptyDataDecls, ScopedTypeVariables, TypeOperators, FlexibleInstances, FlexibleContexts #-} 2 | 3 | import Data.Monoid 4 | 5 | 6 | -- Type family for evaluators on types 7 | type family E a :: * 8 | 9 | -- Tag for functor application: fundamental to our approach 10 | infixr 9 :% 11 | data f :% a 12 | 13 | -- Tags for evalutor-style data declarations: such declarations contain "internal" 14 | -- occurrences of E, so we can delay evaluation of their arguments 15 | data P0T (f :: *) 16 | type instance E (P0T f) = f 17 | data P1T (f :: * -> *) 18 | type instance E (P1T f :% a) = f a 19 | data P2T (f :: * -> * -> *) 20 | type instance E (P2T f :% a :% b) = f a b 21 | data P3T (f :: * -> * -> * -> *) 22 | type instance E (P3T f :% a :% b :% c) = f a b c 23 | 24 | -- When applying legacy data types we have to manually force the arguments: 25 | data FunT 26 | type instance E (FunT :% a :% b) = E a -> E b 27 | data Tup2T 28 | type instance E (Tup2T :% a :% b) = (E a, E b) 29 | data Tup3T 30 | type instance E (Tup3T :% a :% b :% c) = (E a, E b, E c) 31 | 32 | 33 | -- Evalutor-style versions of some type classes 34 | class FunctorT f where 35 | fmapT :: (E a -> E b) -> E (f :% a) -> E (f :% b) 36 | 37 | class MonoidT a where 38 | memptyT :: E a 39 | mappendT :: E a -> E a -> E a 40 | 41 | 42 | data AdditiveIntT 43 | type instance E AdditiveIntT = Int 44 | instance MonoidT AdditiveIntT where 45 | memptyT = 0 46 | mappendT = (+) 47 | 48 | data MultiplicativeIntT 49 | type instance E MultiplicativeIntT = Int 50 | instance MonoidT MultiplicativeIntT where 51 | memptyT = 1 52 | mappendT = (*) 53 | 54 | -- Make the default instance of Monoid be additive: 55 | instance MonoidT (P0T Int) where 56 | memptyT = memptyT :: E AdditiveIntT 57 | mappendT = mappendT :: E AdditiveIntT -> E AdditiveIntT -> E AdditiveIntT 58 | 59 | 60 | main = do 61 | print (result :: E (P0T Int)) 62 | print (result :: E MultiplicativeIntT) 63 | where 64 | result :: forall a. (E a ~ Int, MonoidT a) => E a 65 | result _ = memptyT `mappendT` 2 `mappendT` 3 -------------------------------------------------------------------------------- /GeneralisedApplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | module GeneralisedApplicative where 3 | 4 | -- What if I have two Records and I want to zip them together? 5 | -- We want to zip each field in a distinctive way. 6 | -- 7 | -- This module shows a possible solution using I concocted that 8 | -- appears to be a generalisation of Applicative 9 | data Record f = Record { 10 | foo :: f Int, 11 | bar :: f Bool, 12 | baz :: f Double 13 | } 14 | 15 | naturality :: (forall a. f a -> g a) 16 | -> Record f -> Record g 17 | naturality f r = Record { 18 | foo = f (foo r), 19 | bar = f (bar r), 20 | baz = f (baz r) 21 | } 22 | 23 | 24 | -- NB: (/\f g -> forall a. Mapper f g a) seems to be a Category in a certain sense, 25 | -- though the lack of kind polymorphism would prevent us from making it a Category instance 26 | newtype Mapper f g a = Mapper { unMapper :: f a -> g a } 27 | 28 | -- Analgous to pure :: a -> r a 29 | pureRecord :: (forall a. f a) -> Record f 30 | pureRecord x = Record { 31 | foo = x, 32 | bar = x, 33 | baz = x 34 | } 35 | 36 | -- Analogous to <*> :: r (a -> b) -> r a -> r b 37 | mapRecord :: Record (Mapper f g) -> Record f -> Record g 38 | mapRecord r1 r2 = Record { 39 | foo = unMapper (foo r1) (foo r2), 40 | bar = unMapper (bar r1) (bar r2), 41 | baz = unMapper (baz r1) (baz r2) 42 | } 43 | 44 | 45 | -- We can use that machinery to implement the zipping operation we were 46 | -- originally after: 47 | 48 | newtype Zipper f g h a = Zipper { unZipper :: f a -> g a -> h a } 49 | 50 | zipRecord :: Record (Zipper f g h) -> Record f -> Record g -> Record h 51 | zipRecord r1 r2 r3 = Record { 52 | foo = unZipper (foo r1) (foo r2) (foo r3), 53 | bar = unZipper (bar r1) (bar r2) (bar r3), 54 | baz = unZipper (baz r1) (baz r2) (baz r3) 55 | } 56 | 57 | zipRecord' :: Record (Zipper f g h) -> Record f -> Record g -> Record h 58 | zipRecord' r1 r2 r3 = mapRecord (doit1 r1 r2) r3 59 | where 60 | doit1 :: Record (Zipper f g h) -> Record f -> Record (Mapper g h) 61 | doit1 r1 r2 = mapRecord (naturality doit2 r1) r2 62 | 63 | doit2 :: Zipper f g h a -> Mapper f (Mapper g h) a 64 | doit2 z = Mapper (Mapper . unZipper z) 65 | 66 | 67 | main :: IO () 68 | main = return () 69 | -------------------------------------------------------------------------------- /ArrayTraversal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, Rank2Types, TupleSections #-} 2 | import Control.Applicative 3 | import Control.Arrow ((&&&), (***)) 4 | 5 | import Data.List 6 | import Data.Traversable 7 | 8 | 9 | class WriterMonad m where 10 | tell :: Int -> m () 11 | 12 | 13 | newtype DfM a = DfM { unDfM :: ([Int], a) } 14 | 15 | instance Functor DfM where 16 | fmap f mx = pure f <*> mx 17 | 18 | instance Applicative DfM where 19 | pure x = DfM ([], x) 20 | mf <*> mx = case unDfM mf of (told1, f) -> case unDfM mx of (told2, x) -> DfM (told1 ++ told2, f x) 21 | 22 | instance Monad DfM where 23 | return x = DfM ([], x) 24 | mx >>= fxmy = case unDfM mx of (told1, x) -> case unDfM (fxmy x) of (told2, y) -> DfM (told1 ++ told2, y) 25 | 26 | instance WriterMonad DfM where 27 | tell x = DfM ([x], ()) 28 | 29 | 30 | -- newtype BfM a = BfM { unBfM :: [([Int], a)] } 31 | -- 32 | -- instance Functor BfM where 33 | -- fmap f mx = pure f <*> mx 34 | -- 35 | -- instance Applicative BfM where 36 | -- pure x = BfM [([], x)] 37 | -- mf <*> mx = BfM [(told1 ++ told2, f x) | (told1, f) <- unBfM mf, (told2, x) <- unBfM mx] 38 | -- 39 | -- instance Monad BfM where 40 | -- return x = BfM [([], x)] 41 | -- mx >>= fxmy = join (fmap fxmy mx) -- BfM [(told1 ++ told2, y) | (told1, x) <- unBfM mx, (told2, y) <- unBfM (fxmy x)] 42 | -- where 43 | -- join :: BfM (BfM a) -> BfM a 44 | -- join = BfM . (\(told, ys) -> map (told,) ys) . (concat *** concat) . map unzip . map unBfM . unBfM 45 | -- 46 | -- instance WriterMonad BfM where 47 | -- tell t = BfM [([t], ())] 48 | 49 | 50 | bitsToNumber :: [Bool] -> Int 51 | bitsToNumber = foldr (\b acc -> acc * 2 + if b then 1 else 0) 0 52 | 53 | tHRESHOLD :: Int 54 | tHRESHOLD = 4 55 | 56 | tree :: (Applicative m, Monad m, WriterMonad m) => [Bool] -> m Int 57 | tree n | length n > tHRESHOLD = return 1 58 | | otherwise = tell (bitsToNumber n) >> traverse tree [False : n, True : n] >>= \[n1, n2] -> return (n1 + n2) 59 | 60 | 61 | 62 | main :: IO () 63 | main = do 64 | print $ unDfM $ tree [True] 65 | --print $ ((concatMap fst &&& map snd) . unBfM) $ tree [True] 66 | 67 | -- Depth-first traversal: ([1,2,4,8,9,5,10,11,3,6,12,13,7,14,15],16) 68 | -- Breadth-first traversal: ([1,2,3,4,5,6,7,8,9,10,11,12,13,14,15],16) 69 | 70 | -------------------------------------------------------------------------------- /DeforestFree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | 3 | import Control.Monad 4 | 5 | 6 | newtype CodensityPlus p a = CodensityPlus { runCodensityPlus :: forall b. (a -> p b -> p b) -> p b -> p b } 7 | 8 | liftCodensityPlus :: MonadPlus p => p a -> CodensityPlus p a 9 | liftCodensityPlus m = CodensityPlus (\fmsuc mfai -> m >>= (\x -> fmsuc x mfai)) 10 | 11 | lowerCodensityPlus :: MonadPlus p => CodensityPlus p a -> p a 12 | lowerCodensityPlus m = runCodensityPlus m (\x mx -> return x `mplus` mx) mzero 13 | 14 | instance Functor (CodensityPlus p) where 15 | fmap f m = CodensityPlus (\fmsuc mfai -> runCodensityPlus m (fmsuc . f) mfai) 16 | 17 | instance Monad (CodensityPlus p) where 18 | return x = CodensityPlus (\fmsuc mfai -> fmsuc x mfai) 19 | mx >>= fxmy = CodensityPlus (\fmsuc mfai -> runCodensityPlus mx (\x mfai -> runCodensityPlus (fxmy x) fmsuc mfai) mfai) 20 | 21 | instance MonadPlus (CodensityPlus p) where 22 | mzero = CodensityPlus (\_fmsuc mfai -> mfai) 23 | m1 `mplus` m2 = CodensityPlus (\fmsuc mfai -> runCodensityPlus m1 fmsuc (runCodensityPlus m2 fmsuc mfai)) 24 | 25 | 26 | {-# NOINLINE interpret #-} 27 | interpret :: [a] -> CodensityPlus [] a 28 | interpret = liftCodensityPlus 29 | 30 | {-# NOINLINE reify #-} 31 | reify :: CodensityPlus [] a -> [a] 32 | reify = lowerCodensityPlus 33 | 34 | 35 | {-# RULES "reify/interpret" forall xs. interpret (reify xs) = xs #-} 36 | 37 | 38 | {-# INLINE mapL #-} 39 | mapL :: (a -> b) -> [a] -> [b] 40 | mapL f xs = reify (mapD f (interpret xs)) 41 | 42 | {-# INLINE mapD #-} 43 | mapD :: Monad m => (a -> b) -> m a -> m b 44 | mapD f mx = do 45 | x <- mx 46 | return (f x) 47 | 48 | {-# INLINE concatMapL #-} 49 | concatMapL f xs = reify (concatMapD (interpret . f) (interpret xs)) 50 | 51 | {-# INLINE concatMapD #-} 52 | concatMapD :: Monad m => (a -> m b) -> m a -> m b 53 | concatMapD = flip (>>=) 54 | 55 | {-# INLINE enumFromToL #-} 56 | enumFromToL :: Int -> Int -> [Int] 57 | enumFromToL x y = reify (enumFromToD x y) 58 | 59 | {-# INLINE enumFromToD #-} 60 | {-# SPECIALISE enumFromToD :: Int -> Int -> CodensityPlus p Int #-} 61 | enumFromToD :: MonadPlus m => Int -> Int -> m Int 62 | enumFromToD x y | x > y = mzero 63 | | otherwise = return x `mplus` enumFromToD (x + 1) y 64 | 65 | 66 | main :: IO () 67 | main = do 68 | print (reify (interpret ([1..10] :: [Int]))) 69 | print (reify (interpret (enumFromToL 1 10 :: [Int]))) 70 | print (mapL (+1) (mapL (+2) (enumFromToL 2 10)) :: [Int]) 71 | print (concatMapL (\y -> return (y+4) `mplus` return (y+5)) (concatMapL (\x -> return (x+2) `mplus` return (x+3)) (enumFromToL 2 10)) :: [Int]) -------------------------------------------------------------------------------- /OperationalSearchApplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, TypeSynonymInstances #-} 2 | import Control.Applicative 3 | import Control.Monad 4 | 5 | import Data.Traversable 6 | 7 | import Debug.Trace 8 | 9 | 10 | class Monad m => MonadSuspend m where 11 | suspend :: String -> m Int 12 | 13 | 14 | 15 | data Program instr a where 16 | Return :: a -> Program instr a 17 | Ap :: Program instr (a -> b) -> Program instr a -> Program instr b 18 | Bind :: Program instr b -> (b -> Program instr a) -> Program instr a 19 | Instr :: instr a -> Program instr a 20 | 21 | 22 | instance Applicative (Program instr) where 23 | pure = return 24 | (<*>) = Ap 25 | 26 | instance Functor (Program instr) where 27 | fmap = liftM 28 | 29 | instance Monad (Program instr) where 30 | return = Return 31 | (>>=) = Bind 32 | 33 | 34 | data ProgramView instr a where 35 | ReturnView :: a -> ProgramView instr a 36 | BindView :: instr b -> (b -> Program instr a ) -> ProgramView instr a 37 | 38 | view :: Program instr a -> ProgramView instr a 39 | view (Return x) = ReturnView x 40 | view ((Return f) `Ap` g) = view (g x) 41 | view (()) 42 | view ((Return x) `Bind` g) = view (g x) 43 | view ((m `Bind` g) `Bind` h) = view (m `Bind` (\x -> g x `Bind` h)) 44 | view ((Instr i) `Bind` g) = i `BindView` g 45 | view (Instr i) = i `BindView` Return 46 | 47 | 48 | -- newtype JumpM a = 49 | -- 50 | -- instance Functor JumpM where 51 | -- fmap = liftM 52 | -- 53 | -- instance Applicative JumpM where 54 | -- pure = return 55 | -- mf <*> mx = ... 56 | -- 57 | -- instance Monad JumpM where 58 | -- return = ... 59 | -- mx >>= fxmy = ... 60 | 61 | 62 | data JumpI a where 63 | Suspend :: String -> JumpI Int 64 | 65 | type JumpM = Program JumpI 66 | 67 | instance MonadSuspend JumpM where 68 | suspend = Instr . Suspend 69 | 70 | 71 | 72 | runJumpM :: JumpM a -> a 73 | runJumpM = go id 74 | where 75 | go = undefined 76 | -- go :: [(Int -> )] -> (a -> b) -> JumpM a -> b 77 | -- go others k (Return x) = k x 78 | -- go others k (mf `Ap` mx) = go (\f -> go (\x -> k (f x)) mx) mf 79 | -- go others k (mx `Bind` fxmy) = go (go k . fxmy) mx 80 | -- go others k (Instr (Suspend s)) = trace s $ k 1 81 | 82 | 83 | 84 | bitsToNumber :: [Bool] -> Int 85 | bitsToNumber = foldr (\b acc -> acc * 2 + if b then 1 else 0) 0 86 | 87 | tHRESHOLD :: Int 88 | tHRESHOLD = 4 89 | 90 | tree :: (Applicative m, MonadSuspend m) => [Bool] -> m Int 91 | tree n | length n > tHRESHOLD = return 1 92 | | otherwise = suspend ("Suspension point: " ++ show (bitsToNumber n)) >>= \_ -> traverse tree [False : n, True : n] >>= \[n1, n2] -> return (n1 + n2) 93 | 94 | 95 | 96 | main :: IO () 97 | main = print $ runJumpM $ tree [True] -------------------------------------------------------------------------------- /ANormalisation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | import Text.PrettyPrint.HughesPJClass 3 | 4 | import System.IO.Unsafe 5 | 6 | import Control.Monad.State 7 | 8 | 9 | type UniqM = State [Int] 10 | 11 | uniqSupply :: [Int] 12 | uniqSupply = [0..] 13 | 14 | runUniq :: UniqM a -> a 15 | runUniq = flip evalState uniqSupply 16 | 17 | unique :: UniqM Int 18 | unique = get >>= \(x:ss) -> put ss >> return x 19 | 20 | 21 | -- -- Codensity is the "mother of all monads": 22 | -- 23 | -- -- return :: forall b. b -> m b 24 | -- -- (>>=) :: forall a. m a -> (forall b. (a -> m b) -> m b) 25 | -- -- 26 | -- -- return a >>= f = f a -- Left identity 27 | -- -- m >>= return = m -- Right identity 28 | -- -- (m >>= f) >>= g = m >>= (\x -> f x >>= g) -- Associativity 29 | -- newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b } 30 | -- 31 | -- liftCodensity :: Monad m => m a -> Codensity m a 32 | -- liftCodensity m = Codensity ((>>=) m) 33 | -- 34 | -- lowerCodensity :: Monad m => Codensity m a -> m a 35 | -- lowerCodensity m = runCodensity m return 36 | -- 37 | -- instance Functor (Codensity f) where 38 | -- fmap f m = Codensity (\k -> runCodensity m (k . f)) 39 | -- 40 | -- instance Applicative (Codensity f) where 41 | -- pure = return 42 | -- mf <*> mx = Codensity (\k -> runCodensity mf (\f -> runCodensity mx (\x -> k (f x)))) 43 | -- 44 | -- instance Monad (Codensity f) where 45 | -- return x = Codensity (\k -> k x) 46 | -- m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c)) 47 | 48 | 49 | instance Pretty MonadSyn where 50 | pPrint = runUniq . pPrintMonadSyn 51 | 52 | pPrintMonadSyn (Return e) = return $ text "return" <+> text e 53 | pPrintMonadSyn (Bind mx fxmy) = do 54 | x <- fmap (\i -> "x" ++ show i) unique 55 | liftM2 (\dmx dmy -> text "let" <+> text x <+> text "=" <+> dmx $$ text "in" <+> dmy) (pPrintMonadSyn mx) (pPrintMonadSyn (fxmy x)) 56 | pPrintMonadSyn (Foreign e) = return $ text e 57 | 58 | 59 | type Term = String 60 | 61 | data MonadSyn = Return Term 62 | | Bind MonadSyn (String -> MonadSyn) 63 | | Foreign String 64 | 65 | normalise :: MonadSyn -> MonadSyn 66 | normalise m = go m Return 67 | where 68 | go :: MonadSyn -> (String -> MonadSyn) -> MonadSyn 69 | go (Return x) k = k x 70 | go (Bind m k) c = go m (\a -> go (k a) c) 71 | 72 | go (Foreign x) k = Bind (Foreign x) k 73 | 74 | 75 | non_normalised = Bind (Return "10") $ \x -> 76 | Bind (Bind (Bind (Foreign "get") (\y -> Return y)) (\z -> Bind (Foreign ("put " ++ x)) (\_ -> Return z))) $ \w -> 77 | Return w 78 | 79 | main = do 80 | putStrLn "== Before" 81 | print $ pPrint non_normalised 82 | 83 | putStrLn "== After" 84 | print $ pPrint $ normalise non_normalised 85 | -------------------------------------------------------------------------------- /StreamFusionReassoc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, BangPatterns, TypeOperators #-} 2 | import Prelude hiding (enumFromTo, concatMap, replicate) 3 | 4 | data Stream a = forall s. Stream !(s -> Step a s) -- a stepper function 5 | !s -- an initial state 6 | 7 | -- | A stream step. 8 | -- 9 | -- A step either ends a stream, skips a value, or yields a value 10 | -- 11 | data Step a s = Yield a !s 12 | | Skip !s 13 | | Done 14 | 15 | 16 | -- | Construct an abstract stream from a list. 17 | stream :: [a] -> Stream a 18 | stream xs0 = Stream next xs0 19 | where 20 | {-# INLINE next #-} 21 | next [] = Done 22 | next (x:xs) = Yield x xs 23 | {-# INLINE [0] stream #-} 24 | 25 | -- | Flatten a stream back into a list. 26 | unstream :: Stream a -> [a] 27 | unstream (Stream next s0) = unfold_unstream s0 28 | where 29 | unfold_unstream !s = case next s of 30 | Done -> [] 31 | Skip s' -> unfold_unstream s' 32 | Yield x s' -> x : unfold_unstream s' 33 | {-# INLINE [0] unstream #-} 34 | 35 | -- 36 | -- /The/ stream fusion rule 37 | -- 38 | 39 | {-# RULES 40 | "STREAM stream/unstream fusion" forall s. 41 | stream (unstream s) = s 42 | #-} 43 | 44 | 45 | {-# INLINE replicate #-} 46 | replicate n x = unstream (replicateS n x) 47 | 48 | {-# INLINE [0] replicateS #-} 49 | replicateS :: Int -> a -> Stream a 50 | replicateS n x = Stream next n 51 | where 52 | {-# INLINE next #-} 53 | next !i | i <= 0 = Done 54 | | otherwise = Yield x (i-1) 55 | 56 | {-# INLINE enumFromTo #-} 57 | enumFromTo x y = unstream (enumFromToS x y) 58 | 59 | {-# INLINE [0] enumFromToS #-} 60 | enumFromToS x y = Stream step x 61 | where 62 | {-# INLINE step #-} 63 | step x | x <= y = Yield x (x + 1) 64 | | otherwise = Done 65 | 66 | data a :!: b = !a :!: !b 67 | 68 | {-# INLINE concatMap #-} 69 | concatMap f xs = unstream (concatMapS (stream . f) (stream xs)) 70 | 71 | {-# INLINE [0] concatMapS #-} 72 | concatMapS :: (a -> Stream b) -> Stream a -> Stream b 73 | concatMapS f (Stream next0 s0) = Stream next (s0 :!: Nothing) 74 | where 75 | {-# INLINE next #-} 76 | next (s :!: Nothing) = case next0 s of 77 | Done -> Done 78 | Skip s' -> Skip (s' :!: Nothing) 79 | Yield x s' -> Skip (s' :!: Just (f x)) 80 | 81 | next (s :!: Just (Stream g t)) = case g t of 82 | Done -> Skip (s :!: Nothing) 83 | Skip t' -> Skip (s :!: Just (Stream g t')) 84 | Yield x t' -> Yield x (s :!: Just (Stream g t')) 85 | 86 | -- [1,1,2,2,3,3,4,4,5,5,2,2,3,3,4,4,5,5,3,3,4,4,5,5,4,4,5,5,5,5] 87 | main = do 88 | print $ concatMap (\y -> replicate 2 y) (concatMap (\x -> enumFromTo x 5) (enumFromTo 1 (5 :: Int))) 89 | --print $ concatMap (\x -> concatMap (\y -> replicate 2 y) (enumFromTo x 5)) (enumFromTo 1 (5 :: Int)) 90 | -------------------------------------------------------------------------------- /ArrowNormalisation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | import Text.PrettyPrint.HughesPJClass 3 | 4 | import System.IO.Unsafe 5 | 6 | import Control.Monad.State 7 | 8 | 9 | type UniqM = State [Int] 10 | 11 | uniqSupply :: [Int] 12 | uniqSupply = [0..] 13 | 14 | runUniq :: UniqM a -> a 15 | runUniq = flip evalState uniqSupply 16 | 17 | unique :: UniqM Int 18 | unique = get >>= \(x:ss) -> put ss >> return x 19 | 20 | 21 | instance Pretty ArrowSyn where 22 | pPrint Id = text "id" 23 | pPrint (Comp a1 a2) = pPrint a1 <+> text "." <+> pPrint a2 24 | pPrint (Arr e) = text "arr" <+> parens (pPrint (Lam e)) 25 | pPrint (First a) = text "first" <+> pPrint a 26 | pPrint (Foreign e) = text e 27 | 28 | instance Pretty Term where 29 | pPrint = runUniq . pPrintTerm 30 | 31 | pPrintTerm (Lam f) = do 32 | x <- fmap (\i -> "x" ++ show i) unique 33 | return $ parens $ text "\\" <> text x <+> text "->" <+> pPrint (f (ForeignE x)) 34 | pPrintTerm (App e1 e2) = liftM2 (\e1 e2 -> e1 <+> parens e2) (pPrintTerm e1) (pPrintTerm e2) 35 | pPrintTerm (ForeignE e) = return $ text e 36 | 37 | 38 | data Term = Lam (Term -> Term) 39 | | App Term Term 40 | | ForeignE String 41 | 42 | data ArrowSyn = Id 43 | | Comp ArrowSyn ArrowSyn 44 | | Arr (Term -> Term) 45 | | First ArrowSyn 46 | | Foreign String 47 | 48 | normalise :: ArrowSyn -> ArrowSyn 49 | normalise m = Arr (ForeignE "fst" `App`) `Comp` go m Arr (\x -> x) `Comp` Arr (\x -> ForeignE "(\\x -> (x, ()))" `App` x) 50 | where 51 | -- r a b -> forall e. (forall d. (d -> (b, c)) -> p d e) -> (forall e. (e -> (a, c)) -> p e e) 52 | go :: ArrowSyn -> ( (Term -> Term) -> ArrowSyn) -> ( (Term -> Term) -> ArrowSyn) 53 | go Id = \k k' -> k k' 54 | go (Comp a1 a2) = go a2 . go a1 55 | go (Arr e) = \k k' -> k (e . k') 56 | go (First a) = (\k k' -> k (assoc . k')) . go a . (\k k' -> k (reassoc . k')) 57 | where assoc = App (ForeignE "assoc") 58 | reassoc = App (ForeignE "reassoc") 59 | go (Foreign e) = \k k' -> k id `Comp` First (Foreign e) `Comp` Arr k' 60 | 61 | 62 | non_normaliseds = [ 63 | Id, 64 | 65 | First (Arr (ForeignE "f" `App`)), 66 | Arr (ForeignE "f `cross` id" `App`), 67 | 68 | First (Foreign "g" `Comp` Foreign "f"), 69 | First (Foreign "g") `Comp` First (Foreign "f"), 70 | 71 | Arr (ForeignE "id `cross` g" `App`) `Comp` First (Foreign "f"), 72 | First (Foreign "f") `Comp` Arr (ForeignE "id `cross` g" `App`), 73 | 74 | Arr (ForeignE "fst" `App`) `Comp` First (Foreign "f"), 75 | Foreign "f" `Comp` Arr (ForeignE "fst" `App`), 76 | 77 | Arr (ForeignE "assoc" `App`) `Comp` First (First (Foreign "f")), 78 | First (Foreign "f") `Comp` Arr (ForeignE "assoc" `App`) 79 | ] 80 | 81 | main = forM_ non_normaliseds $ \non_normalised -> do 82 | putStrLn "== Before" 83 | print $ pPrint non_normalised 84 | 85 | putStrLn "== After" 86 | print $ pPrint $ normalise non_normalised -------------------------------------------------------------------------------- /Generics4.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, EmptyDataDecls, ScopedTypeVariables, TypeOperators, FlexibleInstances, FlexibleContexts #-} 2 | 3 | import Data.Monoid 4 | 5 | 6 | -- Type family for evaluators on types 7 | newtype E a = E { unE :: E' a } -- Work around lack of type application by reifying a type witnesses as a newtype parameter 8 | type family E' a :: * 9 | 10 | -- Tag for functor application: fundamental to our approach 11 | infixr 9 :% 12 | data f :% a 13 | 14 | -- Tags for evalutor-style data declarations: such declarations contain "internal" 15 | -- occurrences of E, so we can delay evaluation of their arguments 16 | data P0T (f :: *) 17 | type instance E' (P0T f) = f 18 | data P1T (f :: * -> *) 19 | type instance E' (P1T f :% a) = f a 20 | data P2T (f :: * -> * -> *) 21 | type instance E' (P2T f :% a :% b) = f a b 22 | data P3T (f :: * -> * -> * -> *) 23 | type instance E' (P3T f :% a :% b :% c) = f a b c 24 | 25 | -- When applying legacy data types we have to manually force the arguments: 26 | data FunT 27 | type instance E' (FunT :% a :% b) = E a -> E b 28 | data Tup2T 29 | type instance E' (Tup2T :% a :% b) = (E a, E b) 30 | data Tup3T 31 | type instance E' (Tup3T :% a :% b :% c) = (E a, E b, E c) 32 | 33 | 34 | -- Type-level fixed points require UndecidableInstances, as you would expect! 35 | --data FixT 36 | --type instance E' (FixT :% f) = E' (f :% (FixT :% f)) 37 | 38 | 39 | -- Evalutor-style versions of some type classes 40 | class FunctorT f where 41 | fmapT :: (E a -> E b) -> E (f :% a) -> E (f :% b) 42 | 43 | class MonoidT a where 44 | memptyT :: E a 45 | mappendT :: E a -> E a -> E a 46 | 47 | 48 | data AdditiveIntT 49 | type instance E' AdditiveIntT = Int 50 | instance MonoidT AdditiveIntT where 51 | memptyT = E 0 52 | mappendT (E x) (E y) = E (x + y) 53 | 54 | data MultiplicativeIntT 55 | type instance E' MultiplicativeIntT = Int 56 | instance MonoidT MultiplicativeIntT where 57 | memptyT = E 1 58 | mappendT (E x) (E y) = E (x * y) 59 | 60 | 61 | castE0 :: (a ~ a') => E a -> E a' 62 | castE0 (E x) = E x 63 | 64 | castE1 :: (a ~ a', b ~ b') => (E a -> E b) -> E a' -> E b' 65 | castE1 f = castE0 . f . castE0 66 | 67 | castE2 :: (a ~ a', b ~ b', c ~ c') => (E a -> E b -> E c) -> E a' -> E b' -> E c' 68 | castE2 f = castE1 . f . castE0 69 | 70 | 71 | -- Make the default instance of Monoid be additive: 72 | instance MonoidT (P0T Int) where 73 | -- FIXME: these two don't work, but I don't fully understand why: 74 | --memptyT = castE0 (memptyT :: E AdditiveIntT) 75 | --mappendT = castE2 (mappendT :: E AdditiveIntT -> E AdditiveIntT -> E AdditiveIntT) 76 | 77 | -- These two do work: 78 | memptyT = case memptyT :: E AdditiveIntT of E x -> E x 79 | mappendT x y = case (mappendT :: E AdditiveIntT -> E AdditiveIntT -> E AdditiveIntT) (case x of E x -> E x) (case y of E y -> E y) of E z -> E z 80 | 81 | 82 | main = do 83 | print $ unE (result :: E (P0T Int)) 84 | print $ unE (result :: E AdditiveIntT) 85 | print $ unE (result :: E MultiplicativeIntT) 86 | where 87 | result :: forall a. (E' a ~ Int, MonoidT a) => E a 88 | result = memptyT `mappendT` E 2 `mappendT` E 3 -------------------------------------------------------------------------------- /ListMonads.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Data.Maybe 3 | 4 | 5 | newtype DfM a = DfM { unDfM :: [a] } 6 | 7 | instance Functor DfM where 8 | fmap f = DfM . fmap f . unDfM 9 | 10 | instance Monad DfM where 11 | return x = DfM [x] 12 | mx >>= fxmy = join $ fmap fxmy mx 13 | where 14 | join :: DfM (DfM a) -> DfM a 15 | join = DfM . dfs . map unDfM . unDfM 16 | 17 | dfs :: [[a]] -> [a] 18 | dfs = concat 19 | fail _ = mzero 20 | 21 | instance MonadPlus DfM where 22 | mzero = DfM [] 23 | mx `mplus` my = DfM $ unDfM mx ++ unDfM my 24 | 25 | 26 | -- 1) Left-identity 27 | -- return a >>= f == f a 28 | -- <==> 29 | -- concat $ fmap f [a] 30 | -- == concat [f a] 31 | -- == f a 32 | -- 33 | -- 2) Right-identity 34 | -- m >>= return == m 35 | -- <==> 36 | -- concat $ fmap (\x -> [x]) m 37 | -- == m 38 | -- 39 | -- 3) Associativity 40 | -- (m >>= f) >>= g == m >>= (\x -> f x >>= g) 41 | -- <==> 42 | -- concat (fmap g (concat (fmap f m))) 43 | -- == ??? 44 | -- == concat (fmap (\x -> concat (fmap g (f x))) m) 45 | 46 | newtype BfM a = BfM { unBfM :: [a] } 47 | 48 | instance Functor BfM where 49 | fmap f = BfM . fmap f . unBfM 50 | 51 | instance Monad BfM where 52 | return x = BfM [x] 53 | mx >>= fxmy = join $ fmap fxmy mx 54 | where 55 | join :: BfM (BfM a) -> BfM a 56 | join = BfM . bfs . map unBfM . unBfM 57 | 58 | bfs :: [[a]] -> [a] 59 | bfs [] = [] 60 | bfs xss = ys ++ bfs yss 61 | where (ys, yss) = unzip $ mapMaybe unconsMaybe xss 62 | unconsMaybe [] = Nothing 63 | unconsMaybe (x:xs) = Just (x, xs) 64 | fail _ = mzero 65 | 66 | instance MonadPlus BfM where 67 | mzero = BfM [] 68 | mx `mplus` my = BfM $ unBfM mx ++ unBfM my 69 | 70 | 71 | 72 | newtype OmegaM a = OmegaM { unOmegaM :: [a] } 73 | 74 | instance Functor OmegaM where 75 | fmap f = OmegaM . fmap f . unOmegaM 76 | 77 | instance Monad OmegaM where 78 | return x = OmegaM [x] 79 | mx >>= fxmy = join $ fmap fxmy mx 80 | where 81 | join :: OmegaM (OmegaM a) -> OmegaM a 82 | join = OmegaM . diagonal . map unOmegaM . unOmegaM 83 | 84 | -- | This is the hinge algorithm of the Omega monad, 85 | -- exposed because it can be useful on its own. Joins 86 | -- a list of lists with the property that for every i j 87 | -- there is an n such that @xs !! i !! j == diagonal xs !! n@. 88 | -- In particular, @n <= (i+j)*(i+j+1)/2 + j@. 89 | diagonal :: [[a]] -> [a] 90 | diagonal = concat . stripe 91 | where 92 | stripe [] = [] 93 | stripe ([]:xss) = stripe xss 94 | stripe ((x:xs):xss) = [x] : zipCons xs (stripe xss) 95 | 96 | zipCons [] ys = ys 97 | zipCons xs [] = map (:[]) xs 98 | zipCons (x:xs) (y:ys) = (x:y) : zipCons xs ys 99 | fail _ = mzero 100 | 101 | instance MonadPlus OmegaM where 102 | mzero = OmegaM [] 103 | mx `mplus` my = OmegaM $ unOmegaM mx ++ unOmegaM my 104 | 105 | 106 | 107 | 108 | mpluses :: MonadPlus m => [m a] -> m a 109 | mpluses = foldr mplus mzero 110 | 111 | 112 | main = do 113 | print $ unDfM $ liftM2 (,) (mpluses [return x | x <- [1..5]]) (mpluses [return x | x <- [-1,-2..(-5)]]) 114 | print $ unBfM $ liftM2 (,) (mpluses [return x | x <- [1..5]]) (mpluses [return x | x <- [-1,-2..(-5)]]) 115 | print $ unOmegaM $ liftM2 (,) (mpluses [return x | x <- [1..5]]) (mpluses [return x | x <- [-1,-2..(-5)]]) 116 | -------------------------------------------------------------------------------- /GADTZipper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, Rank2Types #-} 2 | import Control.Applicative 3 | 4 | 5 | -- data ApplicativeTree a where 6 | -- Pure :: a -> ApplicativeTree a 7 | -- Star :: ApplicativeTree (b -> a) -> ApplicativeTree b -> ApplicativeTree a 8 | -- 9 | -- evaluate :: Applicative f => ApplicativeTree a -> f a 10 | -- evaluate (Pure x) = pure x 11 | -- evaluate (Star t1 t2) = evaluate t1 <*> evaluate t2 12 | 13 | data List a where 14 | Nil :: List a 15 | Cons :: a -> List a -> List a 16 | 17 | data ZList a where 18 | StopList :: List a -> ZList a 19 | Down :: a -> ZList a -> ZList a 20 | 21 | reverseConcatList :: List a -> List a -> List a 22 | reverseConcatList Nil ys = ys 23 | reverseConcatList (Cons x xs) ys = reverseConcatList xs (Cons x ys) 24 | 25 | startList :: List a -> (List a, ZList a) 26 | startList xs = (xs, StopList Nil) 27 | 28 | rebuildList :: List a -> ZList a -> List a 29 | rebuildList xs (StopList ys) = reverseConcatList ys xs 30 | rebuildList xs (Down x zl) = rebuildList (Cons x xs) zl 31 | 32 | down :: List a -> ZList a -> (List a, ZList a) 33 | down (Cons x xs) zl = (xs, Down x zl) 34 | 35 | 36 | data Tree a where 37 | Leaf :: a -> Tree a 38 | Branch :: Tree a -> Tree a -> Tree a 39 | 40 | data ZTree a where 41 | StopTree :: ZTree a 42 | RightTree :: Tree a -> ZTree a -> ZTree a 43 | LeftTree :: ZTree a -> Tree a -> ZTree a 44 | 45 | startTree :: Tree a -> (Tree a, ZTree a) 46 | startTree t = (t, StopTree) 47 | 48 | rebuildTree :: Tree a -> ZTree a -> Tree a 49 | rebuildTree t StopTree = t 50 | rebuildTree t (RightTree tl ztr) = rebuildTree (Branch tl t) ztr 51 | rebuildTree t (LeftTree ztl tr) = rebuildTree (Branch t tr) ztl 52 | 53 | leftTree :: Tree a -> ZTree a -> (Tree a, ZTree a) 54 | leftTree (Branch tl tr) zt = (tl, LeftTree zt tr) 55 | 56 | 57 | -- Free algebra on the Applicative typeclass, plus an "Unexpanded" injection from the standard type 58 | data ApplicativeTree f a where 59 | Unexpanded :: f a -> ApplicativeTree f a 60 | Pure :: a -> ApplicativeTree f a 61 | Star :: ApplicativeTree f (b -> a) -> ApplicativeTree f b -> ApplicativeTree f a 62 | 63 | evaluate :: Applicative f => ApplicativeTree f a -> f a 64 | evaluate (Unexpanded fx) = fx 65 | evaluate (Pure x) = pure x 66 | evaluate (Star t1 t2) = evaluate t1 <*> evaluate t2 67 | 68 | 69 | -- GADT zipper. What the hell do these types mean?? I derived them by performing unification on the "rebuild" algorithm 70 | -- with pencil and paper, so the definitions typechecked. But I have idea what the types really *mean*. 71 | -- 72 | -- Perhaps: 73 | -- zt :: ZApplicativeTree f a a' 74 | -- If (zt) *consumes* an (ApplicativeTree f a) to produce an (ApplicativeTree f a') 75 | data ZApplicativeTree f a a' where 76 | StopApplicativeTree :: ZApplicativeTree f a a 77 | RightApplicativeTree :: ApplicativeTree f (b -> a) -> ZApplicativeTree f a a' -> ZApplicativeTree f b a' 78 | LeftApplicativeTree :: ZApplicativeTree f b a' -> ApplicativeTree f a -> ZApplicativeTree f (a -> b) a' 79 | 80 | startApplicativeTree :: ApplicativeTree f a -> (ApplicativeTree f a, ZApplicativeTree f a a) 81 | startApplicativeTree t = (t, StopApplicativeTree) 82 | 83 | rebuildApplicativeTree :: ApplicativeTree f a -> ZApplicativeTree f a a' -> ApplicativeTree f a' 84 | rebuildApplicativeTree t StopApplicativeTree = t 85 | rebuildApplicativeTree t (RightApplicativeTree tl ztr) = rebuildApplicativeTree (Star tl t) ztr 86 | rebuildApplicativeTree t (LeftApplicativeTree ztl tr) = rebuildApplicativeTree (Star t tr) ztl 87 | 88 | leftApplicativeTree :: ApplicativeTree f a -> ZApplicativeTree f a a' -> (forall b. ApplicativeTree f (b -> a) -> ZApplicativeTree f (b -> a) a' -> r) -> r 89 | leftApplicativeTree (Star tl tr) zt k = k tl (LeftApplicativeTree zt tr) 90 | 91 | rightApplicativeTree :: ApplicativeTree f a -> ZApplicativeTree f a a' -> (forall b. ApplicativeTree f b -> ZApplicativeTree f b a' -> r) -> r 92 | rightApplicativeTree (Star tl tr) zt k = k tr (RightApplicativeTree tl zt) 93 | 94 | 95 | main = return () -------------------------------------------------------------------------------- /DelayedApplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} 2 | module Process2 where 3 | 4 | import Control.Applicative (Applicative(..), liftA2) 5 | import Control.Monad (liftM, liftM2, ap, join) 6 | import Data.Foldable (toList) 7 | import Data.Traversable (Traversable(..)) 8 | import Data.Functor.Identity (Identity(..)) 9 | import Data.Functor.Product (Product(..)) 10 | 11 | import Debug.Trace 12 | 13 | 14 | -- If you don't want DelayM to have Monad structure, you can nuke the nested use of DelayM, 15 | -- and make some of the consumers simpler. I actually want this generalisation, though. 16 | data DelayM q a r = Done r 17 | | forall f. DelayStructure f => Delayed (f q) (f a -> DelayM q a r) 18 | 19 | instance Functor (DelayM q a) where 20 | fmap f x = pure f <*> x 21 | 22 | instance Applicative (DelayM q a) where 23 | pure = return 24 | Done f <*> Done x = Done (f x) 25 | Delayed qs k <*> Done x = Delayed qs (\as -> k as <*> Done x) 26 | Done f <*> Delayed qs k = Delayed qs (\as -> Done f <*> k as) 27 | Delayed qs1 k1 <*> Delayed qs2 k2 = Delayed (Pair qs1 qs2) (\(Pair as1 as2) -> k1 as1 <*> k2 as2) 28 | 29 | instance Monad (DelayM q a) where 30 | return = Done 31 | Done x >>= fxmy = fxmy x 32 | Delayed qs k >>= fxmy = Delayed qs (\as -> k as >>= fxmy) 33 | 34 | delay :: Show q => q -> DelayM q a a 35 | delay q = Delayed (Identity q) (\(Identity a) -> pure a) 36 | 37 | justOne :: Show q => DelayM q a r -> DelayM q a (DelayM q a r) 38 | justOne (Done x) = Done (Done x) 39 | justOne (Delayed qs k) = fmap k (delayMany qs) 40 | 41 | class Traversable f => DelayStructure f where 42 | delayMany :: Show q => f q -> DelayM q a (f a) 43 | 44 | -- For debugging only: 45 | show1 :: Show a => f a -> String 46 | 47 | instance DelayStructure Identity where 48 | delayMany (Identity q) = fmap Identity (delay q) 49 | show1 (Identity x) = "I (" ++ show x ++ ")" 50 | 51 | instance (DelayStructure f, DelayStructure g) => DelayStructure (Product f g) where 52 | -- NB: the use of liftM2 is critical here! It ensures all but the leftmost child will be delayed. 53 | delayMany (Pair qs1 qs2) = liftM2 Pair (delayMany qs1) (delayMany qs2) 54 | show1 (Pair x y) = "P (" ++ show1 x ++ ") (" ++ show1 y ++ ")" 55 | 56 | 57 | -- Simple example supercompiler-alike to show that it all works: 58 | 59 | 60 | type HFunction = Int 61 | --data State = State deriving (Eq) 62 | type State = Int 63 | data Term = Tieback HFunction | Base Int | Split Term Term deriving (Show) 64 | 65 | type ScpM = DelayM State Term 66 | 67 | -- Execution trace: 68 | -- 10 => 9 69 | -- 4 => 3 70 | -- 1 => 0 BASE 71 | -- 2 => 1 BASE 72 | -- 5 => 4 73 | -- 2 => 1 BASE 74 | -- 3 => 2 BASE 75 | 76 | split :: (State -> ScpM Term) 77 | -> State -> ScpM Term 78 | --split = undefined 79 | split f x | x <= 2 = pure (Base x) 80 | | otherwise = liftA2 Split (f (x `div` 2)) (f ((x `div` 2) + 1)) -- Change A2 to M2 to linearise the search :-) 81 | 82 | reduce :: State -> State 83 | --reduce = undefined 84 | reduce x = x-1 85 | 86 | 87 | supercompile :: State -> ([(State, HFunction)], Term) 88 | supercompile state = unMemoM (my_choose (scPostMatch state)) [] 89 | where 90 | -- Depth-first, left-biased exploration of the process tree. 91 | -- NB: by varying the implementation of justOne you change the strategy: 92 | --my_choose = choose justOne 93 | 94 | -- Breadth-first exploration of the process tree: 95 | my_choose = choose return 96 | 97 | -- A simplified version: no sc-history 98 | scPostMatch :: State -> ScpM Term 99 | scPostMatch state = split delay (reduce state) 100 | 101 | 102 | newtype MemoM a = MemoM { unMemoM :: [(State, HFunction)] -> ([(State, HFunction)], a) } 103 | 104 | instance Functor MemoM where 105 | fmap = liftM 106 | 107 | instance Applicative MemoM where 108 | pure = return 109 | (<*>) = ap 110 | 111 | instance Monad MemoM where 112 | return x = MemoM $ \s -> (s, x) 113 | MemoM xf >>= fxmy = MemoM $ \s -> case xf s of (s', x) -> unMemoM (fxmy x) s' 114 | 115 | modify :: ([(State, HFunction)] -> ([(State, HFunction)], a)) 116 | -> MemoM a 117 | modify = MemoM 118 | 119 | choose :: (ScpM a -> ScpM (ScpM a)) 120 | -> ScpM a -> MemoM a 121 | choose choose_some = go 122 | where 123 | go = go' . join . choose_some 124 | 125 | go' (Done x) = pure x 126 | go' (Delayed (qs :: f State) k) = trace ("iteration: " ++ show1 qs) $ traverse sc qs >>= \fs -> go (sequenceA fs >>= k) 127 | 128 | sc :: State -> MemoM (ScpM Term) 129 | sc state = modify $ \memo -> case lookup state memo of 130 | Just h -> (memo, pure (Tieback h)) 131 | Nothing -> ((state, h'):memo, scPostMatch state) 132 | where h' = 1 + maximum (0:map snd memo) 133 | 134 | 135 | main = supercompile 10 -------------------------------------------------------------------------------- /Generics1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, EmptyDataDecls, ScopedTypeVariables #-} 2 | 3 | import Data.Monoid 4 | 5 | 6 | type family Force a :: * 7 | 8 | data Forced (a :: *) 9 | type instance Force (Forced a) = a 10 | 11 | 12 | newtype VarF var term value = AVar { unVar :: String } 13 | 14 | data TermF var term value 15 | = Var (Force var) 16 | | App (Force term) (Force var) 17 | | Value (Force value) 18 | | Add (Force term) (Force term) 19 | 20 | data ValueF var term value 21 | = Literal Int 22 | | Lambda String (Force term) 23 | 24 | data SyntaxAlgebra var term value = SyntaxAlgebra { 25 | varAlgebra :: VarF var term value -> Force var, 26 | termAlgebra :: TermF var term value -> Force term, 27 | valueAlgebra :: ValueF var term value -> Force value 28 | } 29 | 30 | 31 | type Fix3_1 f g h = f (FixTag3_1 f g h) (FixTag3_2 f g h) (FixTag3_3 f g h) 32 | type Fix3_2 f g h = g (FixTag3_1 f g h) (FixTag3_2 f g h) (FixTag3_3 f g h) 33 | type Fix3_3 f g h = h (FixTag3_1 f g h) (FixTag3_2 f g h) (FixTag3_3 f g h) 34 | 35 | data FixTag3_1 f g h 36 | data FixTag3_2 f g h 37 | data FixTag3_3 f g h 38 | type instance Force (FixTag3_1 f g h) = Fix3_1 f g h 39 | type instance Force (FixTag3_2 f g h) = Fix3_2 f g h 40 | type instance Force (FixTag3_3 f g h) = Fix3_3 f g h 41 | 42 | 43 | type Var = Fix3_1 VarF TermF ValueF 44 | type Term = Fix3_2 VarF TermF ValueF 45 | type Value = Fix3_3 VarF TermF ValueF 46 | 47 | 48 | -- TODO: try doing this as a functor category? 49 | fmap3VarF :: (Force var -> Force var') 50 | -> (Force term -> Force term') 51 | -> (Force value -> Force value') 52 | -> VarF var term value 53 | -> VarF var' term' value' 54 | fmap3VarF _var _term _value x = case x of 55 | AVar x -> AVar x 56 | 57 | fmap3TermF :: (Force var -> Force var') 58 | -> (Force term -> Force term') 59 | -> (Force value -> Force value') 60 | -> TermF var term value 61 | -> TermF var' term' value' 62 | fmap3TermF var term value e = case e of 63 | Var x -> Var (var x) 64 | App e x -> App (term e) (var x) 65 | Value v -> Value (value v) 66 | Add e1 e2 -> Add (term e1) (term e2) 67 | 68 | fmap3ValueF :: (Force var -> Force var') 69 | -> (Force term -> Force term') 70 | -> (Force value -> Force value') 71 | -> ValueF var term value 72 | -> ValueF var' term' value' 73 | fmap3ValueF _var term _value v = case v of 74 | Literal l -> Literal l 75 | Lambda x e -> Lambda x (term e) 76 | 77 | foldMap3VarF :: Monoid m 78 | => (Force var -> m) 79 | -> (Force term -> m) 80 | -> (Force value -> m) 81 | -> VarF var term value 82 | -> m 83 | foldMap3VarF _var _term _value x = case x of 84 | AVar _ -> mempty 85 | 86 | foldMap3TermF :: Monoid m 87 | => (Force var -> m) 88 | -> (Force term -> m) 89 | -> (Force value -> m) 90 | -> TermF var term value 91 | -> m 92 | foldMap3TermF var term value e = case e of 93 | Var x -> var x 94 | App e x -> term e `mappend` var x 95 | Value v -> value v 96 | Add e1 e2 -> term e1 `mappend` term e2 97 | 98 | foldMap3ValueF :: Monoid m 99 | => (Force var -> m) 100 | -> (Force term -> m) 101 | -> (Force value -> m) 102 | -> ValueF var term value 103 | -> m 104 | foldMap3ValueF _var term _value v = case v of 105 | Literal _ -> mempty 106 | Lambda _ e -> term e 107 | 108 | 109 | example :: Value 110 | example = Lambda "x" $ Add (Value (Literal 1)) (Var (AVar "x")) `App` AVar "x" 111 | 112 | 113 | -- fixAlgebra :: SyntaxAlgebra var term value -> SyntaxAlgebra (Fix3_1 var term value) (Fix3_2 var term value) (Fix3_3 var term value) 114 | -- fixAlgebra alg = undefined 115 | 116 | applyAlgebra :: forall var term value. 117 | SyntaxAlgebra var term value 118 | -> Term -> Force term 119 | -- -> SyntaxAlgebra (FixTag3_1 VarF TermF ValueF) (FixTag3_2 VarF TermF ValueF) (FixTag3_3 VarF TermF ValueF) 120 | applyAlgebra alg = {- SyntaxAlgebra var term value -- -} term 121 | where 122 | var :: Var -> Force var 123 | var = varAlgebra alg . fmap3VarF var term value 124 | term :: Term -> Force term 125 | term = termAlgebra alg . fmap3TermF var term value 126 | value :: Value -> Force value 127 | value = valueAlgebra alg . fmap3ValueF var term value 128 | 129 | 130 | instance Monoid Int where 131 | mempty = 0 132 | mappend = (+) 133 | 134 | main = print result 135 | where 136 | result = applyAlgebra alg (Value example) 137 | 138 | alg :: SyntaxAlgebra (Forced Int) (Forced Int) (Forced Int) 139 | alg = SyntaxAlgebra var term value 140 | 141 | var x = 1 + foldMap3VarF id id id x 142 | term e = 1 + foldMap3TermF id id id e 143 | value v = 1 + foldMap3ValueF id id id v 144 | -------------------------------------------------------------------------------- /DelayedApplicativeGADT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, ScopedTypeVariables #-} 2 | module Process2 where 3 | 4 | import Control.Applicative (Applicative(..), liftA2, (<$>)) 5 | import Control.Monad (liftM, liftM2, ap, join) 6 | import Data.Foldable (Foldable(..), toList) 7 | import Data.Traversable (Traversable(..), fmapDefault, foldMapDefault) 8 | 9 | import Debug.Trace 10 | 11 | 12 | data DelayStructure sh a where 13 | Leaf :: a -> DelayStructure () a 14 | Branch :: DelayStructure sh1 a -> DelayStructure sh2 a -> DelayStructure (sh1, sh2) a 15 | 16 | instance Show a => Show (DelayStructure sh a) where 17 | show (Leaf x) = "Leaf (" ++ show x ++ ")" 18 | show (Branch t1 t2) = "Branch (" ++ show t1 ++ ") (" ++ show t2 ++ ")" 19 | 20 | instance Functor (DelayStructure sh) where 21 | fmap = fmapDefault 22 | 23 | instance Foldable (DelayStructure sh) where 24 | foldMap = foldMapDefault 25 | 26 | instance Traversable (DelayStructure sh) where 27 | traverse f (Leaf x) = Leaf <$> f x 28 | traverse f (Branch t1 t2) = Branch <$> traverse f t1 <*> traverse f t2 29 | 30 | 31 | -- If you don't want DelayM to have Monad structure, you can nuke the nested use of DelayM, 32 | -- and make some of the consumers simpler. I actually want this generalisation, though. 33 | data DelayM q a r = Done r 34 | | forall sh. Delayed (DelayStructure sh q) (DelayStructure sh a -> DelayM q a r) 35 | 36 | instance Functor (DelayM q a) where 37 | fmap f x = pure f <*> x 38 | 39 | instance Applicative (DelayM q a) where 40 | pure = return 41 | Done f <*> Done x = Done (f x) 42 | Delayed qs k <*> Done x = Delayed qs (\as -> k as <*> Done x) 43 | Done f <*> Delayed qs k = Delayed qs (\as -> Done f <*> k as) 44 | Delayed qs1 k1 <*> Delayed qs2 k2 = Delayed (Branch qs1 qs2) (\(Branch as1 as2) -> k1 as1 <*> k2 as2) 45 | 46 | instance Monad (DelayM q a) where 47 | return = Done 48 | Done x >>= fxmy = fxmy x 49 | Delayed qs k >>= fxmy = Delayed qs (\as -> k as >>= fxmy) 50 | 51 | delay :: q -> DelayM q a a 52 | delay q = Delayed (Leaf q) (\(Leaf a) -> pure a) 53 | 54 | justLeftmost :: DelayM q a r -> DelayM q a r 55 | justLeftmost (Done x) = Done x 56 | justLeftmost (Delayed qs k) = delayTail qs >>= k 57 | where 58 | delayTail :: DelayStructure sh q -> DelayM q a (DelayStructure sh a) 59 | delayTail (Leaf q) = fmap Leaf (delay q) 60 | delayTail (Branch qs1 qs2) = liftM2 Branch (delayTail qs1) (traverse delay qs2) 61 | 62 | 63 | -- Simple example supercompiler-alike to show that it all works: 64 | 65 | 66 | type HFunction = Int 67 | --data State = State deriving (Eq) 68 | type State = Int 69 | data Term = Tieback HFunction | Base Int | Split Term Term deriving (Show) 70 | 71 | type ScpM = DelayM State Term 72 | 73 | -- Execution trace: 74 | -- 10 => 9 75 | -- 4 => 3 76 | -- 1 => 0 BASE 77 | -- 2 => 1 BASE 78 | -- 5 => 4 79 | -- 2 => 1 BASE 80 | -- 3 => 2 BASE 81 | 82 | split :: (State -> ScpM Term) 83 | -> State -> ScpM Term 84 | --split = undefined 85 | split f x | x <= 2 = pure (Base x) 86 | | otherwise = liftA2 Split (f (x `div` 2)) (f ((x `div` 2) + 1)) -- Change A2 to M2 to linearise the search :-) 87 | 88 | reduce :: State -> State 89 | --reduce = undefined 90 | reduce x = x-1 91 | 92 | 93 | supercompile :: State -> ([(State, HFunction)], Term) 94 | supercompile state = unMemoM (my_choose (scPostMatch state)) [] 95 | where 96 | -- Depth-first, left-biased exploration of the process tree. 97 | -- NB: by varying the implementation of justLeftmost you change the strategy: 98 | --my_choose = choose justLeftmost 99 | 100 | -- Breadth-first exploration of the process tree: 101 | my_choose = choose id 102 | 103 | -- A simplified version: no sc-history 104 | scPostMatch :: State -> ScpM Term 105 | scPostMatch state = split delay (reduce state) 106 | 107 | 108 | newtype MemoM a = MemoM { unMemoM :: [(State, HFunction)] -> ([(State, HFunction)], a) } 109 | 110 | instance Functor MemoM where 111 | fmap = liftM 112 | 113 | instance Applicative MemoM where 114 | pure = return 115 | (<*>) = ap 116 | 117 | instance Monad MemoM where 118 | return x = MemoM $ \s -> (s, x) 119 | MemoM xf >>= fxmy = MemoM $ \s -> case xf s of (s', x) -> unMemoM (fxmy x) s' 120 | 121 | modify :: ([(State, HFunction)] -> ([(State, HFunction)], a)) 122 | -> MemoM a 123 | modify = MemoM 124 | 125 | choose :: (ScpM a -> ScpM a) 126 | -> ScpM a -> MemoM a 127 | choose choose_some = go 128 | where 129 | go = go' . choose_some 130 | 131 | go' (Done x) = pure x 132 | go' (Delayed qs k) = trace ("iteration: " ++ show qs) $ traverse sc qs >>= \fs -> go (sequenceA fs >>= k) 133 | 134 | sc :: State -> MemoM (ScpM Term) 135 | sc state = modify $ \memo -> case lookup state memo of 136 | Just h -> (memo, pure (Tieback h)) 137 | Nothing -> ((state, h'):memo, scPostMatch state) 138 | where h' = 1 + maximum (0:map snd memo) 139 | 140 | 141 | main = supercompile 10 -------------------------------------------------------------------------------- /DelayedApplicativeGADTModular.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, ScopedTypeVariables #-} 2 | module Process2 where 3 | 4 | import Control.Applicative (Applicative(..), liftA2, (<$>)) 5 | import Control.Monad (liftM, liftM2, ap, join) 6 | import Data.Foldable (Foldable(..), toList) 7 | import Data.Traversable (Traversable(..), fmapDefault, foldMapDefault) 8 | 9 | import Debug.Trace 10 | 11 | 12 | data DelayStructure sh a where 13 | Leaf :: a -> DelayStructure () a 14 | Branch :: DelayStructure sh1 a -> DelayStructure sh2 a -> DelayStructure (sh1, sh2) a 15 | 16 | instance Show a => Show (DelayStructure sh a) where 17 | show (Leaf x) = "Leaf (" ++ show x ++ ")" 18 | show (Branch t1 t2) = "Branch (" ++ show t1 ++ ") (" ++ show t2 ++ ")" 19 | 20 | instance Functor (DelayStructure sh) where 21 | fmap = fmapDefault 22 | 23 | instance Foldable (DelayStructure sh) where 24 | foldMap = foldMapDefault 25 | 26 | instance Traversable (DelayStructure sh) where 27 | traverse f (Leaf x) = Leaf <$> f x 28 | traverse f (Branch t1 t2) = Branch <$> traverse f t1 <*> traverse f t2 29 | 30 | 31 | -- If you don't want DelayM to have Monad structure, you can nuke the nested use of DelayM, 32 | -- and make some of the consumers simpler. I actually want this generalisation, though. 33 | data DelayM q a r = Done r 34 | | forall sh. Delayed (DelayStructure sh q) (DelayStructure sh a -> DelayM q a r) 35 | 36 | instance Functor (DelayM q a) where 37 | fmap f x = pure f <*> x 38 | 39 | instance Applicative (DelayM q a) where 40 | pure = return 41 | Done f <*> Done x = Done (f x) 42 | Delayed qs k <*> Done x = Delayed qs (\as -> k as <*> Done x) 43 | Done f <*> Delayed qs k = Delayed qs (\as -> Done f <*> k as) 44 | Delayed qs1 k1 <*> Delayed qs2 k2 = Delayed (Branch qs1 qs2) (\(Branch as1 as2) -> k1 as1 <*> k2 as2) 45 | 46 | instance Monad (DelayM q a) where 47 | return = Done 48 | Done x >>= fxmy = fxmy x 49 | Delayed qs k >>= fxmy = Delayed qs (\as -> k as >>= fxmy) 50 | 51 | delay :: q -> DelayM q a a 52 | delay q = Delayed (Leaf q) (\(Leaf a) -> pure a) 53 | 54 | runDelayM :: (Applicative memom, Monad memom, 55 | Show q) -- Debugging only 56 | => (DelayM q a r -> DelayM q a r) -- ^ Chooses the evaluation strategy 57 | -> (q -> memom (DelayM q a a)) -- ^ How to answer questions in the monad (possibly generating new requests in the process) 58 | -> DelayM q a r -> memom r 59 | runDelayM choose_some sc = go 60 | where 61 | go = go' . choose_some 62 | 63 | go' (Done x) = pure x 64 | go' (Delayed qs k) = -- trace ("iteration: " ++ show qs) $ 65 | traverse sc qs >>= \fs -> go (sequenceA fs >>= k) 66 | 67 | 68 | depthFirst :: DelayM q a r -> DelayM q a r 69 | depthFirst (Done x) = Done x 70 | depthFirst (Delayed qs k) = delayTail qs >>= k 71 | where 72 | delayTail :: DelayStructure sh q -> DelayM q a (DelayStructure sh a) 73 | delayTail (Leaf q) = fmap Leaf (delay q) 74 | delayTail (Branch qs1 qs2) = liftM2 Branch (delayTail qs1) (traverse delay qs2) 75 | 76 | breadthFirst :: DelayM q a r -> DelayM q a r 77 | breadthFirst = id 78 | 79 | 80 | -- Simple example supercompiler-alike to show that it all works: 81 | 82 | 83 | type HFunction = Int 84 | --data State = State deriving (Eq) 85 | type State = Int 86 | data Term = Tieback HFunction | Base Int | Split Term Term deriving (Show) 87 | 88 | type ScpM = DelayM State Term 89 | 90 | -- Execution trace: 91 | -- 10 => 9 92 | -- 4 => 3 93 | -- 1 => 0 BASE 94 | -- 2 => 1 BASE 95 | -- 5 => 4 96 | -- 2 => 1 BASE 97 | -- 3 => 2 BASE 98 | 99 | split :: Applicative t 100 | => (State -> t Term) 101 | -> State -> t Term 102 | --split = undefined 103 | split f x | x <= 2 = pure (Base x) 104 | | otherwise = liftA2 Split (f (x `div` 2)) (f ((x `div` 2) + 1)) -- Change A2 to M2 to linearise the search :-) 105 | 106 | reduce :: State -> State 107 | --reduce = undefined 108 | reduce x = x-1 109 | 110 | 111 | supercompile :: State -> ([(State, HFunction)], Term) 112 | supercompile state = unMemoM (sc state >>= runDelayM eval_strat sc) [] 113 | where 114 | --eval_strat = depthFirst 115 | eval_strat = breadthFirst 116 | 117 | -- A simplified version of a supercompiler: no sc-history. 118 | -- Generates requests for States 119 | sc' :: State -> ScpM Term 120 | sc' state = split delay (reduce state) 121 | 122 | -- Allows us to answer requests for States in the memoisation monad, 123 | -- possibly generating new requests in the process (hence the nested ScpM) 124 | sc :: State -> MemoM (ScpM Term) 125 | sc = memo sc' 126 | 127 | memo :: (State -> ScpM Term) 128 | -> State -> MemoM (ScpM Term) 129 | memo opt state = modify $ \memo -> case lookup state memo of 130 | Just h -> (memo, pure (Tieback h)) 131 | Nothing -> ((state, h'):memo, opt state) 132 | where h' = 1 + maximum (0:map snd memo) 133 | 134 | 135 | newtype MemoM a = MemoM { unMemoM :: [(State, HFunction)] -> ([(State, HFunction)], a) } 136 | 137 | instance Functor MemoM where 138 | fmap = liftM 139 | 140 | instance Applicative MemoM where 141 | pure = return 142 | (<*>) = ap 143 | 144 | instance Monad MemoM where 145 | return x = MemoM $ \s -> (s, x) 146 | MemoM xf >>= fxmy = MemoM $ \s -> case xf s of (s', x) -> unMemoM (fxmy x) s' 147 | 148 | modify :: ([(State, HFunction)] -> ([(State, HFunction)], a)) 149 | -> MemoM a 150 | modify = MemoM 151 | 152 | 153 | main = print $ supercompile 10 -------------------------------------------------------------------------------- /Cont.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, Rank2Types #-} 2 | import Control.Arrow (first) 3 | import Control.Monad 4 | 5 | import Data.Maybe 6 | 7 | 8 | newtype Cont res a = Cont { unCont :: (a -> res) -> res } 9 | 10 | instance Functor (Cont res) where 11 | fmap f m = Cont $ \c -> unCont m (c . f) 12 | 13 | instance Monad (Cont res) where 14 | return x = Cont ($ x) 15 | m >>= fm = Cont $ \c -> unCont m $ \x -> unCont (fm x) c 16 | 17 | callCC :: ((a -> Cont res b) -> Cont res a) -> Cont res a 18 | callCC f = Cont $ \c -> unCont (f (\a -> Cont $ \_ -> c a)) c 19 | 20 | 21 | newtype ContT r m a = ContT { unContT :: (a -> m r) -> m r } 22 | 23 | runContT :: Monad m => ContT r m r -> m r 24 | runContT x = unContT x return 25 | 26 | instance Functor (ContT r m) where 27 | fmap f m = ContT $ \c -> unContT m (c . f) 28 | 29 | instance Monad (ContT r m) where 30 | return x = ContT ($ x) 31 | m >>= fm = ContT (\c -> unContT m (\x -> unContT (fm x) c)) 32 | 33 | 34 | newtype ScpM' a = ScpM' { unScpM' :: Int -> (Int, a) } 35 | 36 | instance Functor ScpM' where 37 | fmap = liftM 38 | 39 | instance Monad ScpM' where 40 | return x = ScpM' (\s -> (s, x)) 41 | mx >>= fxmy = ScpM' (\s -> case unScpM' mx s of (s, x) -> unScpM' (fxmy x) s) 42 | 43 | 44 | data CompTree a = Branch (CompTree a) (CompTree a) 45 | | Leaf a 46 | 47 | mkCompTree :: [a] -> Maybe (CompTree a) 48 | mkCompTree [] = Nothing 49 | mkCompTree [x] = Just (Leaf x) 50 | mkCompTree xs = case mb_t1 of Nothing -> mb_t2; Just t1 -> case mb_t2 of Nothing -> Just t1; Just t2 -> Just (Branch t1 t2) 51 | where (xs1, xs2) = splitAt (length xs `div` 2) xs 52 | mb_t1 = mkCompTree xs1 53 | mb_t2 = mkCompTree xs2 54 | 55 | flattenCompTree :: CompTree a -> [a] 56 | flattenCompTree (Leaf x) = [x] 57 | flattenCompTree (Branch t1 t2) = flattenCompTree t1 ++ flattenCompTree t2 58 | 59 | instance Functor CompTree where 60 | fmap f (Leaf x) = Leaf (f x) 61 | fmap f (Branch t1 t2) = Branch (fmap f t1) (fmap f t2) 62 | 63 | compTreeLeftmost :: CompTree a -> (a, a -> CompTree a) 64 | compTreeLeftmost (Leaf x) = (x, Leaf) 65 | compTreeLeftmost (Branch t1 t2) = (x, \x' -> Branch (rb x') t2) 66 | where (x, rb) = compTreeLeftmost t1 67 | 68 | compTreeLeftmost' :: CompTree a -> (a, Either (CompTree a, b -> CompTree b -> CompTree b) (b -> CompTree b)) 69 | compTreeLeftmost' (Leaf x) = (x, Right Leaf) 70 | compTreeLeftmost' (Branch t1 t2) = (x, Left $ case ei of Left (t', rb) -> (Branch t' t2, \y (Branch t' t2) -> Branch (rb y t') t2) 71 | Right rb -> (t2, \y t2 -> Branch (rb y) t2)) 72 | where (x, ei) = compTreeLeftmost' t1 73 | 74 | 75 | type ScpM = ContT Res ScpM' 76 | data Res = Choice { resComps :: CompTree (ScpM Res'), resCont :: Maybe (CompTree Res') -> ScpM' Res } 77 | | Done Res' 78 | type Res' = Tree Int 79 | 80 | runScpM :: ScpM Res' -> Res' 81 | runScpM mx = runScpM' $ unContT mx (return . Done) >>= combine 82 | where 83 | combine :: Res -> ScpM' Res' 84 | combine (Done b) = return b 85 | combine (Choice comps cont) = combineChoice (Just comps) cont 86 | 87 | combineChoice :: Maybe (CompTree (ScpM Res')) -> (Maybe (CompTree Res') -> ScpM' Res) -> ScpM' Res' 88 | combineChoice Nothing cont = cont Nothing >>= combine 89 | combineChoice (Just t) cont = do 90 | let (comp, ei) = compTreeLeftmost' t 91 | r <- unContT comp (return . Done) 92 | case r of 93 | Done b -> combineChoice (case ei of Left (comps, _) -> Just comps; Right _ -> Nothing) (case ei of Left (_, rb) -> \(Just bs) -> cont (Just (rb b bs)); Right rb -> \Nothing -> cont (Just (rb b))) 94 | -- Effects in breadth-first order: 95 | --Choice comps' cont' -> combineChoice (case ei of Left (comps, _) -> Just (Branch comps comps'); Right _ -> Just comps') (case ei of Left (_, rb) -> \(Just (Branch bs bs')) -> cont' (Just bs') >>= \r -> combine r >>= \b -> cont (Just (rb b bs)); Right rb -> \(Just bs') -> cont' (Just bs') >>= \r -> combine r >>= \b -> cont (Just (rb b))) 96 | -- Effects in depth-first order: 97 | Choice comps' cont' -> combineChoice (case ei of Left (comps, _) -> Just (Branch comps' comps); Right _ -> Just comps') (case ei of Left (_, rb) -> \(Just (Branch bs' bs)) -> cont' (Just bs') >>= \r -> combine r >>= \b -> cont (Just (rb b bs)); Right rb -> \(Just bs') -> cont' (Just bs') >>= \r -> combine r >>= \b -> cont (Just (rb b))) 98 | 99 | runScpM' :: ScpM' a -> a 100 | runScpM' mx = snd (unScpM' mx 0) 101 | 102 | 103 | class Monad m => MonadNext m where 104 | next :: m Int 105 | 106 | instance MonadNext ScpM' where 107 | next = ScpM' (\s -> (s + 1, s)) 108 | 109 | instance MonadNext m => MonadNext (ContT r m) where 110 | next = ContT (\c -> next >>= c) 111 | 112 | 113 | class Monad m => MonadChoice m where 114 | choice :: [m Res'] -> m [Res'] 115 | 116 | instance MonadChoice ScpM where 117 | choice mxs = ContT $ \c -> return (Choice (fromJust (mkCompTree mxs)) (\(Just ress') -> c (flattenCompTree ress'))) 118 | 119 | --done :: [Res'] -> ScpM a 120 | --done bs = ContT $ \_ -> return (Done bs) 121 | 122 | 123 | splitBy :: [b] -> [a] -> ([a], [a]) 124 | splitBy [] xs = ([], xs) 125 | splitBy (_:ys) (x:xs) = first (x:) $ splitBy ys xs 126 | 127 | 128 | 129 | bitsToNumber :: [Bool] -> Int 130 | bitsToNumber = foldr (\b acc -> acc * 2 + if b then 1 else 0) 0 131 | 132 | tHRESHOLD :: Int 133 | tHRESHOLD = 3 134 | 135 | 136 | data Tree a = Tree a [Tree a] 137 | deriving (Show) 138 | 139 | tree :: [()] -> ScpM Res' 140 | tree n | length n > tHRESHOLD = next >>= \i -> return (Tree i []) 141 | | otherwise = next >>= \i -> choice [tree (() : n), tree (() : n)] >>= \[xs, ys] -> return (Tree i [xs, ys]) 142 | 143 | 144 | 145 | main :: IO () 146 | main = print (runScpM (tree [()])) 147 | -------------------------------------------------------------------------------- /DelayedApplicativeGADTModular2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, ScopedTypeVariables #-} 2 | module Process2 where 3 | 4 | import Control.Applicative (Applicative(..), liftA2, (<$>)) 5 | import Control.Monad (liftM, liftM2, ap, join) 6 | import Data.Foldable (Foldable(..), toList) 7 | import Data.Traversable (Traversable(..), fmapDefault, foldMapDefault) 8 | 9 | import Debug.Trace 10 | 11 | 12 | data DelayStructure sh a where 13 | Leaf :: a -> DelayStructure () a 14 | Branch :: DelayStructure sh1 a -> DelayStructure sh2 a -> DelayStructure (sh1, sh2) a 15 | 16 | instance Show a => Show (DelayStructure sh a) where 17 | show (Leaf x) = "Leaf (" ++ show x ++ ")" 18 | show (Branch t1 t2) = "Branch (" ++ show t1 ++ ") (" ++ show t2 ++ ")" 19 | 20 | instance Functor (DelayStructure sh) where 21 | fmap = fmapDefault 22 | 23 | instance Foldable (DelayStructure sh) where 24 | foldMap = foldMapDefault 25 | 26 | instance Traversable (DelayStructure sh) where 27 | traverse f (Leaf x) = Leaf <$> f x 28 | traverse f (Branch t1 t2) = Branch <$> traverse f t1 <*> traverse f t2 29 | 30 | 31 | -- If you don't want DelayM to have Monad structure, you can nuke the nested use of DelayM, 32 | -- and make some of the consumers simpler. I actually want this generalisation, though. 33 | data DelayM q a r = Done r 34 | | forall sh. Delayed (DelayStructure sh q) (DelayStructure sh a -> DelayM q a r) 35 | 36 | instance Functor (DelayM q a) where 37 | fmap f x = pure f <*> x 38 | 39 | instance Applicative (DelayM q a) where 40 | pure = return 41 | Done f <*> Done x = Done (f x) 42 | Delayed qs k <*> Done x = Delayed qs (\as -> k as <*> Done x) 43 | Done f <*> Delayed qs k = Delayed qs (\as -> Done f <*> k as) 44 | Delayed qs1 k1 <*> Delayed qs2 k2 = Delayed (Branch qs1 qs2) (\(Branch as1 as2) -> k1 as1 <*> k2 as2) 45 | 46 | instance Monad (DelayM q a) where 47 | return = Done 48 | Done x >>= fxmy = fxmy x 49 | Delayed qs k >>= fxmy = Delayed qs (\as -> k as >>= fxmy) 50 | 51 | delay :: q -> DelayM q a a 52 | delay q = Delayed (Leaf q) (\(Leaf a) -> pure a) 53 | 54 | runDelayM :: forall memom q a r. 55 | (Applicative memom, Monad memom, 56 | Show q) -- Debugging only 57 | => (DelayM q a r -> DelayM q a r) -- ^ Chooses the evaluation strategy 58 | -> (q -> memom (DelayM q a a)) -- ^ How to answer questions in the monad (possibly generating new requests in the process) 59 | -> DelayM q a r -> memom r 60 | runDelayM choose_some sc = go 61 | where 62 | go = go' . choose_some 63 | 64 | go' (Done x) = pure x 65 | go' (Delayed (qs :: DelayStructure sh q) (k :: DelayStructure sh a -> DelayM q a r)) 66 | = -- trace ("iteration: " ++ show qs) $ 67 | mungeDS sc qs >>= \mx -> go (mx >>= k) 68 | 69 | 70 | mungeDS :: forall memom sh q a. 71 | (Applicative memom, Monad memom) 72 | => (q -> memom (DelayM q a a)) 73 | -> DelayStructure sh q 74 | -> memom (DelayM q a (DelayStructure sh a)) 75 | mungeDS sc qs = (traverse sc qs :: memom (DelayStructure sh (DelayM q a a))) >>= \fs -> return (sequenceA fs :: DelayM q a (DelayStructure sh a)) 76 | 77 | 78 | depthFirst :: DelayM q a r -> DelayM q a r 79 | depthFirst (Done x) = Done x 80 | depthFirst (Delayed qs k) = delayTail qs >>= k 81 | where 82 | delayTail :: DelayStructure sh q -> DelayM q a (DelayStructure sh a) 83 | delayTail (Leaf q) = fmap Leaf (delay q) 84 | delayTail (Branch qs1 (qs2 :: DelayStructure sh2 q)) = liftM2 Branch (delayTail qs1) (traverse delay qs2 :: DelayM q a (DelayStructure sh2 a)) 85 | 86 | breadthFirst :: DelayM q a r -> DelayM q a r 87 | breadthFirst = id 88 | 89 | 90 | -- Simple example supercompiler-alike to show that it all works: 91 | 92 | 93 | type HFunction = Int 94 | --data State = State deriving (Eq) 95 | type State = Int 96 | data Term = Tieback HFunction | Base Int | Split Term Term deriving (Show) 97 | 98 | type ScpM = DelayM State Term 99 | 100 | -- Execution trace: 101 | -- 10 => 9 102 | -- 4 => 3 103 | -- 1 => 0 BASE 104 | -- 2 => 1 BASE 105 | -- 5 => 4 106 | -- 2 => 1 BASE 107 | -- 3 => 2 BASE 108 | 109 | split :: Applicative t 110 | => (State -> t Term) 111 | -> State -> t Term 112 | --split = undefined 113 | split f x | x <= 2 = pure (Base x) 114 | | otherwise = liftA2 Split (f (x `div` 2)) (f ((x `div` 2) + 1)) -- Change A2 to M2 to linearise the search :-) 115 | 116 | reduce :: State -> State 117 | --reduce = undefined 118 | reduce x = x-1 119 | 120 | 121 | supercompile :: State -> ([(State, HFunction)], Term) 122 | supercompile state = unMemoM (sc state >>= runDelayM eval_strat sc) [] 123 | where 124 | --eval_strat = depthFirst 125 | eval_strat = breadthFirst 126 | 127 | -- A simplified version of a supercompiler: no sc-history. 128 | -- Generates requests for States 129 | sc' :: State -> ScpM Term 130 | sc' state = split delay (reduce state) 131 | 132 | -- Allows us to answer requests for States in the memoisation monad, 133 | -- possibly generating new requests in the process (hence the nested ScpM) 134 | sc :: State -> MemoM (ScpM Term) 135 | sc = memo sc' 136 | 137 | memo :: (State -> ScpM Term) 138 | -> State -> MemoM (ScpM Term) 139 | memo opt state = modify $ \memo -> case lookup state memo of 140 | Just h -> (memo, pure (Tieback h)) 141 | Nothing -> ((state, h'):memo, opt state) 142 | where h' = 1 + maximum (0:map snd memo) 143 | 144 | 145 | newtype MemoM a = MemoM { unMemoM :: [(State, HFunction)] -> ([(State, HFunction)], a) } 146 | 147 | instance Functor MemoM where 148 | fmap = liftM 149 | 150 | instance Applicative MemoM where 151 | pure = return 152 | (<*>) = ap 153 | 154 | instance Monad MemoM where 155 | return x = MemoM $ \s -> (s, x) 156 | MemoM xf >>= fxmy = MemoM $ \s -> case xf s of (s', x) -> unMemoM (fxmy x) s' 157 | 158 | modify :: ([(State, HFunction)] -> ([(State, HFunction)], a)) 159 | -> MemoM a 160 | modify = MemoM 161 | 162 | 163 | main = print $ supercompile 10 -------------------------------------------------------------------------------- /IdiomNormalisation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs #-} 2 | import Text.PrettyPrint.HughesPJClass 3 | 4 | import System.IO.Unsafe 5 | 6 | import Control.Monad 7 | import Control.Monad.State 8 | 9 | 10 | type UniqM = State [Int] 11 | 12 | uniqSupply :: [Int] 13 | uniqSupply = [0..] 14 | 15 | runUniq :: UniqM a -> a 16 | runUniq = flip evalState uniqSupply 17 | 18 | unique :: UniqM Int 19 | unique = get >>= \(x:ss) -> put ss >> return x 20 | 21 | 22 | -- -- Thingy is the "mother of all idioms": 23 | -- 24 | -- -- pure :: forall b. b -> i b 25 | -- -- (<**>) :: forall a. i a -> (forall b. i (a -> b) -> i b) 26 | -- -- 27 | -- -- pure id <*> v = v -- Identity 28 | -- -- pure (.) <*> u <*> v <*> w = u <*> (v <*> w) -- Composition 29 | -- -- pure f <*> pure x = pure (f x) -- Homomorphism 30 | -- -- u <*> pure y = pure ($ y) <*> u -- Interchange 31 | -- -- 32 | -- -- v ==> pure id <*> v -- Identity 33 | -- -- u <*> (v <*> w) ==> pure (.) <*> u <*> v <*> w -- Composition 34 | -- -- pure f <*> pure x ==> pure (f x) -- Homomorphism 35 | -- -- u <*> pure y ==> pure ($ y) <*> u -- Interchange 36 | -- newtype Thingy i a = Thingy { runThingy :: forall b. Yoneda i (a -> b) -> Yoneda i b } 37 | -- 38 | -- liftThingy :: Applicative i => i a -> Thingy i a 39 | -- liftThingy i = Thingy (liftYoneda . (<**>) i . lowerYoneda) 40 | -- 41 | -- lowerThingy :: Applicative i => Thingy i a -> i a 42 | -- lowerThingy i = lowerYoneda $ runThingy i (liftYoneda (pure id)) 43 | -- 44 | -- instance Functor i => Functor (Thingy i) where 45 | -- fmap f m = Thingy $ runThingy m . fmap (. f) 46 | -- 47 | -- instance Applicative (Thingy i) where 48 | -- pure x = Thingy $ \m -> Yoneda (\k -> runYoneda m (k . ($ x))) 49 | -- mf <*> mx = Thingy $ \m -> runThingy mx (runThingy mf (Yoneda (\k -> runYoneda m (k . (.))))) 50 | 51 | 52 | instance Pretty (IdiomSyn a) where 53 | pPrint (Pure e) = text "pure" <+> parens (pPrint e) 54 | pPrint (Ap mf mx) = pPrint mf <+> text "<*>" <+> parens (pPrint mx) 55 | pPrint (Foreign e) = text e 56 | 57 | instance Pretty (Term a) where 58 | pPrint = runUniq . pPrintTerm 59 | 60 | pPrintTerm :: Term a -> UniqM Doc 61 | pPrintTerm (Lam f) = do 62 | x <- fmap (\i -> "x" ++ show i) unique 63 | d <- pPrintTerm (f (ForeignE x)) 64 | return $ parens $ text "\\" <> text x <+> text "->" <+> d 65 | pPrintTerm (App e1 e2) = liftM2 (\e1 e2 -> e1 <+> parens e2) (pPrintTerm e1) (pPrintTerm e2) 66 | pPrintTerm (ForeignE e) = return $ text e 67 | 68 | 69 | data Term a where 70 | Lam :: (Term a -> Term b) -> Term (a -> b) 71 | App :: Term (a -> b) -> Term a -> Term b 72 | ForeignE :: String -> Term a 73 | 74 | data IdiomSyn a where 75 | Pure :: Term a -> IdiomSyn a 76 | Ap :: IdiomSyn (a -> b) -> IdiomSyn a -> IdiomSyn b 77 | Foreign :: String -> IdiomSyn a 78 | 79 | normalise :: IdiomSyn a -> IdiomSyn a 80 | normalise m = go m (\k -> Pure (k id)) id 81 | where 82 | --go :: forall a. IdiomSyn a 83 | -- -> (forall b. 84 | -- (forall c. ((Term a -> Term b) -> Term c) -> IdiomSyn c) 85 | -- -> (forall d. 86 | -- (Term b -> Term d) 87 | -- -> IdiomSyn d)) 88 | go :: forall a b d. 89 | IdiomSyn a 90 | -> (forall c. ((Term a -> Term b) -> Term c) -> IdiomSyn c) 91 | -> (Term b -> Term d) 92 | -> IdiomSyn d 93 | go (Pure x) m = \k -> m (\k' -> k (k' x)) 94 | --go (Ap mf mx) m = go mx (go mf (\k -> m (\k' -> k ((.) k')))) 95 | -- go (Ap mf mx) m = go mx (go mf (\k -> m (k . (\t -> "(.) (" ++ t ++ ")")))) 96 | 97 | go (Ap mf mx) m = go mx (\k' -> go mf (\x -> m (\y -> x (\z -> Lam (\e -> y (z `App` e))))) (\w -> k' (w `App`))) 98 | -- HAVE 99 | -- mf :: IdiomSyn (e -> a) 100 | -- mx :: IdiomSyn e 101 | -- m :: forall f. ((Term a -> Term b) -> Term f) -> IdiomSyn f 102 | -- k :: Term b -> Term d 103 | -- go mf :: forall i. 104 | -- (forall g. ((Term (e -> a) -> Term i) -> Term g) -> IdiomSyn g) 105 | -- -> (forall h. 106 | -- (Term i -> Term h) 107 | -- -> IdiomSyn h) 108 | -- go mx :: forall j. 109 | -- (forall k. ((Term e -> Term j) -> Term k) -> IdiomSyn k) 110 | -- -> (forall l. 111 | -- (Term j -> Term l) 112 | -- -> IdiomSyn l) 113 | -- 114 | -- GOAL 115 | -- undefined :: IdiomSyn d 116 | -- go mx (\(k' :: (Term e -> Term b) -> Term k) -> undefined :: IdiomSyn k) k :: IdiomSyn d 117 | -- go mx (\(k' :: (Term e -> Term b) -> Term k) -> go mf (\(x :: (Term (e -> a) -> Term (e -> b)) -> Term g) -> undefined :: IdiomSyn g) (undefined :: Term (e -> b) -> Term k) :: IdiomSyn k) k :: IdiomSyn d 118 | -- go mx (\(k' :: (Term e -> Term b) -> Term k) -> go mf (\(x :: (Term (e -> a) -> Term (e -> b)) -> Term g) -> m (\(y :: (Term a -> Term b)) -> undefined :: Term g) :: IdiomSyn g) (undefined :: Term (e -> b) -> Term k) :: IdiomSyn k) k :: IdiomSyn d 119 | -- go mx (\(k' :: (Term e -> Term b) -> Term k) -> go mf (\(x :: (Term (e -> a) -> Term (e -> b)) -> Term g) -> m (\(y :: (Term a -> Term b)) -> x (\(z :: Term (e -> a) -> Lam (\e -> y (z `App` e))))) :: IdiomSyn g) (\(w :: Term (e -> b)) -> k' (w `App`) :: Term k) :: IdiomSyn k) k :: IdiomSyn d 120 | -- x :: ((Term (e -> a) -> Term (e -> b)) -> Term g 121 | -- y :: Term a -> Term b 122 | -- 123 | -- x (\(z :: Term (e -> a) -> Lam (\e -> y (z `App` e)))) :: Term g 124 | 125 | -- go (Foreign e) m = \k -> m (\t -> "(.) (\\x -> " ++ k "x" ++ ") (" ++ t ++ ")") `Ap` Foreign e 126 | go x@(Foreign _) m = \k -> m (\k' -> Lam (k . k')) `Ap` x 127 | -- HAVE 128 | -- Foreign e :: IdiomSyn a 129 | -- m :: forall f. ((Term a -> Term b) -> Term f) -> IdiomSyn f 130 | -- k :: Term b -> Term d 131 | -- 132 | -- GOAL 133 | -- undefined :: IdiomSyn d 134 | -- m (\(k' :: Term a -> Term b) -> undefined :: Term (a -> d)) `Ap` Foreign e :: IdiomSyn d 135 | -- m (\(k' :: Term a -> Term b) -> Lam (k . k') :: Term (a -> d)) `Ap` Foreign e :: IdiomSyn d 136 | 137 | -- e :: i a 138 | -- m :: (forall c. ((a -> b) -> c) -> i c) 139 | -- k :: (b -> d) 140 | -- 141 | -- WANT: 142 | -- c =inst=> (a -> d) 143 | -- SO: 144 | -- m :: ((a -> b) -> (a -> d)) -> i (a -> d) 145 | -- (\t -> "(.) (\x -> " ++ k "x" ++ ")") :: ((a -> b) -> (a -> d)) 146 | 147 | 148 | comp :: Term ((b -> c) -> (a -> b) -> (a -> c)) 149 | comp = Lam (\f -> Lam (\g -> Lam (\x -> f `App` (g `App` x)))) 150 | 151 | non_normaliseds = [ 152 | -- Identity 153 | Foreign "effectful", 154 | Pure (Lam (\x -> x)) `Ap` Foreign "effectful", 155 | -- Composition 156 | Foreign "launchMissiles" `Ap` (Foreign "obtainLaunchCode" `Ap` Foreign "getAuthorization"), 157 | Pure comp `Ap` Foreign "launchMissiles" `Ap` Foreign "obtainLaunchCode" `Ap` Foreign "getAuthorization", 158 | Pure (ForeignE "launchMissiles'") `Ap` (Pure (ForeignE "obtainLaunchCode'") `Ap` Pure (ForeignE "getAuthorization'")), 159 | -- Homomorphism 160 | Pure (ForeignE "f") `Ap` Pure (ForeignE "x"), 161 | Pure (Lam (\x -> ForeignE "f" `App` x) `App` ForeignE "x"), 162 | -- Interchange 163 | Foreign "launchMissiles" `Ap` Pure (ForeignE "1337"), -- NB: demonstrates normaliser weakness. Beta-reduction introduced by normalisation! 164 | Pure (Lam (\x -> x `App` ForeignE "1337")) `Ap` Foreign "launchMissiles" 165 | ] 166 | 167 | main = forM_ non_normaliseds $ \non_normalised -> do 168 | putStrLn "== Before" 169 | print $ pPrint non_normalised 170 | 171 | putStrLn "== After" 172 | print $ pPrint $ normalise non_normalised 173 | -------------------------------------------------------------------------------- /Generics2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, EmptyDataDecls, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} 2 | 3 | import Data.Monoid 4 | 5 | 6 | type family ftag :% a :: * 7 | 8 | data Parametric0Tag (a :: *) 9 | type instance Parametric0Tag a :% () = a 10 | 11 | data Parametric1Tag (f :: * -> *) 12 | type instance Parametric1Tag f :% a = f a 13 | 14 | data Parametric3Tag (f :: * -> * -> * -> *) 15 | type instance Parametric3Tag f :% (a, b, c) = f a b c 16 | 17 | 18 | type Force a = a :% () 19 | 20 | 21 | newtype VarF var term value = AVar { unVar :: String } 22 | 23 | data TermF var term value 24 | = Var (Force var) 25 | | App (Force term) (Force var) 26 | | Value (Force value) 27 | | Add (Force term) (Force term) 28 | 29 | data ValueF var term value 30 | = Literal Int 31 | | Lambda String (Force term) 32 | 33 | data SyntaxAlgebra var term value = SyntaxAlgebra { 34 | varAlgebra :: VarF var term value -> Force var, 35 | termAlgebra :: TermF var term value -> Force term, 36 | valueAlgebra :: ValueF var term value -> Force value 37 | } 38 | 39 | 40 | type Fix3_1 f g h = f :% (FixTag3_1 f g h, FixTag3_2 f g h, FixTag3_3 f g h) -- Using :% here requires UndecidableInstances -- fair enough! 41 | type Fix3_2 f g h = g :% (FixTag3_1 f g h, FixTag3_2 f g h, FixTag3_3 f g h) 42 | type Fix3_3 f g h = h :% (FixTag3_1 f g h, FixTag3_2 f g h, FixTag3_3 f g h) 43 | 44 | data FixTag3_1 f g h 45 | data FixTag3_2 f g h 46 | data FixTag3_3 f g h 47 | type instance FixTag3_1 f g h :% () = Fix3_1 f g h 48 | type instance FixTag3_2 f g h :% () = Fix3_2 f g h 49 | type instance FixTag3_3 f g h :% () = Fix3_3 f g h 50 | 51 | 52 | type Var = Fix3_1 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF) 53 | type Term = Fix3_2 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF) 54 | type Value = Fix3_3 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF) 55 | 56 | 57 | -- TODO: try doing this as a functor category? 58 | fmap3VarF :: (Force var -> Force var') 59 | -> (Force term -> Force term') 60 | -> (Force value -> Force value') 61 | -> VarF var term value 62 | -> VarF var' term' value' 63 | fmap3VarF _var _term _value x = case x of 64 | AVar x -> AVar x 65 | 66 | fmap3TermF :: (Force var -> Force var') 67 | -> (Force term -> Force term') 68 | -> (Force value -> Force value') 69 | -> TermF var term value 70 | -> TermF var' term' value' 71 | fmap3TermF var term value e = case e of 72 | Var x -> Var (var x) 73 | App e x -> App (term e) (var x) 74 | Value v -> Value (value v) 75 | Add e1 e2 -> Add (term e1) (term e2) 76 | 77 | fmap3ValueF :: (Force var -> Force var') 78 | -> (Force term -> Force term') 79 | -> (Force value -> Force value') 80 | -> ValueF var term value 81 | -> ValueF var' term' value' 82 | fmap3ValueF _var term _value v = case v of 83 | Literal l -> Literal l 84 | Lambda x e -> Lambda x (term e) 85 | 86 | foldMap3VarF :: Monoid m 87 | => (Force var -> m) 88 | -> (Force term -> m) 89 | -> (Force value -> m) 90 | -> VarF var term value 91 | -> m 92 | foldMap3VarF _var _term _value x = case x of 93 | AVar _ -> mempty 94 | 95 | foldMap3TermF :: Monoid m 96 | => (Force var -> m) 97 | -> (Force term -> m) 98 | -> (Force value -> m) 99 | -> TermF var term value 100 | -> m 101 | foldMap3TermF var term value e = case e of 102 | Var x -> var x 103 | App e x -> term e `mappend` var x 104 | Value v -> value v 105 | Add e1 e2 -> term e1 `mappend` term e2 106 | 107 | foldMap3ValueF :: Monoid m 108 | => (Force var -> m) 109 | -> (Force term -> m) 110 | -> (Force value -> m) 111 | -> ValueF var term value 112 | -> m 113 | foldMap3ValueF _var term _value v = case v of 114 | Literal _ -> mempty 115 | Lambda _ e -> term e 116 | 117 | 118 | example :: Value 119 | example = Lambda "x" $ Add (Value (Literal 1)) (Var (AVar "x")) `App` AVar "x" 120 | 121 | 122 | -- fixAlgebra :: SyntaxAlgebra var term value -> SyntaxAlgebra (Fix3_1 var term value) (Fix3_2 var term value) (Fix3_3 var term value) 123 | -- fixAlgebra alg = undefined 124 | 125 | applyAlgebra :: forall var term value. 126 | SyntaxAlgebra var term value 127 | -> Term -> Force term 128 | -- -> SyntaxAlgebra (FixTag3_1 VarF TermF ValueF) (FixTag3_2 VarF TermF ValueF) (FixTag3_3 VarF TermF ValueF) 129 | applyAlgebra alg = {- SyntaxAlgebra var term value -- -} term 130 | where 131 | var :: Var -> Force var 132 | var = varAlgebra alg . fmap3VarF var term value 133 | term :: Term -> Force term 134 | term = termAlgebra alg . fmap3TermF var term value 135 | value :: Value -> Force value 136 | value = valueAlgebra alg . fmap3ValueF var term value 137 | 138 | 139 | applyHomAlgebra :: SyntaxAlgebra (Parametric0Tag Var) (Parametric0Tag Term) (Parametric0Tag Value) 140 | -> Term -> Term 141 | applyHomAlgebra alg = term 142 | where 143 | var :: Var -> Var 144 | var = varAlgebra alg . fmap3VarF var term value 145 | term :: Term -> Term 146 | term = termAlgebra alg . fmap3TermF var term value 147 | value :: Value -> Value 148 | value = valueAlgebra alg . fmap3ValueF var term value 149 | 150 | 151 | data IdTag 152 | type instance IdTag :% a = a 153 | 154 | data ComposeTag f g 155 | type instance ComposeTag f g :% a = f :% (g :% a) 156 | 157 | 158 | data Annotated ann a = Ann { annotation :: ann, annee :: a } 159 | 160 | instance Functor (Annotated ann) where 161 | fmap f (Ann ann x) = Ann ann (f x) 162 | 163 | type AnnVar annftag = Fix3_1 (ComposeTag annftag (Parametric3Tag VarF)) (ComposeTag annftag (Parametric3Tag TermF)) (ComposeTag annftag (Parametric3Tag ValueF)) 164 | type AnnTerm annftag = Fix3_2 (ComposeTag annftag (Parametric3Tag VarF)) (ComposeTag annftag (Parametric3Tag TermF)) (ComposeTag annftag (Parametric3Tag ValueF)) 165 | type AnnValue annftag = Fix3_3 (ComposeTag annftag (Parametric3Tag VarF)) (ComposeTag annftag (Parametric3Tag TermF)) (ComposeTag annftag (Parametric3Tag ValueF)) 166 | 167 | annotateWithAlgebra :: forall ann. 168 | SyntaxAlgebra ann ann ann 169 | -> Term -> AnnTerm (Parametric1Tag (Annotated (Force ann))) 170 | annotateWithAlgebra alg = term 171 | where 172 | foo :: VarF ann ann ann -> Force ann 173 | foo = varAlgebra alg 174 | 175 | -- Var == Fix3_1 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF) 176 | -- == Parametric3Tag VarF :% (FixTag3_1 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF), 177 | -- FixTag3_2 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF), 178 | -- FixTag3_3 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF)) 179 | -- == VarF (FixTag3_1 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF)) 180 | -- (FixTag3_2 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF)) 181 | -- (FixTag3_3 (Parametric3Tag VarF) (Parametric3Tag TermF) (Parametric3Tag ValueF)) 182 | 183 | var :: Var -> AnnVar (Parametric1Tag (Annotated (Force ann))) 184 | var x = Ann (varAlgebra alg (fmap3VarF annotation annotation annotation x')) x' 185 | where x' = fmap3VarF var term value x 186 | term :: Term -> AnnTerm (Parametric1Tag (Annotated (Force ann))) 187 | term e = Ann (termAlgebra alg (fmap3TermF annotation annotation annotation e')) e' 188 | where e' = fmap3TermF var term value e 189 | value :: Value -> AnnValue (Parametric1Tag (Annotated (Force ann))) 190 | value v = Ann (valueAlgebra alg (fmap3ValueF annotation annotation annotation v')) v' 191 | where v' = fmap3ValueF var term value v 192 | 193 | 194 | instance Monoid Int where 195 | mempty = 0 196 | mappend = (+) 197 | 198 | main = do 199 | print result 200 | print (annotation example_annotated) 201 | where 202 | result = applyAlgebra alg (Value example) 203 | example_annotated = annotateWithAlgebra alg (Value example) 204 | 205 | alg :: SyntaxAlgebra (Parametric0Tag Int) (Parametric0Tag Int) (Parametric0Tag Int) 206 | alg = SyntaxAlgebra var term value 207 | 208 | var x = 1 + foldMap3VarF id id id x 209 | term e = 1 + foldMap3TermF id id id e 210 | value v = 1 + foldMap3ValueF id id id v 211 | -------------------------------------------------------------------------------- /0CFA.hs: -------------------------------------------------------------------------------- 1 | -- Translated from Matt Might's article: http://matt.might.net/articles/implementation-of-kcfa-and-0cfa/k-CFA.scm 2 | -- Extended with less ad-hoc support for halting 3 | 4 | import Control.Applicative (liftA2, liftA3) 5 | import qualified Control.Monad.State as State 6 | import Control.Monad 7 | 8 | import qualified Data.Map as M 9 | import qualified Data.Set as S 10 | import Data.List ((\\)) 11 | 12 | import Debug.Trace 13 | 14 | 15 | type Var = String 16 | type Label = Int 17 | data Exp = Halt | Ref Var | Lam Label [Var] Call deriving (Eq, Ord, Show) 18 | data Call = Call Label Exp [Exp] deriving (Eq, Ord, Show) 19 | 20 | -- Abstract state space 21 | data State = State Call BEnv Store Time deriving (Eq, Ord, Show) 22 | -- A binding environment maps variables to addresses 23 | -- (In Matt's example, this mapped to Addr, but I found this a bit redundant 24 | -- since the Var in the Addr can be inferred, so I map straight to Time) 25 | type BEnv = M.Map Var Time 26 | -- A store maps addresses to denotable values 27 | type Store = M.Map Addr Denotable 28 | -- | An abstact denotable value is a set of possible values 29 | type Denotable = S.Set Value 30 | -- For pure CPS, closures are the only kind of value 31 | type Value = Clo 32 | -- Closures pair a lambda-term with a binding environment that determines 33 | -- the values of its free variables 34 | data Clo = Closure (Label, [Var], Call) BEnv | HaltClosure | Arbitrary deriving (Eq, Ord, Show) 35 | -- Addresses can point to values in the store. In pure CPS, the only kind of addresses are bindings 36 | type Addr = Bind 37 | -- A binding is minted each time a variable gets bound to a value 38 | data Bind = Binding Var Time deriving (Eq, Ord, Show) 39 | -- In k-CFA, time is a bounded memory of program history. 40 | -- In particular, it is the last k call sites through which 41 | -- the program has traversed. 42 | type Time = [Label] 43 | 44 | storeInsert :: Addr -> Value -> Store -> Store 45 | storeInsert a v s = M.insertWith S.union a (S.singleton v) s 46 | 47 | storeJoin :: Store -> Store -> Store 48 | storeJoin = M.unionWith S.union 49 | 50 | -- k-CFA parameters 51 | 52 | k :: Int 53 | k = 1 54 | 55 | tick :: Label -> Time -> Time 56 | tick l t = take k (l:t) 57 | 58 | -- k-CFA abstract interpreter 59 | 60 | atomEval :: BEnv -> Store -> Exp -> Denotable 61 | atomEval benv store Halt = S.singleton HaltClosure 62 | atomEval benv store (Ref x) = case M.lookup x benv of 63 | Nothing -> error $ "Variable unbound in BEnv: " ++ show x 64 | Just t -> case M.lookup (Binding x t) store of 65 | Nothing -> error $ "Address unbound in Store: " ++ show (Binding x t) 66 | Just d -> d 67 | atomEval benv _ (Lam l v c) = S.singleton (Closure (l, v, c) benv) 68 | 69 | next :: State -> S.Set State -- Next states 70 | next s@(State (Call l fun args) benv store time) 71 | = trace ("next" ++ show s) $ 72 | S.fromList [ state' 73 | | clo <- S.toList procs 74 | , state' <- case clo of 75 | HaltClosure -> [] 76 | Closure (_, formals, call') benv' 77 | | let benv'' = foldr (\formal benv' -> M.insert formal time benv') benv' formals 78 | -> [ State call' benv'' store' time' 79 | | params <- S.toList (transpose paramss) 80 | , let store' = foldr (\(formal, params) store -> storeInsert (Binding formal time) params store) store (formals `zip` params) 81 | ] 82 | Arbitrary 83 | -> [ state' 84 | | params <- S.toList (transpose paramss) 85 | , param <- params 86 | , Just state' <- [escape param store] 87 | ] 88 | ] 89 | where time' = tick l time 90 | procs = atomEval benv store fun 91 | paramss = map (atomEval benv store) args 92 | 93 | -- Extension of my own design to allow CFA in the presence of arbitrary values. 94 | -- Similar to "sub-0CFA" where locations are inferred to either have either a single 95 | -- lambda flow to them, no lambdas, or all lambdas 96 | escape :: Value -> Store -> Maybe State 97 | escape Arbitrary _ = Nothing -- If an arbitrary value from outside escapes we don't care 98 | escape HaltClosure _ = Nothing 99 | escape (Closure (_l, formals, call) benv) store = Just (State call (benv `M.union` benv') (store `storeJoin` store') []) 100 | where (benv', store') = fvStuff formals 101 | 102 | fvStuff :: [Var] -> (BEnv, Store) 103 | fvStuff xs = (M.fromList [(x, []) | x <- xs], M.fromList [(Binding x [], S.singleton Arbitrary) | x <- xs]) 104 | 105 | transpose :: Ord a => [S.Set a] -> S.Set [a] 106 | transpose [] = S.singleton [] 107 | transpose (arg:args) = S.fromList [arg:args | args <- S.toList (transpose args), arg <- S.toList arg] 108 | 109 | -- State-space exploration 110 | 111 | explore :: S.Set State -> [State] -> S.Set State 112 | explore seen [] = seen 113 | explore seen (todo:todos) 114 | | todo `S.member` seen = explore seen todos 115 | | otherwise = explore (S.insert todo seen) (S.toList (next todo) ++ todos) 116 | -- NB: Might's dissertation (Section 5.3.5) explains how we can apply widening here to 117 | -- improve the worst case runtime from exponential to cubic: for an new state from the 118 | -- work list, we must extract all seen states which match in every element *except* the 119 | -- store. Then, join those seen stores together. If the potential store is a subset 120 | -- of the seen ones then we can just loop. Otherwise, union the new store onto a global 121 | -- "widening" store, update the global store with this one, and do abstract evalution on the state with the new sotre. 122 | 123 | -- User interface 124 | 125 | summarize :: S.Set State -> Store 126 | summarize states = S.fold (\(State _ _ store' _) store -> store `storeJoin` store') M.empty states 127 | 128 | -- ("Monovariant" because it throws away information we know about what time things arrive at) 129 | monovariantStore :: Store -> M.Map Var (S.Set Exp) 130 | monovariantStore store = M.foldrWithKey (\(Binding x _) d res -> M.alter (\mb_exp -> Just $ maybe id S.union mb_exp (S.map monovariantValue d)) x res) M.empty store 131 | 132 | monovariantValue :: Value -> Exp 133 | monovariantValue (Closure (l, v, c) _) = Lam l v c 134 | monovariantValue HaltClosure = Halt 135 | monovariantValue Arbitrary = Ref "unknown" 136 | 137 | analyse :: Call -> M.Map Var (S.Set Exp) 138 | analyse e = monovariantStore (summarize (explore S.empty [State e benv store []])) 139 | where (benv, store) = fvStuff (S.toList (fvsCall e)) 140 | 141 | fvsCall :: Call -> S.Set Var 142 | fvsCall (Call _ fun args) = fvsExp fun `S.union` S.unions (map fvsExp args) 143 | 144 | fvsExp :: Exp -> S.Set Var 145 | fvsExp Halt = S.empty 146 | fvsExp (Ref x) = S.singleton x 147 | fvsExp (Lam _ xs c) = fvsCall c S.\\ S.fromList xs 148 | 149 | -- Helper functions for constructing syntax trees 150 | 151 | type UniqM = State.State Int 152 | 153 | newLabel :: UniqM Int 154 | newLabel = State.state (\i -> (i, i + 1)) 155 | 156 | runUniqM :: UniqM a -> a 157 | runUniqM = fst . flip State.runState 0 158 | 159 | 160 | ref :: Var -> UniqM Exp 161 | ref = return . Ref 162 | 163 | lam :: [Var] -> UniqM Call -> UniqM Exp 164 | lam xs c = liftA2 (flip Lam xs) newLabel c 165 | 166 | call :: UniqM Exp -> [UniqM Exp] -> UniqM Call 167 | call e es = liftA3 Call newLabel e (sequence es) 168 | 169 | let_ :: Var -> UniqM Exp -> UniqM Call -> UniqM Call 170 | let_ x e c = call (lam [x] c) [e] 171 | 172 | halt :: UniqM Exp -> UniqM Call 173 | halt e = call (return Halt) [e] 174 | 175 | -- The Standard Example 176 | -- 177 | -- In direct style: 178 | -- 179 | -- let id = \x -> x 180 | -- a = id (\z -> halt z) 181 | -- b = id (\y -> halt y) 182 | -- in halt b 183 | standardExample :: UniqM Call 184 | standardExample = 185 | let_ "id" (lam ["x", "k"] (call (ref "k") [ref "x"])) $ 186 | call (ref "id") [lam ["z"] (halt (ref "z")), 187 | lam ["a"] (call (ref "id") [lam ["y"] (halt (ref "y")), 188 | lam ["b"] (halt (ref "b"))])] 189 | 190 | -- Example with free varibles (showing escapes): 191 | fvExample :: UniqM Call 192 | fvExample = 193 | let_ "id" (lam ["x", "k"] (call (ref "k") [ref "x"])) $ 194 | call (ref "id") [lam ["z"] (call (ref "escape") [ref "z"]), 195 | lam ["a"] (call (ref "id") [lam ["y"] (call (ref "escape") [ref "y"]), 196 | lam ["b"] (call (ref "escape") [ref "b"])])] 197 | 198 | 199 | main = forM_ [fvExample, standardExample] $ \example -> do 200 | putStrLn "=====" 201 | forM_ (M.toList (analyse (runUniqM example))) $ \(x, es) -> do 202 | putStrLn (x ++ ":") 203 | mapM_ (putStrLn . (" " ++) . show) (S.toList es) 204 | -------------------------------------------------------------------------------- /BFS-DFS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, ExistentialQuantification, TypeSynonymInstances, ScopedTypeVariables #-} 2 | import Control.Monad 3 | 4 | import Data.List 5 | import Data.Ord 6 | 7 | import Debug.Trace 8 | 9 | 10 | newtype ContT r m a = ContT { unContT :: (a -> m r) -> m r } 11 | 12 | runContT :: Monad m => ContT r m r -> m r 13 | runContT x = unContT x return 14 | 15 | instance Functor (ContT r m) where 16 | fmap f m = ContT $ \c -> unContT m (c . f) 17 | 18 | instance Monad (ContT r m) where 19 | return x = ContT ($ x) 20 | m >>= fm = ContT (\c -> unContT m (\x -> unContT (fm x) c)) 21 | 22 | 23 | newtype ScpM' a = ScpM' { unScpM' :: Int -> (Int, a) } 24 | 25 | instance Functor ScpM' where 26 | fmap = liftM 27 | 28 | instance Monad ScpM' where 29 | return x = ScpM' (\s -> (s, x)) 30 | mx >>= fxmy = ScpM' (\s -> case unScpM' mx s of (s, x) -> unScpM' (fxmy x) s) 31 | 32 | 33 | data ApplicativeTree f a where 34 | Lifted :: f a -> ApplicativeTree f a 35 | Pure :: a -> ApplicativeTree f a -- ?? 36 | Deepen :: ApplicativeTree f a -> ApplicativeTree f a 37 | Star :: ApplicativeTree f (b -> a) -> ApplicativeTree f b -> ApplicativeTree f a 38 | 39 | instance Functor f => Functor (ApplicativeTree f) where 40 | fmap f (Lifted x) = Lifted (fmap f x) 41 | fmap f (Star mg mx) = Star (fmap (\g -> f . g) mg) mx 42 | 43 | 44 | type ScpM = ContT (Res Res') ScpM' 45 | data Res a = forall b. Res (ApplicativeTree ScpM b) (b -> ScpM' (Res a)) 46 | | Done a 47 | type Res' = Tree Int 48 | 49 | runScpM :: ScpM Res' -> Res' 50 | runScpM = runScpM' . go0 51 | where 52 | go0 :: ScpM Res' -> ScpM' Res' 53 | go0 mx = unContT mx (return . Done) >>= go1 54 | 55 | go1 :: Res Res' -> ScpM' Res' 56 | go1 (Done x) = return x 57 | --go1 (Res at cont) = dfs at cont 58 | go1 (Res at cont) = bfs at cont 59 | 60 | dfs :: forall a. ApplicativeTree ScpM a -> (a -> ScpM' (Res Res')) -> ScpM' Res' 61 | --dfs (Lifted mx) cont = go0 mx >>= \a -> cont a >>= \r -> go1 r 62 | --dfs (Lifted mx) cont = unContT mx (\(x :: a) -> undefined :: ScpM' (Res Res')) >>= \(r :: Res Res') -> undefined :: ScpM' Res' 63 | dfs (Lifted mx) cont = unContT mx cont >>= go1 64 | dfs (Deepen t) cont = dfs t cont 65 | dfs (Pure x) cont = cont x >>= go1 66 | dfs (Star mf mx) cont = dfs mf (\f -> return (Res (fmap f mx) cont)) 67 | 68 | {- 69 | bfs at cont = bfs'' 0 at cont 70 | 71 | bfs'' d at cont = trace (show (length cands)) $ snd $ minimumBy (comparing fst) cands 72 | where cands = bfs' d at cont 73 | 74 | bfs' :: Int -> ApplicativeTree ScpM a -> (a -> ScpM' (Res Res')) -> [(Int, ScpM' Res')] 75 | --bfs' d (Lifted mx) cont = [(d, unContT mx cont >>= go1)] 76 | bfs' d (Lifted mx) cont = do 77 | r <- unContT mx cont 78 | case r of Done x -> return x 79 | Res at cont -> bfs' (d + 1) at cont 80 | bfs' d (Star mf mx) cont = bfs' (d + 1) mf (\f -> return (Res (fmap f mx) cont)) ++ 81 | bfs' (d + 1) mx (\x -> return (Res (fmap ($ x) mf) cont)) 82 | -} 83 | 84 | {- 85 | bfs at cont = bfs' [Candidate 0 at cont] 86 | 87 | bfs' :: [Candidate] -> ScpM' Res' 88 | --bfs' (Candidate (Lifted mx) cont:cs) = unContT mx cont >>= go1 89 | bfs' (Candidate (Lifted mx) cont:cs) = do 90 | r <- unContT mx cont 91 | case r of Done x -> return x 92 | Res at cont -> 93 | --bfs' (Candidate (Deepen t) cont:cs) = bfs' (cs ++ [Candidate t cont]) 94 | --bfs' (Candidate (Pure x) cont:cs) = cont x >>= go1 95 | --bfs' (Candidate (Star mf mx) cont:cs) = bfs' (cs ++ [Candidate mf (\f -> return (Res (fmap f mx) cont)), Candidate mx (\x -> return (Res (fmap ($ x) mf) cont))]) 96 | --bfs' (Candidate (Star mf mx) cont:cs) = bfs' (cs ++ [Candidate mf (\f -> return (Res (Pure f `Star` mx) cont)), Candidate mx (\x -> return (Res (mf `Star` Pure x) cont))]) 97 | bfs' (Candidate (Star mf mx) cont:cs) = bfs' (cs ++ [Candidate mf (\f -> return (Res (Deepen (fmap f mx)) cont)), Candidate mx (\x -> return (Res (Deepen (fmap ($ x) mf)) cont))]) 98 | -} 99 | 100 | {- 101 | bfs :: forall a r. 102 | ApplicativeTree ScpM a 103 | -> (ApplicativeTree ScpM a -> r) 104 | -> (a -> ScpM' (Res Res')) 105 | -> ScpM' Res' 106 | -} 107 | bfs at k = bfs' [Candidate at k (\at' -> bfs at' k)] 108 | 109 | bfs' :: [Candidate] -> ScpM' Res' 110 | bfs' (Candidate (Lifted (mx :: ScpM a)) k rb:cands) = do 111 | r <- unContT mx k 112 | case r of 113 | Done x -> return x 114 | Res at' k' -> bfs' (cands ++ [Candidate at' k' (\at' -> bfs at' k')]) 115 | bfs' (Candidate (Pure x) k rb:cands) = do 116 | r <- k x 117 | case r of 118 | Done x -> return x 119 | Res at' k' -> bfs' (cands ++ [Candidate at' k' (\at' -> bfs at' k')]) 120 | bfs' (Candidate (Star (Pure f) (Pure x)) k rb:cands) = do 121 | r <- k (f x) 122 | case r of 123 | Done x -> return x 124 | Res at' k' -> bfs' (cands ++ [Candidate at' k' (\at' -> bfs at' k')]) 125 | bfs' (Candidate (Star fat xat) k rb:cands) = do 126 | bfs' (cands ++ [Candidate xat (\x -> rb (Star fat (Pure x))) (\xat -> rb (Star fat xat)), 127 | Candidate fat (\f -> rb (Star (Pure f) xat)) (\fat -> rb (Star fat xat))]) 128 | 129 | {- 130 | bfs' :: [Candidate' b] -> (b -> ScpM' (Res Res')) -> ScpM' Res' 131 | bfs' (Candidate' (Lifted mx) rb cont:cs) contt = do 132 | r <- unContT mx cont 133 | case r of Done x -> bfs (rb (Pure x)) contt 134 | Res at cont -> undefined 135 | --bfs' (Candidate' (Pure x) rb cont:cs) contt = s 136 | bfs' (Candidate' (Star mf mx) rb cont:cs) contt = bfs' (cs ++ [Candidate' mf (\f -> cont (f `Star` mx)) (\f -> return (Res (fmap f mx) cont)), 137 | Candidate' mx (\x -> cont (mf `Star`x)) (\x -> return (Res (fmap ($ x) mf) cont))]) contt 138 | -} 139 | 140 | data Candidate = forall a. Candidate { 141 | focus :: ApplicativeTree ScpM a, 142 | finished :: a -> ScpM' (Res Res'), -- If focus reduced to pure value 143 | rebuild :: ApplicativeTree ScpM a -> ScpM' (Res Res') -- If focus still a tree of some sort 144 | } 145 | 146 | --data Candidate = forall a. Candidate Int (ApplicativeTree ScpM a) (a -> ScpM' (Res Res')) 147 | --data Candidate' b = forall a. Candidate' (ApplicativeTree ScpM a) (ApplicativeTree ScpM a -> ApplicativeTree ScpM b) (a -> ScpM' (Res Res')) 148 | --data Candidate2 = forall a. Candidate2 (ScpM a) (a -> ScpM' (Res Res')) 149 | 150 | {- 151 | runScpM :: ScpM Res' -> Res' 152 | runScpM mx = runScpM' $ unContT mx (\b -> return (Res (Pure b) return)) >>= combine 153 | where 154 | combine :: Res -> ScpM' Res' 155 | combine (Res comps cont) = combineChoice comps cont 156 | 157 | combineChoice :: ApplicativeTree ScpM a -> (a -> ScpM' Res) -> ScpM' Res' 158 | combineChoice (Pure x) cont = cont x >>= combine 159 | combineChoice (Star compf compx) cont = combineChoice compf $ \f -> do 160 | combineChoice compx $ \x -> do 161 | return (f x) 162 | 163 | -- combineChoice (Star compf compx) cont = do 164 | -- r <- unContT compf (return . flip Res return) 165 | -- case r of 166 | -- Res (Pure f) cont' -> combineChoice compx (\x -> cont (f x)) 167 | -- 168 | -- 169 | -- -- Effects in breadth-first order: 170 | -- --Choice comps' cont' -> combine (Choice (comps ++ comps') (\bs -> case comps `splitBy` bs of (bs, bs') -> cont' bs' >>= \r -> combine r >>= \b -> cont (b : bs))) 171 | -- -- Effects in depth-first order: 172 | -- Choice comps' cont' -> combineChoice (comps' ++ comps) (\bs -> case comps' `splitBy` bs of (bs', bs) -> cont' bs' >>= \r -> combine r >>= \b -> cont (b : bs)) 173 | -} 174 | 175 | runScpM' :: ScpM' a -> a 176 | runScpM' mx = snd (unScpM' mx 0) 177 | 178 | 179 | class Monad m => MonadNext m where 180 | next :: m Int 181 | 182 | instance MonadNext ScpM' where 183 | next = ScpM' (\s -> (s + 1, s)) 184 | 185 | instance MonadNext m => MonadNext (ContT r m) where 186 | next = ContT (\c -> next >>= c) 187 | 188 | 189 | class Monad m => MonadChoice m where 190 | choice :: m (a -> b) -> m a -> m b 191 | 192 | instance MonadChoice ScpM where 193 | choice mf mx = ContT $ \c -> return (Res (Lifted mf `Star` Lifted mx) c) 194 | 195 | 196 | choicePair :: MonadChoice m => m a -> m b -> m (a, b) 197 | choicePair ma mb = return (,) `choice` ma `choice` mb 198 | 199 | 200 | bitsToNumber :: [Bool] -> Int 201 | bitsToNumber = foldr (\b acc -> acc * 2 + if b then 1 else 0) 0 202 | 203 | tHRESHOLD :: Int 204 | tHRESHOLD = 3 205 | 206 | 207 | data Tree a = Tree a [Tree a] 208 | deriving (Show) 209 | 210 | tree :: [()] -> ScpM Res' 211 | tree n | length n > tHRESHOLD = next >>= \i -> return (Tree i []) 212 | | otherwise = next >>= \i -> choicePair (tree (() : n)) (tree (() : n)) >>= \(xs, ys) -> return (Tree i [xs, ys]) 213 | 214 | 215 | main :: IO () 216 | main = print (runScpM (tree [()])) 217 | 218 | -------------------------------------------------------------------------------- /Graphs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphs where 3 | 4 | import qualified Data.Map as M 5 | import qualified Data.IntMap as IM 6 | import qualified Data.Set as S 7 | 8 | import Control.Applicative 9 | import Control.Arrow 10 | import Control.Monad 11 | import Data.List 12 | import Data.Maybe 13 | 14 | 15 | type LGraph node edge = [(node, [(edge, node)])] 16 | 17 | shortcutEdges :: forall node edge. 18 | Ord node 19 | => (node -> Bool) 20 | -> (edge -> node -> edge -> edge) 21 | -> LGraph node edge 22 | -> LGraph node edge 23 | shortcutEdges should_shortcut combine g = evalState visit_graph M.empty 24 | where 25 | g_map = M.fromList g 26 | 27 | --visit_graph :: State (M.Map node [(edge, node)]) (LGraph node edge) 28 | visit_graph = sequence $ flip mapMaybe g $ \(n, ens) -> do 29 | guard (not (should_shortcut n)) 30 | return $ liftM ((,) n) $ visit S.empty ens 31 | 32 | --visit :: [node] -> [(edge, node)] -> State (M.Map node [(edge, node)]) [(edge, node)] 33 | -- Given the outgoing edges for some node, returns all the outgoing edges for that node 34 | -- after shortcutting 35 | visit path ens = concatMapM (uncurry (visit' path)) ens 36 | 37 | --visit' :: S.Set node -> edge -> node -> State (M.Map node [(edge, node)]) [(edge, node)] 38 | -- Given an edge label and the node reached via that label, returns all the nodes reached 39 | -- after shortcutting 40 | visit' path e n' | n' `S.member` path = return [] -- Doesn't contribute any extra paths: all paths will considered by a caller 41 | | not (should_shortcut n') = return [(e, n')] -- Won't be shortcutted away, no need to look further 42 | | otherwise = do 43 | -- Since n' is not in the path, we can try to memoise 44 | mb_res <- liftM (M.lookup n') get 45 | res <- case mb_res of 46 | Just res -> return res 47 | Nothing -> do 48 | res <- visit (S.insert n' path) (M.findWithDefault (error "shortcutEdges") n' g_map) 49 | modify (M.insert n' res) 50 | return res 51 | return $ map (first (combine e n')) res 52 | 53 | sccs :: Ord node 54 | => LGraph node edge 55 | -- -> LGraph (LGraph node edge) [(edge, node)] 56 | -> [[node]] 57 | sccs g = case execState strongconnect_graph (0, M.empty, [], []) of (_, _, _, sccs) -> sccs 58 | where 59 | g_map = M.fromList g 60 | 61 | -- Observations about Tarjan's algorithm: 62 | -- 1. strongconnect(v) is only called if v.index is undefined 63 | -- 2. Vertex v's lowlink is only mutated by strongconnect(v) 64 | -- 3. Once index is set it is never changed 65 | -- 66 | -- We can use these facts to build an implementation that makes minimal use of the state monad 67 | 68 | strongconnect_graph = forM_ g $ \(n, ens) -> do 69 | ix_defined <- liftM (\(_, ixs, _, _) -> n `M.member` ixs) get 70 | unless ix_defined $ void $ strongconnect n ens 71 | 72 | -- (strongconnect n ens) returns index of a node n' reachable from n such that that index[n'] < index[n], 73 | -- if possible. Otherwise returns index[n]. 74 | strongconnect n ens = do 75 | ix <- state $ \(next_ix, ixs, s, sccs) -> (next_ix, (next_ix + 1, M.insert n next_ix ixs, n:s, sccs)) 76 | lowlink <- (\f -> foldM f ix ens) $ \lowlink (e, n') -> do 77 | (mb_ix', in_s') <- liftM (\(_, ixs, s, _) -> (M.lookup n' ixs, n' `elem` s)) get 78 | case mb_ix' of 79 | Nothing -> liftM (lowlink `min`) $ strongconnect n' (M.findWithDefault (error "sccs") n' g_map) -- Successor not yet visited: recurse on it 80 | Just ix' | in_s' -> return $ lowlink `min` ix' -- Successor is in the stack and hence the current SCC 81 | | otherwise -> return lowlink 82 | -- Since lowlink is at most ix, this condition can only be true if we failed to find a node reachable 83 | -- from n with a lower index. We use this as our cue to form a new SCC. 84 | when (lowlink == ix) $ do 85 | modify $ \(next_ix, ixs, s, sccs) -> let (scc, _n:s') = span (/= n) s in (next_ix, ixs, s', (n:scc) : sccs) 86 | -- Return this nodes final lowlink for use when computing the predecessors lowlink 87 | return lowlink 88 | 89 | sccs' :: forall node edge. 90 | (Ord node, Ord edge) -- FIXME: can relax (Ord edge) requirement really.. 91 | => LGraph node edge 92 | -> LGraph (LGraph node edge) [(edge, node)] 93 | sccs' g = case execState strongconnect_graph (0, M.empty, [], [], M.empty, M.empty) of (_, _, _, sccs, _, _) -> sccs 94 | where 95 | g_map = M.fromList g 96 | 97 | -- Observations about Tarjan's algorithm: 98 | -- 1. strongconnect(v) is only called if v.index is undefined 99 | -- 2. Vertex v's lowlink is only mutated by strongconnect(v) 100 | -- 3. Once index is set it is never changed 101 | -- 4. Nodes occur in the stack in decreasing order of index 102 | -- 103 | -- We can use these facts to build an implementation that makes minimal use of the state monad 104 | 105 | strongconnect_graph = forM_ g $ \(n, ens) -> do 106 | ix_defined <- liftM (\(_, ixs, _, _, _, _) -> n `M.member` ixs) get 107 | unless ix_defined $ void $ strongconnect n ens 108 | 109 | strongconnect :: node -> [(edge, node)] 110 | -> State (Int, 111 | M.Map node Int, 112 | [node], 113 | LGraph (LGraph node edge) [(edge, node)], 114 | M.Map node [(edge, node)], 115 | M.Map (LGraph node edge) [(edge, node)]) 116 | (Int, 117 | Maybe (LGraph node edge)) 118 | -- (strongconnect n ens) returns: 119 | -- 1. Index of a node n' reachable from n such that that index[n'] < index[n], 120 | -- if possible. Otherwise returns index[n]. 121 | -- 2. The SCC graph node of the newly-created SCC. If no new SCC was created then n is guaranteed 122 | -- to still be on the stack (which occurs iff we managed to find a suitable index[n']) 123 | strongconnect n ens = do 124 | ix <- state $ \(next_ix, ixs, s, sccs, all_internal_ens, all_external_ens) -> (next_ix, (next_ix + 1, M.insert n next_ix ixs, n:s, sccs, all_internal_ens, all_external_ens)) 125 | (lowlink, internal_ens, external_ens) <- (\f -> foldM f (ix, [], M.empty) ens) $ \(lowlink, internal_ens, external_ens) (e, n') -> do 126 | (mb_ix', in_s') <- liftM (\(_, ixs, s, _, _, _) -> (M.lookup n' ixs, n' `elem` s)) get 127 | (lowlink, mb_scc) <- case mb_ix' of 128 | -- Successor not yet visited: recurse on it 129 | -- Since the index assigned to n' > ix, it is guaranteed that n will still be on the 130 | -- stack when we return. 131 | -- TODO: include an edge depending on in_s' 132 | Nothing -> liftM (first (lowlink `min`)) $ strongconnect n' (M.findWithDefault (error "sccs") n' g_map) 133 | -- Successor is in the stack and hence the current SCC 134 | -- TODO: include this edge as an internal edge in the SCC 135 | Just ix' | in_s' -> return (lowlink `min` ix', Nothing) 136 | -- Successor visited but not in stack: it is already part of another SCC 137 | -- TODO: prepare to emit an edge from this node to that other SCC 138 | | otherwise -> do scc <- liftM (\(_, _, _, sccs, _, _) -> head [scc | (scc, _) <- sccs, any (\(n'', _) -> n'' == n') scc]) get 139 | return (lowlink, Just scc) 140 | (internal_ens, external_ens) <- return $ case mb_scc of 141 | Nothing -> ((e, n'):internal_ens, external_ens) 142 | Just scc -> (internal_ens, M.insertWith (++) scc [(e, n')] external_ens) 143 | return (lowlink, internal_ens, external_ens) 144 | -- Record discovered internal/external edges 145 | modify $ \(next_ix, ixs, s, sccs, all_internal_ens, all_external_ens) -> (next_ix, ixs, s, sccs, M.insert n internal_ens all_internal_ens, M.unionWith (++) external_ens all_external_ens) 146 | -- Since lowlink is at most ix, this condition can only be true if we failed to find a node reachable 147 | -- from n with a lower index. We use this as our cue to form a new SCC. 148 | mb_scc <- if (lowlink == ix) 149 | -- NB: because nodes on the stack are in decreasing order of index, this operation never pops a node with index < ix 150 | then do scc <- state $ \(next_ix, ixs, s, sccs, all_internal_ens, all_external_ens) -> let (s_scc, _n:s') = span (/= n) s 151 | scc = [(n, M.findWithDefault (error "sccs") n all_internal_ens) | n <- n:s_scc] 152 | all_external_ens' = [(ens, scc) | (scc, ens) <- M.toList all_external_ens] 153 | in (scc, (next_ix, ixs, s', (scc, all_external_ens') : sccs, all_internal_ens, M.empty)) 154 | return (Just scc) 155 | else return Nothing 156 | -- Return this nodes final lowlink for use when computing the predecessors lowlink 157 | return (lowlink, mb_scc) 158 | 159 | -- Given a graph, returns: 160 | -- 1. An acyclic graph of the strongly connected components of the input graph. 161 | -- Each SCC is identified by a unique Int. 162 | -- 2. A mapping from Ints to the "sub-graph" corresponding to each SCC. Each sub-graph 163 | -- contains all the nodes in the SCC as well as any edges between those nodes. 164 | -- Note that in particular the sub-graph for an acyclic SCC will contain exactly one node and no edges. 165 | -- 166 | -- Uses an adaptation of Tarjan's algorithm 167 | sccs'' :: forall node edge. 168 | Ord node 169 | => LGraph node edge 170 | -> (LGraph Int [(edge, node)], 171 | IM.IntMap (LGraph node edge)) 172 | sccs'' g = case execState strongconnect_graph (0, M.empty, [], [], IM.empty, M.empty, IM.empty) of (_, _, _, sccs, scc_datas, _, _) -> (sccs, scc_datas) 173 | where 174 | g_map = M.fromList g 175 | 176 | -- Observations about Tarjan's algorithm: 177 | -- 1. strongconnect(v) is only called if v.index is undefined 178 | -- 2. Vertex v's lowlink is only mutated by strongconnect(v) 179 | -- 3. Once index is set it is never changed 180 | -- 4. Nodes occur in the stack in decreasing order of index 181 | -- 182 | -- We can use these facts to build an implementation that makes minimal use of the state monad 183 | 184 | strongconnect_graph = forM_ g $ \(n, ens) -> do 185 | ix_defined <- liftM (\(_, ixs, _, _, _, _, _) -> n `M.member` ixs) get 186 | unless ix_defined $ void $ strongconnect n ens 187 | 188 | -- (strongconnect n ens) returns: 189 | -- 1. Index of a node n' reachable from n such that that index[n'] < index[n], 190 | -- if possible. Otherwise returns index[n]. 191 | -- 2. Whether we didn't just create a new SCC containing n. If no new SCC was created then n is guaranteed 192 | -- to still be on the stack (which occurs iff we managed to find a suitable index[n']) 193 | -- 194 | -- Precondition: there is no assigned index for n 195 | strongconnect :: node -> [(edge, node)] 196 | -> State (-- Next node index to assign 197 | Int, 198 | -- Mapping from nodes to their assigned index (if any) 199 | -- NB: after the node has been removed from the stack, we update the Int in the mapping 200 | -- to instead be the lowlink of the SCC it was assigned to. This is OK because we don't 201 | -- need the raw index of the node after that point: we only need record the fact that 202 | -- it had some index at a point in the past 203 | M.Map node Int, 204 | -- Stack containing expanded nodes that are not presently in a SCC 205 | [node], 206 | -- Work-in-progress graph of SCC 207 | LGraph Int [(edge, node)], 208 | -- Work-in-progress SCC sub-graph mapping 209 | IM.IntMap (LGraph node edge), 210 | -- Records all discovered "internal" edges from expanded nodes to somewhere *within* their SCC 211 | M.Map node [(edge, node)], 212 | -- Records all discovered "external" edges from the current SCC-in-progress to some other (already existant) SCC 213 | -- It might seem more obvious to use a [([(edge, node)], Int)] here, but that makes it awkward to common up multiple 214 | -- edges from this SCC going to the same external SCC 215 | IM.IntMap [(edge, node)]) 216 | (Int, Bool) 217 | strongconnect n ens = do 218 | ix <- state $ \(next_ix, ixs, s, sccs, scc_datas, all_internal_ens, all_external_ens) -> (next_ix, (next_ix + 1, M.insert n next_ix ixs, n:s, sccs, scc_datas, all_internal_ens, all_external_ens)) 219 | (lowlink, internal_ens, external_ens) <- (\f -> foldM f (ix, [], IM.empty) ens) $ \(lowlink, internal_ens, external_ens) (e, n') -> do 220 | (mb_ix', in_s') <- liftM (\(_, ixs, s, _, _, _, _) -> (M.lookup n' ixs, n' `elem` s)) get 221 | (lowlink, mb_scc) <- case mb_ix' of 222 | -- Successor not yet visited: recurse on it 223 | -- Whether we add an internal or external edge depends on whether the recursive call created an SCC or not. 224 | -- If it did create an SCC, that SCC will be identified by lowlink' 225 | Nothing -> do (lowlink', in_s') <- strongconnect n' (M.findWithDefault (error "sccs") n' g_map) 226 | return (lowlink `min` lowlink', if in_s' then Nothing else Just lowlink') 227 | -- Successor is in the stack and hence the current SCC, so record an internal edge 228 | Just ix' | in_s' -> return (lowlink `min` ix', Nothing) 229 | -- Successor visited but not in stack: it is already part of another SCC, so record an external edge 230 | -- NB: this makes use of my hack whereby ix' will actually be a SCC lowlink for such successors 231 | | otherwise -> return (lowlink, Just ix') 232 | (internal_ens, external_ens) <- return $ case mb_scc of 233 | Nothing -> ((e, n'):internal_ens, external_ens) 234 | Just scc -> (internal_ens, IM.insertWith (++) scc [(e, n')] external_ens) 235 | return (lowlink, internal_ens, external_ens) 236 | -- Record accumulated internal/external edges. We don't need to record them as we go along because they can only possibly be used by one of our callers, not our callees 237 | modify $ \(next_ix, ixs, s, sccs, scc_datas, all_internal_ens, all_external_ens) -> (next_ix, ixs, s, sccs, scc_datas, M.insert n internal_ens all_internal_ens, IM.unionWith (++) external_ens all_external_ens) 238 | -- Since lowlink is at most ix, this condition can only be true if we failed to find a node reachable 239 | -- from n with a lower index. We use this as our cue to form a new SCC. 240 | in_s <- if (lowlink == ix) 241 | -- NB: because nodes on the stack are in decreasing order of index, this operation never pops a node with index < ix 242 | then do modify $ \(next_ix, ixs, s, sccs, scc_datas, all_internal_ens, all_external_ens) -> let (s_scc, _n:s') = span (/= n) s 243 | scc = [(n, M.findWithDefault (error "sccs") n all_internal_ens) | n <- n:s_scc] 244 | all_external_ens' = [(ens, scc) | (scc, ens) <- IM.toList all_external_ens] 245 | -- Replace node indexes with the lowlink of the SCC they were assigned to (a small hack to save one map lookup): 246 | ixs' = foldr (\n -> M.insert n lowlink) ixs (n:s_scc) 247 | in (next_ix, ixs', s', (lowlink, all_external_ens') : sccs, IM.insert lowlink scc scc_datas, all_internal_ens, IM.empty) 248 | return False 249 | else return True 250 | -- Return this nodes final lowlink for use when computing the predecessors lowlink 251 | return (lowlink, in_s) 252 | 253 | obscure :: Ord node => LGraph node edge -> LGraph Int edge 254 | obscure g = [(to_key n, [(e, to_key n') | (e, n') <- ens]) | (n, ens) <- g] 255 | where key_map = M.fromList [(n, i) | ((n, _), i) <- g `zip` [0..]] 256 | to_key n = M.findWithDefault (error "obscure") n key_map 257 | 258 | 259 | {- 260 | sccs g = search_graph -- FIXME 261 | where 262 | g_map = M.fromList g 263 | 264 | allocatePreorderNumber n = state $ \(next_pon, pons, s, p, assigned, sccs) -> case M.lookup n pons of 265 | Just pon -> ((False, pon), (next_pon, pons, s, p, assigned, sccs)) 266 | Nothing -> ((True, next_pon), (next_pon + 1, M.insert n next_pon pons, s, p, assigned, sccs)) 267 | 268 | search_graph = case execState (mapM_ (uncurry search) g) (0, M.empty, [], [], S.empty, []) of (_, _, _, _, _, sccs) -> sccs 269 | 270 | search n ens = do 271 | (fresh, pon) <- allocatePreorderNumber n 272 | if not fresh 273 | then return (Just pon) 274 | else do 275 | -- Push onto both stacks 276 | modify $ \(next_pon, pons, s, p, assigned, sccs) -> (next_pon, pons, n:s, (n, pon):p, assigned, sccs) 277 | -- Consider paths 278 | forM ens $ \(e, n') -> do 279 | mb_n'_pon <- search n' (M.findWithDefault (error "sccs") n' g_map) 280 | case mb_n'_pon of 281 | -- PON was not yet assigned, the recursive search was enough 282 | Nothing -> return () 283 | -- PON was already assigned, need to mess with p 284 | Just n'_pon -> modify $ \(next_pon, pons, s, p, assigned, sccs) -> if n' `S.member` assigned 285 | then (next_pon, pons, s, p, assigned, sccs) 286 | else (next_pon, pons, s, dropWhile (\(_, p_pon) -> p_pon > n'_pon) p, assigned, sccs) 287 | modify $ \(next_pon, pons, s, p, assigned, sccs) -> case p of 288 | (p_head, _):p_tail | p_head == n -> (next_pon, pons, s, p_tail, assigned `S.union` S.fromList scc, scc : sccs) 289 | where (s1, _n:s2) = span (/= n) s 290 | scc = n:s1 291 | _ -> (next_pon, pons, s, p, assigned, sccs) 292 | return Nothing 293 | -} 294 | 295 | 296 | g0 = [("Root", [("a", "Residual Loop") 297 | ,("b", "Fully Shortcutted Loop") 298 | ,("c", "Shortcutted Loop") 299 | ,("d", "Indirect Non-Loop 1") 300 | ,("e", "Indirect Non-Loop 2")]) 301 | ,("Residual Loop", [("f", "Residual Loop")]) 302 | ,("Fully Shortcutted Loop", [("g", "Fully Shortcutted Loop")]) 303 | ,("Shortcutted Loop", [("h", "Shortcutted Loop 1")]) 304 | ,("Shortcutted Loop 1", [("i", "Shortcutted Loop")]) 305 | ,("Indirect Non-Loop 1", [("j", "Indirect Non-Loop 2")]) 306 | ,("Indirect Non-Loop 2", [])] 307 | 308 | test1 = shortcutEdges (`elem` ["Fully Shortcutted Loop", "Shortcutted Loop 1"]) (\e1 n e2 -> e1 ++ "(" ++ n ++ ")" ++ e2) g0 309 | 310 | test2 = sccs g0 311 | 312 | test3 = sccs test1 313 | 314 | test4 = sccs'' g0 315 | 316 | test5 = sccs'' test1 317 | 318 | 319 | -- Code below this line stolen from GHC to save time 320 | newtype State s a = State { runState' :: s -> ( a, s ) } 321 | 322 | instance Functor (State s) where 323 | fmap f m = State $ \s -> case runState' m s of 324 | ( r, s' ) -> ( f r, s' ) 325 | 326 | instance Applicative (State s) where 327 | pure x = State $ \s -> ( x, s ) 328 | m <*> n = State $ \s -> case runState' m s of 329 | ( f, s' ) -> case runState' n s' of 330 | ( x, s'' ) -> ( f x, s'' ) 331 | 332 | instance Monad (State s) where 333 | return x = State $ \s -> ( x, s ) 334 | m >>= n = State $ \s -> case runState' m s of 335 | ( r, s' ) -> runState' (n r) s' 336 | 337 | get :: State s s 338 | get = State $ \s -> ( s, s ) 339 | 340 | gets :: (s -> a) -> State s a 341 | gets f = State $ \s -> ( f s, s ) 342 | 343 | put :: s -> State s () 344 | put s' = State $ \_ -> ( (), s' ) 345 | 346 | modify :: (s -> s) -> State s () 347 | modify f = State $ \s -> ( (), f s ) 348 | 349 | state :: (s -> (a, s)) -> State s a 350 | state f = State $ \s -> case f s of (x, s') -> ( x, s' ) 351 | 352 | 353 | evalState :: State s a -> s -> a 354 | evalState s i = case runState' s i of 355 | ( a, _ ) -> a 356 | 357 | 358 | execState :: State s a -> s -> s 359 | execState s i = case runState' s i of 360 | ( _, s' ) -> s' 361 | 362 | 363 | runState :: State s a -> s -> (a, s) 364 | runState s i = case runState' s i of 365 | ( a, s' ) -> (a, s') 366 | 367 | 368 | -- | Monadic version of concatMap 369 | concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] 370 | concatMapM f xs = liftM concat (mapM f xs) -------------------------------------------------------------------------------- /Mother.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, GeneralizedNewtypeDeriving, 2 | FlexibleInstances, UndecidableInstances, IncoherentInstances #-} 3 | import Prelude hiding (id, (.)) 4 | 5 | import Control.Applicative 6 | import Control.Arrow 7 | import Control.Category 8 | import Control.Monad 9 | 10 | 11 | -- Yoneda is the "mother of all functors": 12 | 13 | -- flip fmap :: forall a. f a -> (forall b. (a -> b) -> f b) 14 | -- 15 | -- fmap id = id -- Identity 16 | -- fmap (f . g) = fmap f . fmap g -- Composition 17 | newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b } 18 | 19 | liftYoneda :: Functor f => f a -> Yoneda f a 20 | liftYoneda f = Yoneda (flip fmap f) 21 | 22 | lowerYoneda :: Yoneda f a -> f a 23 | lowerYoneda f = runYoneda f id 24 | 25 | instance Functor (Yoneda f) where 26 | fmap f m = Yoneda (\k -> runYoneda m (k . f)) 27 | -- fmap id m 28 | -- = Yoneda (\k -> runYoneda m (k . id)) 29 | -- = Yoneda (\k -> runYoneda m k) 30 | -- = m 31 | -- 32 | -- fmap (f . g) m 33 | -- = Yoneda (\k -> runYoneda m (k . (f . g))) 34 | -- = Yoneda (\k -> runYoneda m ((k . f) . g)) 35 | -- = Yoneda (\k -> runYoneda (Yoneda (\k -> runYoneda m (k . g))) (k . f)) 36 | -- = Yoneda (\k -> runYoneda (fmap g m) (k . f)) 37 | -- = fmap f (fmap g m) 38 | 39 | instance Applicative f => Applicative (Yoneda f) where 40 | pure = liftYoneda . pure 41 | mf <*> mx = liftYoneda (lowerYoneda mf <*> lowerYoneda mx) 42 | 43 | 44 | 45 | -- Thingy is the "mother of all idioms": 46 | 47 | -- pure :: forall b. b -> i b 48 | -- (<**>) :: forall a. i a -> (forall b. i (a -> b) -> i b) 49 | -- 50 | -- pure id <*> v = v -- Identity 51 | -- pure (.) <*> u <*> v <*> w = u <*> (v <*> w) -- Composition 52 | -- pure f <*> pure x = pure (f x) -- Homomorphism 53 | -- u <*> pure y = pure ($ y) <*> u -- Interchange 54 | -- 55 | -- v ==> pure id <*> v -- Identity 56 | -- u <*> (v <*> w) ==> pure (.) <*> u <*> v <*> w -- Composition 57 | -- pure f <*> pure x ==> pure (f x) -- Homomorphism 58 | -- u <*> pure y ==> pure ($ y) <*> u -- Interchange 59 | 60 | --newtype Thingy3 i a = Thingy3 { runThingy3 :: forall b. (forall c e. (c -> a) -> ((c -> b) -> e) -> i e) -> i b } 61 | --newtype Thingy2 i a = Thingy2 { runThingy2 :: forall b. (forall c. ((a -> b) -> c) -> i c) -> (forall d. (b -> d) -> i d) } 62 | newtype Thingy5 i a = Thingy5 { runThingy5 :: forall b. (forall c e. (c -> a) -> ((c -> b) -> e) -> i e) -> i b } 63 | 64 | newtype Thingy4 i a = Thingy4 { runThingy4 :: forall c d. i d -> (d -> (a -> c)) -> (forall e. (c -> e) -> i e) } 65 | 66 | instance Functor (Thingy4 i) where 67 | fmap f m = Thingy4 (\k j l -> runThingy4 m k (\x y -> j x (f y)) l) 68 | -- f :: a -> b 69 | -- m :: Thingy4 i a 70 | -- runThingy4 m :: forall f g. i g -> (g -> (a -> f)) -> (forall h. (f -> h) -> i h) 71 | -- k :: i d 72 | -- j :: d -> (b -> c) 73 | -- l :: c -> e 74 | -- 75 | -- GOAL: 76 | -- undefined :: i e 77 | -- runThingy4 m (undefined :: i g?) (undefined :: g? -> (a -> f?)) (undefined :: f? -> e) :: i e 78 | -- runThingy4 m k (\(x :: d) (y :: a) -> j x (f y) :: c) (l :: c -> e) :: i e 79 | -- runThingy4 m k (\x y -> j x (f y)) l 80 | 81 | --instance Applicative (Thingy4 i) where 82 | -- pure x = Thingy4 (\k j l -> undefined) 83 | -- x :: a 84 | -- k :: i d 85 | -- j :: d -> (a -> c) 86 | -- l :: c -> e 87 | -- 88 | -- GOAL: 89 | -- undefined :: i e 90 | -- IMPOSSIBLE. Need functorality of i. 91 | 92 | 93 | newtype Thingy3 i a = Thingy3 { runThingy3 :: forall b. (forall c e. (c -> a) -> ((c -> b) -> e) -> i e) -> i b } 94 | 95 | instance Functor (Thingy3 i) where 96 | fmap f m = Thingy3 (\k -> runThingy3 m (\g h -> k (f . g) h)) 97 | -- f :: a -> b 98 | -- runThingy3 m :: forall d. (forall e h. (e -> a) -> ((e -> d) -> h) -> i h) -> i d 99 | -- k :: forall f g. (f -> b) -> ((f -> c) -> g) -> i g 100 | -- 101 | -- GOAL: 102 | -- undefined :: i c 103 | -- runThingy3 m (undefined :: (forall e h. (e -> a) -> ((e -> d) -> h) -> i h)) :: i c 104 | -- runThingy3 m (\(g :: e -> a) (h :: (e -> d) -> h) -> undefined :: i h) :: i c 105 | -- runThingy3 m (\(g :: e -> a) (h :: (e -> d) -> h) -> k (undefined :: f? -> b) (undefined :: ((f? -> c) -> h)) :: i h) :: i c 106 | 107 | 108 | -- runThingy3 m (\(g :: e -> a) h -> k (undefined :: e -> b) h :: i (e -> c)) :: i c 109 | -- runThingy3 m (\(g :: e -> a) h -> k (f . g :: e -> b) h :: i (e -> c)) :: i c 110 | 111 | instance Applicative (Thingy3 i) where 112 | --pure (x :: a) = Thingy3 (\(k :: forall f g. (f -> a) -> ((f -> b) -> g) -> i g) -> k id (\f -> f x) :: i b) 113 | pure x = Thingy3 (\k -> k id ($ x)) 114 | -- x :: a 115 | -- k :: forall f g. (f -> a) -> ((f -> b) -> g) -> i g 116 | -- 117 | -- GOAL: 118 | -- undefined :: i b 119 | -- k (undefined :: f? -> a) (undefined :: (f? -> b) -> b) :: i b 120 | -- k id (\f -> f x) :: i b 121 | 122 | --(mf :: Thingy3 i (c -> a)) <*> (mx :: Thingy3 i c) = Thingy3 (\(k :: forall d e. (d -> a) -> ((d -> b) -> e) -> i e) -> runThingy3 mx (\(f :: k -> c) (g :: (k -> b) -> l) -> runThingy3 mf (\(h :: g -> (c -> a)) (i :: (g -> l) -> h) -> k id (\(l :: a -> b) -> i (\(x :: g) -> g (\(z :: k) -> l (h x (f z :: c) :: a) :: b) :: l) :: h) :: i h) :: i l) :: i b) 123 | mf <*> mx = Thingy3 (\k -> runThingy3 mx (\f g -> runThingy3 mf (\h i -> k id (\l -> i (\x -> g (\z -> l (h x (f z)))))))) 124 | -- mf :: Thingy3 i (c -> a) 125 | -- mx :: Thingy3 i c 126 | -- k :: forall d e. (d -> a) -> ((d -> b) -> e) -> i e 127 | -- runThingy3 mf :: forall f. (forall g h. (g -> (c -> a)) -> ((g -> f) -> h) -> i h) -> i f 128 | -- runThingy3 mx :: forall j. (forall k l. (k -> c) -> ((k -> j) -> l) -> i l) -> i j 129 | -- 130 | -- GOAL: 131 | -- undefined :: i b 132 | -- runThingy3 mx (\(f :: k -> c) (g :: (k -> b) -> l) -> undefined :: i l) :: i b 133 | -- runThingy3 mx (\(f :: k -> c) (g :: (k -> b) -> l) -> runThingy3 mf (\(h :: g -> (c -> a)) (i :: (g -> l) -> h) -> undefined :: i h) :: i l) :: i b 134 | -- runThingy3 mx (\(f :: k -> c) (g :: (k -> b) -> l) -> runThingy3 mf (\(h :: g -> (c -> a)) (i :: (g -> l) -> h) -> k (undefined :: d? -> a) (\(l :: d? -> b) -> undefined :: h) :: i h) :: i l) :: i b 135 | -- 136 | -- f :: k -> c 137 | -- g :: (k -> b) -> l 138 | -- h :: g -> (c -> a) 139 | -- i :: (g -> l) -> h 140 | -- 141 | -- (\(y :: d?) -> h (undefined :: g) (f (undefined :: k) :: c) :: a) (\(l :: d? -> b) -> i (\(x :: g) -> g (\(z :: k) -> l (undefined :: d?) :: b) :: l) :: h) :: i h) 142 | -- id (\(l :: a -> b) -> i (\(x :: g) -> g (\(z :: k) -> l (h x (f z :: c) :: a) :: b) :: l) :: h) :: i h) 143 | -- 144 | -- runThingy3 mx (\(f :: k -> c) (g :: (k -> b) -> l) -> runThingy3 mf (\(h :: g -> (c -> a)) (i :: (g -> l) -> h) -> k id (\(l :: a -> b) -> i (\(x :: g) -> g (\(z :: k) -> l (h x (f z :: c) :: a) :: b) :: l) :: h) :: i h) :: i l) :: i b 145 | 146 | -- pure id <*> v 147 | -- = Thingy3 (\k -> runThingy3 (Thingy3 (\k -> k id ($ id))) (\f g -> runThingy3 v (\h i -> k id (\l -> i (\x -> g (\z -> l (h x (f z)))))))) 148 | -- = Thingy3 (\k -> (runThingy3 v (\h i -> k id (\l -> i (\x -> ($ id) (\z -> l (h x (id z)))))))) 149 | -- = Thingy3 (\k -> runThingy3 v (\h i -> k id (\l -> i (\x -> l (h x id))))) 150 | -- 151 | -- = Thingy3 (\k -> runThingy3 v k) 152 | -- = v 153 | -- 154 | -- pure h <*> pure x 155 | -- = Thingy3 (\k -> runThingy3 (Thingy3 (\k -> k id ($ x))) (\f g -> runThingy3 (Thingy3 (\k -> k id ($ h))) (\h i -> k id (\l -> i (\x -> g (\z -> l (h x (f z)))))))) 156 | -- = Thingy3 (\k -> (\k -> k id ($ x)) (\f g -> ((k id (\l -> ($ h) (\x -> g (\z -> l (id x (f z))))))))) 157 | -- = Thingy3 (\k -> ((((k id (\l -> ($ h) (\x -> ($ x) (\z -> l (id x (id z)))))))))) 158 | -- = Thingy3 (\k -> k id (\l -> l (h x))) 159 | -- = Thingy3 (\k -> k id ($ (h x))) 160 | -- = pure (h x) 161 | -- 162 | -- pure ($ y) <*> u 163 | -- = Thingy3 (\k -> runThingy3 u (\f g -> runThingy3 (Thingy3 (\k -> k id ($ ($ y)))) (\h i -> k id (\l -> i (\x -> g (\z -> l (h x (f z)))))))) 164 | -- = Thingy3 (\k -> runThingy3 u (\f g -> k id (\l -> g (\z -> l (f z y))))) 165 | -- = Thingy3 (\k -> runThingy3 u (\h i -> k id (\l -> i (\x -> l (h x y))))) 166 | -- = Thingy3 (\k -> runThingy3 (Thingy3 (\k -> k id ($ y))) (\f g -> runThingy3 u (\h i -> k id (\l -> i (\x -> g (\z -> l (h x (f z)))))))) 167 | -- = u <*> pure y 168 | 169 | 170 | newtype Thingy2 i a = Thingy2 { runThingy2 :: forall b. (forall c. ((a -> b) -> c) -> i c) -> (forall d. (b -> d) -> i d) } 171 | 172 | liftThingy2 :: Applicative i => i a -> Thingy2 i a 173 | liftThingy2 i = Thingy2 (\k -> flip fmap (i <**> k id)) 174 | 175 | lowerThingy2 :: Applicative i => Thingy2 i a -> i a 176 | lowerThingy2 i = runThingy2 i (flip fmap (pure id)) id 177 | 178 | instance Functor (Thingy2 i) where 179 | fmap f m = Thingy2 $ runThingy2 m . (\m -> (\k -> m (k . (. f)))) 180 | 181 | instance Applicative (Thingy2 i) where 182 | pure x = Thingy2 $ \k f -> k (\g -> f (g x)) 183 | mf <*> mx = Thingy2 $ \k -> runThingy2 mx (runThingy2 mf (\f -> k (\g -> f (g .)))) 184 | 185 | 186 | newtype Thingy i a = Thingy { runThingy :: forall b. Yoneda i (a -> b) -> Yoneda i b } 187 | 188 | liftThingy :: Applicative i => i a -> Thingy i a 189 | liftThingy i = Thingy (liftYoneda . (<**>) i . lowerYoneda) 190 | 191 | lowerThingy :: Applicative i => Thingy i a -> i a 192 | lowerThingy i = lowerYoneda $ runThingy i (liftYoneda (pure id)) 193 | 194 | 195 | instance Functor (Thingy i) where 196 | fmap f m = Thingy $ runThingy m . fmap (. f) 197 | -- fmap id m 198 | -- = Thingy (\x -> runThingy m (fmap (. id) x)) 199 | -- = Thingy (\x -> runThingy m (fmap id x)) 200 | -- = Thingy (\x -> runThingy m x) 201 | -- = m 202 | -- 203 | -- fmap f (fmap g m) 204 | -- = Thingy (\x -> runThingy (fmap g m) (fmap (. f) x)) 205 | -- = Thingy (\x -> runThingy (Thingy (\y -> runThingy m (fmap (. g) y))) (fmap (. f) x)) 206 | -- = Thingy (\x -> runThingy m (fmap (. g) (fmap (. f) x))) 207 | -- = Thingy (\x -> runThingy m (fmap ((. g) . (. f)) x)) 208 | -- = Thingy (\x -> runThingy m (fmap (\z -> (z . f) . g) x)) 209 | -- = Thingy (\x -> runThingy m (fmap (\z -> z . (f . g)) x)) 210 | -- = Thingy (\x -> runThingy m (fmap (. (f . g)) x)) 211 | -- = fmap (f . g) m 212 | 213 | instance Applicative (Thingy i) where 214 | --pure x = Thingy $ \m -> Yoneda (\k -> runYoneda m (k . ($ x))) 215 | --mf <*> mx = Thingy $ \m -> runThingy mx (runThingy mf (Yoneda (\k -> runYoneda m (k . (.))))) 216 | pure x = Thingy $ \m -> fmap ($ x) m 217 | mf <*> mx = Thingy $ \m -> runThingy mx (runThingy mf (fmap (.) m)) 218 | -- pure f <*> pure x 219 | -- = Thingy (\m -> runThingy (pure x) (runThingy (pure f) (Yoneda (\k -> runYoneda m (k . (.)))))) 220 | -- = Thingy (\m -> runThingy (Thingy (\m -> Yoneda (\k -> runYoneda m (k . ($ x))))) (runThingy (Thingy (\m -> Yoneda (\k -> runYoneda m (k . ($ f))))) (Yoneda (\k -> runYoneda m (k . (.)))))) 221 | -- = Thingy (\m -> (\m2 -> Yoneda (\k -> runYoneda m2 (k . ($ x)))) ((\m3 -> Yoneda (\k -> runYoneda m3 (k . ($ f)))) (Yoneda (\k -> runYoneda m (k . (.)))))) 222 | -- = Thingy (\m -> (\m2 -> Yoneda (\k -> runYoneda m2 (k . ($ x)))) ((Yoneda (\k -> runYoneda ((Yoneda (\k -> runYoneda m (k . (.))))) (k . ($ f)))))) 223 | -- = Thingy (\m -> (Yoneda (\k -> runYoneda ((Yoneda (\k -> runYoneda ((Yoneda (\k -> runYoneda m (k . (.))))) (k . ($ f))))) (k . ($ x))))) 224 | -- = Thingy (\m -> (Yoneda (\k4 -> (\k2 -> runYoneda ((Yoneda (\k3 -> runYoneda m (k3 . (.))))) (k2 . ($ f))) (k4 . ($ x))))) 225 | -- = Thingy (\m -> (Yoneda (\k4 -> ((runYoneda m (((k4 . ($ x)) . ($ f)) . (.))))))) 226 | -- = Thingy (\m -> Yoneda (\k -> runYoneda m (\i -> k (i (f x))))) 227 | -- = Thingy (\m -> Yoneda (\k -> runYoneda m (k . ($ (f x))))) 228 | -- = pure (f x) 229 | -- 230 | -- pure id <*> v 231 | -- = Thingy (\m -> runThingy v (runThingy (pure id) (Yoneda (\k -> runYoneda m (k . (.)))))) 232 | -- = Thingy (\m -> runThingy v ((\m -> Yoneda (\k1 -> runYoneda m (k1 . ($ id)))) (Yoneda (\k2 -> runYoneda m (k2 . (.)))))) 233 | -- = Thingy (\m -> runThingy v ((\m -> Yoneda (\k1 -> runYoneda m ((k1 . ($ id)) . (.)))))) 234 | -- = Thingy (\m -> runThingy v (\m -> Yoneda (\k1 -> runYoneda m ((k1 . ($ id)) . (.))))) 235 | -- = Thingy (\m -> runThingy v (\m -> Yoneda (\k1 -> runYoneda m (\h -> k1 (\e -> h e))))) 236 | -- = v 237 | -- 238 | -- pure ($ y) <*> u 239 | -- = Thingy (\m -> runThingy u (runThingy (pure ($ y)) (Yoneda (\k -> runYoneda m (k . (.)))))) 240 | -- = Thingy (\m -> runThingy u (runThingy (Thingy (\m -> Yoneda (\k -> runYoneda m (k . ($ ($ y)))))) (Yoneda (\k -> runYoneda m (k . (.)))))) 241 | -- = Thingy (\m -> runThingy u ((Yoneda (\k -> runYoneda (Yoneda (\k -> runYoneda m (k . (.)))) (k . ($ ($ y))))))) 242 | -- = Thingy (\m -> runThingy u ((Yoneda (\k1 -> (\k2 -> runYoneda m (k2 . (.))) (k1 . ($ ($ y))))))) 243 | -- = Thingy (\m -> runThingy u (Yoneda (\k1 -> runYoneda m (\h -> k1 (\e -> h (e y)))))) 244 | -- 245 | -- = Thingy (\m -> Yoneda (\k5 -> runYoneda (runThingy u (Yoneda (\k4 -> runYoneda m (\f -> k4 (\b c -> f (b c)))))) (\d -> k5 (d y)))) 246 | -- = Thingy (\m -> (Yoneda (\k5 -> runYoneda (runThingy u (Yoneda (\k4 -> runYoneda m (k4 . (.))))) (k5 . ($ y))))) 247 | -- = Thingy (\m -> runThingy (Thingy (\m -> Yoneda (\k -> runYoneda m (k . ($ y))))) (runThingy u (Yoneda (\k -> runYoneda m (k . (.)))))) 248 | -- = Thingy (\m -> runThingy (pure y) (runThingy u (Yoneda (\k -> runYoneda m (k . (.)))))) 249 | -- = u <*> pure y 250 | -- 251 | -- pure ($ y) <*> u 252 | -- = Thingy (\m -> runThingy u (runThingy (Thingy (\m -> fmap ($ y) m)) (fmap (.) m))) 253 | -- = Thingy (\m -> runThingy u (fmap ($ y) (fmap (.) m))) 254 | -- ??? free theorem 255 | -- = Thingy (\m -> fmap ($ y) (runThingy u (fmap (.) m))) 256 | -- = Thingy (\m -> runThingy (Thingy (\m -> fmap ($ y) m)) (runThingy u (fmap (.) m))) 257 | -- = u <*> pure y 258 | 259 | -- Wotsit is the "mother of all categories": 260 | 261 | -- id :: forall c. t c c 262 | -- (>>>) :: forall a b. t a b -> (forall c. t b c -> t a c) 263 | -- 264 | -- id . t = t -- Left-identity 265 | -- t . id = t -- Right-identity 266 | -- t . (r . s) = (t . r) . s -- Associativity 267 | newtype Wotsit t a b = Wotsit { runWotsit :: forall c. t b c -> t a c } 268 | 269 | liftWotsit :: Category t => t a b -> Wotsit t a b 270 | liftWotsit t = Wotsit ((>>>) t) 271 | 272 | lowerWotsit :: Category t => Wotsit t a b -> t a b 273 | lowerWotsit t = runWotsit t id 274 | 275 | instance Category (Wotsit t) where 276 | -- *Strongly* reminiscent of NBE for monoids (reassociation realised by assocativity of function application) 277 | -- There is probably some connection between NBE and Yoneda (e.g. "Normalization and the Yoneda embedding", but 278 | -- can't get access to this paper electronically) 279 | id = Wotsit id 280 | t1 . t2 = Wotsit (runWotsit t2 . runWotsit t1) 281 | -- id . t 282 | -- = Wotsit (runWotsit t . runWotsit (Wotsit id)) 283 | -- = Wotsit (runWotsit t . id) 284 | -- = Wotsit (runWotsit t) 285 | -- = t 286 | -- 287 | -- t . id 288 | -- = Wotsit (runWotsit (Wotsit id) . runWotsit t) 289 | -- = Wotsit (id . runWotsit t) 290 | -- = Wotsit (runWotsit t) 291 | -- = t 292 | -- 293 | -- t . (r . s) 294 | -- = Wotsit (runWotsit (Wotsit (runWotsit s . runWotsit r)) . runWotsit t) 295 | -- = Wotsit ((runWotsit s . runWotsit r) . runWotsit t) 296 | -- = Wotsit (runWotsit s . (runWotsit r . runWotsit t)) 297 | -- = Wotsit (runWotsit s . runWotsit (Wotsit (runWotsit r . runWotsit t))) 298 | -- = (t . r) . s 299 | 300 | -- Demonstrate that we can hoist stronger operations into Wotsit as well, given a type class context 301 | instance Arrow t => Arrow (Wotsit t) where 302 | arr f = Wotsit (\k -> arr f >>> k) 303 | --first t1 = Wotsit (\k -> first (runWotsit t1 id) >>> k) 304 | first t1 = Wotsit (\k -> first (lowerWotsit t1) >>> k) 305 | 306 | 307 | -- BiYoneda is the "mother of all BiFunctors" 308 | 309 | -- Satisfies obvious laws 310 | class Bifunctor u where 311 | bimap :: (a -> b) -> (c -> d) -> u b c -> u a d 312 | 313 | instance Bifunctor (->) where 314 | bimap f g h = g . h . f 315 | 316 | -- Every arrow is a Bifunctor: 317 | --newtype ArrowBifunctor u a b = ArrowBifunctor { unArrowBifunctor :: u a b } 318 | -- deriving (Category, Arrow) 319 | -- 320 | --instance Arrow u => Bifunctor (ArrowBifunctor u) where 321 | -- bimap = arrowBimap 322 | 323 | instance Arrow u => Bifunctor u where 324 | bimap = arrowBimap 325 | 326 | arrowBimap :: Arrow r => (a -> b) -> (c -> d) -> r b c -> r a d 327 | arrowBimap f g u = arr f >>> u >>> arr g 328 | 329 | 330 | newtype BiYoneda u b c = BiYoneda { runBiYoneda :: forall a d. (a -> b) -> (c -> d) -> u a d } 331 | 332 | liftBiYoneda :: Bifunctor u => u a b -> BiYoneda u a b 333 | liftBiYoneda u = BiYoneda (\f' g' -> bimap f' g' u) 334 | 335 | lowerBiYoneda :: BiYoneda u a b -> u a b 336 | lowerBiYoneda u = runBiYoneda u id id 337 | 338 | instance Bifunctor (BiYoneda u) where 339 | bimap f g u = BiYoneda (\f' g' -> runBiYoneda u (f . f') (g' . g)) 340 | 341 | 342 | -- ContraYoneda1 is the "mother of all ContraFunctor1" 343 | 344 | -- contrafmap1 id x = x 345 | -- contrafmap1 f (contrafmap1 g x) = contrafmap1 (g . f) x 346 | class ContraFunctor1 u where 347 | contrafmap1 :: (a -> b) -> u b c -> u a c 348 | 349 | instance ContraFunctor1 (->) where 350 | contrafmap1 f h = h . f 351 | -- contrafmap1 id x 352 | -- = x . id 353 | -- = x 354 | -- 355 | -- contrafmap1 f (contrafmap1 g x) 356 | -- = (x . g) . f 357 | -- = x . (g . f) 358 | -- = contrafmap1 (g . f) x 359 | 360 | -- Every arrow is a ContraFunctor1: 361 | instance Arrow u => ContraFunctor1 u where 362 | contrafmap1 = arrowContrafmap1 363 | 364 | arrowContrafmap1 :: Arrow r => (a -> b) -> r b c -> r a c 365 | arrowContrafmap1 f u = arr f >>> u 366 | 367 | 368 | newtype ContraYoneda1 u b c = ContraYoneda1 { runContraYoneda1 :: forall a. (a -> b) -> u a c } 369 | 370 | liftContraYoneda1 :: ContraFunctor1 u => u a b -> ContraYoneda1 u a b 371 | liftContraYoneda1 u = ContraYoneda1 (\f' -> contrafmap1 f' u) 372 | 373 | lowerContraYoneda1 :: ContraYoneda1 u a b -> u a b 374 | lowerContraYoneda1 u = runContraYoneda1 u id 375 | 376 | instance ContraFunctor1 (ContraYoneda1 u) where 377 | contrafmap1 f u = ContraYoneda1 (\f' -> runContraYoneda1 u (f . f')) 378 | -- contrafmap1 id x 379 | -- = ContraYoneda1 (\f' -> runContraYoneda1 x (id . f')) 380 | -- = ContraYoneda1 (\f' -> runContraYoneda1 x f') 381 | -- = x 382 | -- 383 | -- contrafmap1 f (contrafmap1 g x) 384 | -- = ContraYoneda1 (\f' -> runContraYoneda1 (ContraYoneda1 (\f' -> runContraYoneda1 x (g . f'))) (f . f')) 385 | -- = ContraYoneda1 (\f' -> runContraYoneda1 x (g . (f . f'))) 386 | -- = ContraYoneda1 (\f' -> runContraYoneda1 x ((g . f) . f')) 387 | -- = contrafmap1 (g . f) x 388 | 389 | -- FIXME: a bit funny. Why do I require such a strong superclass constraint? 390 | -- I only need this for (lift/lower)ContraYoneda1Wotsit though, so not a big deal. 391 | instance ContraFunctor1Category u => Category (ContraYoneda1 u) where 392 | id = ContraYoneda1 (\k -> contrafmap1 k id) 393 | u1 . u2 = ContraYoneda1 (\k -> runContraYoneda1 u1 id . runContraYoneda1 u2 k) 394 | -- id . u 395 | -- = ContraYoneda1 (\k -> runContraYoneda1 (ContraYoneda1 (\k -> contrafmap1 k id)) id . runContraYoneda1 u k) 396 | -- = ContraYoneda1 (\k -> contrafmap1 id id . runContraYoneda1 u k) 397 | -- = ContraYoneda1 (\k -> id . runContraYoneda1 u k) 398 | -- = ContraYoneda1 (\k -> runContraYoneda1 u k) 399 | -- = u 400 | -- 401 | -- u . id 402 | -- = ContraYoneda1 (\k -> runContraYoneda1 u id . runContraYoneda1 (ContraYoneda1 (\k -> contrafmap1 k id)) k) 403 | -- = ContraYoneda1 (\k -> runContraYoneda1 u id . contrafmap1 k id) 404 | -- 405 | -- = ContraYoneda1 (\k -> runContraYoneda1 u k) 406 | -- = u 407 | -- 408 | -- u1 . (u2 . u3) 409 | -- = ContraYoneda1 (\k -> runContraYoneda1 u1 id . runContraYoneda1 (ContraYoneda1 (\k -> runContraYoneda1 u2 id . runContraYoneda1 u3 k)) k) 410 | -- = ContraYoneda1 (\k -> runContraYoneda1 u1 id . (runContraYoneda1 u2 id . runContraYoneda1 u3 k)) 411 | -- = ContraYoneda1 (\k -> (runContraYoneda1 u1 id . runContraYoneda1 u2 id) . runContraYoneda1 u3 k) 412 | -- = ContraYoneda1 (\k -> runContraYoneda1 (ContraYoneda1 (\k -> runContraYoneda1 u1 id . runContraYoneda1 u2 k)) id . runContraYoneda1 u3 k) 413 | -- = (u1 . u2) . u3 414 | 415 | -- BiYonedaWotsit is the "mother of all BifunctorCategories" 416 | -- NB: might be nicer to formulate this in terms of pureA rather than bimap 417 | 418 | -- Satisfies interaction laws something like this: 419 | -- bimap f g (u1 >>> u2) = bimap f id u1 >>> bimap id g u2 420 | class (Bifunctor u, Category u) => BifunctorCategory u where 421 | 422 | instance Arrow u => BifunctorCategory u where 423 | 424 | pureA :: BifunctorCategory u => (a -> b) -> u a b 425 | pureA f = bimap id f id 426 | 427 | newtype BiYonedaWotsit u a b = BiYonedaWotsit { runBiYonedaWotsit :: Wotsit (BiYoneda u) a b } 428 | 429 | instance Bifunctor (BiYonedaWotsit u) where 430 | --bimap f g u = BiYonedaWotsit (bimap f g (runBiYonedaWotsit u)) 431 | bimap (f :: a -> b) (g :: c -> d) (u :: BiYonedaWotsit u b c) = BiYonedaWotsit (Wotsit (\(k :: BiYoneda u d e) -> bimap f id (runWotsit (runBiYonedaWotsit u) (bimap g id k)))) 432 | 433 | instance Category (BiYonedaWotsit u) where 434 | id = BiYonedaWotsit id 435 | u1 . u2 = BiYonedaWotsit (runBiYonedaWotsit u1 . runBiYonedaWotsit u2) 436 | 437 | instance BifunctorCategory (BiYonedaWotsit u) where 438 | 439 | 440 | -- ContraYoneda1Wotsit is the "mother of all ContraFunctor1Categories" 441 | 442 | -- contrafmap1 id id = id 443 | -- contrafmap1 f (u1 . u2) = u1 . contrafmap1 f u2 ??? 444 | -- contrafmap1 f id . contrafmap1 g id = contrafmap1 (g . f) id 445 | -- == OR == 446 | -- pureA1 id = id 447 | -- pureA1 f . pureA1 g = pureA1 (f . g) 448 | class (ContraFunctor1 u, Category u) => ContraFunctor1Category u where 449 | pureA1 :: (a -> b) -> u a b 450 | pureA1 f = contrafmap1 f id 451 | 452 | instance Arrow u => ContraFunctor1Category u where 453 | 454 | 455 | newtype ContraYoneda1Wotsit u a b = ContraYoneda1Wotsit { runContraYoneda1Wotsit :: Wotsit (ContraYoneda1 u) a b } 456 | 457 | liftContraYoneda1Wotsit :: ContraFunctor1Category u => u a b -> ContraYoneda1Wotsit u a b 458 | liftContraYoneda1Wotsit u = ContraYoneda1Wotsit (liftWotsit (liftContraYoneda1 u)) 459 | 460 | lowerContraYoneda1Wotsit :: ContraFunctor1Category u => ContraYoneda1Wotsit u a b -> u a b 461 | lowerContraYoneda1Wotsit u = lowerContraYoneda1 (lowerWotsit (runContraYoneda1Wotsit u)) 462 | 463 | instance ContraFunctor1 (ContraYoneda1Wotsit u) where 464 | contrafmap1 f u = ContraYoneda1Wotsit (Wotsit (\k -> contrafmap1 f (runWotsit (runContraYoneda1Wotsit u) k))) 465 | 466 | instance Category (ContraYoneda1Wotsit u) where 467 | id = ContraYoneda1Wotsit id 468 | u1 . u2 = ContraYoneda1Wotsit (runContraYoneda1Wotsit u1 . runContraYoneda1Wotsit u2) 469 | -- id . u 470 | -- = ContraYoneda1Wotsit (runContraYoneda1Wotsit (ContraYoneda1Wotsit id) . runContraYoneda1Wotsit u) 471 | -- = ContraYoneda1Wotsit (id . runContraYoneda1Wotsit u) 472 | -- = ContraYoneda1Wotsit (runContraYoneda1Wotsit u) 473 | -- = u 474 | -- 475 | -- u . id 476 | -- = ContraYoneda1Wotsit (runContraYoneda1Wotsit u . runContraYoneda1Wotsit (ContraYoneda1Wotsit id)) 477 | -- = ContraYoneda1Wotsit (runContraYoneda1Wotsit u . id) 478 | -- = ContraYoneda1Wotsit (runContraYoneda1Wotsit u) 479 | -- = u 480 | -- 481 | -- u1 . (u2 . u3) 482 | -- = ContraYoneda1Wotsit (runContraYoneda1Wotsit u1 . runContraYoneda1Wotsit (ContraYoneda1Wotsit (runContraYoneda1Wotsit u2 . runContraYoneda1Wotsit u3))) 483 | -- = ContraYoneda1Wotsit (runContraYoneda1Wotsit u1 . (runContraYoneda1Wotsit u2 . runContraYoneda1Wotsit u3)) 484 | -- = ContraYoneda1Wotsit ((runContraYoneda1Wotsit u1 . runContraYoneda1Wotsit u2) . runContraYoneda1Wotsit u3) 485 | -- = ContraYoneda1Wotsit (runContraYoneda1Wotsit (ContraYoneda1Wotsit (runContraYoneda1Wotsit u1 . runContraYoneda1Wotsit u2)) . runContraYoneda1Wotsit u3) 486 | -- = (u1 . u2) . u3 487 | 488 | instance ContraFunctor1Category (ContraYoneda1Wotsit u) where 489 | 490 | 491 | -- pureC id = id 492 | -- pureC f . pureC g = pureC (f . g) 493 | class Category p => PurishCategory p where 494 | pureC :: (a -> b) -> p a b 495 | 496 | instance Arrow a => PurishCategory a where 497 | pureC = arr 498 | 499 | newtype PurishWotsit p a b = PurishWotsit { runPurishWotsit :: forall c. (forall d. (d -> b) -> p d c) -> (forall e. (e -> a) -> p e c) } 500 | 501 | liftPurishWotsit :: PurishCategory p => p a b -> PurishWotsit p a b 502 | liftPurishWotsit p = PurishWotsit (\k k' -> pureC k' >>> p >>> k id) 503 | 504 | lowerPurishWotsit :: PurishCategory p => PurishWotsit p a b -> p a b 505 | lowerPurishWotsit p = runPurishWotsit p pureC id 506 | 507 | instance Category (PurishWotsit p) where 508 | id = PurishWotsit (\k k' -> k k') 509 | p1 . p2 = PurishWotsit (runPurishWotsit p2 . runPurishWotsit p1) 510 | -- id . p 511 | -- = PurishWotsit (runPurishWotsit p . runPurishWotsit (PurishWotsit (\k k' -> k k'))) 512 | -- = PurishWotsit (runPurishWotsit p . (\k k' -> k k')) 513 | -- = PurishWotsit (runPurishWotsit p) 514 | -- = p 515 | -- 516 | -- p . id 517 | -- = PurishWotsit (runPurishWotsit (PurishWotsit (\k k' -> k k')) . runPurishWotsit p) 518 | -- = PurishWotsit ((\k k' -> k k') . runPurishWotsit p) 519 | -- = PurishWotsit (runPurishWotsit p) 520 | -- = p 521 | -- 522 | -- p1 . (p2 . p3) 523 | -- = PurishWotsit (runPurishWotsit (PurishWotsit (runPurishWotsit p3 . runPurishWotsit p2)) . runPurishWotsit p1) 524 | -- = PurishWotsit ((runPurishWotsit p3 . runPurishWotsit p2) . runPurishWotsit p1) 525 | -- = PurishWotsit (runPurishWotsit p3 . (runPurishWotsit p2 . runPurishWotsit p1)) 526 | -- = PurishWotsit (runPurishWotsit p3 . runPurishWotsit (PurishWotsit (runPurishWotsit p2 . runPurishWotsit p1))) 527 | -- = (p1 . p2) . p3 528 | 529 | instance PurishCategory (PurishWotsit p) where 530 | pureC x = PurishWotsit (\k k' -> k (x . k')) 531 | -- pureC id 532 | -- = PurishWotsit (\k k' -> k (id . k')) 533 | -- = PurishWotsit (\k k' -> k k') 534 | -- = id 535 | -- 536 | -- pureC f . pureC g 537 | -- = PurishWotsit (runPurishWotsit (PurishWotsit (\k k' -> k (g . k'))) . runPurishWotsit (PurishWotsit (\k k' -> k (f . k')))) 538 | -- = PurishWotsit ((\k k' -> k (g . k')) . (\k k' -> k (f . k'))) 539 | -- = PurishWotsit (\k k' -> k (\l -> f (g (k' l)))) 540 | -- = PurishWotsit (\k k' -> k ((f . g) . k')) 541 | -- = pureC (f . g) 542 | 543 | 544 | -- Voldemort is the "mother of all arrows": 545 | 546 | -- arr :: forall c d. (c -> d) -> r c d 547 | -- (>>>) :: forall a b. r a b -> (forall c. r b c -> r a c) 548 | -- first :: forall a b. r a b -> (forall c. r (a, c) (b, c)) 549 | -- (***) :: forall a b. r a b -> (forall c d. r c d -> r (a, c) (b, d)) 550 | -- 551 | -- arr = pureC 552 | -- first (arr f) = arr (f `cross` id) -- Extension 553 | -- first (f >>> g) = first f >>> first g -- Functor 554 | -- first f >>> arr (id `cross` g) = arr (id `cross` g) >>> first f -- Exchange 555 | -- first f >>> arr fst = arr fst >>> f -- Unit 556 | -- first (first f) >>> arr assoc = arr assoc >>> first f -- Association 557 | -- 558 | -- where 559 | --- (>>>) = flip (.) 560 | -- f `cross` g = \(x, y) -> (f x, g y) 561 | -- assoc (~(a, b), c) = (a, (b, c)) 562 | --newtype Voldemort r a b = Voldemort { runVoldemort :: forall c. BiYonedaWotsit r (a, c) (b, c) } 563 | newtype Voldemort r a b = Voldemort { runVoldemort :: forall c. PurishWotsit r (a, c) (b, c) } 564 | 565 | liftVoldemort :: Arrow r => r a b -> Voldemort r a b 566 | liftVoldemort r = Voldemort (liftPurishWotsit (first r)) 567 | 568 | lowerVoldemort :: Arrow r => Voldemort r a b -> r a b 569 | lowerVoldemort (r :: Voldemort r a b) = arr (\x -> (x, ())) >>> lowerPurishWotsit (runVoldemort r) >>> arr (\(x, ()) -> x) 570 | 571 | instance Category (Voldemort r) where 572 | id = Voldemort id 573 | t1 . t2 = Voldemort (runVoldemort t1 . runVoldemort t2) 574 | 575 | instance PurishCategory (Voldemort r) where 576 | pureC f = Voldemort (pureC (\(x, y) -> (f x, y))) 577 | -- pureC id 578 | -- = Voldemort $ pureC (\(x, y) -> (id x, y)) 579 | -- = Voldemort $ pureC (\(x, y) -> (x, y)) 580 | -- = Voldemort $ pureC id 581 | -- = Voldemort id 582 | -- = id 583 | -- 584 | -- pureC f . pureC g 585 | -- = Voldemort (runVoldemort (Voldemort (pureC (\(x, y) -> (f x, y)))) . runVoldemort (Voldemort (pureC (\(x, y) -> (g x, y))))) 586 | -- = Voldemort ((pureC (\(x, y) -> (f x, y))) . (pureC (\(x, y) -> (g x, y)))) 587 | -- = Voldemort (pureC ((\(x, y) -> (f x, y)) . (\(x, y) -> (g x, y)))) 588 | -- = Voldemort (pureC (\(x, y) -> (f (g x), y))) 589 | -- = Voldemort (pureC (\(x, y) -> ((f . g) x, y))) 590 | -- = pureC (f . g) 591 | 592 | instance Arrow (Voldemort r) where 593 | arr = pureC 594 | -- first t1 = Voldemort (pureC assoc >>> runVoldemort t1 >>> pureC reassoc) 595 | -- where assoc (~(a, c), d) = (a, (c, d)) 596 | -- reassoc (b, ~(c, d)) = ((b, c), d) 597 | first t1 = Voldemort (PurishWotsit ((\k k' -> k (assoc . k')) . runPurishWotsit (runVoldemort t1) . (\k k' -> k (reassoc . k')))) 598 | where assoc (~(a, c), d) = (a, (c, d)) 599 | reassoc (b, ~(c, d)) = ((b, c), d) 600 | -- first (arr f) 601 | -- = Voldemort (pureC assoc >>> runVoldemort (Voldemort (pureC (\(x, y) -> (f x, y)))) >>> pureC reassoc) 602 | -- = Voldemort (pureC assoc >>> pureC (\(x, y) -> (f x, y)) >>> pureC reassoc) 603 | -- = Voldemort (pureC (reassoc . (\(x, y) -> (f x, y)) . assoc)) 604 | -- = Voldemort (pureC (\(~(a, c), d) -> ((f a, c), d))) 605 | -- = Voldemort (pureC (\(~(a, c), d) -> ((f a, id c), d))) 606 | -- = Voldemort (pureC (\(~(a, c), d) -> ((f `cross` id) (a, c), d))) 607 | -- = Voldemort (pureC (\(x, d) -> ((f `cross` id) x, d))) 608 | -- = pureC (f `cross` id) 609 | -- 610 | -- first (f >>> g) 611 | -- = Voldemort (pureC assoc >>> runVoldemort (Voldemort (runVoldemort g . runVoldemort f)) >>> pureC reassoc) 612 | -- = Voldemort (pureC assoc >>> (runVoldemort g . runVoldemort f) >>> pureC reassoc) 613 | -- = Voldemort (pureC reassoc . runVoldemort g . runVoldemort f . pureC assoc) 614 | -- = Voldemort (pureC reassoc . runVoldemort g . id . runVoldemort f . pureC assoc) 615 | -- = Voldemort (pureC reassoc . runVoldemort g . pureC id . runVoldemort f . pureC assoc) 616 | -- = Voldemort (pureC reassoc . runVoldemort g . pureC (assoc . reassoc) . runVoldemort f . pureC assoc) 617 | -- = Voldemort ((pureC reassoc . runVoldemort g . pureC assoc) . (pureC reassoc . runVoldemort f . pureC assoc)) 618 | -- = Voldemort ((pureC assoc >>> runVoldemort g >>> pureC reassoc) . (pureC assoc >>> runVoldemort f >>> pureC reassoc)) 619 | -- = Voldemort (runVoldemort (Voldemort (pureC assoc >>> runVoldemort g >>> pureC reassoc)) . runVoldemort (Voldemort (pureC assoc >>> runVoldemort f >>> pureC reassoc))) 620 | -- = first f >>> first g 621 | -- 622 | -- first f >>> arr (id `cross` g) 623 | -- = Voldemort (runVoldemort (Voldemort (pureC (\(x, y) -> ((id `cross` g) x, y)))) . runVoldemort (Voldemort (pureC assoc >>> runVoldemort f >>> pureC reassoc))) 624 | -- = Voldemort ((pureC (\(x, y) -> ((id `cross` g) x, y))) . (pureC assoc >>> runVoldemort f >>> pureC reassoc)) 625 | -- = Voldemort (pureC (\(x, y) -> ((id `cross` g) x, y)) . pureC reassoc . runVoldemort f . pureC assoc) 626 | -- = Voldemort (pureC ((\(x, y) -> ((id `cross` g) x, y)) . reassoc) . runVoldemort f . pureC assoc) 627 | -- = Voldemort (pureC (\(b, ~(c, d)) -> (((id `cross` g) (b, c), d))) . runVoldemort f . pureC assoc) 628 | -- = Voldemort (pureC (\(b, ~(c, d)) -> (((id b, g c), d))) . runVoldemort f . pureC assoc) 629 | -- = Voldemort (pureC (\(b, ~(c, d)) -> (((b, g c), d))) . runVoldemort f . pureC assoc) 630 | -- ??? free theorem (after expanding . and pureC for PurishWotsit) 631 | -- = Voldemort (pureC reassoc . runVoldemort f . pureC (\(~(a, c), d) -> (a, (g c, d)))) 632 | -- = Voldemort (pureC reassoc . runVoldemort f . pureC (assoc . (\(~(a, c), d) -> ((id a, g c), d)))) 633 | -- = Voldemort (pureC reassoc . runVoldemort f . pureC (assoc . (\(x, y) -> ((id `cross` g) x, y)))) 634 | -- = Voldemort (pureC reassoc . runVoldemort f . pureC assoc . pureC (\(x, y) -> ((id `cross` g) x, y))) 635 | -- = Voldemort ((pureC assoc >>> runVoldemort f >>> pureC reassoc) . (pureC (\(x, y) -> ((id `cross` g) x, y)))) 636 | -- = Voldemort (runVoldemort (Voldemort (pureC assoc >>> runVoldemort f >>> pureC reassoc)) . runVoldemort (Voldemort (pureC (\(x, y) -> ((id `cross` g) x, y))))) 637 | -- = arr (id `cross` g) >>> first f 638 | -- 639 | -- first f >>> arr fst 640 | -- = Voldemort (runVoldemort (Voldemort (pureC (\(x, y) -> (fst x, y)))) . runVoldemort (Voldemort (pureC assoc >>> runVoldemort f >>> pureC reassoc))) 641 | -- = Voldemort (pureC (\(x, y) -> (fst x, y)) . pureC reassoc . runVoldemort f . pureC assoc) 642 | -- = Voldemort (pureC ((\(x, y) -> (fst x, y)) . reassoc) . runVoldemort f . pureC assoc) 643 | -- = Voldemort (pureC (\(b, ~(c, d)) -> (fst (b, c), d)) . runVoldemort f . pureC assoc) 644 | -- = Voldemort (pureC (\(b, ~(c, d)) -> (b, d)) . runVoldemort f . pureC (\(~(a, c), d) -> (a, (c, d)))) 645 | -- ??? free theorem (after expanding . and pureC for PurishWotsit) 646 | -- = Voldemort (runVoldemort f . pureC (\(~(b, c), d) -> (b, d))) 647 | -- = Voldemort (runVoldemort f . pureC (\(x, y) -> (fst x, y))) 648 | -- = Voldemort (runVoldemort f . runVoldemort (Voldemort (pureC (\(x, y) -> (fst x, y))))) 649 | -- = arr fst >>> f 650 | -- 651 | -- first (first f) >>> arr assoc 652 | -- = Voldemort (runVoldemort (Voldemort (pureC (\(x, y) -> (assoc x, y)))) . runVoldemort (Voldemort (pureC assoc >>> runVoldemort (Voldemort (pureC assoc >>> runVoldemort f >>> pureC reassoc)) >>> pureC reassoc))) 653 | -- = Voldemort ((pureC (\(x, y) -> (assoc x, y))) . (pureC assoc >>> (pureC assoc >>> runVoldemort f >>> pureC reassoc) >>> pureC reassoc)) 654 | -- = Voldemort (pureC (\(x, y) -> (assoc x, y)) . pureC reassoc . pureC reassoc . runVoldemort f . pureC assoc . pureC assoc) 655 | -- = Voldemort (pureC ((\(x, y) -> (assoc x, y)) . reassoc . reassoc) . runVoldemort f . pureC (assoc . assoc)) 656 | -- = Voldemort (pureC (\(b, ~(c, ~(d, e))) -> ((b, (c, d)), e)) . runVoldemort f . pureC (\(~(~(a, b), c), d) -> (a, (b, (c, d))))) 657 | -- ??? free theorem 658 | -- = Voldemort (pureC (\(b, ~(c, d)) -> ((b, c), d)) . runVoldemort f . pureC (\(~(~(a, b), c), d) -> (a, ((b, c), d)))) 659 | -- = Voldemort (pureC reassoc . runVoldemort f . pureC (assoc . (\(x, y) -> (assoc x, y)))) 660 | -- = Voldemort (pureC reassoc . runVoldemort f . pureC assoc . pureC (\(x, y) -> (assoc x, y))) 661 | -- = Voldemort ((pureC assoc >>> runVoldemort f >>> pureC reassoc) . (pureC (\(x, y) -> (assoc x, y)))) 662 | -- = arr assoc >>> first f 663 | 664 | 665 | -- Codensity is the "mother of all monads": 666 | 667 | -- return :: forall b. b -> m b 668 | -- (>>=) :: forall a. m a -> (forall b. (a -> m b) -> m b) 669 | -- 670 | -- return a >>= f = f a -- Left identity 671 | -- m >>= return = m -- Right identity 672 | -- (m >>= f) >>= g = m >>= (\x -> f x >>= g) -- Associativity 673 | newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b } 674 | 675 | liftCodensity :: Monad m => m a -> Codensity m a 676 | liftCodensity m = Codensity ((>>=) m) 677 | 678 | lowerCodensity :: Monad m => Codensity m a -> m a 679 | lowerCodensity m = runCodensity m return 680 | 681 | instance Functor (Codensity f) where 682 | fmap f m = Codensity (\k -> runCodensity m (k . f)) 683 | 684 | instance Applicative (Codensity f) where 685 | pure = return 686 | mf <*> mx = Codensity (\k -> runCodensity mf (\f -> runCodensity mx (\x -> k (f x)))) 687 | 688 | instance Monad (Codensity f) where 689 | return x = Codensity (\k -> k x) 690 | m >>= f = Codensity (\c -> runCodensity m (\a -> runCodensity (f a) c)) 691 | -- return a >>= f 692 | -- = Codensity (\c -> runCodensity (Codensity (\k -> k a)) (\a -> runCodensity (f a) c)) 693 | -- = Codensity (\c -> runCodensity (f a) c) 694 | -- = f a 695 | -- 696 | -- m >>= return 697 | -- = Codensity (\c -> runCodensity m (\a -> runCodensity (Codensity (\k -> k x)) c)) 698 | -- = Codensity (\c -> runCodensity m (\a -> c a)) 699 | -- = m 700 | -- 701 | -- ((m >>= f) >>= g) 702 | -- = Codensity (\c -> runCodensity (Codensity (\c -> runCodensity m (\a -> runCodensity (f a) c))) (\a -> runCodensity (g a) c)) 703 | -- = Codensity (\c -> runCodensity m (\a -> runCodensity (f a) (\a -> runCodensity (g a) c))) 704 | -- = Codensity (\c -> runCodensity m (\a -> runCodensity (Codensity (\c -> runCodensity (f a) (\a -> runCodensity (g a) c))) c)) 705 | -- = Codensity (\c -> runCodensity m (\a -> runCodensity (f a >>= g) c)) 706 | -- = m >>= (\x -> f x >>= g) 707 | 708 | 709 | -- CodensityPlus is the "mother of all MonadPlus" 710 | 711 | -- mzero :: forall a. m a 712 | -- mplus :: forall a. m a -> m a -> m a 713 | -- 714 | -- mzero >>= f = mzero -- Left-zero 715 | -- v >>= (\_ -> mzero) = mzero -- Right-zero 716 | -- mplus mzero m = m -- Left-identity 717 | -- mplus m mzero = m -- Right-identity 718 | -- mplus m (mplus n o) = mplus (mplus m n) o -- Associativity 719 | -- mplus m n >>= o = mplus (m >>= o) (n >>= o) -- Distributivity 720 | newtype CodensityPlus p a = CodensityPlus { runCodensityPlus :: forall b. (a -> p b -> p b) -> p b -> p b } 721 | 722 | liftCodensityPlus :: MonadPlus p => p a -> CodensityPlus p a 723 | liftCodensityPlus m = CodensityPlus (\fmsuc mfai -> m >>= (\x -> fmsuc x mfai)) 724 | 725 | lowerCodensityPlus :: MonadPlus p => CodensityPlus p a -> p a 726 | lowerCodensityPlus m = runCodensityPlus m (\x mx -> return x `mplus` mx) mzero 727 | 728 | instance Functor (CodensityPlus p) where 729 | fmap f m = CodensityPlus (\fmsuc mfai -> runCodensityPlus m (fmsuc . f) mfai) 730 | 731 | instance Monad (CodensityPlus p) where 732 | return x = CodensityPlus (\fmsuc mfai -> fmsuc x mfai) 733 | mx >>= fxmy = CodensityPlus (\fmsuc mfai -> runCodensityPlus mx (\x mfai -> runCodensityPlus (fxmy x) fmsuc mfai) mfai) 734 | 735 | instance MonadPlus (CodensityPlus p) where 736 | mzero = CodensityPlus (\_fmsuc mfai -> mfai) 737 | m1 `mplus` m2 = CodensityPlus (\fmsuc mfai -> runCodensityPlus m1 fmsuc (runCodensityPlus m2 fmsuc mfai)) 738 | -- mzero >>= f 739 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus (CodensityPlus (\_fmsuc mfai -> mfai)) (\x mfai -> runCodensityPlus (f x) fmsuc mfai) mfai) 740 | -- = CodensityPlus (\fmsuc mfai -> mfai) 741 | -- = mzero 742 | -- 743 | -- v >>= (\_ -> mzero) 744 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus v (\x mfai -> runCodensityPlus ((\_ -> mzero) x) fmsuc mfai) mfai) 745 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus v (\x mfai -> runCodensityPlus (CodensityPlus (\_fmsuc mfai -> mfai)) fmsuc mfai) mfai) 746 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus v (\x mfai -> mfai) mfai) 747 | -- 748 | -- = CodensityPlus (\_fmsuc mfai -> mfai) 749 | -- = mzero 750 | -- 751 | -- mplus mzero m 752 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus (CodensityPlus (\_fmsuc mfai -> mfai)) fmsuc (runCodensityPlus m fmsuc mfai)) 753 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus m fmsuc mfai) 754 | -- = m 755 | -- 756 | -- mplus m mzero 757 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus m fmsuc (runCodensityPlus (CodensityPlus (\_fmsuc mfai -> mfai)) fmsuc mfai)) 758 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus m fmsuc mfai) 759 | -- = m 760 | -- 761 | -- mplus m (mplus n o) 762 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus m fmsuc (runCodensityPlus (CodensityPlus (\fmsuc mfai -> runCodensityPlus n fmsuc (runCodensityPlus o fmsuc mfai))) fmsuc mfai)) 763 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus m fmsuc (runCodensityPlus n fmsuc (runCodensityPlus o fmsuc mfai))) 764 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus (CodensityPlus (\fmsuc mfai -> runCodensityPlus m fmsuc (runCodensityPlus n fmsuc mfai))) fmsuc (runCodensityPlus o fmsuc mfai)) 765 | -- = mplus (mplus m n) o 766 | -- 767 | -- mplus m n >>= o 768 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus (CodensityPlus (\fmsuc mfai -> runCodensityPlus m fmsuc (runCodensityPlus n fmsuc mfai))) (\x mfai -> runCodensityPlus (o x) fmsuc mfai) mfai) 769 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus m (\x mfai -> runCodensityPlus (o x) fmsuc mfai) (runCodensityPlus n (\x mfai -> runCodensityPlus (o x) fmsuc mfai) mfai)) 770 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus (CodensityPlus (\fmsuc mfai -> runCodensityPlus m (\x mfai -> runCodensityPlus (o x) fmsuc mfai) mfai)) fmsuc (runCodensityPlus (CodensityPlus (\fmsuc mfai -> runCodensityPlus n (\x mfai -> runCodensityPlus (o x) fmsuc mfai) mfai)) fmsuc mfai)) 771 | -- = CodensityPlus (\fmsuc mfai -> runCodensityPlus (m >>= o) fmsuc (runCodensityPlus (n >>= o) fmsuc mfai)) 772 | -- = mplus (m >>= o) (n >>= o) 773 | 774 | main :: IO () 775 | main = return () 776 | --------------------------------------------------------------------------------