fart

src/Gyehoek/CPS/Syntax.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FunctionalDependencies #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
@@ -19,6 +20,11 @@ module Gyehoek.CPS.Syntax
   , _ExpPrim
   , _ExpLetRec
   , _ExpApply
+  , binders
+  , body
+  , op
+  , args
+  , cont
   , cps
   , pattern AbsLambda'
   , pattern AbsKappa'
@@ -48,6 +54,7 @@ import Data.HashSet (HashSet)
 import qualified Data.HashSet as HS
 import Data.Hashable (Hashable)
 import Data.Monoid (Endo)
+import Data.Containers.ListUtils (nubOrd)
 
 -- Data types
 
@@ -56,10 +63,10 @@ data Val
   | ValLit Lit
   deriving (Show, Generic, Data, Eq)
 
-data Kappa = MkKappa (List Name) Exp
+data Kappa = MkKappa { binders :: List Name, body :: Exp }
   deriving (Show, Generic, Data, Eq)
 
-data Lambda = MkLambda (List Name) Name Exp
+data Lambda = MkLambda { binders :: List Name, ktail :: Name, body :: Exp }
   deriving (Show, Generic, Data, Eq)
 
 data Abs
@@ -72,7 +79,7 @@ pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp
   = ExpPrim (Prim Val) Kappa
-  | ExpLetRec (NonEmpty (Name, Abs)) Exp
+  | ExpLetRec { binders :: NonEmpty (Name, Abs), body :: Exp }
   | ExpContinue Name (List Val)
   | ExpIf Val Exp Exp
   | ExpApply
@@ -97,7 +104,24 @@ data Program = MkProgram
   deriving (Show, Generic, Data)
 
 makePrisms ''Kappa
+-- makeLenses ''Kappa
 makePrisms ''Exp
+-- makeLenses ''Exp
+-- makeFieldsNoPrefix ''Exp
+-- makeFieldsNoPrefix ''Kappa
+-- makeLensesWith abbreviatedFields ''Exp
+-- makeLensesFor [("binders", "_binders"), ("body", "_body")] ''Exp
+makeFieldsId ''Exp
+makeFieldsId ''Kappa
+makeFieldsId ''Lambda
+
+instance HasBinders Abs (List Name) where
+  binders k (AbsKappa kap) = AbsKappa <$> binders k kap
+  binders k (AbsLambda lam) = AbsLambda <$> binders k lam
+
+instance HasBody Abs Exp where
+  body k (AbsKappa kap) = AbsKappa <$> body k kap
+  body k (AbsLambda lam) = AbsLambda <$> body k lam
 
 
 -- SexpIso instances
@@ -230,24 +254,29 @@ free = go where
 
 -- | Free variables given in the order of their appearance.
 free' :: Exp -> List Name
-free' = go HS.empty where
+free' = nubOrd . goFree HS.empty where
-  gokap bound (MkKappa xs m) = go (bound & insertFrom xs) m
+
-  golam bound (MkLambda xs k m) = go (bound & insertFrom (k:xs)) m
+goFreeKap bound (MkKappa xs m) = goFree (bound & insertFrom xs) m
-  goabs bound = \case
+goFreeLam bound (MkLambda xs k m) = goFree (bound & insertFrom (k:xs)) m
-    AbsKappa kap -> gokap bound kap
+goFreeAbs bound = \case
-    AbsLambda lam -> golam bound lam
+  AbsKappa kap -> goFreeKap bound kap
-  go :: HashSet Name -> Exp -> List Name
+  AbsLambda lam -> goFreeLam bound lam
-  go bound = \case
+
-    ExpPrim p k ->
+goFree :: HashSet Name -> Exp -> List Name
-      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+goFree bound = \case
-        & (<> gokap bound k)
+  ExpPrim p k ->
-    ExpLetRec bs m ->
+    p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-      foldMapOf (each . _2) (goabs bound') bs <> go bound' m
+      & (<> goFreeKap bound k)
-      where bound' = bound & insertFrom (bs ^.. each . _1)
+  ExpLetRec bs m ->
-    ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
+    foldMapOf (each . _2) (goFreeAbs bound') bs <> goFree bound' m
-    ExpIf c t f ->
+    where bound' = bound & insertFrom (bs ^.. each . _1)
-      (c ^.. #ValVar . filtered (`notElem` bound))
+  ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
-      <> go bound t <> go bound f
+  ExpIf c t f ->
-    ExpApply f xs k ->
+    (c ^.. #ValVar . filtered (`notElem` bound))
-      (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
+    <> goFree bound t <> goFree bound f
-      <> (k ^.. filtered (`notElem` bound))
+  ExpApply f xs k ->
+    (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
+    <> (k ^.. filtered (`notElem` bound))
+
+freeLambda :: Lambda -> List Name
+freeLambda (MkLambda {binders,ktail,body}) = _

src/Gyehoek/Scheme/Syntax.hs

@@ -52,7 +52,7 @@ import Language.Haskell.TH.Quote (QuasiQuoter)
 
 
 newtype Name = MkName { inner :: Text }
-  deriving newtype (Show, Eq, IsString, Gen, Hashable)
+  deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
   deriving stock (Generic, Data)
 
 getName :: Name -> Text