├── Setup.hs ├── .gitignore ├── CallByName.hs ├── CallByValue.hs ├── Ids.hs ├── Utilities.hs ├── Duality.hs ├── dual-calculus.cabal ├── LICENSE ├── CallByValue ├── CPS.hs └── Evaluate.hs ├── CallByName ├── Evaluate.hs └── CPS.hs ├── Test.hs ├── Substitution.hs ├── Syntax.hs ├── Core.hs └── Main.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Build artifacts 2 | dist/ 3 | *.hi 4 | *.o 5 | 6 | # Operating system rubbish 7 | .DS_Store 8 | Thumbs.db 9 | -------------------------------------------------------------------------------- /CallByName.hs: -------------------------------------------------------------------------------- 1 | module CallByName ( 2 | module CallByName.CPS, 3 | module CallByName.Evaluate 4 | ) where 5 | 6 | import CallByName.CPS 7 | import CallByName.Evaluate -------------------------------------------------------------------------------- /CallByValue.hs: -------------------------------------------------------------------------------- 1 | module CallByValue ( 2 | module CallByValue.CPS, 3 | module CallByValue.Evaluate 4 | ) where 5 | 6 | import CallByValue.CPS 7 | import CallByValue.Evaluate -------------------------------------------------------------------------------- /Ids.hs: -------------------------------------------------------------------------------- 1 | module Ids( 2 | module Data.Unique.Id, 3 | 4 | IdM, runIdM, 5 | idSupply, fresh 6 | ) where 7 | 8 | import Control.Monad 9 | 10 | import Data.Unique.Id 11 | 12 | 13 | newtype IdM a = IdM { unIdM :: IdSupply -> a } 14 | 15 | instance Functor IdM where 16 | fmap = liftM 17 | 18 | instance Monad IdM where 19 | return = IdM . const 20 | mx >>= fxmy = IdM $ \ids -> case splitIdSupply ids of (ids1, ids2) -> unIdM (fxmy (unIdM mx ids1)) ids2 21 | 22 | runIdM :: IdSupply -> IdM a -> a 23 | runIdM = flip unIdM 24 | 25 | idSupply :: IdM IdSupply 26 | idSupply = IdM id 27 | 28 | fresh :: String -> IdM String 29 | fresh x = fmap (\ids -> x ++ "_" ++ show (idFromSupply ids)) idSupply 30 | -------------------------------------------------------------------------------- /Utilities.hs: -------------------------------------------------------------------------------- 1 | module Utilities where 2 | 3 | 4 | uncons [] = Nothing 5 | uncons xs = Just (init xs, last xs) 6 | 7 | spanRev p xs = case span p (reverse xs) of (sats, unsats) -> (reverse unsats, reverse sats) 8 | 9 | 10 | data InfiniteTree a = Node { tree_node :: a, tree_left :: InfiniteTree a, tree_right :: InfiniteTree a } 11 | 12 | flattenInfiniteTree :: InfiniteTree a -> [a] 13 | flattenInfiniteTree (Node x t1 _) = x : flattenInfiniteTree t1 14 | 15 | splitInfiniteTree :: InfiniteTree a -> [InfiniteTree a] 16 | splitInfiniteTree (Node _ t1 t2) = t1 : splitInfiniteTree t2 17 | 18 | filterInfiniteTree :: (a -> Bool) -> InfiniteTree a -> InfiniteTree a 19 | filterInfiniteTree p (Node x t1 t2) | p x = Node x (filterInfiniteTree p t1) (filterInfiniteTree p t2) 20 | | otherwise = filterInfiniteTree p t1 21 | -------------------------------------------------------------------------------- /Duality.hs: -------------------------------------------------------------------------------- 1 | module Duality( dualizeStmt, dualizeTerm, dualizeCoTerm ) where 2 | 3 | import Syntax 4 | 5 | 6 | dualizeStmt :: Stmt -> Stmt 7 | dualizeStmt (m `Cut` k) = dualizeCoTerm k `Cut` dualizeTerm m 8 | 9 | dualizeTerm :: Term -> CoTerm 10 | dualizeTerm (Var x) = CoVar x 11 | dualizeTerm (Tup m n) = CoData (dualizeTerm m) (dualizeTerm n) 12 | dualizeTerm (Data m lr) = CoTup (case lr of Inl -> Fst; Inr -> Snd) (dualizeTerm m) 13 | dualizeTerm (Not k) = CoNot (dualizeCoTerm k) 14 | dualizeTerm (Bind s a) = CoBind a (dualizeStmt s) 15 | 16 | dualizeCoTerm :: CoTerm -> Term 17 | dualizeCoTerm (CoVar a) = Var a 18 | dualizeCoTerm (CoData k l) = Tup (dualizeCoTerm k) (dualizeCoTerm l) 19 | dualizeCoTerm (CoTup fs k) = Data (dualizeCoTerm k) (case fs of Fst -> Inl; Snd -> Inr) 20 | dualizeCoTerm (CoNot m) = Not (dualizeTerm m) 21 | dualizeCoTerm (CoBind x s) = Bind (dualizeStmt s) x 22 | -------------------------------------------------------------------------------- /dual-calculus.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: >= 1.2 2 | Build-Type: Simple 3 | Name: dual-calculus 4 | Version: 0.1 5 | Maintainer: Max Bolingbroke 6 | Homepage: http://www.github.com/batterseapower/dual-calculus 7 | License: BSD3 8 | License-File: LICENSE 9 | Author: Max Bolingbroke 10 | Synopsis: An implementation of the dual calculus in Haskell 11 | Category: Language 12 | 13 | Executable dual-calculus 14 | Main-Is: Main.hs 15 | Build-Depends: base >= 4 && < 5, containers >= 0.3 && < 0.4, 16 | prettyclass >= 1 && < 1.2, uniqueid >= 0.1.1 && < 0.2, 17 | QuickCheck >= 1.2 && < 1.3, random >= 1.0 && < 1.1 18 | Extensions: TypeOperators, PatternGuards 19 | 20 | Ghc-Options: -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Neil Mitchell 2006-2007. 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 Neil Mitchell 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 | -------------------------------------------------------------------------------- /CallByValue/CPS.hs: -------------------------------------------------------------------------------- 1 | module CallByValue.CPS( cps ) where 2 | 3 | import CallByValue.Evaluate ( lam, colam ) 4 | import Core 5 | import Ids 6 | import Syntax 7 | 8 | import Data.Maybe 9 | 10 | 11 | cps :: IdSupply -> Stmt -> Core 12 | cps ids = runIdM ids . cpsStmt [] [] 13 | 14 | 15 | type Env = [(Var, Core)] 16 | type CoEnv = [(CoVar, Core -> IdM Core)] 17 | 18 | lookupVar x env = fromMaybe (CoreVar x) $ lookup x env 19 | lookupCoVar a coenv = fromMaybe (return . (CoreVar a `CoreApp`)) $ lookup a coenv 20 | 21 | cpsTerm :: Env -> CoEnv -> Term -> (Core -> IdM Core) -> IdM Core 22 | cpsTerm env coenv m gamma = case m of 23 | Var x -> gamma (lookupVar x env) 24 | Tup m n -> cpsTerm env coenv m $ \x -> cpsTerm env coenv n $ \y -> gamma (CoreTup x y) 25 | Data m lr -> cpsTerm env coenv m $ \x -> gamma (CoreData lr x) 26 | Not k -> do 27 | z <- fresh "notcob" 28 | body <- cpsCoTerm env coenv k (CoreVar z) 29 | gamma (CoreLam z body) 30 | Bind s a -> cpsStmt env ((a, gamma) : coenv) s 31 | Lam x m -> cpsTerm env coenv (lam x m) gamma 32 | 33 | cpsCoTerm :: Env -> CoEnv -> CoTerm -> Core -> IdM Core 34 | cpsCoTerm env coenv k z = case k of 35 | CoVar a -> (lookupCoVar a coenv) z 36 | CoData k l -> do 37 | x <- fresh "altb1" 38 | y <- fresh "altb2" 39 | inlcont <- cpsCoTerm env coenv k (CoreVar x) 40 | inrcont <- cpsCoTerm env coenv l (CoreVar y) 41 | return $ CoreCase z (x, inlcont) (y, inrcont) 42 | CoTup fs k -> do 43 | x <- fresh "selb" 44 | cont <- cpsCoTerm env coenv k (CoreVar x) 45 | return $ CoreSelect z fs x cont 46 | CoNot m -> do 47 | -- Possibly correct alternative rule: 48 | --cpsTerm env coenv m (return . (`CoreApp` z)) 49 | gamma <- fresh "conotb" 50 | body <- cpsTerm env coenv m (return . (`CoreApp` CoreVar gamma)) 51 | return $ z `CoreApp` CoreLam gamma body 52 | CoBind x s -> cpsStmt ((x, z) : env) coenv s 53 | CoLam m k -> cpsCoTerm env coenv (colam m k) z 54 | 55 | cpsStmt :: Env -> CoEnv -> Stmt -> IdM Core 56 | cpsStmt env coenv (m `Cut` k) = cpsTerm env coenv m (cpsCoTerm env coenv k) -------------------------------------------------------------------------------- /CallByValue/Evaluate.hs: -------------------------------------------------------------------------------- 1 | module CallByValue.Evaluate( step, eval, value, lam, colam, CallByValue.Evaluate.app ) where 2 | 3 | import Substitution 4 | import Syntax 5 | 6 | import Data.Maybe 7 | 8 | 9 | step :: Stmt -> Maybe Stmt 10 | -- If we are cutting against a non-value we can evaluate inside, do so 11 | step (m `Cut` k) | Just (Just f, m) <- eval m = Just $ m `Cut` CoBind wildEcks (f (Var wildEcks) `Cut` k) 12 | -- Two possibilities remain: 13 | -- 1) We are cutting against a value 14 | -- 2) We are cutting against a non-value we can't go inside: i.e. a bind 15 | -- 16 | -- We tackle 2) first. NB: it doesn't matter if the bind is also a value, the result is confluent 17 | step (Bind s a `Cut` k) = {- trace (prettyShow ("SHAREABLE", k)) $ -} Just $ substStmt (coTermSubst a k) s 18 | -- The only remaining possibility is 1), so we can run the other clauses 19 | step (Data v lr `Cut` CoData k l) = Just $ v `Cut` (case lr of Inl -> k; Inr -> l) 20 | step (Tup v w `Cut` CoTup fs k) = Just $ (case fs of Fst -> v; Snd -> w) `Cut` k 21 | step (Not k `Cut` CoNot m) = Just $ m `Cut` k 22 | step (Lam x n `Cut` CoLam m k) = Just $ m `Cut` CoBind x (n `Cut` k) 23 | step (v `Cut` CoBind x s) = Just $ substStmt (termSubst x v) s 24 | -- We can't reduce if any one of these occurs: 25 | -- 1) The term is a variable 26 | -- 2) The coterm is a covariable 27 | -- 3) The term is Fix (Fix isn't reducible in CBV. Could add CoFix to do something here though) 28 | step _ = Nothing 29 | 30 | -- Invariant: eval m == Just (_, n) ==> not (value n) 31 | -- This prevents infinite loops in the normaliser: there is no point pulling out bare variables, for example 32 | eval :: Term -> Maybe (Maybe (Term -> Term), Term) 33 | eval (Data m lr) = do (mb_f, m) <- eval m; return (Just $ flip Data lr . fromMaybe id mb_f, m) 34 | eval (Tup m n) | not (value m) = do (mb_f, m) <- eval m; return (Just $ \m -> Tup (fromMaybe id mb_f m) n, m) 35 | | not (value n) = do (mb_f, n) <- eval n; return (Just $ \n -> Tup m (fromMaybe id mb_f n), n) 36 | eval m | value m = Nothing 37 | | otherwise = Just (Nothing, m) 38 | 39 | value :: Term -> Bool 40 | value (Var _) = True 41 | value (Data m _) = value m 42 | value (Tup m n) = value m && value n 43 | value (Not _) = True 44 | value (Lam _ _) = True 45 | value (Fix _ _) = False 46 | --value (Bind (m `Cut` CoTup _ (CoVar b)) a) = value m && a == b 47 | value (Bind _ _) = False 48 | 49 | -- CBV Is Dual To CBN, Reloaded: Section 3, Proposition 3 50 | lam x m = Not (CoBind wildEcks (Var wildEcks `Cut` CoTup Fst (CoBind x (Var wildEcks `Cut` CoTup Snd (CoNot m))))) 51 | colam m k = CoNot (Tup m (Not k)) 52 | app m n = Bind (m `Cut` (n `colam` CoVar wildAlpha)) wildAlpha 53 | -------------------------------------------------------------------------------- /CallByName/Evaluate.hs: -------------------------------------------------------------------------------- 1 | module CallByName.Evaluate( step, coeval, covalue, lam, colam, CallByName.Evaluate.app ) where 2 | 3 | import Substitution 4 | import Syntax 5 | 6 | import Data.Maybe 7 | 8 | 9 | step :: Stmt -> Maybe Stmt 10 | -- If we are cutting against a non-covalue we can evaluate inside, do so 11 | step (m `Cut` k) | Just (Just f, k) <- coeval k = Just $ Bind (m `Cut` f (CoVar wildAlpha)) wildAlpha `Cut` k 12 | -- Two possibilities remain: 13 | -- 1) We are cutting against a covalue 14 | -- 2) We are cutting against a non-covalue we can't go inside: i.e. a cobind 15 | -- 16 | -- We tackle 2) first. NB: it doesn't matter if the cobind is also a covalue, the result is confluent 17 | step (m `Cut` CoBind x s) = {- trace (prettyShow ("SHAREABLE", m)) $ -} Just $ substStmt (termSubst x m) s 18 | -- The only remaining possibility is 1), so we can run the other clauses 19 | step (Data m lr `Cut` CoData k l) = Just $ m `Cut` (case lr of Inl -> k; Inr -> l) 20 | step (Tup m n `Cut` CoTup fs p) = Just $ (case fs of Fst -> m; Snd -> n) `Cut` p 21 | step (Not k `Cut` CoNot m) = Just $ m `Cut` k 22 | step (Lam x n `Cut` CoLam m k) = Just $ m `Cut` CoBind x (n `Cut` k) 23 | step (Fix x m `Cut` p) = Just $ Fix x m `Cut` CoBind x (m `Cut` p) 24 | step (Bind s a `Cut` p) = Just $ substStmt (coTermSubst a p) s 25 | -- We can't reduce if any one of these occurs: 26 | -- 1) The term is a variable 27 | -- 2) The coterm is a covariable 28 | step _ = Nothing 29 | 30 | -- Invariants: 31 | -- coeval k == Just (_, l) ==> not (covalue l) 32 | -- coeval k == Just (Nothing, l) ==> k == l 33 | -- coeval k == Just (Just f, l) ==> k /= l && k == f l 34 | coeval :: CoTerm -> Maybe (Maybe (CoTerm -> CoTerm), CoTerm) 35 | coeval (CoData k l) 36 | | not (covalue l) = do (mb_f, l) <- coeval l; return (Just $ \l -> CoData k (fromMaybe id mb_f l), l) 37 | | not (covalue k) = do (mb_f, k) <- coeval k; return (Just $ \k -> CoData (fromMaybe id mb_f k) l, k) 38 | coeval (CoTup fs k) = do (mb_f, k) <- coeval k; return (Just $ CoTup fs . fromMaybe id mb_f, k) 39 | coeval (CoLam m k) = do (mb_f, k) <- coeval k; return (Just $ CoLam m . fromMaybe id mb_f, k) 40 | coeval k | covalue k = Nothing 41 | | otherwise = Just (Nothing, k) 42 | 43 | covalue :: CoTerm -> Bool 44 | covalue (CoVar _) = True 45 | covalue (CoData k l) = covalue k && covalue l 46 | covalue (CoTup _ k) = covalue k 47 | covalue (CoNot _) = True 48 | covalue (CoLam _ k) = covalue k 49 | --covalue (CoBind x (Data _ (Var y) `Cut` k)) = covalue k && x == y 50 | covalue (CoBind _ _) = False 51 | 52 | -- CBV Is Dual To CBN, Reloaded: Section 3, Proposition 4 53 | lam x m = Bind (Data (Not (CoBind x (Data m Inr `Cut` CoVar wildAlpha))) Inl `Cut` CoVar wildAlpha) wildAlpha 54 | colam m k = CoData (CoNot m) k 55 | app m n = Bind (m `Cut` (n `colam` CoVar wildAlpha)) wildAlpha 56 | -------------------------------------------------------------------------------- /CallByName/CPS.hs: -------------------------------------------------------------------------------- 1 | module CallByName.CPS( cps ) where 2 | 3 | import CallByName.Evaluate ( lam, colam ) 4 | import Core 5 | import Ids 6 | import Syntax 7 | 8 | import Data.Maybe 9 | 10 | 11 | cps :: IdSupply -> Stmt -> Core 12 | cps ids = runIdM ids . cpsStmt [] [] 13 | 14 | 15 | type Env = [(Var, Core -> IdM Core)] 16 | type CoEnv = [(CoVar, Core)] 17 | 18 | lookupVar x env = fromMaybe (return . (CoreVar x `CoreApp`)) $ lookup x env 19 | lookupCoVar a coenv = fromMaybe (CoreVar a) $ lookup a coenv 20 | 21 | cpsTerm :: Env -> CoEnv -> Term -> Core -> IdM Core 22 | cpsTerm env coenv m gamma = case m of 23 | Var x -> (lookupVar x env) gamma 24 | Tup m n -> do 25 | x <- fresh "tupcob1" 26 | y <- fresh "tupcob2" 27 | left <- cpsTerm env coenv m (CoreVar x) 28 | right <- cpsTerm env coenv n (CoreVar y) 29 | return $ CoreCase gamma (x, left) (y, right) 30 | Data m lr -> do 31 | x <- fresh "datacob" 32 | body <- cpsTerm env coenv m (CoreVar x) 33 | return $ CoreSelect gamma (case lr of Inl -> Fst; Inr -> Snd) x body 34 | Not k -> do 35 | -- Possibly correct alternative rule: 36 | --cpsCoTerm env coenv k (return . (gamma `CoreApp`)) 37 | z <- fresh "notb" 38 | body <- cpsCoTerm env coenv k (return . (CoreVar z `CoreApp`)) 39 | return $ CoreLam z body `CoreApp` gamma 40 | Bind s a -> cpsStmt env ((a, gamma):coenv) s 41 | Lam x m -> cpsTerm env coenv (lam x m) gamma 42 | 43 | cpsCoTerm :: Env -> CoEnv -> CoTerm -> (Core -> IdM Core) -> IdM Core 44 | cpsCoTerm env coenv k z = case k of 45 | CoVar a -> z (lookupCoVar a coenv) 46 | CoData k l -> cpsCoTerm env coenv k $ \alpha -> cpsCoTerm env coenv l $ \beta -> z (CoreTup alpha beta) 47 | CoTup fs k -> cpsCoTerm env coenv k $ \alpha -> z (CoreData (case fs of Fst -> Inl; Snd -> Inr) alpha) 48 | CoNot m -> do 49 | gamma <- fresh "notcob" 50 | body <- cpsTerm env coenv m (CoreVar gamma) 51 | z (CoreLam gamma body) 52 | CoBind x s -> cpsStmt ((x, z):env) coenv s 53 | CoLam m k -> cpsCoTerm env coenv (colam m k) z 54 | 55 | cpsStmt :: Env -> CoEnv -> Stmt -> IdM Core 56 | cpsStmt env coenv (m `Cut` k) = cpsCoTerm env coenv k (cpsTerm env coenv m) 57 | 58 | {- 59 | example1 = lam "x" (Var "x") `Cut` colam (Var "y") (CoVar "halt") 60 | example2 = Data "Left" (Tup []) `Cut` CoData [(Just "Left", CoVar "halt"), (Just "Right", CoTup 1 (CoVar "halt"))] 61 | example3 = Tup [Tup [], Tup [Tup [], Tup []]] `Cut` CoTup 1 (CoTup 0 (CoVar "halt")) 62 | example4 = lam "x" (Var "x") `Cut` CoBind "id" (Bind (Var "id" `Cut` colam (Var "id") (CoVar "alpha")) "alpha" `Cut` 63 | CoBind "expensive" (Var "expensive" `Cut` colam (Var "expensive") (CoVar "halt"))) 64 | 65 | 66 | example = example4 67 | 68 | main = do 69 | print example 70 | print $ cpsStmt [("y", Zed (CoreApp (CoreVar "y"))), ("halt", Gamma (CoreVar "halt"))] example 71 | -} -------------------------------------------------------------------------------- /Test.hs: -------------------------------------------------------------------------------- 1 | module Test where 2 | 3 | import qualified CallByName 4 | import qualified CallByValue 5 | import Duality 6 | import Substitution 7 | import Syntax 8 | 9 | import Control.Monad 10 | 11 | import Data.Unique.Id 12 | 13 | import Test.QuickCheck 14 | import Text.Show.Functions () 15 | 16 | 17 | instance Arbitrary InlInr where 18 | arbitrary = elements [Inl, Inr] 19 | coarbitrary Inl = variant 0 20 | coarbitrary Inr = variant 1 21 | 22 | instance Arbitrary FstSnd where 23 | arbitrary = elements [Fst, Snd] 24 | coarbitrary Fst = variant 0 25 | coarbitrary Snd = variant 1 26 | 27 | instance Arbitrary Stmt where 28 | arbitrary = arbitraryStmt ["input"] ["halt"] 29 | coarbitrary = error "Stmt: coarbitrary" 30 | 31 | arbitraryStmt :: [Var] -> [CoVar] -> Gen Stmt 32 | arbitraryStmt vs covs = liftM2 Cut (arbitraryTerm vs covs) (arbitraryCoTerm vs covs) 33 | 34 | arbitraryTerm :: [Var] -> [CoVar] -> Gen Term 35 | arbitraryTerm vs covs = sized $ \n -> 36 | if n <= 0 37 | then liftM Var (elements vs) 38 | else oneof [ 39 | resize (n - 1) $ liftM2 Data (arbitraryTerm vs covs) arbitrary, 40 | resize (n `div` 2) $ liftM2 Tup (arbitraryTerm vs covs) (arbitraryTerm vs covs), 41 | resize (n - 1) $ liftM Not (arbitraryCoTerm vs covs), 42 | resize (n - 1) $ let a = "a" ++ show (length covs) in liftM (flip Bind a) (arbitraryStmt vs (a : covs)) 43 | ] 44 | 45 | arbitraryCoTerm :: [Var] -> [CoVar] -> Gen CoTerm 46 | arbitraryCoTerm vs covs = sized $ \n -> 47 | if n <= 0 48 | then liftM CoVar (elements covs) 49 | else oneof [ 50 | resize (n `div` 2) $ liftM2 CoData (arbitraryCoTerm vs covs) (arbitraryCoTerm vs covs), 51 | resize (n - 1) $ liftM2 CoTup arbitrary (arbitraryCoTerm vs covs), 52 | resize (n - 1) $ liftM CoNot (arbitraryTerm vs covs), 53 | resize (n - 1) $ let x = "x" ++ show (length vs) in liftM (CoBind x) (arbitraryStmt (x : vs) covs) 54 | ] 55 | 56 | 57 | main :: IdSupply -> IO () 58 | main ids = do 59 | -- CBV Is Dual To CBN: Proposition 3.1 -- Duality is an involution 60 | quickCheck $ \s -> dualizeStmt (dualizeStmt s) == s 61 | -- CBV Is Dual To CBN: Proposition 5.1 -- Call-by-value is dual to call-by-name 62 | quickCheck $ \s -> CallByName.step s == fmap dualizeStmt (CallByValue.step (dualizeStmt s)) 63 | -- CBV Is Dual To CBN: Proposition 5.2 -- Under call-by-value, implication can be defined by ... 64 | quickCheck $ forAllTwoHoleCtxt $ \ctxt -> forAll (arbitraryTerm ["x"] []) $ \m -> 65 | CallByValue.step (ctxt (CallByValue.lam "x" m) (CallByValue.colam (Var "y") (CoVar "halt"))) == CallByValue.step (ctxt (Lam "x" m) (CoLam (Var "y") (CoVar "halt"))) 66 | -- CBV Is Dual To CBN: Proposition 5.3 -- Under call-by-name, implication can be defined by ... 67 | quickCheck $ forAllTwoHoleCtxt $ \ctxt -> forAll (arbitraryTerm ["x"] []) $ \m -> 68 | normalise CallByName.step (ctxt (CallByName.lam "x" m) (CallByValue.colam (Var "y") (CoVar "halt"))) == normalise CallByName.step (ctxt (Lam "x" m) (CoLam (Var "y") (CoVar "halt"))) 69 | -- CBV Is Dual To CBN: Proposition 6.3 -- The call-by-value and call-by-name CPS translations are dual 70 | quickCheck $ \s -> CallByValue.cps ids s == CallByName.cps ids (dualizeStmt s) 71 | 72 | normalise :: (a -> Maybe a) -> a -> Maybe a 73 | normalise step what = go 50 what 74 | where go 0 _ = Nothing 75 | go n what = case step what of Just what -> go (n - 1) what 76 | Nothing -> Just what 77 | 78 | forAllTwoHoleCtxt :: Testable b => ((Term -> CoTerm -> Stmt) -> b) -> Property 79 | forAllTwoHoleCtxt test = forAll (arbitraryStmt ["f"] ["a"]) $ \stmt -> test $ \f a -> substStmt (extendSubstTerm (coTermSubst "a" a) "f" f) stmt -------------------------------------------------------------------------------- /Substitution.hs: -------------------------------------------------------------------------------- 1 | module Substitution where 2 | 3 | import Syntax 4 | 5 | import Control.Arrow (first, second) 6 | 7 | import qualified Data.Map as M 8 | import qualified Data.Set as S 9 | 10 | 11 | type InScopeSet = (S.Set Var, S.Set CoVar) 12 | 13 | emptyInScopeSet :: InScopeSet 14 | emptyInScopeSet = (S.empty, S.empty) 15 | 16 | 17 | varInInScopeSet :: InScopeSet -> Var -> Bool 18 | varInInScopeSet = flip S.member . fst 19 | 20 | coVarInInScopeSet :: InScopeSet -> CoVar -> Bool 21 | coVarInInScopeSet = flip S.member . snd 22 | 23 | extendInScopeSetVar :: InScopeSet -> Var -> InScopeSet 24 | extendInScopeSetVar iss x = first (S.insert x) iss 25 | 26 | extendInScopeSetCoVar :: InScopeSet -> CoVar -> InScopeSet 27 | extendInScopeSetCoVar iss a = second (S.insert a) iss 28 | 29 | 30 | data Subst = Subst { 31 | subst_terms :: M.Map Var Term, 32 | subst_coterms :: M.Map CoVar CoTerm, 33 | subst_inscope :: InScopeSet 34 | } 35 | 36 | emptySubst :: InScopeSet -> Subst 37 | emptySubst iss = Subst M.empty M.empty iss 38 | 39 | termSubst :: Var -> Term -> Subst 40 | termSubst = extendSubstTerm (emptySubst emptyInScopeSet) 41 | 42 | coTermSubst :: CoVar -> CoTerm -> Subst 43 | coTermSubst = extendSubstCoTerm (emptySubst emptyInScopeSet) 44 | 45 | 46 | extendSubstTerm :: Subst -> Var -> Term -> Subst 47 | extendSubstTerm s x m = s { subst_terms = M.insert x m (subst_terms s) } 48 | 49 | extendSubstCoTerm :: Subst -> CoVar -> CoTerm -> Subst 50 | extendSubstCoTerm s a k = s { subst_coterms = M.insert a k (subst_coterms s) } 51 | 52 | uniqAway :: String -> S.Set String -> String 53 | uniqAway x iss = go 0 54 | where go n | x' `S.notMember` iss = x' 55 | | otherwise = go (n + 1) 56 | where x' = x ++ show n 57 | 58 | substAnyBinder :: (InScopeSet -> S.Set String) -> (InScopeSet -> S.Set String -> InScopeSet) 59 | -> (Subst -> M.Map String a) -> (Subst -> M.Map String a -> Subst) 60 | -> (String -> a) 61 | -> Subst -> String -> (Subst, String) 62 | substAnyBinder get set get_map set_map inj s x = (s' { subst_inscope = set iss (S.insert x' my_iss) }, x') 63 | where 64 | iss = subst_inscope s 65 | my_iss = get iss 66 | (s', x') | x `S.member` my_iss 67 | , let x' = uniqAway x my_iss = (set_map s (M.insert x (inj x') (get_map s)), x') 68 | | otherwise = (set_map s (M.delete x (get_map s)), x) 69 | 70 | substBinder :: Subst -> Var -> (Subst, Var) 71 | substBinder = substAnyBinder fst (\iss set -> (set, snd iss)) subst_terms (\s m -> s { subst_terms = m }) Var 72 | 73 | substCoBinder :: Subst -> CoVar -> (Subst, CoVar) 74 | substCoBinder = substAnyBinder snd (\iss set -> (fst iss, set)) subst_coterms (\s m -> s { subst_coterms = m }) CoVar 75 | 76 | substVar :: Subst -> Var -> Term 77 | substVar s x = M.findWithDefault (Var x) x (subst_terms s) 78 | 79 | substCoVar :: Subst -> CoVar -> CoTerm 80 | substCoVar s a = M.findWithDefault (CoVar a) a (subst_coterms s) 81 | 82 | 83 | substTerm :: Subst -> Term -> Term 84 | substTerm subst m = case m of 85 | Var x -> substVar subst x 86 | Data m lr -> Data (substTerm subst m) lr 87 | Tup m n -> Tup (substTerm subst m) (substTerm subst n) 88 | Not k -> Not (substCoTerm subst k) 89 | Lam x m -> Lam x' (substTerm subst' m) 90 | where (subst', x') = substBinder subst x 91 | Bind s a -> Bind (substStmt subst' s) a' 92 | where (subst', a') = substCoBinder subst a 93 | Fix x m -> Fix x' (substTerm subst' m) 94 | where (subst', x') = substBinder subst x 95 | 96 | substCoTerm :: Subst -> CoTerm -> CoTerm 97 | substCoTerm subst k = case k of 98 | CoVar a -> substCoVar subst a 99 | CoData k l -> CoData (substCoTerm subst k) (substCoTerm subst l) 100 | CoTup i k -> CoTup i (substCoTerm subst k) 101 | CoNot m -> CoNot (substTerm subst m) 102 | CoLam m k -> CoLam (substTerm subst m) (substCoTerm subst k) 103 | CoBind x s -> CoBind x' (substStmt subst' s) 104 | where (subst', x') = substBinder subst x 105 | 106 | substStmt :: Subst -> Stmt -> Stmt 107 | substStmt subst (m `Cut` k) = substTerm subst m `Cut` substCoTerm subst k 108 | -------------------------------------------------------------------------------- /Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | import Data.Unique.Id 4 | 5 | import System.IO.Unsafe 6 | 7 | import Text.PrettyPrint.HughesPJClass 8 | 9 | 10 | type Var = String 11 | type CoVar = String 12 | 13 | data InlInr = Inl | Inr deriving (Eq) 14 | data FstSnd = Fst | Snd deriving (Eq) 15 | 16 | data Term = Var Var | Data Term InlInr | Tup Term Term | Not CoTerm | Lam Var Term | Bind Stmt CoVar | Fix Var Term deriving (Eq) 17 | data CoTerm = CoVar CoVar | CoData CoTerm CoTerm | CoTup FstSnd CoTerm | CoNot Term | CoLam Term CoTerm | CoBind Var Stmt {- | CoFix CoTerm CoVar -} deriving (Eq) 18 | data Stmt = Term `Cut` CoTerm deriving (Eq) 19 | 20 | type Bind = (Var, Term) 21 | type CoBind = (CoVar, CoTerm) 22 | 23 | 24 | -- Note [Lambdas] 25 | -- ~~~~~~~~~~~~~~ 26 | -- 27 | -- Lambdas and colambdas are strictly speaking unnecessary, because you can always encode them away by using a 28 | -- evaluation-strategy specific means. However, they are sure as hell easier to read than their encodings! 29 | -- 30 | -- If we avoid using the encoding, you can drop Not and CoNot when compiling a language without first class 31 | -- continuations. 32 | 33 | -- Note [Fixpoints] 34 | -- ~~~~~~~~~~~~~~~~ 35 | -- 36 | -- Because I allow recursive data with contravariant occurences, the fixed point operators can be 37 | -- encoded away, analagously to how you can encode away lambdas and applications. The encoding 38 | -- of fix is as follows: 39 | -- fix x. M = ((\u. (u ● case MkU -> p.((p ● u @ c).c ● x.(M ● b))).b) ● russel.(russel ● (MkU russel @ a))).a 40 | -- 41 | -- Where we have: 42 | -- data U a = MkU (U a -> a) 43 | -- 44 | -- Note that we *might* be able to clean up this combinator a bit if we expanded the definition of lambda and @, 45 | -- and then reduced. 46 | -- 47 | -- One issue with this combinator is that it doesn't preserve sharing of M in call by need. 48 | 49 | 50 | dot = text "." 51 | dnot = text "not" 52 | at = text "@" 53 | cut = text "●" 54 | lambda = text "\\" 55 | fix = text "fix" 56 | angles d = text "<" <> d <> text ">" 57 | 58 | instance Show InlInr where show = show . pPrint 59 | 60 | instance Pretty InlInr where 61 | pPrint Inl = text "inl" 62 | pPrint Inr = text "inr" 63 | 64 | instance Show FstSnd where show = show . pPrint 65 | 66 | instance Pretty FstSnd where 67 | pPrint Fst = text "fst" 68 | pPrint Snd = text "snd" 69 | 70 | instance Show Term where show = show . pPrint 71 | 72 | instance Pretty Term where 73 | pPrintPrec level prec m = case m of 74 | Var x -> text x 75 | Data m lr -> angles (pPrintPrec level 0 m) <> pPrint lr 76 | Tup m n -> parens $ pPrintPrec level 0 m <> comma <+> pPrintPrec level 0 n 77 | Not k -> brackets (pPrintPrec level 0 k) <> dnot 78 | Lam x m -> prettyParen (prec >= 9) (lambda <> text x <> dot <+> pPrintPrec level 0 m) 79 | Bind s a -> parens (pPrintPrec level 0 s) <> dot <> text a 80 | Fix x m -> fix <+> text x <> dot <> parens (pPrintPrec level 0 m) 81 | 82 | instance Show CoTerm where show = show . pPrint 83 | 84 | instance Pretty CoTerm where 85 | pPrintPrec level prec k = case k of 86 | CoVar a -> text a 87 | CoData k l -> brackets (pPrintPrec level 0 k <> comma <+> pPrintPrec level 0 l) 88 | CoTup fs k -> pPrint fs <> brackets (pPrintPrec level 0 k) 89 | CoNot m -> dnot <> parens (pPrintPrec level 0 m) 90 | CoLam m k -> prettyParen (prec >= 9) (pPrintPrec level 0 m <+> at <+> pPrintPrec level 0 k) 91 | CoBind x s -> text x <> dot <> parens (pPrintPrec level 0 s) 92 | 93 | instance Show Stmt where show = show . pPrint 94 | 95 | instance Pretty Stmt where 96 | pPrintPrec level prec k = case k of 97 | m `Cut` k -> prettyParen (prec >= 9) (pPrintPrec level 9 m <+> cut <+> pPrintPrec level 9 k) 98 | 99 | 100 | app m n = Bind (m `Cut` (n `CoLam` CoVar wildAlpha)) wildAlpha 101 | letin x m n = Bind (m `Cut` (CoBind x (n `Cut` CoVar wildAlpha))) wildAlpha 102 | letrecin x m n = Bind (Fix x m `Cut` (CoBind x (n `Cut` CoVar wildAlpha))) wildAlpha 103 | 104 | bindMany :: [(Var, Term)] -> Stmt -> Stmt 105 | bindMany binds s = foldr (\(x, m) s -> m `Cut` CoBind x s) s binds 106 | 107 | 108 | {-# NOINLINE wildIdSupply #-} 109 | wildIdSupply :: IdSupply 110 | wildIdSupply = unsafePerformIO $ initIdSupply 'a' 111 | 112 | wildAlpha, wildEcks :: String 113 | (wildAlpha:wildEcks:_) = map (show . idFromSupply) $ splitIdSupplyL wildIdSupply 114 | -------------------------------------------------------------------------------- /Core.hs: -------------------------------------------------------------------------------- 1 | module Core where 2 | 3 | import Syntax 4 | 5 | import Data.Unique.Id 6 | 7 | import Text.PrettyPrint.HughesPJClass 8 | 9 | 10 | data Core = CoreVar Var 11 | | CoreLam Var Core 12 | | CoreApp Core Core 13 | | CoreLet Var Core Core 14 | | CoreLetRec Var Core Core 15 | | CoreData InlInr Core 16 | | CoreCase Core (Var, Core) (Var, Core) 17 | | CoreTup Core Core 18 | | CoreSelect Core FstSnd Var Core 19 | deriving (Eq) 20 | 21 | instance Show Core where show = show . pPrint 22 | 23 | instance Pretty Core where 24 | pPrintPrec level prec t = case t of 25 | CoreVar x -> text x 26 | CoreLam x t -> parens (lambda <> text x <+> text "->" <+> pPrintPrec level 0 t) 27 | CoreApp t1 t2 -> prettyParen (prec >= 9) (pPrintPrec level 0 t1 <+> pPrintPrec level 9 t2) 28 | CoreLet x t1 t2 -> prettyParen (prec >= 9) (text "let" <+> text x <+> equals <+> pPrintPrec level 0 t1 $$ text "in" <+> pPrintPrec level 0 t2) 29 | CoreLetRec x t1 t2 -> prettyParen (prec >= 9) (text "letrec" <+> text x <+> equals <+> pPrintPrec level 0 t1 $$ text "in" <+> pPrintPrec level 0 t2) 30 | CoreData lr t -> prettyParen (prec >= 9) (pPrint lr <+> pPrintPrec level 9 t) 31 | CoreCase t (x1, t1) (x2, t2) -> prettyParen (prec >= 9) (text "case" <+> pPrintPrec level 0 t <+> text "of" $$ nest 2 (alt Inl x1 t1 $$ alt Inr x2 t2)) 32 | where alt lr x t = hang (pPrint lr <+> text x <+> text "->") 2 (pPrintPrec level 0 t) 33 | CoreTup t1 t2 -> parens (pPrintPrec level 0 t1 <> comma <+> pPrintPrec level 0 t2) 34 | CoreSelect t1 fs x t2 -> prettyParen (prec >= 9) (hang (text "select" <+> pPrintPrec level 0 t1 <+> text "!!" <+> pPrint fs <+> text x <+> text "->") 2 (pPrintPrec level 0 t2)) 35 | 36 | 37 | -- Investigations on the Dual Calculus, Nikos Tzevelekos: Definition 1.6, p7 38 | dualize :: IdSupply -> Core -> Term 39 | dualize _ (CoreVar x) = Var x 40 | dualize ids (CoreLam x t) = Lam x (dualize ids t) 41 | dualize ids (CoreApp t1 t2) = Bind (dualize ids2 t1 `Cut` (dualize ids3 t2 `CoLam` CoVar a)) a 42 | where (ids1, ids') = splitIdSupply ids 43 | (ids2, ids3) = splitIdSupply ids' 44 | a = "$a" ++ show (idFromSupply ids1) 45 | dualize ids (CoreLet v t1 t2) = letin v (dualize ids1 t1) (dualize ids2 t2) 46 | where (ids1, ids2) = splitIdSupply ids 47 | dualize ids (CoreLetRec v t1 t2) = letrecin v (dualize ids1 t1) (dualize ids2 t2) 48 | where (ids1, ids2) = splitIdSupply ids 49 | dualize ids (CoreData lr t) = Data (dualize ids t) lr 50 | dualize ids (CoreCase t (y1, t1) (y2, t2)) = Bind (dualize ids2 t `Cut` CoData (CoBind y1 (dualize ids3 t1 `Cut` CoVar a)) (CoBind y2 (dualize ids4 t2 `Cut` CoVar a))) a 51 | where ids1:ids2:ids3:ids4:_ = splitIdSupplyL ids 52 | a = "$a" ++ show (idFromSupply ids1) 53 | dualize ids (CoreTup t1 t2) = Tup (dualize ids1 t1) (dualize ids2 t2) 54 | where (ids1, ids2) = splitIdSupply ids 55 | dualize ids (CoreSelect t1 fs v t2) = Bind (dualize ids2 t1 `Cut` CoTup fs (CoBind v $ dualize ids3 t2 `Cut` CoVar a)) a 56 | where (ids1, ids') = splitIdSupply ids 57 | (ids2, ids3) = splitIdSupply ids' 58 | a = "$a" ++ show (idFromSupply ids1) 59 | 60 | {- 61 | cpsTerm :: Term -> LamTerm 62 | cpsTerm = 63 | 64 | data PendingTerm = AdminTerm (LamTerm -> LamTerm) 65 | | ResidTerm LamTerm 66 | 67 | applyTerm :: PendingTerm -> LamTerm -> LamTerm 68 | applyTerm (ResidTerm t1) t2 = App t1 t2 69 | applyTerm (AdminTerm f) t2 = f t2 70 | 71 | cpsCoTerm :: CoTerm -> PendingTerm -> LamTerm 72 | cpsCoTerm k pt = case k of 73 | CoVar a -> applyTerm pt (LamVar a) 74 | {- 75 | CoData alts -> foldr go (\k -> f (mkTup bs)) (alts `zip` bs) 76 | where go ((mb_con, k), b) f = \k -> cpsCoTerm k f 77 | bs = ... 78 | -} 79 | CoTup i k -> cpsCoTerm k (\k -> ) 80 | CoLam m k -> 81 | CoBind x s -> 82 | 83 | cpsStmt :: Stmt -> LamTerm 84 | cpsStmt (m `Cut` k) = cpsCoTerm k (cpsTerm m) 85 | -} 86 | 87 | {- 88 | example1 = letrecin (Var "map") (lam "f" $ lam "xs" $ Bind (Var "xs" `Cut` CoData [(Just "Nil", CoBind "_" (Data "Nil" (Tup []) `Cut` CoVar "a")), 89 | (Just "Cons", CoBind "cons" (CoVar "cons" `Cut` CoBind "y" (CoVar "cons" `Cut` CoBind "ys" ( 90 | Data "Cons" (Tup [app (Var "f") (Var "x"), app (app (Var "map") (Var "f")) (Var "map")]) `Cut` CoVar "a"))))]) "a") 91 | (app (app (Var "map") (Var "inc")) $ app (app (Var "map") (Var "double")) (Var "input")) 92 | -} 93 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified CallByName 4 | -- FIXME: until I can work out how to do it properly: 5 | -- import qualified CallByNeed.Evaluate as CallByNeed 6 | import qualified CallByValue 7 | import Core 8 | import Syntax 9 | import qualified Test 10 | 11 | import Control.Monad 12 | 13 | import Data.Unique.Id 14 | 15 | import Text.PrettyPrint.HughesPJClass 16 | 17 | 18 | -- TODO: 19 | -- * Prove call by need correct (or otherwise) 20 | -- # The definition for covalue and value may be incorrect: are cuts (V ● a).a really values in general, and not just at the top level? 21 | -- * Implement the strategy dual to call by need 22 | 23 | 24 | normalise :: (Stmt -> Maybe Stmt) -> Stmt -> [Stmt] 25 | normalise step s = s : case step s of 26 | Nothing -> [] 27 | Just s -> normalise step s 28 | 29 | 30 | -- letrec ones = one : ones in ones 31 | -- 32 | -- Simple demonstration of infinite data 33 | lamExample1 = CoreLetRec "ones" (CoreApp (CoreApp (CoreVar "Cons") (CoreVar "one")) (CoreVar "ones")) $ 34 | CoreVar "ones" 35 | 36 | -- let map = \f. \xs. case xs of Nil -> Nil_wrap; Cons y ys -> Cons_wrap (f y) (map f ys) 37 | -- in map inc (map double input) 38 | -- 39 | -- Advanced example for supercompilation experiments 40 | lamExample2 = CoreLetRec "map" (CoreLam "f" $ CoreLam "xs" $ CoreCase (CoreVar "xs") ("_", CoreVar "Nil_wrap") ("cons", CoreSelect (CoreVar "cons") Fst "y" $ CoreSelect (CoreVar "cons") Snd "ys" $ CoreApp (CoreApp (CoreVar "Cons_wrap") (CoreApp (CoreVar "f") (CoreVar "y"))) $ CoreApp (CoreApp (CoreVar "map") (CoreVar "f")) (CoreVar "ys"))) $ 41 | CoreApp (CoreApp (CoreVar "map") (CoreVar "inc")) $ CoreApp (CoreApp (CoreVar "map") (CoreVar "double")) (CoreVar "input") 42 | 43 | 44 | -- (\x. x) () 45 | -- 46 | -- Very basic example! 47 | dualExample0 = Lam "x" (Var "x") `app` Var "()" `Cut` CoVar "halt" 48 | 49 | -- let f = \x. x 50 | -- in (f (), f 2) 51 | -- 52 | -- Useful for getting a feel of how lambdas work in their primitive form 53 | dualExample1Term 54 | = letin "f" (CallByName.lam "x" (Var "x")) 55 | (Bind (CallByName.app (Var "f") (Var "()") `Cut` 56 | CoBind "r1" (CallByName.app (Var "f") (Var "2") `Cut` 57 | CoBind "r2" (Tup (Var "r1") (Var "r2") `Cut` 58 | CoVar "c"))) "c") 59 | 60 | dualExample1 = dualExample1Term `Cut` CoVar "halt" 61 | 62 | -- let id = (\x. x) (\x. x) 63 | -- in id id 64 | -- 65 | -- Useful for showing the difference between call by name and call by need 66 | -- (or call by value), since the latter two evaluate the application in "id" only once 67 | dualExample2 = letin "id" (app (Lam "x" (Var "x")) (Lam "x" (Var "x"))) 68 | (app (Var "id") (Var "id")) `Cut` CoVar "halt" 69 | 70 | -- ([res1.([res2.((res1, res2) ● halt)]~ ● a)]~ ● a).a ● x.(((), 3) ● 1 !! res.(x ● ~(res))) 71 | -- 72 | -- An example that shows the difference between call by value and the strategy 73 | -- dual to call by need. Because the coterm bound to "a" is used non-linearly, 74 | -- we have the opportunity to force it to perform the cut of Tup against CoTup 75 | -- more than once, which leads to inefficiency. 76 | -- 77 | -- The reason that this strategy has not recieved more attention is that in 78 | -- lambda calculus, the coterm (continuation) is typically used linearly, so 79 | -- there is little to be gained by memoization, even though you see CBV reductions 80 | -- like the following that at first glance seem to introduce work duplication: 81 | -- 82 | -- ((\x. x) ● (\x. x @ a1)).a1 ● id.((id ● (id @ a1)).a1 ● halt) 83 | -- --> 84 | -- (\x. x) ● (\x. x @ id.((id ● (id @ a1)).a1 ● halt)) 85 | dualExample3 = Bind (Not (CoBind "res1" (Not (CoBind "res2" (Tup (Var "res1") (Var "res2") `Cut` CoVar "halt")) `Cut` CoVar "a")) `Cut` CoVar "a") "a" 86 | `Cut` CoBind "x" (Tup (Var "()") (Var "3") `Cut` CoTup Snd (CoBind "res" (Var "x" `Cut` CoNot (Var "res")))) 87 | 88 | -- let fix = \x -> x x in fix fix 89 | -- 90 | -- Obviously not well-typed in the standard rules! 91 | dualExample4 = letin "fix" (CallByName.lam "x" $ Var "x" `CallByName.app` Var "x") 92 | (Var "fix" `CallByName.app` Var "fix") `Cut` CoVar "halt" 93 | 94 | -- let ones = 1 : ones in case ones of x:_ -> x 95 | -- 96 | -- Useful for testing the behaviour of fixed points. 97 | dualExample5 = letrecin "ones" (Data (Tup (Var "1") (Var "ones")) Inr) 98 | (Bind (Var "ones" `Cut` CoData (CoVar "a") (CoTup Fst (CoVar "a"))) "a") `Cut` CoVar "halt" 99 | 100 | -- letrec f = select f 1 !! fst x -> x 101 | -- in f 2 102 | -- 103 | -- Useful for testing the behaviour of black holes. 104 | dualExample6 = letrecin "f" (Bind (app (Var "f") (Var "1") `Cut` CoTup Fst (CoVar "a")) "a") 105 | (app (Var "f") (Var "2")) `Cut` CoVar "halt" 106 | 107 | {- 108 | -- See http://www.mail-archive.com/haskell@haskell.org/msg14044.html, and in particular http://www.mail-archive.com/haskell@haskell.org/msg14047.html 109 | -- (define (make-cell) ; Alan Bawden, 1989 110 | -- (call-with-current-continuation 111 | -- (lambda (return-from-make-cell) 112 | -- (letrec ((state 113 | -- (call-with-current-continuation 114 | -- (lambda (return-new-state) 115 | -- (return-from-make-cell 116 | -- (lambda (op) 117 | -- (case op 118 | -- ((set) 119 | -- (lambda (value) 120 | -- (call-with-current-continuation 121 | -- (lambda (return-from-access) 122 | -- (return-new-state 123 | -- (list value return-from-access)))))) 124 | -- ((get) (car state))))))))) 125 | -- ((cadr state) 'done))))) 126 | dualExample7 127 | = letin "fst" (Lam "pair" (Bind (Var "pair" `Cut` CoTup 0 (CoVar "a")) "a")) $ 128 | letin "snd" (Lam "pair" (Bind (Var "pair" `Cut` CoTup 1 (CoVar "b")) "b")) $ 129 | letin "makecell" (callcc (Lam "return-from-make-call" 130 | (letrecin "state" (callcc (Lam "return-new-state" 131 | (Var "return-from-make-call" `app` Tup [Lam "value" 132 | (callcc (Lam "return-from-access" 133 | (Var "return-new-state" `app` Tup [Var "value", Var "return-from-access"]))), 134 | Var "fst" `app` Var "state"]))) $ 135 | ((Var "snd" `app` Var "state") {- `app` Tup [] -})))) $ 136 | letin "c" (Var "makecell") $ 137 | Bind (Var "c" `Cut` CoTup 0 (CoBind "setter" (Var "setter" `Cut` (CoLam (Data "Foo" (Tup [])) (CoBind "_" (Var "c" `Cut` CoTup 1 (CoVar "a"))))))) "a" 138 | 139 | 140 | -- Tup [Bind (Var "meh" `Cut` CoVar "halt2") "_", Var "foo"] `Cut` CoBind "x" (Var "x" `Cut` CoTup 1 (CoVar "halt1")) 141 | -- Tup [Bind (Var "meh" `Cut` CoVar "halt2") "_", Var "foo"] `Cut` CoBind "x" (Var "x" `Cut` CoTup 1 (CoBind "y" (Var "y" `Cut` CoTup 1 (CoVar "halt1")))) 142 | -- Tup [Tup[Var "a", Var "b"], Var "c"] `Cut` CoTup 0 (CoBind "a" (Var "a" `Cut` CoTup 0 (CoBind "x" (Var "a" `Cut` CoTup 1 (CoBind "y" (Var "done" `Cut` CoVar "halt")))))) 143 | 144 | -- dualExample8 = callcc (Lam "return" (Bind (Tup [Var "1", Var "2"] `Cut` CoBind "t" ((Var "return" `app` Tup [Var "1", Var "2"]) `Cut` CoTup 0 (CoBind "t2" (Var "t" `Cut` CoVar "a"))) "a"))) 145 | 146 | callcc :: Term -> Term 147 | callcc m = Bind ((m `app` (Lam "v" $ Bind (Var "v" `Cut` CoVar "a-captured") "_")) `Cut` CoVar "a-captured") "a-captured" 148 | -} 149 | 150 | dualExample1Main = do 151 | -- Just show what we're going to work on 152 | header "Original" 153 | print $ pPrint dualExample1 154 | -- Obtain the tuple from example1 155 | header "Call by name" 156 | printNormalise CallByName.step dualExample1 157 | -- Place demand on the first component of that tuple 158 | header "Call by name, first component" 159 | printNormalise CallByName.step $ dualExample1Term `Cut` CoTup Fst (CoVar "halt") 160 | -- Right, what does that look like in need? 161 | --header "Call by need, first component" 162 | --printNormalise CallByNeed.step $ dualExample1Term `Cut` CoTup 0 (CoVar "halt") 163 | 164 | exampleMain example ids = do 165 | header "Original" 166 | print $ pPrint example 167 | 168 | header "Call by name CPS" 169 | (ids, ids') <- return $ splitIdSupply ids 170 | print $ pPrint $ CallByName.cps ids' example 171 | header "Call by name evaluation" 172 | printNormalise CallByName.step example 173 | 174 | --header "Call by need" 175 | --printNormalise CallByNeed.step example 176 | 177 | header "Call by value CPS" 178 | (ids, ids') <- return $ splitIdSupply ids 179 | print $ pPrint $ CallByValue.cps ids' example 180 | header "Call by value evaluation" 181 | printNormalise CallByValue.step example 182 | 183 | printNormalise step s = do 184 | mapM_ (print . pPrint) steps 185 | when (length steps >= lIMIT) $ putStrLn $ "Terminated: number of steps exceeds " ++ show lIMIT 186 | where steps = take lIMIT $ normalise step s 187 | lIMIT = 1000 188 | 189 | tests :: [(Bool, String, IdSupply -> IO ())] 190 | tests = [ 191 | (True, "Basic lambdas", exampleMain dualExample0), 192 | (True, "Basic nots", exampleMain (Not (CoVar "alpha") `Cut` CoNot (Var "x"))), 193 | (True, "Primitive lambdas", const dualExample1Main), 194 | (True, "Call-by-name vs Call-by-need", exampleMain dualExample2), 195 | (False, "Call-by-value vs Call-by-coneed", exampleMain dualExample3), 196 | (False, "Russel non-termination", exampleMain dualExample4), 197 | (False, "Fixed points", exampleMain dualExample5), 198 | (True, "Black holes", exampleMain dualExample6) 199 | ] 200 | 201 | main = do 202 | ids:idss <- fmap splitIdSupplyL $ initIdSupply 'a' 203 | 204 | -- Quickcheck properties of the Dual Calculus 205 | Test.main ids 206 | 207 | -- Some specific interesting examples 208 | forM_ (tests `zip` idss) $ \((enabled, title, example), ids) -> when enabled $ do 209 | header title 210 | example ids 211 | putStrLn "" 212 | 213 | header s = putStrLn $ unwords [replicate 10 '=', s, replicate 10 '='] 214 | 215 | {- 216 | main = do 217 | ids1:ids2:_ <- fmap splitIdSupplyL $ initIdSupply 'm' 218 | print $ pPrint example1 219 | print $ pPrint $ dualize ids1 example1 220 | print $ pPrint example2 221 | print $ pPrint $ dualize ids2 example2 222 | -} 223 | --------------------------------------------------------------------------------