From f4b891f2412fa154160676357c86ec7b778a8119 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Mon, 17 Aug 2026 17:19:34 -0600 Subject: [PATCH] --- gyehoek.cabal | 2 + src/Gyehoek/Sexp.hs | 28 ++++++++++++ src/Gyehoek/Stack/Eval.hs | 4 ++ src/Gyehoek/Stack/Syntax.hs | 87 +++++++++++++++++++++++++++++++++++++ t.stk | 22 ++++++++++ 5 files changed, 143 insertions(+) create mode 100644 src/Gyehoek/Stack/Eval.hs create mode 100644 src/Gyehoek/Stack/Syntax.hs create mode 100644 t.stk diff --git a/gyehoek.cabal b/gyehoek.cabal index 91a6714..29b66c2 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -61,6 +61,8 @@ library Gyehoek.Options Gyehoek.Scheme.Syntax Gyehoek.Sexp + Gyehoek.Stack.Eval + Gyehoek.Stack.Syntax Gyehoek.Wasm build-depends: diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index aa73a49..a8c0066 100644 --- a/src/Gyehoek/Sexp.hs +++ b/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 "-" = "" +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) diff --git a/src/Gyehoek/Stack/Eval.hs b/src/Gyehoek/Stack/Eval.hs new file mode 100644 index 0000000..d0a79fe --- /dev/null +++ b/src/Gyehoek/Stack/Eval.hs @@ -0,0 +1,4 @@ +module Gyehoek.Stack.Eval + ( + ) where + diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs new file mode 100644 index 0000000..feb9887 --- /dev/null +++ b/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 diff --git a/t.stk b/t.stk new file mode 100644 index 0000000..925fc89 --- /dev/null +++ b/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))