src/Gyehoek/CPS/Convert.hs

@@ -2,6 +2,7 @@
 {- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Convert
   ( convertProgram
+  , convertExp
   ) where
 
 import Gyehoek.CPS.Syntax
@@ -79,7 +80,6 @@ convert (Scm.ExpLet bs e) k =
         (continue #{kbody} ##{rhss'}))
     |]
 
-
 convert _ k = _
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
@@ -88,3 +88,6 @@ convertProgram p =
     pure . Halt1 $ case NE.nonEmpty exps of
       Nothing -> ValLit Void
       Just es -> NE.last es
+
+convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
+convertExp e = convert e (pure . Halt1)

src/Gyehoek/CPS/Syntax.hs

@@ -309,32 +309,53 @@ instance Vars Exp where
 
 
 data Scope
-  = Bind (List Name) Scope
-  | Use (List Name) Scope
-  | Leaf
+  = Bind (List Name) (List Scope)
+  | Use (List Name) (List Scope)
   deriving (Show, Eq)
 
 makeBaseFunctor ''Scope
 
-class Subst a where
-  substWith :: (Name -> Val) -> a -> a
-
-instance Subst Exp where
-  substWith sub = cata \e ->
-    _
-
 class Scoped a where
   scope :: a -> Scope
 
 instance Scoped Kappa where
   scope (MkKappa bs e) =
-    Bind bs (scope e)
+    Bind bs [scope e]
+
+instance Scoped Lambda where
+  scope (MkLambda bs k e) = Bind (bs ++ [k]) [scope e]
+
+instance Scoped Abs where
+  scope = \case
+    AbsKappa k -> scope k
+    AbsLambda l -> scope l
 
 instance Scoped Val where
   scope = \case
-    ValVar x -> Use [x] Leaf
-    _ -> Leaf
+    ValVar x -> Use [x] []
+    _ -> Use [] []
 
 instance Scoped Exp where
   scope = \case
-    ExpApply f xs k = _
+    ExpApply f xs k ->
+      Use (((f:xs) ^.. each . _ValVar) ++ [k]) []
+    ExpLetRec bs e ->
+      Bind (bs ^.. each . _1) $
+        (bs ^.. each . _2 . to scope)
+        ++ [scope e]
+    ExpPrim p k ->
+      Use (p ^.. each . _ValVar) [scope k]
+    ExpContinue k xs ->
+      Use (k : (xs ^.. each . _ValVar)) []
+    ExpIf c t f ->
+      Use (c ^.. _ValVar) [ scope t, scope f ]
+
+
+
+class Subst a where
+  substWith :: (Name -> Maybe Val) -> a -> a
+
+instance Subst Exp where
+  substWith f = go HS.empty where
+    go bound e = case scope e of
+      Use xs ss -> _

src/Gyehoek/Scheme/Syntax.hs

@@ -23,6 +23,8 @@ module Gyehoek.Scheme.Syntax
   , subst
   , getName
   , scm
+  , readExp
+  , readProgram
   )
   where
 
@@ -33,6 +35,7 @@ import Language.SexpGrammar
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp.Located qualified as S
 import Language.SexpGrammar.Generic
+import Effectful
 import GHC.Generics
 import Prelude hiding ((.), id)
 import Control.Category
@@ -49,6 +52,10 @@ import Data.HashSet (HashSet)
 import qualified Data.HashSet as HS
 import Data.Foldable (fold)
 import Language.Haskell.TH.Quote (QuasiQuoter)
+import Effectful.FileSystem (runFileSystem)
+import qualified Effectful.FileSystem.IO as FS
+import qualified Data.Text.Encoding as T
+import qualified Effectful.FileSystem.IO.ByteString as FB
 
 
 newtype Name = MkName { inner :: Text }
@@ -72,7 +79,8 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
-  | PrimMakeClosure { code :: e, upvals :: List e }
+  | PrimMakeClosure { code :: e, env :: List e }
+  | PriEnvRef e Int
   deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
 
 instance Each (Prim e) (Prim e') e e'
@@ -157,6 +165,7 @@ primSexpIso namefn a = match
     $ With (. unop "zero?")
     $ With (. nullop "newline")
     $ With (. mkclosure)
+    $ With (. envref)
     $ End
     where
       idn s = el (sym (namefn s))
@@ -164,6 +173,7 @@ primSexpIso namefn a = match
       unop s = list $ idn s >>> el a
       binop s = list $ idn s >>> el a >>> el a
       mkclosure = list $ idn "make-closure" >>> el a >>> rest a
+      envref = list $ idn "env-ref" >>> el a >>> el Sexp.int
 
 instance SexpIso a => SexpIso (Prim a) where
   -- sexpIso = primSexpIso ("prim:"<>) sexpIso
@@ -259,3 +269,22 @@ subst f = \e -> cata go e mempty where
   go (ExpLetF _ _) _ = error "todo lol"
   go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
   go e bound = embed $ fmap ($ bound) e
+
+
+
+fileName :: FilePath -> FilePath
+fileName "-" = "<interactive>"
+fileName e = e
+
+hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text
+hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
+
+readProgram :: IOE :> es => FilePath -> Eff es Program
+readProgram fp = runFileSystem $
+  FS.withFile fp FS.ReadMode $ \h ->
+    Gyehoek.Sexp.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
+     >>= either error (pure . MkProgram)
+
+readExp :: IOE :> es => FilePath -> Eff es Program
+readExp fp = readProgram fp <&>
+  (^?! (#commandsAndDefs . _head . _Comm))