more stackification

src/Gyehoek/Stack/Syntax.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Gyehoek.Stack.Syntax
   ( Program(..)
   , Block(..)
@@ -11,6 +12,7 @@ module Gyehoek.Stack.Syntax
   , Prim(..)
   , Name
   , pattern ValLabel
+  , encodeProgram
   ) where
 
 import Control.Lens
@@ -29,6 +31,7 @@ import qualified Data.HashMap.Strict as H
 import Effectful
 import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
 import GHC.Exts (IsList(..))
+import Data.List (intersperse)
 
 
 newtype Program = MkProgram
@@ -56,7 +59,7 @@ data Instr
   = Pop Name
   | Push Val
   | PopCont Name
-  | PushCont Name
+  | PushCont Val
   | Prim Name (Prim Val)
   | Call Val (List Val)
   | If Val (List Instr) (List Instr)
@@ -79,3 +82,61 @@ data Imm
 data Obj
   = ObjImm Imm
   deriving (Show, Generic, Data, Eq)
+
+
+--- sexp work
+
+pure []
+
+instance SexpIso Instr where
+  sexpIso = match
+    $ With (Gyehoek.Sexp.headTagged1 "pop!" regName >>>)
+    $ With (Gyehoek.Sexp.headTagged1 "push!" S.sexpIso >>>)
+    $ With (Gyehoek.Sexp.headTagged1 "pop-cont!" regName >>>)
+    $ With (Gyehoek.Sexp.headTagged1 "push-cont!" S.sexpIso >>>)
+    $ With (Gyehoek.Sexp.headTagged2 "prim" regName S.sexpIso >>>)
+    $ With (Gyehoek.Sexp.headTagged1' "call" S.sexpIso S.sexpIso >>>)
+    $ With (if_ >>>)
+    $ End
+    where
+      if_ = S.list $ S.el (S.sym "if")
+        >>> S.el (S.sexpIso @Val)
+        >>> S.el (S.list $ S.el (S.sym "then") >>> S.rest (S.sexpIso @Instr))
+        >>> S.el (S.list $ S.el (S.sym "else") >>> S.rest (S.sexpIso @Instr))
+
+instance SexpIso Val where
+  sexpIso = match
+    $ With (regName >>>)
+    $ With (S.sexpIso >>>)
+    $ End
+
+instance SexpIso Imm where
+  sexpIso = match
+    $ With (S.sexpIso @Int >>>)
+    $ With (Gyehoek.Sexp.schemeBool >>>)
+    $ With (labelName >>>)
+    $ End
+
+instance SexpIso Block where
+  sexpIso = with (block >>>)
+    where
+      block = S.list $
+        S.el (S.sym "define")
+        >>> S.el (S.list $ S.el labelName >>> S.rest regName)
+        >>> S.rest (S.sexpIso @Instr)
+
+encodeProgram :: Program -> Text
+encodeProgram p = p.blocks
+  & fmap ((^?! _Right) . Gyehoek.Sexp.encodePretty)
+  & intersperse "\n\n"
+  & mconcat
+
+regName :: S.SexpGrammar Name
+regName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
+  (S.expected "register")
+  (prefixed @Name "%")
+
+labelName :: S.SexpGrammar Name
+labelName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
+        (S.expected "label")
+        (prefixed @Name "$")

src/Gyehoek/Stack/VM.hs

@@ -5,6 +5,7 @@ module Gyehoek.Stack.VM
   , eval
   , trace
   , module Gyehoek.Stack.Syntax
+  , writeObj
   ) where
 
 import Gyehoek.Stack.Syntax
@@ -46,7 +47,7 @@ stepI :: Env -> VM -> Instr -> VM
 
 stepI e vm (Push v) = vm & #stack %~ (evalVal e vm v :)
 
-stepI e vm (PushCont k) = vm & #kstack %~ (k:)
+stepI e vm (PushCont k) = vm & #kstack %~ (evalToLabel e vm k :)
 
 stepI e vm (Prim r p) = case evalVal e vm <$> p of
   PrimZeroP x -> case x of
@@ -133,3 +134,10 @@ trace p = initialVM & unfoldr \vm ->
       Just _ -> Nothing
       Nothing -> Just (vm, step e vm)
   where e = initialEnv p
+
+writeObj :: Obj -> Text
+writeObj (ObjImm im) = case im of
+  ImmInt n -> [i|#{n}|]
+  ImmBool True -> "#t"
+  ImmBool False -> "#f"
+  ImmLabel l -> "#<procedure>"