├── .gitignore ├── Setup.lhs ├── Language └── ContextSemantics │ ├── Common.hs │ ├── Output.hs │ ├── Main.hs │ ├── Expressions.hs │ ├── Utilities.hs │ ├── LinearLambda.hs │ ├── LinearLambdaExplicit.hs │ ├── Graph.hs │ └── CallByNeedLambda.hs ├── context-semantics.cabal └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | # OS Junk 2 | .DS_Store 3 | Thumbs.db 4 | 5 | # Build artifacts 6 | dist/ 7 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain -------------------------------------------------------------------------------- /Language/ContextSemantics/Common.hs: -------------------------------------------------------------------------------- 1 | module Language.ContextSemantics.Common where 2 | 3 | 4 | type PortName = String -------------------------------------------------------------------------------- /Language/ContextSemantics/Output.hs: -------------------------------------------------------------------------------- 1 | module Language.ContextSemantics.Output where 2 | 3 | import Language.ContextSemantics.Common 4 | 5 | import qualified System.IO.UTF8 6 | 7 | 8 | data Output a = Output PortName a 9 | 10 | instance Show a => Show (Output a) where 11 | show (Output port what) = port ++ ": " ++ show what 12 | 13 | showCompactList :: Show a => [a] -> ShowS 14 | showCompactList = foldr (\x -> (shows x .)) id 15 | 16 | printUTF8 :: Show a => a -> IO () 17 | printUTF8 = System.IO.UTF8.print -------------------------------------------------------------------------------- /Language/ContextSemantics/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified Language.ContextSemantics.CallByNeedLambda as CBN 4 | import qualified Language.ContextSemantics.LinearLambda as L 5 | import qualified Language.ContextSemantics.LinearLambdaExplicit as LE 6 | 7 | 8 | main :: IO () 9 | main = do 10 | putStrLn "Linear Lambda Calculus:" 11 | L.examples 12 | putStrLn "Explicit Linear Lambda Calculus:" 13 | LE.examples 14 | putStrLn "Call By Name Lambda Calculus:" 15 | CBN.examples -------------------------------------------------------------------------------- /context-semantics.cabal: -------------------------------------------------------------------------------- 1 | Name: context-semantics 2 | Version: 0.1 3 | Cabal-Version: >= 1.2 4 | Category: Language 5 | Synopsis: Lambda evaluator using context semantics 6 | License: BSD3 7 | License-File: LICENSE 8 | Author: Max Bolingbroke 9 | Maintainer: batterseapower@hotmail.com 10 | Homepage: http://github.com/batterseapower/context-semantics 11 | Build-Type: Simple 12 | 13 | Executable context-semantics 14 | Main-Is: Language/ContextSemantics/Main.hs 15 | 16 | Build-Depends: base >= 3, containers >= 0.2, template-haskell >= 2.3, 17 | utf8-string >= 0.3.4, ListZipper >= 1.1.1, nthable >= 0.1 18 | 19 | Extensions: PatternGuards, TemplateHaskell, TypeFamilies, KindSignatures, ScopedTypeVariables, FlexibleContexts, FlexibleInstances 20 | Ghc-Options: -Wall 21 | -------------------------------------------------------------------------------- /Language/ContextSemantics/Expressions.hs: -------------------------------------------------------------------------------- 1 | module Language.ContextSemantics.Expressions where 2 | 3 | import Data.List 4 | 5 | import qualified Language.Haskell.TH as TH 6 | 7 | 8 | data Expr = V String 9 | | Expr :@ Expr 10 | | Lam String Expr 11 | 12 | infixl 8 :@ 13 | 14 | freeVars :: Expr -> [String] 15 | freeVars (V v) = [v] 16 | freeVars (e1 :@ e2) = freeVars e1 ++ freeVars e2 17 | freeVars (Lam v e) = delete v $ freeVars e 18 | 19 | expr :: TH.ExpQ -> TH.ExpQ 20 | expr qe = do 21 | e <- qe 22 | case e of 23 | TH.VarE nm -> [| V $(TH.stringE (TH.nameBase nm)) |] 24 | TH.AppE e1 e2 -> [| $(expr (return e1)) :@ $(expr (return e2)) |] 25 | TH.LamE [TH.VarP nm] e1 -> [| Lam $(TH.stringE (TH.nameBase nm)) $(expr (return e1)) |] 26 | _ -> fail $ "Sorry, can't handle this bit of Haskell in the expression language: " ++ show e 27 | 28 | fvTH :: String -> TH.ExpQ 29 | fvTH s = TH.varE (TH.mkName s) -------------------------------------------------------------------------------- /Language/ContextSemantics/Utilities.hs: -------------------------------------------------------------------------------- 1 | module Language.ContextSemantics.Utilities where 2 | 3 | import qualified Data.IntMap as IM 4 | import Data.Maybe 5 | import qualified Data.Traversable as T 6 | 7 | import Debug.Trace 8 | 9 | 10 | instance Monad (Either String) where 11 | return = Right 12 | 13 | Left s >>= _ = Left s 14 | Right x >>= f = f x 15 | 16 | fail = Left 17 | 18 | 19 | fromSingleton :: [a] -> a 20 | fromSingleton [x] = x 21 | fromSingleton xs = error $ "fromSingleton: got " ++ show (length xs) ++ " items" 22 | 23 | lookupCertainly :: Eq a => a -> [(a, b)] -> b 24 | lookupCertainly = (fromJust .) . lookup 25 | 26 | iMlookupCertainly :: Int -> IM.IntMap a -> a 27 | iMlookupCertainly = (fromJust .) . IM.lookup 28 | 29 | fmapM :: (T.Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) 30 | fmapM = T.mapM 31 | 32 | fmapM_ :: (T.Traversable t, Monad m) => (a -> m b) -> t a -> m () 33 | fmapM_ f x = fmapM f x >> return () 34 | 35 | bitrace :: String -> b -> b 36 | bitrace s x = trace (">>> " ++ s) (x `seq` trace ("<<< " ++ s) x) 37 | 38 | assertJust :: String -> Maybe a -> a 39 | assertJust _ (Just x) = x 40 | assertJust s Nothing = error $ "assertJust: got Nothing (" ++ s ++ ")" 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted 5 | provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this list of 8 | conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this list of 10 | conditions and the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 13 | endorse or promote products derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 17 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 18 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 20 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 21 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 22 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Language/ContextSemantics/LinearLambda.hs: -------------------------------------------------------------------------------- 1 | module Language.ContextSemantics.LinearLambda where 2 | 3 | import Language.ContextSemantics.Expressions 4 | import Language.ContextSemantics.Output 5 | 6 | import Data.Maybe 7 | 8 | -- 9 | -- Context semantics 10 | -- 11 | 12 | data Token = White | Black 13 | 14 | instance Show Token where 15 | show White = "⚪" 16 | show Black = "⚫" 17 | 18 | showList = showCompactList 19 | 20 | type Port = [Token] -> Either String (Output [Token]) 21 | 22 | app :: Port -> Port -> Port -> (Port, Port, Port) 23 | app princp_out cont_out arg_out = (princp_in, cont_in, arg_in) 24 | where 25 | princp_in (White:ts) = cont_out ts 26 | princp_in (Black:ts) = arg_out ts 27 | princp_in [] = Left "app: empty incoming context at principal port" 28 | 29 | cont_in ts = princp_out (White:ts) 30 | 31 | arg_in ts = princp_out (Black:ts) 32 | 33 | lam :: Port -> Port -> Port -> (Port, Port, Port) 34 | lam princp_out body_out param_out = (princp_in, body_in, param_in) 35 | where 36 | princp_in (White:ts) = body_out ts 37 | princp_in (Black:ts) = param_out ts 38 | princp_in [] = Left "lam: empty incoming context at principal port" 39 | 40 | body_in ts = princp_out (White:ts) 41 | 42 | param_in ts = princp_out (Black:ts) 43 | 44 | fv :: String -> Port 45 | fv = (Right .) . Output 46 | 47 | -- 48 | -- Translation from traditional linear lambda calculus 49 | -- 50 | 51 | exprSemantics :: Expr -> (Port, [(String, Port)]) 52 | exprSemantics e = exprSemantics' (fv "Input") [(v, fv v) | v <- freeVars e] e 53 | 54 | exprSemantics' :: Port -> [(String, Port)] -> Expr -> (Port, [(String, Port)]) 55 | exprSemantics' out_port env (V v) 56 | | Just p <- lookup v env = (p, [(v, out_port)]) 57 | | otherwise = error $ "No binding for " ++ v 58 | exprSemantics' out_port env (e1 :@ e2) = (c, usg1 ++ usg2) 59 | where (e1_port, usg1) = exprSemantics' r env e1 60 | (e2_port, usg2) = exprSemantics' a env e2 61 | (r, c, a) = app e1_port out_port e2_port 62 | exprSemantics' out_port env (Lam v e) = (r, filter ((/= v) . fst) usg) 63 | where (e_port, usg) = exprSemantics' b ((v, p) : env) e 64 | v_port = (error $ "Missing usage of " ++ v) `fromMaybe` lookup v usg 65 | (r, b, p) = lam out_port e_port v_port 66 | 67 | -- 68 | -- Examples 69 | -- 70 | 71 | examples :: IO () 72 | examples = do 73 | printUTF8 $ identity [] 74 | printUTF8 $ normal [White, White] 75 | printUTF8 $ normal_expr [White, White] 76 | printUTF8 $ normal_expr_th [White, White] 77 | 78 | -- (\x.x) @ y 79 | -- Port wired to the input of the application 80 | identity :: Port 81 | identity = cont_app 82 | where 83 | inp = fv "Input" 84 | y_out = fv "y" 85 | (princp_app, cont_app, _y_in) = app princp_id inp y_out 86 | (princp_id, body_id, param_id) = lam princp_app param_id body_id 87 | 88 | -- (\x.\y.(y @ z) @ x) 89 | -- Port wired to the input of the lambda term 90 | normal :: Port 91 | normal = r1 92 | where 93 | inp = fv "Input" 94 | z = fv "z" 95 | (r1, b1, p1) = lam inp r2 a3 96 | (r2, b2, p2) = lam b1 c3 r4 97 | (r3, c3, a3) = app c4 b2 p1 98 | (r4, c4, _a4) = app p2 r3 z 99 | 100 | normal_expr :: Port 101 | normal_expr = fst $ exprSemantics $ Lam "x" (Lam "y" (V "y" :@ V "z" :@ V "x")) 102 | 103 | normal_expr_th :: Port 104 | normal_expr_th = fst $ exprSemantics $ $(expr [| \x -> \y -> y $(fvTH "z") x |]) -------------------------------------------------------------------------------- /Language/ContextSemantics/LinearLambdaExplicit.hs: -------------------------------------------------------------------------------- 1 | module Language.ContextSemantics.LinearLambdaExplicit where 2 | 3 | import Language.ContextSemantics.Common 4 | import Language.ContextSemantics.Expressions 5 | import Language.ContextSemantics.Graph 6 | import Language.ContextSemantics.Output 7 | import Language.ContextSemantics.Utilities 8 | 9 | import Control.Applicative ((<$>), (<*>)) 10 | 11 | import qualified Data.Foldable as F 12 | import Data.Monoid 13 | import qualified Data.Traversable as T 14 | 15 | 16 | -- 17 | -- Interaction graphs 18 | -- 19 | 20 | data Router a = Fan a a a 21 | | FV String a 22 | deriving (Show) 23 | 24 | instance Functor Router where 25 | fmap f (Fan pr wh bl) = Fan (f pr) (f wh) (f bl) 26 | fmap f (FV s pr) = FV s (f pr) 27 | 28 | instance F.Foldable Router where 29 | foldMap f (Fan pr wh bl) = f pr `mappend` f wh `mappend` f bl 30 | foldMap f (FV _ pr) = f pr 31 | 32 | instance T.Traversable Router where 33 | sequenceA (Fan apr awh abl) = Fan <$> apr <*> awh <*> abl 34 | sequenceA (FV s mpr) = FV s <$> mpr 35 | 36 | data RouterSelector = FanPr | FanWh | FanBl | FVPr 37 | deriving (Show, Eq) 38 | 39 | instance Interactor Router where 40 | type Selector Router = RouterSelector 41 | 42 | selectors (Fan pr wh bl) = Fan (FanPr, pr) (FanWh, wh) (FanBl, bl) 43 | selectors (FV s pr) = FV s (FVPr, pr) 44 | 45 | select FanPr (Fan pr _ _ ) = pr 46 | select FanWh (Fan _ wh _ ) = wh 47 | select FanBl (Fan _ _ bl) = bl 48 | select FVPr (FV _ pr) = pr 49 | 50 | inputGraphSemantics :: Graph Router -> Route 51 | inputGraphSemantics = lookupCertainly "Input" . graphSemantics 52 | 53 | graphSemantics :: Graph Router -> [(PortName, Route)] 54 | graphSemantics = foldPortwise routerSemantics 55 | 56 | routerSemantics :: Router Route -> Router Route 57 | routerSemantics (Fan pr wh bl) = Fan pr' wh' bl' 58 | where (pr', wh', bl') = fan pr wh bl 59 | routerSemantics (FV s pr) = FV s (fv s pr) 60 | 61 | graphToDot :: Graph Router -> String 62 | graphToDot = toDot node_attrs edge_attrs 63 | where node_attrs (Fan _ _ _) = [("shape", "triangle")] 64 | node_attrs (FV s _) = [("shape", "dot"), ("label", s)] 65 | 66 | edge_attrs from to = [("arrowtail", selector_shape from), ("arrowhead", selector_shape to), 67 | ("tailport", selector_port from), ("headport", selector_port to)] 68 | 69 | selector_shape FanPr = "none" 70 | selector_shape FanWh = "odot" 71 | selector_shape FanBl = "dot" 72 | selector_shape FVPr = "none" 73 | 74 | selector_port FanPr = "n" 75 | selector_port FanWh = "sw" 76 | selector_port FanBl = "se" 77 | selector_port FVPr = "n" 78 | 79 | writeDot :: String -> Graph Router -> IO () 80 | writeDot nm gr = writeFile (nm ++ ".dot") (graphToDot gr) 81 | 82 | 83 | -- 84 | -- Context semantics 85 | -- 86 | 87 | data Token = White | Black 88 | 89 | instance Show Token where 90 | show White = "⚪" 91 | show Black = "⚫" 92 | 93 | showList = showCompactList 94 | 95 | type Route = [Token] -> Either String (Output [Token]) 96 | 97 | fan :: Route -> Route -> Route -> (Route, Route, Route) 98 | fan princp_out white_out black_out = (princp_in, white_in, black_in) 99 | where 100 | princp_in (White:ts) = white_out ts 101 | princp_in (Black:ts) = black_out ts 102 | princp_in [] = Left "fan: empty incoming context at principal port" 103 | 104 | white_in ts = princp_out (White:ts) 105 | 106 | black_in ts = princp_out (Black:ts) 107 | 108 | fv :: String -> Route -> Route 109 | fv s _fv_out = Right . Output s 110 | 111 | 112 | -- 113 | -- Translation from traditional linear lambda calculus 114 | -- 115 | 116 | fvNode :: String -> LooseEnd -> GraphBuilderM Router () 117 | fvNode s wpr = newNode (FV s wpr) 118 | 119 | fanNode :: LooseEnd -> LooseEnd -> LooseEnd -> GraphBuilderM Router () 120 | fanNode wpr wwh wbl = newNode (Fan wpr wwh wbl) 121 | 122 | exprGraph :: Expr -> Graph Router 123 | exprGraph e = runGraphBuilderM $ do 124 | let buildFVNode v = do 125 | (pfv1, pfv2) <- newWire 126 | fvNode v pfv1 127 | return ((v, pfv1), (v, pfv2)) 128 | (env1, env2) <- fmap unzip $ mapM buildFVNode (freeVars e) 129 | 130 | (proot1, proot2) <- newWire 131 | fvNode "Input" proot1 132 | buildExprGraph env2 proot2 e 133 | return $ ("Input", proot1) : env1 134 | 135 | buildExprGraph :: [(PortName, LooseEnd)] -> LooseEnd -> Expr -> GraphBuilderM Router () 136 | buildExprGraph env ptop (V v) 137 | | Just pbind <- lookup v env = join ptop pbind 138 | | otherwise = error $ "No binding for " ++ v 139 | buildExprGraph env ptop (e1 :@ e2) = do 140 | (pfn1, pfn2) <- newWire 141 | buildExprGraph env pfn1 e1 142 | 143 | (parg1, parg2) <- newWire 144 | buildExprGraph env parg1 e2 145 | 146 | fanNode pfn2 ptop parg2 147 | buildExprGraph env ptop (Lam v e) = do 148 | (pbody1, pbody2) <- newWire 149 | (pparam1, pparam2) <- newWire 150 | buildExprGraph ((v, pparam1) : env) pbody1 e 151 | 152 | fanNode ptop pbody2 pparam2 153 | 154 | 155 | -- 156 | -- Readback 157 | -- 158 | 159 | semanticsExpr :: [(PortName, Route)] -> Expr 160 | semanticsExpr named_routes = undefined 161 | 162 | 163 | -- 164 | -- Examples 165 | -- 166 | 167 | examples :: IO () 168 | examples = do 169 | printUTF8 $ inputGraphSemantics xGraph [Black] 170 | printUTF8 $ inputGraphSemantics xyGraph [White] 171 | printUTF8 $ inputGraphSemantics identityAppGraph [Black] 172 | printUTF8 $ inputGraphSemantics normalGraph [White, White] 173 | 174 | dots :: IO () 175 | dots = do 176 | writeDot "x" xGraph 177 | writeDot "xy" xyGraph 178 | writeDot "identityApp" identityAppGraph 179 | writeDot "normal" normalGraph 180 | 181 | xGraph, xyGraph, identityAppGraph, normalGraph :: Graph Router 182 | 183 | xGraph = exprGraph $ V "x" 184 | 185 | xyGraph = exprGraph $ V "x" :@ V "y" 186 | 187 | identityAppGraph = exprGraph $ (Lam "x" (V "x")) :@ (V "y") 188 | 189 | normalGraph = exprGraph $ Lam "x" (Lam "y" (V "y" :@ V "z" :@ V "x")) 190 | -------------------------------------------------------------------------------- /Language/ContextSemantics/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Language.ContextSemantics.Graph where 4 | 5 | import Language.ContextSemantics.Common 6 | import Language.ContextSemantics.Utilities 7 | 8 | import Control.Arrow (second) 9 | import Control.Monad 10 | 11 | import qualified Data.IntMap as IM 12 | import qualified Data.Foldable as F 13 | import Data.List 14 | import qualified Data.Traversable as T 15 | 16 | 17 | -- 18 | -- Interactors: functors that we can build interaction graphs from 19 | -- 20 | 21 | class (T.Traversable n, Eq (Selector n)) => Interactor n where 22 | type Selector n :: * 23 | 24 | selectors :: n a -> n (Selector n, a) 25 | select :: Selector n -> n a -> a 26 | 27 | 28 | -- 29 | -- Interaction graphs 30 | -- 31 | 32 | type NodeId = Int 33 | 34 | data Port n = Port { 35 | port_node :: NodeId, 36 | port_selector :: Selector n 37 | } 38 | 39 | -- Requires UndecidableInstances 40 | instance Show (Selector n) => Show (Port n) where 41 | show port = show (port_node port) ++ "." ++ show (port_selector port) 42 | 43 | -- Requires UndecidableInstances 44 | instance Eq (Selector n) => Eq (Port n) where 45 | p1 == p2 = port_node p1 == port_node p2 && 46 | port_selector p1 == port_selector p2 47 | 48 | data Graph n = Graph { 49 | gr_nodes :: IM.IntMap (n (Port n)), 50 | gr_named_ports :: [(PortName, Port n)] 51 | } 52 | 53 | foldNodewise :: Functor n => (n a -> a) -> Graph n -> [(PortName, a)] 54 | foldNodewise f gr = map (second lookup_node) (gr_named_ports gr) 55 | where lookup_node port = assertJust "foldNodewise" (IM.lookup (port_node port) node_vals) 56 | node_vals = IM.map (f . fmap lookup_node) (gr_nodes gr) 57 | 58 | foldPortwise :: Interactor n => (n a -> n a) -> Graph n -> [(PortName, a)] 59 | foldPortwise f gr = map (second lookup_port) (gr_named_ports gr) 60 | where lookup_port port = port_selector port `select` assertJust "foldPortwise" (IM.lookup (port_node port) node_port_vals) 61 | node_port_vals = IM.map (f . fmap lookup_port) (gr_nodes gr) 62 | 63 | 64 | -- 65 | -- Converting to .dot files 66 | -- 67 | 68 | toDot :: Interactor n 69 | => (n () -> [(String, String)]) -- ^ Assignment of attributes to node 70 | -> (Selector n -> Selector n -> [(String, String)]) -- ^ Assignment of attributes to edges 71 | -> Graph n 72 | -> String 73 | toDot node_attrs edge_attrs gr = "graph {\r\n" ++ intercalate ";\r\n" statements ++ "\r\n}\r\n" 74 | where nodes = IM.assocs (gr_nodes gr) 75 | edges = [(Port from_nid from_selector, to_port) 76 | | (from_nid, from_n) <- nodes 77 | , (from_selector, to_port) <- F.toList (selectors from_n)] 78 | unique_edges = nubBy (\(p1, p2) (q1, q2) -> (p1 == q1 && p2 == q2) || (p1 == q2 && p2 == q1)) edges 79 | 80 | statements = named_node_statements ++ named_edge_statements ++ node_statements ++ edge_statements 81 | named_node_statements = ["named" ++ name ++ " [shape=point,label=" ++ name ++ "]" 82 | | (name, _) <- gr_named_ports gr] 83 | named_edge_statements = ["named" ++ name ++ " -- node" ++ show (port_node port) ++ " [arrowhead=normal]" 84 | | (name, port) <- gr_named_ports gr] 85 | node_statements = ["node" ++ show nid ++ format_list (("label", show nid) : node_attrs (fmap (const ()) n)) 86 | | (nid, n) <- nodes] 87 | edge_statements = ["node" ++ show (port_node from_port) ++ " -- node" ++ show (port_node to_port) ++ " " ++ format_list (edge_attrs (port_selector from_port) (port_selector to_port)) 88 | | (from_port, to_port) <- unique_edges] 89 | format_list avps = "[" ++ intercalate "," [attr ++ "=" ++ val | (attr, val) <- avps] ++ "]" 90 | 91 | 92 | -- 93 | -- Graph builder monad, for convenience of construction 94 | -- 95 | 96 | newtype LooseEnd = LooseEnd { unLooseEnd :: Int } 97 | deriving (Show) 98 | 99 | data Knot n = KnotToLooseEnd LooseEnd 100 | | KnotToPort (Port n) 101 | 102 | data GraphBuilderEnv n = GraphBuilderEnv { 103 | gbe_next_unique :: Int, 104 | gbe_loose_end_joins :: IM.IntMap LooseEnd, 105 | gbe_loose_ends :: IM.IntMap (Maybe (Knot n)), 106 | gbe_nodes :: IM.IntMap (n LooseEnd) 107 | } 108 | 109 | emptyGraphBuilderEnv :: GraphBuilderEnv n 110 | emptyGraphBuilderEnv = GraphBuilderEnv { 111 | gbe_next_unique = 0, 112 | gbe_loose_end_joins = IM.empty, 113 | gbe_loose_ends = IM.empty, 114 | gbe_nodes = IM.empty 115 | } 116 | 117 | newtype GraphBuilderM n a = GraphBuilderM { 118 | unGraphBuilderM :: GraphBuilderEnv n -> (GraphBuilderEnv n, a) 119 | } 120 | 121 | instance Functor (GraphBuilderM n) where 122 | fmap f mx = mx >>= \x -> return (f x) 123 | 124 | instance Monad (GraphBuilderM n) where 125 | return x = GraphBuilderM $ \env -> (env, x) 126 | mx >>= f = GraphBuilderM $ \env -> case unGraphBuilderM mx env of (env', y) -> unGraphBuilderM (f y) env' 127 | 128 | newUnique :: GraphBuilderM n Int 129 | newUnique = GraphBuilderM $ \env -> let i = gbe_next_unique env in (env { gbe_next_unique = i + 1 }, i) 130 | 131 | insertNode :: Int -> n LooseEnd -> GraphBuilderM n () 132 | insertNode i node = GraphBuilderM $ \env -> (env { gbe_nodes = IM.insert i node (gbe_nodes env) }, ()) 133 | 134 | knotOnce :: a -> Maybe a -> Maybe a 135 | knotOnce what Nothing = Just what 136 | knotOnce _ (Just _) = error "Can't knot a loose end twice!" 137 | 138 | knotLooseEndToPort :: LooseEnd -> Port n -> GraphBuilderM n () 139 | knotLooseEndToPort le p = GraphBuilderM $ \env -> (env { gbe_loose_ends = IM.adjust (knotOnce (KnotToPort p)) (unLooseEnd le) (gbe_loose_ends env) }, ()) 140 | 141 | knotLooseEnds :: LooseEnd -> LooseEnd -> GraphBuilderM n () 142 | knotLooseEnds le1 le2 = GraphBuilderM $ \env -> (env { gbe_loose_ends = IM.adjust (knotOnce (KnotToLooseEnd le1)) (unLooseEnd le2) (IM.adjust (knotOnce (KnotToLooseEnd le2)) (unLooseEnd le1) (gbe_loose_ends env)) }, ()) 143 | 144 | newWire :: GraphBuilderM a (LooseEnd, LooseEnd) 145 | newWire = do 146 | le1 <- liftM LooseEnd newUnique 147 | le2 <- liftM LooseEnd newUnique 148 | GraphBuilderM $ \env -> (env { gbe_loose_end_joins = IM.insert (unLooseEnd le2) le1 (IM.insert (unLooseEnd le1) le2 (gbe_loose_end_joins env)) 149 | , gbe_loose_ends = IM.insert (unLooseEnd le1) Nothing (IM.insert (unLooseEnd le2) Nothing (gbe_loose_ends env)) }, (le1, le2)) 150 | 151 | newNode :: Interactor n => n LooseEnd -> GraphBuilderM n () 152 | newNode n_loose_ends = do 153 | nid <- newUnique 154 | insertNode nid n_loose_ends 155 | fmapM_ (\(selector, loose_end) -> knotLooseEndToPort loose_end (Port nid selector)) (selectors n_loose_ends) 156 | 157 | join :: LooseEnd -> LooseEnd -> GraphBuilderM n () 158 | join = knotLooseEnds 159 | 160 | runGraphBuilderM :: Interactor n => GraphBuilderM n [(PortName, LooseEnd)] -> Graph n 161 | runGraphBuilderM mx = Graph { 162 | gr_nodes = nodes, 163 | gr_named_ports = map (second lookupLooseEndPort) named_les 164 | } 165 | where (final_env, named_les) = unGraphBuilderM mx emptyGraphBuilderEnv 166 | 167 | nodes = IM.map (fmap lookupLooseEndPort) (gbe_nodes final_env) 168 | lookupLooseEndPort le = case iMlookupCertainly (unLooseEnd $ iMlookupCertainly (unLooseEnd le) (gbe_loose_end_joins final_env)) (gbe_loose_ends final_env) of 169 | Nothing -> error $ "An unknotted loose end remained!" 170 | Just (KnotToLooseEnd le') -> lookupLooseEndPort le' 171 | Just (KnotToPort p) -> p 172 | -------------------------------------------------------------------------------- /Language/ContextSemantics/CallByNeedLambda.hs: -------------------------------------------------------------------------------- 1 | module Language.ContextSemantics.CallByNeedLambda where 2 | 3 | import Language.ContextSemantics.Expressions 4 | import Language.ContextSemantics.Utilities () 5 | import Language.ContextSemantics.Output 6 | 7 | import Control.Arrow (second) 8 | 9 | import Data.List (nub) 10 | import Data.List.Zipper 11 | import Data.Maybe 12 | import Data.Nthable 13 | 14 | import Prelude hiding (fst, snd) 15 | 16 | -- 17 | -- Context semantics 18 | -- 19 | 20 | data Token = White | Black | LeftT | RightT | Bracket [Token] [Token] | Symbol String 21 | 22 | instance Show Token where 23 | show White = "⚪" 24 | show Black = "⚫" 25 | show LeftT = "L" 26 | show RightT = "R" 27 | show (Bracket ts1 ts2) = "<" ++ show ts1 ++ "," ++ show ts2 ++ ">" 28 | show (Symbol s) = s 29 | 30 | showList = showCompactList 31 | 32 | type Port = Zipper [Token] -> Either String (Output (Zipper [Token])) 33 | 34 | popAtCursor :: Zipper [Token] -> Either String (Token, Zipper [Token]) 35 | popAtCursor tss = case cursor tss of 36 | (t:ts) -> return (t, replace ts tss) 37 | [] -> Left $ "popAtCursor: malformed incoming context " ++ show tss 38 | 39 | pushAtCursor :: Token -> Zipper [Token] -> Zipper [Token] 40 | pushAtCursor t tss = replace (t : cursor tss) tss 41 | 42 | app :: Port -> Port -> Port -> (Port, Port, Port) 43 | app princp_out cont_out arg_out = (princp_in, cont_in, arg_in) 44 | where 45 | princp_in tss = popAtCursor tss >>= \tss' -> case tss' of 46 | (White, tss'') -> cont_out tss'' 47 | (Black, tss'') -> arg_out tss'' 48 | _ -> Left $ "app: principal port got malformed incoming context " ++ show tss 49 | 50 | cont_in tss = princp_out (pushAtCursor White tss) 51 | 52 | arg_in tss = princp_out (pushAtCursor Black tss) 53 | 54 | lam :: Port -> Port -> Port -> (Port, Port, Port) 55 | lam princp_out body_out param_out = (princp_in, body_in, param_in) 56 | where 57 | princp_in tss = popAtCursor tss >>= \tss' -> case tss' of 58 | (White, tss'') -> body_out tss'' 59 | (Black, tss'') -> param_out tss'' 60 | _ -> Left $ "lam: principal port got malformed incoming context " ++ show tss 61 | 62 | body_in tss = princp_out (pushAtCursor White tss) 63 | 64 | param_in tss = princp_out (pushAtCursor Black tss) 65 | 66 | share :: Port -> Port -> Port -> (Port, Port, Port) 67 | share princp_out left_out right_out = (princp_in, left_in, right_in) 68 | where 69 | princp_in tss = popAtCursor tss >>= \tss' -> case tss' of 70 | (LeftT, tss'') -> left_out tss'' 71 | (RightT, tss'') -> right_out tss'' 72 | _ -> Left $ "share: principal port got malformed incoming context " ++ show tss 73 | 74 | left_in tss = princp_out (pushAtCursor LeftT tss) 75 | 76 | right_in tss = princp_out (pushAtCursor RightT tss) 77 | 78 | enterBox :: Port -> Port 79 | enterBox entering ts = entering (right ts) 80 | 81 | leaveBox :: Port -> Port 82 | leaveBox leaving ts = leaving (left ts) 83 | 84 | croissant :: String -> Port -> Port -> (Port, Port) 85 | croissant s forced_out boxed_out = (forced_in, boxed_in) 86 | where 87 | forced_in tss = boxed_out (insert [Symbol s] tss) 88 | 89 | boxed_in tss = case cursor tss of 90 | [Symbol s'] | s == s' -> forced_out (delete tss) 91 | _ -> Left $ "croissant: boxed port got malformed incoming context " ++ show tss 92 | 93 | bracket :: Port -> Port -> (Port, Port) 94 | bracket merged_out waiting_out = (merged_in, waiting_in) 95 | where 96 | merged_in tss = waiting_out (insert ([Bracket (cursor tss) (cursor (right tss))]) (delete (delete tss))) 97 | 98 | waiting_in tss = case cursor tss of 99 | [Bracket shallow deep] -> merged_out $ insert shallow $ insert deep $ delete tss 100 | _ -> Left $ "bracket: waiting port got malformed incoming context " ++ show tss 101 | 102 | fv :: String -> Port 103 | fv = (Right .) . Output 104 | 105 | -- 106 | -- Translation from traditional CBN lambda calculus 107 | -- 108 | 109 | exprSemantics :: Expr -> (Port, [(String, Port)]) 110 | exprSemantics e = exprSemantics' (fv "Input") [(v, fv v) | v <- freeVars e] e 111 | 112 | exprSemantics' :: Port -> [(String, Port)] -> Expr -> (Port, [(String, Port)]) 113 | exprSemantics' out_port env (V v) = (forced_port, [(v, boxed_port)]) 114 | where (forced_port, boxed_port) = croissant v out_port (lookupInEnv env v) 115 | exprSemantics' out_port env (e1 :@ e2) = (c, usg) 116 | where (e1_port, usg1) = exprSemantics' r env1 e1 117 | -- If you send a signal out of e2 then it must leave the box - hence the modifications 118 | -- to the environment and the port we supply 119 | (e2_port, usg2) = exprSemantics' (leaveBox a) (map (second leaveBox) env2') e2 120 | 121 | -- Both expressions in the application might refer to the same free variable, and we need 122 | -- to insert share nodes if that happens 123 | (env1, env2, usg) = combineUsages env usg1 usg2' 124 | 125 | -- If you send a signal to the usages originating from e2 then you implicitly enter the box. 126 | -- Furthermore, we need to make sure that before you enter the box you go through a bracket 127 | -- node -- inserting these is the job of bracketUsages 128 | (env2', usg2') = bracketUsages env2 (map (second enterBox) usg2) 129 | 130 | -- Finally, build the app node. Remember that e2 is boxed, so we need to enterBox on its input port 131 | (r, c, a) = app e1_port out_port (enterBox e2_port) 132 | exprSemantics' out_port env (Lam v e) = (r, filter ((/= v) . fst) usg) 133 | where (e_port, usg) = exprSemantics' b ((v, p) : env) e 134 | v_port = (fv $ "Plug for " ++ v) `fromMaybe` lookup v usg 135 | (r, b, p) = lam out_port e_port v_port 136 | 137 | combineUsages :: [(String, Port)] -> [(String, Port)] -> [(String, Port)] -> ([(String, Port)], [(String, Port)], [(String, Port)]) 138 | combineUsages env usg1 usg2 = (catMaybes env1_mbs, catMaybes env2_mbs, usg) 139 | where 140 | (usg, env1_mbs, env2_mbs) = unzip3 [combineUsage v (lookup v usg1) (lookup v usg2) 141 | | v <- nub $ map fst (usg1 ++ usg2)] 142 | 143 | -- If both sides of the usage refer to the same variable, we need to insert a share node and 144 | -- adjust the usage and environment appropriately to interdict all communication between the 145 | -- use and definition sites 146 | combineUsage v mb_p1 mb_p2 = case (mb_p1, mb_p2) of 147 | (Nothing, Nothing) -> error "combineUsage" 148 | (Just p1, Nothing) -> ((v, p1), Just (v, p), Nothing) 149 | (Nothing, Just p2) -> ((v, p2), Nothing, Just (v, p)) 150 | (Just p1, Just p2) -> let (p_in, l_in, r_in) = share p p1 p2 151 | in ((v, p_in), Just (v, l_in), Just (v, r_in)) 152 | where p = lookupInEnv env v 153 | 154 | bracketUsages :: [(String, Port)] -> [(String, Port)] -> ([(String, Port)], [(String, Port)]) 155 | bracketUsages env = unzip . map bracketUsage 156 | where 157 | -- For every usage originating from the expression, add something to the environment that 158 | -- brackets it before we go any further away from the box, adjusting the usage information 159 | -- to now refer to the bracket 160 | bracketUsage (v, p) = ((v, m), (v, w)) 161 | where (m, w) = bracket p (lookupInEnv env v) 162 | 163 | lookupInEnv :: [(String, Port)] -> String -> Port 164 | lookupInEnv env v = error ("No binding for " ++ v) `fromMaybe` lookup v env 165 | 166 | -- 167 | -- Examples 168 | -- 169 | 170 | examples :: IO () 171 | examples = do 172 | printUTF8 $ identity $ fromList [[White]] 173 | printUTF8 $ identity_app $ fromList [[]] 174 | printUTF8 $ self_app $ fromList [[White]] 175 | printUTF8 $ self_app $ fromList [[Black, LeftT, Symbol "x"], [Black, Symbol "α"]] 176 | printUTF8 $ fst dead_var $ fromList [[Black]] 177 | printUTF8 $ fst dead_var $ fromList [[White]] 178 | printUTF8 $ snd dead_var $ fromList [[Symbol "x"], [Symbol "α"]] 179 | printUTF8 $ fst app_to_fv $ fromList [[]] 180 | printUTF8 $ fst app_to_fv_in_lam $ fromList [[White]] 181 | printUTF8 $ snd app_to_fv_in_lam $ fromList [[Symbol "x"], [Black, Symbol "α"], [White]] 182 | 183 | -- (\x.x) @ y 184 | -- Port wired to the input of the lambda 185 | identity :: Port 186 | identity = r1 187 | where 188 | inp = fv "Input" 189 | (r1, b1, p1) = lam inp f2 b2 190 | (f2, b2) = croissant "x" b1 p1 191 | 192 | -- (\x.x) @ y 193 | -- Port wired to the input of the application 194 | identity_app :: Port 195 | identity_app = c1 196 | where 197 | inp = fv "Input" 198 | y = fv "y" 199 | (r1, c1, _a1) = app r2 inp (enterBox y) 200 | (r2, b2, p2) = lam r1 f3 b3 201 | (f3, b3) = croissant "x" b2 p2 202 | 203 | self_app :: Port 204 | self_app = fst $ exprSemantics $ Lam "x" $ V "x" :@ V "x" 205 | 206 | dead_var :: (Port, Port) 207 | dead_var = (p, lookupInEnv fvs "x") 208 | where (p, fvs) = exprSemantics $ Lam "y" $ V "x" 209 | 210 | app_to_fv :: (Port, Port, Port) 211 | app_to_fv = (p, lookupInEnv fvs "x", lookupInEnv fvs "y") 212 | where (p, fvs) = exprSemantics $ V "x" :@ V "y" 213 | 214 | app_to_fv_in_lam :: (Port, Port) 215 | app_to_fv_in_lam = (p, lookupInEnv fvs "x") 216 | where (p, fvs) = exprSemantics $ Lam "y" $ V "x" :@ V "y" --------------------------------------------------------------------------------