cli, cps interpreter, stack vm, closure-conversion, fixes, tests, LOL

src/Gyehoek/Scheme/Syntax.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -15,6 +16,7 @@ module Gyehoek.Scheme.Syntax
   , Lit(..)
   , Def(..)
   , Exp(..)
+  , ExpF(..)
   , Sexp(..)
   , Program(..)
   , CommandOrDef(..)
@@ -26,11 +28,15 @@ module Gyehoek.Scheme.Syntax
   , scm
   , readExp
   , readProgram
+  , free'
+  , freeWithBound'
+  , freeO
+  , encodeProgram
   )
   where
 
 import Data.Text (Text)
-import Data.List (List)
+import Data.List (List, intersperse)
 import Language.SexpGrammar
   ( SexpIso(..), list, el, rest, sym, symbol )
 import Language.SexpGrammar qualified as Sexp
@@ -51,13 +57,15 @@ import Data.Functor.Foldable.TH (makeBaseFunctor)
 import Data.Functor.Foldable hiding (fold)
 import Data.HashSet (HashSet)
 import qualified Data.HashSet as HS
-import Data.Foldable (fold)
+import Data.Foldable (fold, toList)
 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
 import Control.DeepSeq (NFData)
+import qualified Data.Set.Ordered as O
+import Data.Sequence (Seq)
 
 
 newtype Name = MkName { inner :: Text }
@@ -87,6 +95,7 @@ data Prim e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
   | PrimEnvRef e Int
+  | PrimEnvCode e
   | PrimCallCC e
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
@@ -112,8 +121,8 @@ data Def
   deriving anyclass (NFData)
 
 data Exp
-  = ExpLet (NonEmpty (Name, Exp)) Exp
-  | ExpLetRec (NonEmpty (Name, Exp)) Exp
+  = ExpLet (List (Name, Exp)) Exp
+  | ExpLetRec (List (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (List Exp)
   | ExpIf Exp Exp Exp
@@ -180,6 +189,7 @@ primSexpIso namefn a = match
     $ With (. nullop "newline")
     $ With (. ht1' "make-closure")
     $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
+    $ With (. ht1 "env-code")
     $ With (. ht1 "call/cc")
     $ End
     where
@@ -253,6 +263,35 @@ instance SexpIso CommandOrDef where
 scm :: QuasiQuoter
 scm = GS.makeSx [|| GS.fromSexp @Exp ||]
 
+freeWithBound' :: Foldable f => f Name -> Exp -> List Name
+freeWithBound' bound = filter (`elem` bound) . free'
+
+freeO :: Exp -> O.OSet Name
+freeO = O.unbiased . cata \case
+  ExpVarF x -> O.Bias @O.L $ O.singleton x
+  ExpLetF bs e ->
+    foldOf (each . _2) bs
+    <> (e & coerced %~ deleteFromO (bs ^.. each . _1))
+  ExpLetRecF bs e ->
+    (foldOf (each . _2) bs & coerced %~ deleteFromO binds)
+    <> (e & coerced %~ deleteFromO binds)
+    where binds = bs ^.. each . _1
+  ExpLambdaF bs e -> e & coerced %~ deleteFromO bs
+  e -> fold e
+
+free' :: Exp -> List Name
+free' = toList @O.OSet . O.unbiased . cata \case
+  ExpVarF x -> O.Bias @O.L $ O.singleton x
+  ExpLetF bs e ->
+    foldOf (each . _2) bs
+    <> (e & coerced %~ deleteFromO (bs ^.. each . _1))
+  ExpLetRecF bs e ->
+    (foldOf (each . _2) bs & coerced %~ deleteFromO binds)
+    <> (e & coerced %~ deleteFromO binds)
+    where binds = bs ^.. each . _1
+  ExpLambdaF bs e -> e & coerced %~ deleteFromO bs
+  e -> fold e
+
 free :: Exp -> HashSet Name
 free = cata \case
   ExpVarF x -> HS.singleton x
@@ -260,6 +299,9 @@ free = cata \case
   ExpLambdaF binders vs -> deleteFrom binders vs
   e -> fold e
 
+deleteFromO :: (Foldable f, Ord a) => f a -> O.OSet a -> O.OSet a
+deleteFromO = flip $ foldr O.delete
+
 deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 deleteFrom = flip $ foldr HS.delete
 
@@ -292,3 +334,9 @@ readProgram fp = runFileSystem $
 
 readExp :: IOE :> es => FilePath -> Eff es Exp
 readExp fp = readProgram fp <&> (^?! #commandsAndDefs . _head . #Command)
+
+encodeProgram :: Program -> Text
+encodeProgram p = p.commandsAndDefs
+  & fmap ((^?! _Right) . GS.encodePretty)
+  & intersperse "\n\n"
+  & mconcat