From 796b967686c91e9c706c217735a7b487b0789269 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Mon, 24 Aug 2026 06:21:54 -0600 Subject: [PATCH] continue takes var --- gyehoek.cabal | 24 +-- src/Gyehoek/CPS/Convert.hs | 2 +- src/Gyehoek/CPS/Lower.hs | 325 ------------------------------- src/Gyehoek/CPS/Syntax.hs | 26 +-- src/Gyehoek/Driver.hs | 16 +- src/Gyehoek/Sexp/Grammar.hs | 11 -- src/Gyehoek/Sexp/Grammar/Base.hs | 9 +- src/Gyehoek/Stack/Lower.hs | 29 +++ src/Gyehoek/Wasm.hs | 177 ++--------------- test/Gyehoek/Test/CPS/Syntax.hs | 6 +- 10 files changed, 84 insertions(+), 541 deletions(-) delete mode 100644 src/Gyehoek/CPS/Lower.hs create mode 100644 src/Gyehoek/Stack/Lower.hs diff --git a/gyehoek.cabal b/gyehoek.cabal index c247dcb..8baa6e1 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -14,9 +14,9 @@ build-type: Simple -- extra-source-files: flag doctest - description: enable the doctest suite - default: True - manual: True + description: enable the doctest suite + default: True + manual: True common ghcstuffs-dev ghc-options: @@ -60,7 +60,6 @@ library Gyehoek.CPS.Close Gyehoek.CPS.Convert Gyehoek.CPS.Eval - Gyehoek.CPS.Lower Gyehoek.CPS.Stackify Gyehoek.CPS.Syntax Gyehoek.Driver @@ -77,6 +76,7 @@ library Gyehoek.Sexp.QQ Gyehoek.Sexp.Read Gyehoek.Sexp.Syntax + Gyehoek.Stack.Lower Gyehoek.Stack.Syntax Gyehoek.Stack.VM Gyehoek.Wasm @@ -162,13 +162,15 @@ test-suite test -- https://github.com/martijnbastiaan/doctest-parallel/pull/66 test-suite doctest - import: ghcstuffs, ghcstuffs-dev - type: exitcode-stdio-1.0 - hs-source-dirs: test - build-depends: base + import: ghcstuffs, ghcstuffs-dev + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: base default-extensions: CPP - main-is: doctest.hs + main-is: doctest.hs + if flag(doctest) - build-depends: doctest-parallel >=0.1 + build-depends: doctest-parallel >=0.1 + else - cpp-options: "-DGYEHOEK_NO_DOCTEST" + cpp-options: -DGYEHOEK_NO_DOCTEST diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index a08d466..697f80a 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -105,7 +105,7 @@ convertLambda => List Name -> Scm.Exp -> Eff es Lambda convertLambda bs m = do ktail <- gensym' "lambda-tail" - m' <- convert m $ pure . ExpContinue ktail . (:[]) + m' <- convert m $ pure . ExpContinue (ValVar ktail) . (:[]) pure [cps|(λ (##{bs} #{ktail}) #{m'})|] convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs deleted file mode 100644 index a9c7a91..0000000 --- a/src/Gyehoek/CPS/Lower.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultilineStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE RecursiveDo #-} -{- HLINT ignore "Use camelCase" -} -module Gyehoek.CPS.Lower - (lower, lowerProgram) where - -import Gyehoek.CPS.Syntax -import Data.Vector.Strict (Vector) -import Control.Lens hiding (op) -import Numeric.Natural -import qualified Data.Vector.Strict as V -import Gyehoek.Wasm qualified as Wasm -import Gyehoek.Wasm hiding (Expr) -import Control.Monad.Fix -import Data.Text qualified as T -import Data.Foldable (fold) -import Gyehoek.Jalmot -import Gyehoek.Sexp qualified as S -import Gyehoek.Prelude - - -data Env = MkEnv - { vars :: Vector Name - , kvars :: Vector Name - } - deriving (Show, Generic) - -type instance Index Env = Natural -type instance IxValue Env = Name - -instance Ixed Env where - ix i = #vars . ix (fromIntegral i) - - - -tonat :: Integral a => a -> Natural -tonat = fromIntegral - --- | @makeSmallFixnum@ emits an expression injecting the i32 on top --- of the stack into the SCM unitype. -makeSmallFixnum :: Wasm.Expr -makeSmallFixnum = [expr| - (@gyehoek "construct small fixnum") - (i32.const 1) - i32.shl - ref.i31 - |] - -getArgRegister :: Natural -> S.Datum -getArgRegister n = S.Symbol [i|$arg#{n}|] - --- | Given an expression @e@ leaving a @ref eq@ atop the stack, --- @pushArg rt n e@ sets the nth slot of the arg-passing array to the --- result of @e@. -pushArg :: Natural -> Wasm.Expr -> Wasm.Expr -pushArg n e = [expr| - (@gyehoek begin pushArg) - ##{e} - (global.set #{reg}) - (@gyehoek end pushArg) - |] - where reg = getArgRegister n - --- | Pop the nth arg from the arg-passing array onto the stack. -popArg :: Natural -> Wasm.Expr -popArg n = [expr| - (@gyehoek begin popArg) - (global.get #{reg}) - ref.as_non_null - (@gyehoek end popArg) -|] - where reg = getArgRegister n - - - -lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr - -lowerVal g (ValImm imm) = - pure $ case imm of - ImmInt n -> [expr| - (i32.const #{n}) - ##{makeSmallFixnum} - |] - ImmBool b -> [expr| - (i32.const #{b'}) - ref.i31 - |] - where b' :: Int = if b then 0b11 else 0b01 - _ -> _ - -lowerVal g (ValVar x) = do - pure [expr|(global.get #{l})|] - where - l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just - -lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr - -lower' g (Halt [v]) = do - arg <- pushArg 0 <$> lowerVal g v - pure [expr| - ##{arg} - (return_call $halt (i32.const 1)) - |] - -lower' g e@(ExpPrim p k) = - case p of - PrimAdd x y -> lowerBinOp "i32.add" g x y k - PrimMul x y -> lowerBinOp "i32.mul" g x y k - -lower' g (ExpIf c t f) = do - c' <- lowerVal g c - t' <- lower' g t - f' <- lower' g f - pure [expr| - ##{c'} - (call $gh-truthy?) - (if (then ##{t'}) - (else ##{f'})) - |] - -lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do - idx <- lowerKappa g kap - let g' = g & #kvars <>~ [r] - e' <- lower' g' e - pure [expr| - (@gyehoek "push cont" :idx #{idx}) - (array.set $cont-stack-type - (global.get $cont-stack) - (global.get $cont-stack-top) - (ref.func #{idx})) - (global.set $cont-stack-top - (i32.add (global.get $cont-stack-top) - (i32.const 1))) - ##{e'} - |] - -lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do - idx <- lowerLambda g lam - let g' = g & #vars <>~ [r] - let n = succ $ length g.vars - e' <- lower' g' e - let reg = getArgRegister . fromIntegral $ n - pure [expr| - (i32.const 0) - (ref.func #{idx}) - (struct.new $closure) - (global.set #{reg}) - ##{e'} - |] - -lower' g e@(ExpApply f xs ktail) = do - let nargs = length xs - f' <- lowerVal g f - let l = succ $ V.elemIndex ktail g.kvars ^?! _Just - args <- fold <$> - itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs - pure [expr| - (@gyehoek "load args") - ##{args} - (i32.const 1) - ##{f'} - (ref.cast (ref $closure)) - (struct.get $closure $code) - (return_call_ref $cont-type) - (@gyehoek todo - (f' ##{f'}) - (ktail #{l})) - |] - -lower' g e@(ExpContinue k xs) = do - let nargs = length xs - args <- fold <$> - itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs - pure [expr| - (@gyehoek "push args") - ##{args} - (@gyehoek "nargs") - (i32.const #{nargs}) - (@gyehoek "pop cont stack") - (global.get $cont-stack-top) - (i32.const #{l}) - i32.sub - (global.set $cont-stack-top) - (global.get $cont-stack) - (global.get $cont-stack-top) - (array.get $cont-stack-type) - ref.as_non_null - (return_call_ref $cont-type) - |] - where - l = succ $ V.elemIndex k g.kvars ^?! _Just - -lower' g e = error . S.encodeOrShow' S.datumIso $ e - -lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx -lowerKappa g e@(MkKappa xs m) = do - let g' = g & #vars <>~ V.fromList xs - m' <- lower' g' m - idx <- Wasm.defineFunction [wat| - (func (param i32) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - ##{m'}) - |] - Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|] - pure idx - -lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx -lowerLambda g e@(MkLambda xs ktail m) = do - let g' = g & #vars .~ V.fromList xs - & #kvars <>~ [ktail] - m' <- lower' g' m - idx <- Wasm.defineFunction [wat| - (func (param i32) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - ##{m'}) - |] - Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|] - pure idx - -lowerBinOp - :: (GenMod :> es) - => Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr -lowerBinOp op g x y (MkKappa [r] e) = do - let op' = S.Symbol op - let g' = g & #vars <>~ [r] - let n = succ $ length (g ^. #vars) - let reg = getArgRegister . fromIntegral $ n - x' <- lowerVal g x - y' <- lowerVal g y - e' <- lower' g' e - pure [expr| - ##{x'} - (i31.get_s (ref.cast (ref i31))) - (i32.const 1) - i32.shr_u - ##{y'} - (i31.get_s (ref.cast (ref i31))) - (i32.const 1) - i32.shr_u - #{op'} - ##{makeSmallFixnum} - (global.set #{reg}) - ##{e'} - |] - - - -emitRuntime :: GenMod :> es => Eff es () -emitRuntime = mfix \runtime -> do - Wasm.defineFunctions [wats| - (import "gyehoek" "write" (func $gh-write (param (ref eq)))) - (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq)) - (result i32))) - |] - -- cont stack - Wasm.defineTypes [wats| - (type $heap-object (sub (struct (field $hash (mut i32))))) - (type $cont-type (func (param i32))) - (type $cont-stack-type (array (mut (ref null $cont-type)))) - (type $closure (sub $heap-object - (struct (field $hash (mut i32)) - (field $code (ref $cont-type))))) - |] - Wasm.defineGlobals [wats| - (global $cont-stack-top (mut i32) (i32.const 0)) - (global $cont-stack (ref $cont-stack-type) - (array.new_default $cont-stack-type (i32.const 128))) - |] - -- arg registers - Wasm.defineGlobals [wats| - (global $arg0 (mut (ref null eq)) (ref.null eq)) - (global $arg1 (mut (ref null eq)) (ref.null eq)) - (global $arg2 (mut (ref null eq)) (ref.null eq)) - (global $arg3 (mut (ref null eq)) (ref.null eq)) - (global $arg4 (mut (ref null eq)) (ref.null eq)) - (global $arg5 (mut (ref null eq)) (ref.null eq)) - (global $arg6 (mut (ref null eq)) (ref.null eq)) - (global $arg7 (mut (ref null eq)) (ref.null eq)) - (global $arg8 (mut (ref null eq)) (ref.null eq)) - (global $arg9 (mut (ref null eq)) (ref.null eq)) - (global $arg10 (mut (ref null eq)) (ref.null eq)) - (global $arg11 (mut (ref null eq)) (ref.null eq)) - (global $arg12 (mut (ref null eq)) (ref.null eq)) - (global $arg13 (mut (ref null eq)) (ref.null eq)) - (global $arg14 (mut (ref null eq)) (ref.null eq)) - (global $arg15 (mut (ref null eq)) (ref.null eq)) - |] - -- other things 😼 - Wasm.defineGlobal [wat| - (global $result (mut (ref null eq)) - (ref.null eq)) - |] - -- procedures - let arg = popArg 0 - Wasm.defineFunction [wat| - (func $halt (param i32) - ##{arg} - (global.set $result)) - |] - pure () - -lower :: Exp -> Eff es Text -lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do - runtime <- emitRuntime - let g = MkEnv mempty mempty - e' <- lower' g e - Wasm.defineFunction [wat| - (func $scm-entry (param i32) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - ##{e'}) - |] - Wasm.defineFunction [wat| - (func (export "main") - (call $scm-entry (i32.const 0)) - (call $gh-write (ref.as_non_null (global.get $result)))) - |] - -lowerProgram :: Program -> Eff es Text -lowerProgram (MkProgram e) = lower e diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 6cbc227..28a18e1 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -102,7 +102,7 @@ pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail) data Exp = ExpPrim (Prim Val) Kappa | ExpLetRec { binders :: List (Name, Abs), body :: Exp } - | ExpContinue Name (List Val) + | ExpContinue Val (List Val) | ExpIf Val Exp Exp | ExpApply { op :: Val @@ -112,10 +112,10 @@ data Exp deriving (Show, Generic, Data, Eq) pattern Halt :: List Val -> Exp -pattern Halt xs = ExpContinue "halt" xs +pattern Halt xs = ExpContinue (ValLabel "halt") xs pattern Halt1 :: Val -> Exp -pattern Halt1 x = ExpContinue "halt" [x] +pattern Halt1 x = ExpContinue (ValLabel "halt") [x] data Def = DefConstant Name Exp deriving (Show, Generic, Data) @@ -315,7 +315,7 @@ instance Free Exp where foldMapOf (each . _2) (freeWithBound' bound') bs <> freeWithBound' bound' m where bound' = bound & insertFrom (bs ^.. each . _1) - ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar) + ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar) ExpIf c t f -> (c ^.. #ValVar . filtered (`notElem` bound)) <> freeWithBound' bound t <> freeWithBound' bound f @@ -330,21 +330,3 @@ instance Free Kappa where instance Free Lambda where freeWithBound' bound (MkLambda xs k m) = freeWithBound' (bound & insertFrom (k:xs)) m - - - -class Vars a where - -- | Traverse the immediate variables of an expression. - vars :: Traversal' a Name - -instance Vars Val where - vars k (ValVar x) = ValVar <$> k x - vars _ x = pure x - -instance Vars a => Vars (Prim a) where - vars k p = traverseOf (each . vars) k p - -instance Vars Exp where - vars k (ExpPrim p kap) = ExpPrim <$> vars k p <*> pure kap - vars k (ExpContinue kname xs) = ExpContinue <$> k kname <*> pure xs - vars _ e = pure e diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 33b98a0..834e68e 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -1,7 +1,7 @@ module Gyehoek.Driver (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e) where - + import Gyehoek.Options import Prelude hiding (readFile) import Options.Applicative @@ -17,7 +17,7 @@ import qualified Data.Text.Encoding as T import System.IO (Handle) import System.IO qualified as IO import Gyehoek.CPS.Convert -import Gyehoek.CPS.Lower +import Gyehoek.Stack.Lower import Gyehoek.CPS.Eval qualified as CPS import Control.Monad import Text.Pretty.Simple (pShowNoColor) @@ -35,14 +35,14 @@ import Control.Arrow ((>>>)) import Gyehoek.Prelude import Gyehoek.Jalmot import qualified Gyehoek.Sexp as S - + main :: IO () main = do opts <- execParser $ info (helper <*> parser) fullDesc runJalmotIO . runFileSystem . runGenSym . driver $ opts - + -- hPutStr :: FileSystem :> es => Handle -> Text -> Eff es () -- hPutStr h = FB.hPutStr h . T.encodeUtf8 @@ -135,10 +135,10 @@ driver opts = do & fmap writeObj & T.unwords & hPutStrLn FS.stdout - dumpOrRun opts.inspectWasm (rt_is #Wasm) - (lowerProgram cps) - inspectWasm - (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat) + -- dumpOrRun opts.inspectWasm (rt_is #Wasm) + -- (lowerProgram cps) + -- inspectWasm + -- (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat) parse_e2e :: FilePath -> IO Scm.Program parse_e2e = runJalmotIO . runFileSystem . readScm diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index 33ba9e1..063911f 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -150,14 +150,3 @@ instance DatumIso a => DataIso (V.Vector a) where instance (DatumIso a, DatumIso b) => DatumIso (a, b) where datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2 - -data Example = MkExample (List Int) Text - deriving (Generic, Show) - -instance DataIso Example where - dataIso = with \g -> - flipped snoced - >>> onHead (traversed $ sealed int) - >>> onTail (onHead $ sealed symbol) - >>> swap - >>> g diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs index 4ca3bbe..2882d0e 100644 --- a/src/Gyehoek/Sexp/Grammar/Base.hs +++ b/src/Gyehoek/Sexp/Grammar/Base.hs @@ -40,7 +40,7 @@ module Gyehoek.Sexp.Grammar.Base , lambdaLike , lambdaKeyword , kappaKeyword - , beginLike + , beginLike, headTagged2' ) where import Data.InvertibleGrammar @@ -325,6 +325,13 @@ headTagged2 -> G (Datum :- t) (b :- a :- t) headTagged2 s g1 g2 = list $ el (symProcedure s) >>> el g1 >>> el g2 +headTagged2' + :: Text + -> DatumGrammar a -> DatumGrammar b -> DatumGrammar c + -> G (Datum :- t) (List c :- b :- a :- t) +headTagged2' s g1 g2 gt = + list $ el (symProcedure s) >>> el g1 >>> el g2 >>> rest gt + ifLike -- | keyword :: Text diff --git a/src/Gyehoek/Stack/Lower.hs b/src/Gyehoek/Stack/Lower.hs new file mode 100644 index 0000000..75d7c30 --- /dev/null +++ b/src/Gyehoek/Stack/Lower.hs @@ -0,0 +1,29 @@ +module Gyehoek.Stack.Lower + ( lowerProgram + ) where + +import Gyehoek.Stack.Syntax +import Gyehoek.Wasm qualified as Wasm +import Gyehoek.Prelude +import Gyehoek.Wasm (wat, watM) + + +lowerRoutine :: Routine -> Wasm.Function +lowerRoutine rt = _ + +lowerBlock :: Block -> Wasm.Expr +lowerBlock = _ + +lowerInstr :: Instr -> Wasm.Expr +lowerInstr = \case + PopCont ktail -> [wat| + + |] + +lowerProgram :: Program -> Eff es Wasm.Module +lowerProgram p = pure [watM| + (module + ##{rs}) +|] + where + rs = p ^.. #routines . each . to lowerRoutine diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index 2c65802..18592e2 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -6,182 +6,41 @@ module Gyehoek.Wasm ( -- * syntax Module - , Idx + , Program + , Function , Expr -- ** quasiquoters - , expr - , S.sx - , S.sxs - -- * GenMod effect - , GenMod - , runGenMod - , execGenMod - , defineFunction - , defineType - , defineGlobal - , emit - , renderModule + , watM , wat - , wats - , defineFunctions - , defineTypes - , defineGlobals ) where import Data.List (List) import GHC.Generics (Generic) -import Data.Text (Text) -import Effectful -import Numeric.Natural (Natural) -import Effectful.Dispatch.Dynamic -import Effectful.State.Dynamic -import Control.Lens -import Data.Vector.Strict (Vector) -import qualified Data.Vector.Strict as V -import GHC.IsList (IsList(..)) import Language.Haskell.TH.Quote (QuasiQuoter) -import Data.Data (Data) import Gyehoek.Sexp qualified as S -import Gyehoek.Sexp (Datum, sx, (>>>)) -import Data.Foldable (traverse_) -import Data.Coerce (coerce) +import Gyehoek.Sexp (Datum, (>>>)) +import Data.Data (Data) -newtype Module = MkModule { inner :: Vector Datum } - deriving (Show, Generic) +type Program = Module +type Function = Datum +type Expr = List Datum + +newtype Module = MkModule { inner :: List Datum } + deriving (Show, Generic, Data) deriving newtype (Semigroup, Monoid) -newtype Expr = MkExpr { inner :: Vector Instr } - deriving (Show, Generic, Data, Eq) - deriving newtype (Semigroup, Monoid) - -instance IsList Expr where - type Item Expr = Instr - fromList = MkExpr . V.fromList - toList = V.toList . view #inner - -newtype Instr = MkInstr { inner :: Datum } - deriving (Show, Generic, Data, Eq) - -newtype Idx = MkIdx { inner :: Natural } - deriving (Generic, Data) - deriving newtype (Show) - - --- GenMod - --- | 'GenModState' is a 'Module' paired with the numbers of functions, --- types, globals, etc. defined in the module. -data GenModState = MkGenModState - { mod :: Module - , funcs :: Natural - , types :: Natural - , globals :: Natural - } - deriving (Show, Generic) - -instance Semigroup GenModState where - m1 <> m2 = MkGenModState - { mod = m1.mod <> m2.mod - , funcs = m1.funcs + m2.funcs - , types = m1.types + m2.types - , globals = m1.globals + m2.globals - } - -instance Monoid GenModState where - mempty = MkGenModState - { mod = mempty - , funcs = 0 - , types = 0 - , globals = 0 - } - -data GenMod :: Effect where - DefineFunction :: Datum -> GenMod m Idx - DefineType :: Datum -> GenMod m Idx - DefineGlobal :: Datum -> GenMod m Idx - Emit :: Datum -> GenMod m () - -type instance DispatchOf GenMod = Dynamic - -defineFunction :: GenMod :> es => Datum -> Eff es Idx -defineFunction = send . DefineFunction - -defineFunctions :: GenMod :> es => List Datum -> Eff es (List Idx) -defineFunctions = traverse (send . DefineFunction) - -defineType :: GenMod :> es => Datum -> Eff es Idx -defineType = send . DefineType - -defineTypes :: GenMod :> es => List Datum -> Eff es (List Idx) -defineTypes = traverse (send . DefineType) - -defineGlobal :: GenMod :> es => Datum -> Eff es Idx -defineGlobal = send . DefineGlobal - -defineGlobals :: GenMod :> es => List Datum -> Eff es (List Idx) -defineGlobals = traverse (send . DefineGlobal) - -emit :: GenMod :> es => List Datum -> Eff es () -emit = traverse_ (send . Emit) - -appendAndIncrement - :: State GenModState :> es - => LensLike' ((,) Natural) GenModState Natural - -> Datum - -> Eff es Idx -appendAndIncrement l s = - state \st -> st - & #mod . #inner <>~ V.singleton s - & l <<%~ succ - & _1 %~ MkIdx - -runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module) -runGenMod = - let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState) - in reinterpret run \cases - _ (DefineFunction s) -> appendAndIncrement #funcs s - _ (DefineType s) -> appendAndIncrement #types s - _ (DefineGlobal s) -> appendAndIncrement #globals s - _ (Emit s) -> #mod . #inner <>= V.singleton s - -execGenMod :: Eff (GenMod : es) a -> Eff es Module -execGenMod = fmap snd . runGenMod - -renderModule :: Module -> Text -renderModule (MkModule ss) = S.encodeWith' S.datumIso [sx| - (module ##{ss}) -|] - - --- DatumIso instances - -instance S.DatumIso Idx where - datumIso = S.with \idx -> - S.integer >>> S.partialOsi f g - >>> idx - where - f n | n < 0 = Left $ S.unexpected "negative" - <> S.expected "natural" - | otherwise = Right $ fromIntegral n - g = fromIntegral - -instance S.DatumIso Instr where - datumIso = S.with S.id - -instance S.DataIso Expr where - dataIso = S.dataIso @(Vector Instr) >>> S.iso coerce coerce +instance S.DatumIso Module where + datumIso = S.with \g -> + S.list (S.el (S.sym "module") >>> S.rest S.datumIso) + >>> g -- quasiquoters -expr :: QuasiQuoter -expr = S.makeSxs - [|| MkExpr . V.fromList . fmap (S.fromDatumUnsafe $ S.datumIso @Instr) ||] - wat :: QuasiQuoter -wat = S.makeSx [|| id ||] +wat = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @(List Datum)) ||] -wats :: QuasiQuoter -wats = S.makeSxs [|| id ||] +watM :: QuasiQuoter +watM = S.makeSx [|| S.fromDatumUnsafe (S.datumIso @Module) ||] diff --git a/test/Gyehoek/Test/CPS/Syntax.hs b/test/Gyehoek/Test/CPS/Syntax.hs index 5ecd917..f8a7b68 100644 --- a/test/Gyehoek/Test/CPS/Syntax.hs +++ b/test/Gyehoek/Test/CPS/Syntax.hs @@ -29,14 +29,14 @@ qq :: TestTree qq = testGroup "parser" [ testCase "lambda" do assertEqual "" (Sut.MkLambda ["x","y"] "ktail" - (Sut.ExpContinue "ktail" [Sut.ValVar "x"])) + (Sut.ExpContinue (Sut.ValLabel "ktail") [Sut.ValVar "x"])) [cps|(λ (x y ktail) (continue ktail x))|] assertEqual "" (Sut.MkLambda [] "ktail" - (Sut.ExpContinue "ktail" [Sut.ValVar "x"])) + (Sut.ExpContinue (Sut.ValLabel "ktail") [Sut.ValVar "x"])) [cps|(λ (ktail) (continue ktail x))|] , testCase "kappa" do assertEqual "" (Sut.MkKappa ["x","y"] - (Sut.ExpContinue "k123" [Sut.ValVar "x", Sut.ValVar "y"])) + (Sut.ExpContinue (Sut.ValLabel "k123") [Sut.ValVar "x", Sut.ValVar "y"])) [cps|(κ (x y) (continue k123 x y))|] , testCase "application" do assertEqual "" (Sut.ExpApply (Sut.ValVar "f")