gyehoek.cabal

@@ -61,6 +61,8 @@ library
     Gyehoek.Options
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
+    Gyehoek.Stack.Eval
+    Gyehoek.Stack.Syntax
     Gyehoek.Wasm
 
   build-depends:

src/Gyehoek/Sexp.hs

@@ -38,10 +38,12 @@ module Gyehoek.Sexp
   , makeSx'
   , toSexp
   , fromSexp
+  , fromSexp'
   , stripLocation
   , format
   , equivalent
   , encodeOrShow
+  , readSxs
   )
   where
 
@@ -87,6 +89,10 @@ import qualified Data.Vector as V
 import qualified Data.Vector.Strict
 import Data.Function (on)
 import Data.String (IsString (fromString))
+import Effectful
+import qualified Effectful.FileSystem.IO as FS
+import qualified Effectful.FileSystem.IO.ByteString as FB
+import qualified Data.Text.Encoding as T
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -120,6 +126,10 @@ parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
   where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso)
 
+parseSexpsWith :: SexpGrammar a -> FilePath -> Text -> Either String (List a)
+parseSexpsWith g f = marshal . SL.parseSexps f . view lazy . encodeUtf8
+  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
+
 parseSexp :: SexpIso a => FilePath -> Text -> Either String a
 parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
   where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
@@ -140,6 +150,24 @@ parseSexpWithPos g pos =
   marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
   where marshal = join . traverseOf _Right (Sexp.fromSexp g)
 
+fileName :: FilePath -> FilePath
+fileName "-" = "<interactive>"
+fileName e = e
+
+hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text
+hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
+
+readSxs
+  :: IOE :> es
+  => SexpGrammar a
+  -> FilePath -> Eff es (List a)
+readSxs g fp = FS.runFileSystem $
+  FS.withFile fp FS.ReadMode $ \h ->
+    parseSexpsWith g (fileName fp) <$> hGetContents h
+     >>= either error pure
+
+
+
 nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
 nonEmptyGrammar = IGB.Iso
   (\((x:|xs) :- t) -> reverse xs :- x :- t)

src/Gyehoek/Stack/Eval.hs

@@ -0,0 +1,4 @@
+module Gyehoek.Stack.Eval
+  (
+  ) where
+

src/Gyehoek/Stack/Syntax.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Gyehoek.Stack.Syntax
+  ( Program(..)
+  , Block(..)
+  , Instr(..)
+  , stk
+  , readProgram
+  ) where
+
+import Control.Lens
+import Data.List (List)
+import Gyehoek.Scheme.Syntax (Name)
+import GHC.Generics (Generic)
+import Data.HashMap.Strict (HashMap)
+import Language.SexpGrammar (SexpIso, (>>>), (:-))
+import Language.SexpGrammar qualified as S
+import Language.SexpGrammar.Generic
+import Data.Coerce (coerce)
+import Data.Text (Text)
+import qualified Gyehoek.Sexp
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Data.Data (Data)
+import qualified Data.HashMap.Strict as H
+import Effectful
+
+
+newtype Program = MkProgram
+  { blocks :: HashMap Name Block }
+  deriving stock (Show, Generic, Data)
+
+newtype Block = MkBlock { code :: List Instr }
+  deriving stock (Show, Generic, Data)
+
+instance Each Block Block Instr Instr where
+  each = #code . each
+
+data Instr
+  = DefinePop Name
+  | DefinePopCont Name
+  | PushCont (List Name) Block
+  deriving stock (Show, Generic, Data)
+
+
+-- Sexp work
+
+blockGrammar :: S.SexpGrammar (Name, Block)
+blockGrammar = g >>> S.pair where
+  g :: S.Grammar S.Position (S.Sexp :- t) (Block :- (Name :- t))
+  g = S.list $
+    S.el (S.sym "define")
+    >>> S.el (S.list $ S.el $ S.sexpIso @Name)
+    >>> S.rest (S.sexpIso @Instr)
+    >>> S.onTail (S.iso coerce coerce)
+
+instance SexpIso Instr where
+  sexpIso = match
+    $ With (g_DefinePop >>>)
+    $ With (g_DefinePopCont >>>)
+    $ With (g_PushCont >>>)
+    $ End
+    where
+      def :: Text -> S.SexpGrammar Name
+      def s = S.list $
+        S.el (S.sym "define")
+        >>> S.el (S.sexpIso @Name)
+        >>> S.el (S.list $ S.el $ S.sym s)
+      g_DefinePop = def "pop!"
+      g_DefinePopCont = def "pop-cont!"
+      g_PushCont = S.list $
+        S.el (S.sym "push-cont!")
+        >>> S.el (S.list $
+                 S.el Gyehoek.Sexp.kappaKeyword
+                 >>> S.el (S.sexpIso @(List Name))
+                 >>> S.rest (S.sexpIso @Instr)
+                 >>> S.onTail (S.iso coerce coerce))
+
+programFromSexps :: Foldable f => f S.Sexp -> Program
+programFromSexps = MkProgram . foldMap f
+  where f = uncurry H.singleton . Gyehoek.Sexp.fromSexp' blockGrammar
+
+stk :: QuasiQuoter
+stk = Gyehoek.Sexp.makeSxs [|| programFromSexps ||]
+
+readProgram
+  :: IOE :> es
+  => FilePath -> Eff es Program
+readProgram = fmap (MkProgram . H.fromList) . Gyehoek.Sexp.readSxs blockGrammar

t.stk

@@ -0,0 +1,22 @@
+;; -*- mode:scheme -*-
+
+(define (silly)
+  (define f (pop!))
+  (define g (pop!))
+  (define h (pop!))
+  (define x (pop!))
+  (define ktail (pop-cont!))
+  (push-cont! (κ (x0)
+                 (define x* (pop!))
+                 (define g* (pop!))
+                 (push-cont! (κ (x1)
+                                (define f* (pop!))
+                                (define x0* (pop!))
+                                (push-cont! ktail)
+                                (push! x0*)
+                                (push! x1)
+                                (call! f)))
+                 (push! x*)
+                 (call! g)))
+  (push! x)
+  (call! h))