From 2dffdf112cbf99c59f4cf2cede5542d5d46a9b41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Thu, 16 Jul 2026 12:04:33 -0600 Subject: [PATCH] qq! --- src/Gyehoek/CPS/Lower.hs | 353 +++++++++++++++++++---------------- src/Gyehoek/CPS/Syntax.hs | 1 + src/Gyehoek/Scheme/Syntax.hs | 11 -- src/Gyehoek/Sexp.hs | 83 +++++--- src/Gyehoek/Wasm.hs | 117 +++++++++++- 5 files changed, 366 insertions(+), 199 deletions(-) diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index f3264e1..4f63e5a 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ApplicativeDo #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{- HLINT ignore "Use camelCase" -} module Gyehoek.CPS.Lower (lower, lowerProgram) where @@ -14,6 +15,7 @@ import Data.Generics.Labels import Gyehoek.Scheme.Syntax qualified as Scm import Gyehoek.GenSym import Data.List.NonEmpty (NonEmpty((:|))) +import Data.List (List) import Effectful import Control.Monad.Cont qualified as Cont import Effectful.Writer.Static.Local @@ -32,9 +34,11 @@ import Data.IntMap.Strict (IntMap) import Data.String.Interpolate import Gyehoek.Wasm qualified as Wasm import Gyehoek.Wasm hiding (Expr) -import Language.Sexp.Located (pattern ParenList) +import Language.Sexp.Located qualified as SL import Debug.Pretty.Simple import Control.Monad.Fix +import Language.Sexp.Located (Sexp) +import Data.Functor.Foldable (cata) data Env = MkEnv @@ -66,185 +70,222 @@ data Runtime = MkRuntime -- | @makeSmallFixnum@ emits an expression injecting the i32 on top -- of the stack into the SCM unitype. -makeSmallFixnum :: Wasm.Expr -makeSmallFixnum = mconcat - [ ins "i32.const" [sxp @Int 1] - , ins "i32.shl" [] - , ins "ref.i31" [] - ] +-- makeSmallFixnum :: Wasm.Expr +-- makeSmallFixnum = mconcat +-- [ ins "i32.const" [sxp @Int 1] +-- , ins "i32.shl" [] +-- , ins "ref.i31" [] +-- ] -- | 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 :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr -pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat - [ ins "global.get" [sxp argArray] - , ins "i32.const" [sxp n] - , e - , ins "array.set" [sxp argArrayType] - ] +-- pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr +-- pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat +-- [ ins "global.get" [sxp argArray] +-- , ins "i32.const" [sxp n] +-- , e +-- , ins "array.set" [sxp argArrayType] +-- ] -- | Pop the nth arg from the arg-passing array onto the stack. -popArg :: Runtime -> Int -> Wasm.Expr -popArg (MkRuntime {argArrayType,argArray}) n = mconcat - [ ins "global.get" [sxp argArray] - , ins "i32.const" [sxp n] - , ins "array.get" [sxp argArrayType] - , ins "ref.as_non_null" [] - ] +-- popArg :: Runtime -> Int -> Wasm.Expr +-- popArg (MkRuntime {argArrayType,argArray}) n = mconcat +-- [ ins "global.get" [sxp argArray] +-- , ins "i32.const" [sxp n] +-- , ins "array.get" [sxp argArrayType] +-- , ins "ref.as_non_null" [] +-- ] -lowerVal :: Env -> Val -> Wasm.Expr +-- lowerVal :: Env -> Val -> Wasm.Expr -lowerVal g (ValLit l) = - case l of - LitInt n -> - ins "i32.const" [sxp n] - <> makeSmallFixnum - LitBool b -> - ins "i32.const" [sxp @Int $ if b then 1 else 0] - <> ins "ref.i31" [] - _ -> _ +-- lowerVal g (ValLit l) = +-- case l of +-- LitInt n -> +-- ins "i32.const" [sxp n] +-- <> makeSmallFixnum +-- LitBool b -> +-- ins "i32.const" [sxp @Int $ if b then 1 else 0] +-- <> ins "ref.i31" [] +-- _ -> _ -lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)] - where - l = V.elemIndex x g.vars ^?! _Just +-- lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)] +-- where +-- l = V.elemIndex x g.vars ^?! _Just -lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr +-- lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr -lower' g (Halt [v]) = pure . mconcat $ - [ pushArg g.runtime 0 (lowerVal g v) - , ins "return_call" [sxp @Int 1] - ] +-- lower' g (Halt [v]) = pure . mconcat $ +-- [ pushArg g.runtime 0 (lowerVal g v) +-- , ins "return_call" [sxp @Int 1] +-- ] -lower' g (ExpPrim p rs e) = - case p of - PrimAdd x y -> lowerBinOp "i32.add" g x y r e - PrimMul x y -> lowerBinOp "i32.mul" g x y r e - where - r = head rs +-- lower' g (ExpPrim p rs e) = +-- case p of +-- PrimAdd x y -> lowerBinOp "i32.add" g x y r e +-- PrimMul x y -> lowerBinOp "i32.mul" g x y r e +-- where +-- r = head rs -lower' g (ExpIf c t f) = do - t' <- lower' g t - f' <- lower' g f - pure $ lowerVal g c - <> Wasm.if' (Wasm.result [i32]) t' f' +-- lower' g (ExpIf c t f) = do +-- t' <- lower' g t +-- f' <- lower' g f +-- pure $ lowerVal g c +-- <> Wasm.if' (Wasm.result [i32]) t' f' -lower' g (ExpContinue k [x]) = pure . mconcat $ - [ pushArg rt 0 (lowerVal g x) - , ins "i32.const" [sxp @Int 1] -- nargs - -- get the return continuation. - , ins "global.get" [sxp rt.contStack] - , ins "global.get" [sxp rt.contStackTop] - , ins "array.get" [sxp rt.contStackType] - , ins "ref.as_non_null" [] - -- decrement contStackTop, completing the "pop." - , ins "global.get" [sxp rt.contStackTop] - , ins "i32.const" [sxp @Int (1 + l)] - , ins "i32.sub" [] - , ins "global.set" [sxp rt.contStackTop] - , ins "return_call_ref" [sxp rt.contType] - ] - where - rt = g.runtime - l = V.elemIndex k g.kvars ^?! _Just +-- lower' g (ExpContinue k [x]) = pure . mconcat $ +-- [ pushArg rt 0 (lowerVal g x) +-- , ins "i32.const" [sxp @Int 1] -- nargs +-- -- get the return continuation. +-- , ins "global.get" [sxp rt.contStack] +-- , ins "global.get" [sxp rt.contStackTop] +-- , ins "array.get" [sxp rt.contStackType] +-- , ins "ref.as_non_null" [] +-- -- decrement contStackTop, completing the "pop." +-- , ins "global.get" [sxp rt.contStackTop] +-- , ins "i32.const" [sxp @Int (1 + l)] +-- , ins "i32.sub" [] +-- , ins "global.set" [sxp rt.contStackTop] +-- , ins "return_call_ref" [sxp rt.contType] +-- ] +-- where +-- rt = g.runtime +-- l = V.elemIndex k g.kvars ^?! _Just -lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do - idx <- defun [i32] [] (replicate 5 scm) \_ -> do - let g' = g & #vars <>~ V.fromList xs - & #kvars <>~ [ktail] - m' <- lower' g' m - pure . mconcat $ - [ xs & ifoldMap \n _ -> - popArg g.runtime n <> ins "local.set" [sxp (1+n)] - , m' - ] - declareFuncref idx - let g' = g & #vars <>~ [r] - let n = length g.vars - e' <- lower' g' e - pure . mconcat $ - [ ins "ref.func" [sxp idx] - , ins "local.set" [sxp (n+1)] - , e' - ] +-- lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do +-- idx <- defun [i32] [] (replicate 5 scm) \_ -> do +-- let g' = g & #vars <>~ V.fromList xs +-- & #kvars <>~ [ktail] +-- m' <- lower' g' m +-- pure . mconcat $ +-- [ xs & ifoldMap \n _ -> +-- popArg g.runtime n <> ins "local.set" [sxp (1+n)] +-- , m' +-- ] +-- declareFuncref idx +-- let g' = g & #vars <>~ [r] +-- let n = length g.vars +-- e' <- lower' g' e +-- pure . mconcat $ +-- [ ins "ref.func" [sxp idx] +-- , ins "local.set" [sxp (n+1)] +-- , e' +-- ] -lower' g e = error . show $ e +-- lower' g e = error . show $ e -lowerBinOp - :: (GenMod :> es) - => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr -lowerBinOp op g x y r e = do - e' <- lower' g' e - pure . mconcat $ - [ lowerVal g x - , ins "ref.cast" [sxp $ ref i31] - , ins "i31.get_s" [] - , lowerVal g y - , ins "ref.cast" [sxp $ ref i31] - , ins "i31.get_s" [] - , ins op [] - , ins "ref.i31" [] - , ins "local.set" [sxp (1+n)] - , e' - ] - where - g' = g & #vars <>~ [r] - n = length (g ^. #vars) +-- lowerBinOp +-- :: (GenMod :> es) +-- => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr +-- lowerBinOp op g x y r e = do +-- e' <- lower' g' e +-- pure . mconcat $ +-- [ lowerVal g x +-- , ins "ref.cast" [sxp $ ref i31] +-- , ins "i31.get_s" [] +-- , lowerVal g y +-- , ins "ref.cast" [sxp $ ref i31] +-- , ins "i31.get_s" [] +-- , ins op [] +-- , ins "ref.i31" [] +-- , ins "local.set" [sxp (1+n)] +-- , e' +-- ] +-- where +-- g' = g & #vars <>~ [r] +-- n = length (g ^. #vars) -scm = ref eq +-- scm = ref eq -emitRuntime :: GenMod :> es => Eff es Runtime -emitRuntime = mfix \runtime -> do - heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct - [ Wasm.mut i32 ] - -- cont stack - contType <- Wasm.deftype $ Wasm.func [i32] [] - contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType) - contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0] - contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $ - ins "i32.const" [sxp @Int 128] - <> ins "array.new_default" [sxp contStackType] - -- arg array - argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq - argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $ - ins "i32.const" [sxp @Int 32] - <> ins "array.new_default" [sxp argArrayType] - -- consIdx <- Wasm.defun _ _ _ _ - result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq] - halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ -> - pure . mconcat $ - [ popArg runtime 0 - , ins "global.set" [sxp result] - ] - pure $ MkRuntime - {argArray,argArrayType - ,contStack,contStackTop,contStackType,contType - ,result,halt} - -- pure $ error "todo" +-- emitRuntime :: GenMod :> es => Eff es Runtime +-- emitRuntime = mfix \runtime -> do +-- heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct +-- [ Wasm.mut i32 ] +-- -- cont stack +-- contType <- Wasm.deftype $ Wasm.func [i32] [] +-- contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType) +-- contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0] +-- contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $ +-- ins "i32.const" [sxp @Int 128] +-- <> ins "array.new_default" [sxp contStackType] +-- -- arg array +-- argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq +-- argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $ +-- ins "i32.const" [sxp @Int 32] +-- <> ins "array.new_default" [sxp argArrayType] +-- -- consIdx <- Wasm.defun _ _ _ _ +-- result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq] +-- halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ -> +-- pure . mconcat $ +-- [ popArg runtime 0 +-- , ins "global.set" [sxp result] +-- ] +-- pure $ MkRuntime +-- {argArray,argArrayType +-- ,contStack,contStackTop,contStackType,contType +-- ,result,halt} +-- -- pure $ error "todo" -lower :: Exp -> Eff es Text -lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do - runtime <- emitRuntime - let g = MkEnv runtime mempty mempty - scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ -> - lower' g e - main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ -> - pure . mconcat $ - -- push return cont - [-- ins "ref.func" [sxp halt] - -- make call - ins "i32.const" [sxp @Int 0] - , ins "call" [sxp scm_entry] - , ins "global.get" [sxp runtime.result] - , ins "ref.as_non_null" [] - ] - Wasm.export "main" "func" main +-- lower :: Exp -> Eff es Text +-- lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do +-- runtime <- emitRuntime +-- let g = MkEnv runtime mempty mempty +-- scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ -> +-- lower' g e +-- main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ -> +-- pure . mconcat $ +-- -- push return cont +-- [-- ins "ref.func" [sxp halt] +-- -- make call +-- ins "i32.const" [sxp @Int 0] +-- , ins "call" [sxp scm_entry] +-- , ins "global.get" [sxp runtime.result] +-- , ins "ref.as_non_null" [] +-- ] +-- Wasm.export "main" "func" main -lowerProgram :: Program -> Eff es Text -lowerProgram (MkProgram e) = lower e +-- lowerProgram :: Program -> Eff es Text +-- lowerProgram (MkProgram e) = lower e + +lower = _ +lowerProgram = _ + +antiquote_example = + let + metavar :: Integer + metavar = 123 + + e1 :: Wasm.Expr + e1 = [expr| + (func $blah (result i32) + (i32.const #{metavar})) + |] + + e2 :: Wasm.Expr + e2 = [expr| + (func $blah (result i32) + (i32.const 123)) + |] + in (metavar,e1,e2,e1==e2) + +antiquote_splicing_example = + let + metavars :: List Sexp + metavars = [sxs'|i32 i64 f64|] + + e1 :: Wasm.Expr + e1 = [expr| + (func $blah (param ##{metavars})) + |] + + e2 :: Wasm.Expr + e2 = [expr| + (func $blah (param i32 i64 f64)) + |] + in (metavars, e1, e2, e1 == e2) diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 52380ee..0d8fa43 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} module Gyehoek.CPS.Syntax ( Val(..) , Kappa(..) diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 61c821f..7b05e86 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -23,7 +23,6 @@ module Gyehoek.Scheme.Syntax , qexp , qprog , subst - , freeVariables ) where @@ -254,13 +253,3 @@ subst f = \e -> cata go e mempty where go (ExpLetF _ _) _ = error "todo lol" go (ExpLambdaF bs e) bound = e $ insertFrom bs bound go e bound = embed $ fmap ($ bound) e - --- | Unlawful! -freeVariables :: Traversal Exp Exp Name Exp -freeVariables k = \e -> cataA go e mempty where - go (ExpVarF x) bound - | not (x `HS.member` bound) = k x - | otherwise = pure $ ExpVar x - go (ExpLetF _ _) _ = error "todo lol" - go (ExpLambdaF bs e) bound = e $ insertFrom bs bound - go e bound = embed <$> traverse ($ bound) e diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index 91ca7fb..ba85dee 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -34,11 +34,16 @@ module Gyehoek.Sexp , sxs , makeSx , makeSxs + , toSexp + , fromSexp + , stripLocation + , sx' + , sxs' ) where import Data.Text (Text) -import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty) +import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp) import Language.SexpGrammar qualified as Sexp import Language.Sexp qualified as S import Language.SexpGrammar.Generic @@ -67,6 +72,9 @@ import qualified Data.Text as T import qualified Control.Category import Data.Data (Data, Typeable, cast) import Language.Haskell.TH.Syntax (lift, Lift) +import GHC.IsList (fromList) +import Data.Functor.Foldable (cata) +import Data.Functor.Classes (Show1(..)) sexp :: SexpIso a => Iso' a Text @@ -95,21 +103,21 @@ encodePrettyWith g = parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a) parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8 - where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso) + where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso) parseSexp :: SexpIso a => FilePath -> Text -> Either String a parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8 - where marshal = join . traverseOf _Right (fromSexp sexpIso) + where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso) parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a) parseSexpsWithPos g pos = marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8 - where marshal = join . traverseOf (_Right . each) (fromSexp g) + where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g) parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a parseSexpWithPos g pos = marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8 - where marshal = join . traverseOf _Right (fromSexp g) + where marshal = join . traverseOf _Right (Sexp.fromSexp g) nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t) nonEmptyGrammar = IGB.Iso @@ -231,21 +239,15 @@ getPos = do Loc {loc_filename,loc_start} <- location pure $ SL.Position loc_filename (fst loc_start) (snd loc_start) -makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter -makeSxs g f = QuasiQuoter - { quoteExp = \str -> do - pos <- getPos - case parseSexpsWithPos g pos (T.pack str) of - Left e -> fail e - Right xs -> dataToExpQ (const Nothing) (f xs) - , quotePat = undefined - , quoteType = undefined - , quoteDec = undefined - } +fromSexp :: SexpIso a => Sexp -> a +fromSexp = either error id . Sexp.fromSexp sexpIso toSexp :: SexpIso a => a -> Sexp toSexp = either error id . Sexp.toSexp sexpIso +toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp +toSexps = foldMap \x -> [toSexp x] + pattern Unquote x = SL.Modified Hash (SL.BraceList [SL.Symbol x]) pattern UnquoteSplicing x = @@ -262,12 +264,17 @@ instance Each Sexp Sexp Sexp Sexp where each k (SL.BraceList xs) = SL.BraceList <$> traverse k xs each _ e@(SL.Atom _; SL.Modified _ _) = pure e +stripLocation :: Sexp -> Sexp +stripLocation = cata \case + SL.Compose (a SL.:< e) -> + SL.Fix . SL.Compose $ SL.dummyPos SL.:< e + metaSexp :: Sexp.Sexp -> Maybe ExpQ metaSexp (Unquote x) = - Just [| toSexp $(varE (mkName (T.unpack x))) |] + Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |] metaSexp (SL.ParenList xs) | (_:_) <- xs ^.. each . _UnquoteSplicing - = Just [| SL.ParenList (mconcat $(listE spans)) |] + = Just [| stripLocation . toSexp $ SL.ParenList (mconcat $(listE spans)) |] where spans = xs & groupBy \cases @@ -275,8 +282,9 @@ metaSexp (SL.ParenList xs) _ (UnquoteSplicing _) -> False _ _ -> True & fmap \case - [UnquoteSplicing x] -> varE (mkName (T.unpack x)) - x -> lift x + [UnquoteSplicing x] -> + [| stripLocation <$> toSexps $(varE (mkName (T.unpack x))) |] + x -> [| stripLocation <$> x |] metaSexp _ = Nothing -- 뻘짓뻘짓뻘짓뻘짓뻘짓 @@ -287,10 +295,10 @@ lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp lift1 = liftLift lift instance Lift1 f => Lift (SL.Fix f) where - lift (SL.Fix inner) = appE [|Fix|] (lift1 inner) + lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner) instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where - liftLift l (SL.Compose fga) = [|Compose $(liftLift (liftLift l) fga)|] + liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|] instance Lift a => Lift1 (SL.LocatedBy a) where liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|] @@ -314,17 +322,36 @@ deriving instance Lift SL.Prefix extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r extQ f g a = maybe (f a) g (cast a) -makeSx :: Data a => SexpGrammar a -> QuasiQuoter -makeSx g = QuasiQuoter +makeSxs + :: Data b + => (List a -> b) -> SexpGrammar a -> QuasiQuoter +makeSxs f g = QuasiQuoter { quoteExp = \str -> do pos <- getPos - case parseSexpWithPos g pos (T.pack str) of + case parseSexpsWithPos g pos (T.pack str) of Left e -> fail e - Right x -> dataToExpQ (const Nothing `extQ` metaSexp) x + Right xs -> dataToExpQ (const Nothing `extQ` metaSexp) (f xs) , quotePat = undefined , quoteType = undefined , quoteDec = undefined } -sxs = makeSxs (sexpIso @Sexp) id -sx = makeSx (sexpIso @Sexp) +makeSx + :: (Data a, Data r) + => (a -> r) -> SexpGrammar a -> QuasiQuoter +makeSx f g = QuasiQuoter + { quoteExp = \str -> do + pos <- getPos + case parseSexpWithPos g pos (T.pack str) of + Left e -> fail e + Right x -> dataToExpQ (const Nothing `extQ` metaSexp) (f x) + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +sxs = makeSxs id (sexpIso @Sexp) +sx = makeSx id (sexpIso @Sexp) + +sxs' = makeSxs (fmap stripLocation) (sexpIso @Sexp) +sx' = makeSx stripLocation (sexpIso @Sexp) diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index 3b6d084..6bf6400 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -11,7 +11,25 @@ {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE DerivingVia #-} module Gyehoek.Wasm - ( Module + ( + -- * syntax + Module + , Idx + , Expr + -- ** quasiquoters + , expr + , Gyehoek.Sexp.sx + , Gyehoek.Sexp.sxs + , Gyehoek.Sexp.sx' + , Gyehoek.Sexp.sxs' + -- * GenMod effect + , GenMod + , runGenMod + , execGenMod + , defineFunction + , defineType + , defineGlobal + , declare ) where @@ -45,18 +63,29 @@ import GHC.IsList (IsList(..)) import Data.Coerce (coerce) import qualified Control.Category import Data.Functor (void) +import Language.Haskell.TH.Quote (QuasiQuoter) +import Data.Data (Data) +import Data.Functor.Foldable (cata) newtype Module = MkModule { inner :: Vector Sexp } deriving (Show, Generic) deriving newtype (Semigroup, Monoid) -newtype Expr = MkExpr { inner :: Vector Sexp } - deriving (Show, Generic) +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 :: Sexp } + deriving (Show, Generic, Data, Eq) + newtype Idx = MkIdx { inner :: Natural } - deriving (Generic) + deriving (Generic, Data) deriving newtype (Show) @@ -68,9 +97,89 @@ 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 :: Sexp -> GenMod m Idx DefineType :: Sexp -> GenMod m Idx + DefineGlobal :: Sexp -> GenMod m Idx + Declare :: Sexp -> GenMod m () + +type instance DispatchOf GenMod = Dynamic + +defineFunction :: GenMod :> es => Sexp -> Eff es Idx +defineFunction = send . DefineFunction + +defineType :: GenMod :> es => Sexp -> Eff es Idx +defineType = send . DefineType + +defineGlobal :: GenMod :> es => Sexp -> Eff es Idx +defineGlobal = send . DefineGlobal + +declare :: GenMod :> es => Sexp -> Eff es () +declare = send . Declare + +appendAndIncrement + :: State GenModState :> es + => LensLike' ((,) _) GenModState Natural + -> Sexp + -> 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 + _ (Declare s) -> #mod . #inner <>= V.singleton s + +execGenMod :: Eff (GenMod : es) a -> Eff es Module +execGenMod = fmap snd . runGenMod + + +-- SexpIso instances + +instance SexpIso Idx where + sexpIso = with \idx -> + Sexp.integer >>> Sexp.partialOsi f g + >>> idx + where + f n | n < 0 = Left $ Sexp.unexpected "negative" + <> Sexp.expected "natural" + | otherwise = Right $ fromIntegral n + g = fromIntegral + +instance SexpIso Instr where + sexpIso = with id + + +-- quasiquoters + +expr :: QuasiQuoter +expr = Gyehoek.Sexp.makeSxs + (MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation)) + (sexpIso @Instr)