From 7c0642655f20e2a6b635598a675a0ad83b46457b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sat, 22 Aug 2026 23:29:46 -0600 Subject: [PATCH] tests pass! --- golden/read/meta-expression/read | 3 +- golden/read/meta-splice-expression/read | 3 +- golden/read/meta-splice-variable/read | 3 +- golden/read/meta-variable/read | 3 +- gyehoek.cabal | 1 - src/Gyehoek/CPS/Lower.hs | 31 +- src/Gyehoek/CPS/Syntax.hs | 183 +++++----- src/Gyehoek/Driver.hs | 25 +- src/Gyehoek/Jalmot.hs | 7 + src/Gyehoek/Scheme/Syntax.hs | 36 +- src/Gyehoek/Sexp.hs | 454 +----------------------- src/Gyehoek/Sexp/Grammar.hs | 28 ++ src/Gyehoek/Sexp/Grammar/Base.hs | 27 +- src/Gyehoek/Sexp/QQ.hs | 5 +- src/Gyehoek/Wasm.hs | 73 ++-- test/Gyehoek/Test/Sexp.hs | 49 --- 16 files changed, 211 insertions(+), 720 deletions(-) delete mode 100644 test/Gyehoek/Test/Sexp.hs diff --git a/golden/read/meta-expression/read b/golden/read/meta-expression/read index ba6dbf1..685b9d2 100644 --- a/golden/read/meta-expression/read +++ b/golden/read/meta-expression/read @@ -7,6 +7,5 @@ , sourceColumn = Pos 1 } ) - } :< SimpleF - ( SimpleMeta "aHaskellVariable + abc * 2" ) + } :< MetaF "aHaskellVariable + abc * 2" ] \ No newline at end of file diff --git a/golden/read/meta-splice-expression/read b/golden/read/meta-splice-expression/read index a6cdbd6..e5de84d 100644 --- a/golden/read/meta-splice-expression/read +++ b/golden/read/meta-splice-expression/read @@ -7,6 +7,5 @@ , sourceColumn = Pos 1 } ) - } :< SimpleF - ( SimpleMetaSplice "takeWhile (\x -> even x) aHaskellList" ) + } :< MetaSpliceF "takeWhile (\x -> even x) aHaskellList" ] \ No newline at end of file diff --git a/golden/read/meta-splice-variable/read b/golden/read/meta-splice-variable/read index d55be83..d8428ec 100644 --- a/golden/read/meta-splice-variable/read +++ b/golden/read/meta-splice-variable/read @@ -7,6 +7,5 @@ , sourceColumn = Pos 1 } ) - } :< SimpleF - ( SimpleMetaSplice "aHaskellList" ) + } :< MetaSpliceF "aHaskellList" ] \ No newline at end of file diff --git a/golden/read/meta-variable/read b/golden/read/meta-variable/read index cee6314..4ec3604 100644 --- a/golden/read/meta-variable/read +++ b/golden/read/meta-variable/read @@ -7,6 +7,5 @@ , sourceColumn = Pos 1 } ) - } :< SimpleF - ( SimpleMeta "aHaskellVariable" ) + } :< MetaF "aHaskellVariable" ] \ No newline at end of file diff --git a/gyehoek.cabal b/gyehoek.cabal index ccb2fa4..133a4aa 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -131,7 +131,6 @@ test-suite test Gyehoek.Test.CPS.Syntax Gyehoek.Test.Golden Gyehoek.Test.Scheme.Syntax - Gyehoek.Test.Sexp Gyehoek.Test.Sexp.Print Gyehoek.Test.Sexp.QQ Gyehoek.Test.Sexp.Read diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 78a7894..a9c7a91 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -17,12 +17,11 @@ import Numeric.Natural import qualified Data.Vector.Strict as V import Gyehoek.Wasm qualified as Wasm import Gyehoek.Wasm hiding (Expr) -import Language.Sexp.Located qualified as SL import Control.Monad.Fix -import qualified Gyehoek.Sexp import Data.Text qualified as T import Data.Foldable (fold) -import Gyehoek.Sexp (encodeOrShow) +import Gyehoek.Jalmot +import Gyehoek.Sexp qualified as S import Gyehoek.Prelude @@ -53,8 +52,8 @@ makeSmallFixnum = [expr| ref.i31 |] -getArgRegister :: Natural -> SL.Sexp -getArgRegister n = SL.Symbol [i|$arg#{n}|] +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 @@ -110,11 +109,9 @@ lower' g (Halt [v]) = do |] lower' g e@(ExpPrim p k) = - ([expr|(@gyehoek :origin #{origin})|]<>) - <$> case p of + case p of PrimAdd x y -> lowerBinOp "i32.add" g x y k PrimMul x y -> lowerBinOp "i32.mul" g x y k - where origin = encodeOrShow @_ @Text e lower' g (ExpIf c t f) = do c' <- lowerVal g c @@ -131,9 +128,7 @@ lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do idx <- lowerKappa g kap let g' = g & #kvars <>~ [r] e' <- lower' g' e - let origin = encodeOrShow @_ @Text e pure [expr| - (@gyehoek :origin #{origin}) (@gyehoek "push cont" :idx #{idx}) (array.set $cont-stack-type (global.get $cont-stack) @@ -165,9 +160,7 @@ lower' g e@(ExpApply f xs ktail) = do let l = succ $ V.elemIndex ktail g.kvars ^?! _Just args <- fold <$> itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs - let origin = encodeOrShow @_ @Text e pure [expr| - (@gyehoek :origin #{origin}) (@gyehoek "load args") ##{args} (i32.const 1) @@ -184,9 +177,7 @@ lower' g e@(ExpContinue k xs) = do let nargs = length xs args <- fold <$> itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs - let origin = encodeOrShow @_ @Text e pure [expr| - (@gyehoek :origin #{origin}) (@gyehoek "push args") ##{args} (@gyehoek "nargs") @@ -205,18 +196,14 @@ lower' g e@(ExpContinue k xs) = do where l = succ $ V.elemIndex k g.kvars ^?! _Just -lower' g e = error $ case Gyehoek.Sexp.encode e of - Left _ -> show e - Right x -> T.unpack x +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 - let origin = encodeOrShow @_ @Text e idx <- Wasm.defineFunction [wat| (func (param i32) - (@gyehoek :origin #{origin}) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) ##{m'}) |] @@ -228,10 +215,8 @@ lowerLambda g e@(MkLambda xs ktail m) = do let g' = g & #vars .~ V.fromList xs & #kvars <>~ [ktail] m' <- lower' g' m - let origin = encodeOrShow @_ @Text e idx <- Wasm.defineFunction [wat| (func (param i32) - (@gyehoek :origin #{origin}) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) ##{m'}) |] @@ -242,7 +227,7 @@ lowerBinOp :: (GenMod :> es) => Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr lowerBinOp op g x y (MkKappa [r] e) = do - let op' = SL.Symbol op + let op' = S.Symbol op let g' = g & #vars <>~ [r] let n = succ $ length (g ^. #vars) let reg = getArgRegister . fromIntegral $ n @@ -325,10 +310,8 @@ lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do runtime <- emitRuntime let g = MkEnv mempty mempty e' <- lower' g e - let origin = encodeOrShow @_ @Text e Wasm.defineFunction [wat| (func $scm-entry (param i32) - (@gyehoek :origin #{origin}) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) ##{e'}) |] diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index b5032c0..d2bc692 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -40,23 +40,18 @@ module Gyehoek.CPS.Syntax ) where -import Language.SexpGrammar qualified as S -import Gyehoek.Sexp qualified import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..)) -import Language.SexpGrammar.Generic +import Gyehoek.Sexp qualified as S import Control.Category import Prelude hiding ((.), id) -import Language.Haskell.TH.Quote (QuasiQuoter) -import Language.Sexp.Located (Sexp) -import qualified Data.InvertibleGrammar.Base as IG -import Data.InvertibleGrammar.Base (type (:-)((:-))) import qualified Data.HashSet as HS import Data.Monoid (Endo) import Data.Functor.Foldable.TH -import qualified Gyehoek.Sexp as GS -import qualified Language.Sexp.Located as SL import Data.Data.Lens (uniplate) import Gyehoek.Prelude hiding (op) +import Gyehoek.Sexp (Datum) +import Gyehoek.Sexp (G, (:-)(..)) +import qualified Data.InvertibleGrammar.Base as IG -- Data types @@ -131,13 +126,7 @@ data Program = MkProgram deriving (Show, Generic, Data) makePrisms ''Kappa --- makeLenses ''Kappa makePrisms ''Exp --- makeLenses ''Exp --- makeFieldsNoPrefix ''Exp --- makeFieldsNoPrefix ''Kappa --- makeLensesWith abbreviatedFields ''Exp --- makeLensesFor [("binders", "_binders"), ("body", "_body")] ''Exp makeFieldsId ''Exp makeFieldsId ''Kappa makeFieldsId ''Lambda @@ -157,69 +146,61 @@ _AbsLambda' = prism' (\case AbsLambda' bs ktail e -> Just (bs,ktail,e) _ -> Nothing) -instance Plated Exp where - plate = uniplate - -- plate k = \case - -- ExpPrim p kap -> ExpPrim p <$> body k kap - -- ExpLetRec bs e -> ExpLetRec <$> (each . _2 . body) k bs <*> k e - -- ExpContinue c xs -> pure $ ExpContinue c xs - -- ExpIf c t f -> ExpIf c <$> k t <*> k f - -- ExpApply f xs ktail -> pure $ ExpApply f xs ktail +instance Plated Exp where plate = uniplate --- SexpIso instances +-- DatumIso instances -instance S.SexpIso Val where - sexpIso = match - $ With (\imm -> imm . S.sexpIso) - $ With (\var -> var . S.sexpIso) - $ End +instance S.DatumIso Val where + datumIso = S.match + $ S.With (\imm -> imm . S.datumIso) + $ S.With (\var -> var . S.datumIso) + $ S.End -instance S.SexpIso Obj where - sexpIso = match - $ With (\imm -> imm . S.sexpIso) - $ With (\hob -> hob . S.sexpIso) - $ End +instance S.DatumIso Obj where + datumIso = S.match + $ S.With (\imm -> imm . S.datumIso) + $ S.With (\hob -> hob . S.datumIso) + $ S.End -instance S.SexpIso Imm where - sexpIso = match - $ With (. S.int) - $ With (. GS.schemeBool) - $ With (. labelName) - $ End +instance S.DatumIso Imm where + datumIso = S.match + $ S.With (. S.int) + $ S.With (. S.datumIso) + $ S.With (. labelName) + $ S.End -labelName :: S.SexpGrammar Name +labelName :: S.DatumGrammar Name labelName = S.coproduct - [ S.sexpIso @Name >>> Gyehoek.Sexp.prismIso + [ S.datumIso @Name >>> S.prismIso (S.expected "label") (prefixed @Name "$") - , S.list $ S.el (S.sym "$") >>> S.el (S.sexpIso @Name) + , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name) ] -instance S.SexpIso Hob where - sexpIso = match - $ With (. closure) - $ End +instance S.DatumIso Hob where + datumIso = S.match + $ S.With (. closure) + $ S.End where -- closures can be printed, but not parsed. - closure :: S.Grammar S.Position (Sexp :- t) (List Obj :- Name :- t) + closure :: G (Datum :- t) (List Obj :- Name :- t) closure = IG.Flip $ IG.PartialIso - (\(env:-code:-t) -> SL.Modified SL.Hash [GS.sx|(#{code} ##{env})|] :- t) + (\(env:-code:-t) -> [S.sx|( #{code} ##{env})|] :- t) (const . Left $ mempty) -instance S.SexpIso Lambda where - sexpIso = match - $ With (. lambda) - $ End +instance S.DatumIso Lambda where + datumIso = S.match + $ S.With (. lambda) + $ S.End where lambda = S.list $ - S.el Gyehoek.Sexp.lambdaKeyword + S.el S.lambdaKeyword >>> S.el binders - >>> S.el S.sexpIso - binders :: forall t. - IG.Grammar S.Position (Sexp :- t) (Name :- List Name :- t) + >>> S.el S.datumIso + binders :: forall t. G (Datum :- t) (Name :- List Name :- t) binders = S.list $ - S.rest (S.sexpIso @Name) + S.rest (S.datumIso @Name) >>> S.onTail (S.flipped $ IG.PartialIso (\(ktail:-args:-t) -> (args ++ [ktail]) :- t) (\(args:-t) -> case args ^? _Snoc of @@ -227,43 +208,43 @@ instance S.SexpIso Lambda where Nothing -> Left $ S.expected "cont param") ) -instance S.SexpIso Kappa where - sexpIso = match - $ With (. kappa) - $ End +instance S.DatumIso Kappa where + datumIso = S.match + $ S.With (. kappa) + $ S.End where kappa = S.list $ - S.el Gyehoek.Sexp.kappaKeyword - >>> S.el (S.list $ S.rest S.sexpIso) - >>> S.el S.sexpIso + S.el S.kappaKeyword + >>> S.el (S.list $ S.rest S.datumIso) + >>> S.el S.datumIso -instance S.SexpIso Abs where - sexpIso = match - $ With (\lambda -> lambda . S.sexpIso) - $ With (\kappa -> kappa . S.sexpIso) - $ End +instance S.DatumIso Abs where + datumIso = S.match + $ S.With (\lambda -> lambda . S.datumIso) + $ S.With (\kappa -> kappa . S.datumIso) + $ S.End -instance S.SexpIso Exp where - sexpIso = match - $ With (. prim) - $ With (. letrec) - $ With (. continue) - $ With (. if_) - $ With (. app) - $ End +instance S.DatumIso Exp where + datumIso = S.match + $ S.With (. prim) + $ S.With (. letrec) + $ S.With (. continue) + $ S.With (. if_) + $ S.With (. app) + $ S.End where continue = S.list $ S.el (S.sym "continue") - >>> S.el S.sexpIso - >>> S.rest S.sexpIso - letrec = Gyehoek.Sexp.let_ "letrec" S.sexpIso S.sexpIso S.sexpIso - if_ = S.list $ S.el (S.sym "if") - >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso + >>> S.el S.datumIso + >>> S.rest S.datumIso + letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso + if_ = S.ifLike "if" + S.datumIso S.datumIso S.datumIso app :: forall t. - IG.Grammar S.Position (Sexp :- t) (Name :- ([Val] :- (Val :- t))) - app = S.list $ S.el (S.sexpIso @Val) - -- >>> S.flipped Gyehoek.Sexp.nonEmptyGrammar - >>> S.rest (S.sexpIso @Val) + G (Datum :- t) (Name :- ([Val] :- (Val :- t))) + app = S.list $ S.el (S.datumIso @Val) + -- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar + >>> S.rest (S.datumIso @Val) -- >>> _ >>> S.onTail (S.flipped $ IG.PartialIso (\(karg :- args :- op :- t) -> @@ -273,31 +254,29 @@ instance S.SexpIso Exp where Right $ karg:- args :- op :- t _ -> Left $ S.expected "continuation arg" )) - where - _ = S.flipped $ Gyehoek.Sexp.nonEmptyGrammar @S.Position @Val prim = S.list $ S.el (S.sym "prim") - >>> S.el (primSexpIso id (S.sexpIso @Val)) - >>> S.el S.sexpIso + >>> S.el (primDatumIso id (S.datumIso @Val)) + >>> S.el S.datumIso -instance S.SexpIso Program where - sexpIso = with \prog -> S.sexpIso @Exp >>> prog +instance S.DatumIso Program where + datumIso = S.with \prog -> S.datumIso @Exp >>> prog -- quasiquoters class Data a => CPS a where - toCPS :: Sexp -> a + toCPS :: Datum -> a -instance CPS Exp where toCPS = Gyehoek.Sexp.fromSexp -instance CPS Val where toCPS = Gyehoek.Sexp.fromSexp -instance CPS Kappa where toCPS = Gyehoek.Sexp.fromSexp -instance CPS Lambda where toCPS = Gyehoek.Sexp.fromSexp -instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp -instance CPS Program where toCPS = Gyehoek.Sexp.fromSexp +instance CPS Exp where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso -cps :: QuasiQuoter -cps = Gyehoek.Sexp.makeSx' [| toCPS |] +cps :: S.QuasiQuoter +cps = S.makeSx' [| toCPS |] diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index bb2e8a3..d9c3ebe 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -33,12 +33,14 @@ import Gyehoek.CPS.Close (closeProgram) import Control.Lens.Extras (is) 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 - runEff . runFileSystem . runGenSym . driver $ opts + runJalmotIO . runFileSystem . runGenSym . driver $ opts @@ -65,11 +67,12 @@ fileName :: FilePath -> FilePath fileName "-" = "" fileName e = e -readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program +readScm + :: forall es. (Jalmot :> es, FileSystem :> es) + => FilePath -> Eff es Scm.Program readScm f = withFile f FS.ReadMode $ \h -> - Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h - >>= either error (pure . Scm.MkProgram) + S.decodeDataWith @es S.dataIso =<< hGetContents h inspectWasm :: IOE :> es => Text -> Eff es () inspectWasm wat = do @@ -107,7 +110,7 @@ dumpOrRun dump run acquire do_dump do_run = when run (do_run x) driver - :: (GenSym :> es, FileSystem :> es, IOE :> es) + :: (GenSym :> es, FileSystem :> es, Jalmot :> es, IOE :> es) => Options -> Eff es () driver opts = do scm <- readScm opts.sourceFile @@ -115,10 +118,10 @@ driver opts = do hPutStrLn FS.stdout . view strict . pShowNoColor $ scm cps <- convertProgram scm when opts.dumpCPS do - hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right + hPutStrLn FS.stdout =<< S.encodeWith S.datumIso cps closedCps <- closeProgram cps when opts.dumpClosed do - hPutStrLn FS.stdout $ Sexp.encodePretty closedCps ^?! _Right + hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps let rt_is p = is (_Just . p) opts.runtime dumpOrRun opts.dumpStackified (rt_is #Stackify) (stackifyProgram closedCps) @@ -138,18 +141,18 @@ driver opts = do (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat) parse_e2e :: FilePath -> IO Scm.Program -parse_e2e = runEff . runFileSystem . readScm +parse_e2e = runJalmotIO . runFileSystem . readScm convert_e2e :: FilePath -> IO CPS.Program -convert_e2e = runEff . runFileSystem . runGenSym +convert_e2e = runJalmotIO . runFileSystem . runGenSym . (closeProgram <=< convertProgram <=< readScm) lower_e2e :: FilePath -> IO Text lower_e2e = - runEff . runFileSystem . runGenSym + runJalmotIO . runFileSystem . runGenSym . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm) eval_e2e :: FilePath -> IO (List Obj) -eval_e2e fp = runEff . runFileSystem . runGenSym $ do +eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp pure . eval $ stk diff --git a/src/Gyehoek/Jalmot.hs b/src/Gyehoek/Jalmot.hs index f6acb66..fe946d6 100644 --- a/src/Gyehoek/Jalmot.hs +++ b/src/Gyehoek/Jalmot.hs @@ -7,6 +7,7 @@ module Gyehoek.Jalmot , runJalmot , runJalmotIO , runJalmotIOE + , runJalmotUnsafe ) where @@ -19,6 +20,7 @@ import qualified Data.InvertibleGrammar as Grammar import Gyehoek.Sexp.Syntax (Ann) import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty) import Prettyprinter.Render.String (renderString) +import Control.Exception.Base (throw) deriving instance Show p => Show (Grammar.ErrorMessage p) @@ -46,6 +48,11 @@ runJalmotIOE eff = runJalmotIO :: Eff '[Jalmot, IOE] a -> IO a runJalmotIO = runEff . runJalmotIOE +runJalmotUnsafe :: Eff '[Jalmot] a -> a +runJalmotUnsafe m = case runPureEff . runJalmot $ m of + Left (cs,e) -> throw $ MkAJalmotCS cs e + Right x -> x + instance Exception AJalmot where displayException = \case ReaderError eb -> errorBundlePretty eb diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 8f3da10..f63ec5c 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -24,12 +24,9 @@ module Gyehoek.Scheme.Syntax , subst , getName , scm - , readExp - , readProgram , free' , freeWithBound' , freeO - , encodeProgram ) where @@ -54,7 +51,7 @@ import qualified Effectful.FileSystem.IO.ByteString as FB import qualified Data.Set.Ordered as O import Gyehoek.Sexp.Grammar qualified as Sexp import Gyehoek.Sexp.Grammar qualified as S -import Gyehoek.Sexp.Grammar (DatumIso) +import Gyehoek.Sexp.Grammar (DatumIso, DataIso) import Gyehoek.Prelude @@ -125,7 +122,7 @@ data CommandOrDef deriving stock (Show, Generic, Data) deriving anyclass (NFData) -data Program = MkProgram +newtype Program = MkProgram { commandsAndDefs :: List CommandOrDef } deriving stock (Show, Generic, Data) @@ -221,11 +218,14 @@ instance DatumIso CommandOrDef where $ S.With (\_Begin -> _Begin . S.beginLike "begin" S.datumIso) $ S.End +instance DataIso Program where + dataIso = S.dataIso @(List CommandOrDef) >>> S.iso coerce coerce + -- utilities scm :: QuasiQuoter -scm = GS.makeSx [|| GS.fromSexp @Exp ||] +scm = GS.makeSx [|| S.fromDatumUnsafe S.datumIso ||] freeWithBound' :: Foldable f => f Name -> Exp -> List Name freeWithBound' bound = filter (`elem` bound) . free' @@ -280,27 +280,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 - - - -fileName :: FilePath -> FilePath -fileName "-" = "" -fileName e = e - -hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text -hGetContents h = T.decodeUtf8 <$> FB.hGetContents h - -readProgram :: IOE :> es => FilePath -> Eff es Program -readProgram fp = runFileSystem $ - FS.withFile fp FS.ReadMode $ \h -> - GS.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h - >>= either error (pure . MkProgram) - -readExp :: IOE :> es => FilePath -> Eff es Exp -readExp fp = readProgram fp <&> (^?! #commandsAndDefs . _head . #Command) - -encodeProgram :: Program -> Text -encodeProgram p = p.commandsAndDefs - & fmap ((^?! _Right) . GS.encodePretty) - & intersperse "\n\n" - & mconcat diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index dcf2590..7428d90 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -1,453 +1,11 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE OrPatterns #-} module Gyehoek.Sexp - ( let_ - , sexp - , nonempty - , nonEmptyGrammar - , encode - , decode - , parseSexps - , prefixSugar - , todo - , isoIso - , encodeWith - , decodeWith - , kappa - , lambda - , kappaKeyword - , lambdaKeyword - , encodePrettyWith - , encodePretty - , SpliceSexp(..) - , Position(..) - , parseSexpsWithPos - , parseSexpWithPos - , parseSexp - , sx - , sxs - , makeSx - , makeSxs - , makeSx' - , toSexp - , fromSexp - , fromSexp' - , stripLocation - , format - , equivalent - , encodeOrShow - , readSxs - , prismIso - , schemeBool - , headTagged1' - , headTagged1 - , headTagged2 + ( module Gyehoek.Sexp.QQ + , module Gyehoek.Sexp.Syntax + , module Gyehoek.Sexp.Grammar ) where -import Data.Text (Text) -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 Data.InvertibleGrammar.Base qualified as IGB -import Data.InvertibleGrammar qualified as IG -import Data.InvertibleGrammar.Base ((:-)((:-))) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.List (List, groupBy) -import Data.Text.Encoding -import GHC.Generics (Generic) -import Control.Lens hiding (para) -import Control.Monad (join) -import qualified Language.Sexp.Located as SL -import Data.Void (absurd) -import Language.Haskell.TH.Quote -import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, Q, Code, unTypeCode) -import qualified Data.Text as T -import qualified Control.Category -import Data.Data (Data (..), Typeable, cast) -import Language.Haskell.TH.Syntax (lift, Lift, liftData) -import Data.Functor.Foldable (cata) -import Data.Vector (Vector) -import Numeric.Natural (Natural) -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 +import Gyehoek.Sexp.QQ +import Gyehoek.Sexp.Syntax +import Gyehoek.Sexp.Grammar - -sexp :: SexpIso a => Iso' a Text -sexp = iso - (either error id . encode) - (either error id . decode) - -format :: Sexp -> Text -format = decodeUtf8 . view strict . SL.format - -encode :: SexpIso a => a -> Either String Text -encode = encodeWith sexpIso - -decode :: SexpIso a => Text -> Either String a -decode = decodeWith sexpIso - -encodeWith :: SexpGrammar a -> a -> Either String Text -encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g - -encodePretty :: SexpIso a => a -> Either String Text -encodePretty = encodePrettyWith sexpIso - -decodeWith :: SexpGrammar a -> Text -> Either String a -decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8 - -encodePrettyWith :: SexpGrammar a -> a -> Either String Text -encodePrettyWith g = - (_Right %~ decodeUtf8 . view strict) . Sexp.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) (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) - -readSexpWithPos :: Position -> Text -> Either String Sexp -readSexpWithPos pos = SL.parseSexpWithPos pos . view lazy . encodeUtf8 - -readSexpsWithPos :: Position -> Text -> Either String (List Sexp) -readSexpsWithPos pos = SL.parseSexpsWithPos pos . view lazy . encodeUtf8 - -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) (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 (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) - (\(xs :- x :- t) -> (x :| reverse xs) :- t) - -nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a) -nonempty a = - list (el a >>> rest a) >>> - IG.flipped nonEmptyGrammar - -let_ - :: Text - -> (forall t. Grammar Position (Sexp :- t) (a :- t)) - -> (forall t. Grammar Position (Sexp :- t) (b :- t)) - -> Grammar Position (Sexp :- (List (a, b) :- t1)) t2 - -> Grammar Position (Sexp :- t1) t2 -let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e) - where - -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _) - bindings = list $ rest binding - binding :: Grammar Position (Sexp :- t) ((_, _) :- t) - binding = list (el name >>> el rhs) >>> pair - -data DotList a = MkDotList (NonEmpty a) a - deriving (Show, Generic) - --- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩. -prefixSugar - :: Text -> Prefix - -> Grammar Position (Sexp :- t') a - -> Grammar Position (Sexp :- t') a -prefixSugar name prefix e = coproduct - -- 'something - [ Sexp.prefixed prefix e - -- (quote something) - , list $ el (sym name) >>> el e - ] - -todo :: Grammar p (Sexp :- t) t' -todo = IGB.Flip (IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g - where - f _ = Left $ unexpected "todo" - g _ = Left $ unexpected "todo" - -kappa - :: (forall t. Grammar Position (Sexp :- t) (a :- t)) - -> Grammar Position (Sexp :- List a :- t1) t2 - -> Grammar Position (Sexp :- t1) t2 -kappa name e = list $ - el kappaKeyword - >>> el (list $ rest name) - >>> el e - -lambda - :: (forall t. Grammar Position (Sexp :- t) (a :- t)) - -> Grammar Position (Sexp :- List a :- t1) t2 - -> Grammar Position (Sexp :- t1) t2 -lambda name e = list $ - el lambdaKeyword - >>> el (list $ rest name) - >>> el e - -isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t) -isoIso l = Sexp.iso (view l) (review l) - -prismIso :: Mismatch -> Prism' s a -> Grammar p (s :- t) (a :- t) -prismIso mm p = Sexp.partialOsi - (maybe (Left mm) Right . preview p) - (review p) - -kappaKeyword :: Grammar Position (Sexp :- t) t -kappaKeyword = coproduct [ sym "κ", sym "kappa" ] - -lambdaKeyword :: Grammar Position (Sexp :- t) t -lambdaKeyword = coproduct [ sym "λ", sym "lambda" ] - -schemeBool :: SexpGrammar Bool -schemeBool = Sexp.hashed $ Sexp.partialOsi f g - where - f (SL.Symbol ("t";"true")) = Right True - f (SL.Symbol ("f";"false")) = Right False - f _ = Left $ Sexp.expected "bool" - g True = SL.Symbol "true" - g False = SL.Symbol "false" - -headTagged1 :: Text -> SexpGrammar a -> Grammar Position (Sexp :- t) (a :- t) -headTagged1 s g1 = list $ el (sym s) >>> el g1 - -headTagged1' - :: Text - -> SexpGrammar a -> SexpGrammar b - -> Grammar Position (Sexp :- t) (List b :- a :- t) -headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt - -headTagged2 - :: Text - -> SexpGrammar a -> SexpGrammar b - -> Grammar Position (Sexp :- t) (b :- a :- t) -headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2 - - - -instance SexpIso Sexp where - sexpIso = Control.Category.id - --- evil ass orphan instances -deriving instance (Data a, Data e) => Data (SL.LocatedBy a e) -deriving instance Data SL.Atom -deriving instance Data SL.Prefix -deriving instance Data SL.Position -deriving instance (Data e) => Data (SL.SexpF e) - - --- Quasiquoter - -getPos = do - Loc {loc_filename,loc_start} <- location - pure $ SL.Position loc_filename (fst loc_start) (snd loc_start) - -fromSexp :: SexpIso a => Sexp -> a -fromSexp = either error id . Sexp.fromSexp sexpIso - -fromSexp' :: SexpGrammar a -> Sexp -> a -fromSexp' g = either error id . Sexp.fromSexp g - -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 :: Text -> Sexp -pattern Unquote x = - SL.Modified Hash (SL.BraceList [SL.Symbol x]) - -pattern UnquoteSplicing :: Text -> Sexp -pattern UnquoteSplicing x = - SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x])) - -_UnquoteSplicing :: Prism' Sexp.Sexp Text -_UnquoteSplicing = prism' - UnquoteSplicing - (\case { UnquoteSplicing x -> Just x ; _ -> Nothing }) - -instance Each Sexp Sexp Sexp Sexp where - each k (SL.ParenList xs) = SL.ParenList <$> traverse k xs - each k (SL.BracketList xs) = SL.BracketList <$> traverse k xs - each k (SL.BraceList xs) = SL.BraceList <$> traverse k xs - -- each k (SL.Modified m e) = SL.Modified m <$> each k e - 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 - --- | @('==')@ for 'Sexp's modulo source location — return true if the --- two sexps are equal in all but 'Position' fields. -equivalent :: Sexp -> Sexp -> Bool -equivalent = (==) `on` stripLocation - -instance SexpIso Natural where - sexpIso = Sexp.integer >>> Sexp.partialOsi f g - where - f n | n < 0 = Left $ Sexp.unexpected "negative" - <> Sexp.expected "natural" - | otherwise = Right $ fromIntegral n - g n = fromIntegral n - -class SpliceSexp a where - spliceSexp :: a -> List Sexp - -instance SexpIso a => SpliceSexp (Data.Vector.Strict.Vector a) where - spliceSexp = toSexps - -instance SexpIso a => SpliceSexp (Vector a) where - spliceSexp = toSexps - -instance SexpIso a => SpliceSexp (List a) where - spliceSexp = toSexps - -instance SpliceSexp Sexp where - spliceSexp = toListOf each - -unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ -unquoteSplicingRecursive xs = [| mconcat $(spans) |] - where - spans = xs - & groupBy \cases - (UnquoteSplicing _) _ -> False - _ (UnquoteSplicing _) -> False - _ _ -> True - & fmap \case - [UnquoteSplicing x] -> - [| spliceSexp $(varE (mkName (T.unpack x))) |] - es -> listE $ unquoteRecursive <$> es - & listE - -unquoteRecursive :: Sexp.Sexp -> ExpQ -unquoteRecursive = \case - Unquote x -> [| toSexp $(varE (mkName (T.unpack x))) |] - SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|] - e -> liftData e - -_ParenList :: Prism' Sexp (List Sexp) -_ParenList = prism' SL.ParenList \case - SL.ParenList xs -> Just xs - _ -> Nothing - -metaSexps :: List Sexp.Sexp -> Maybe ExpQ -metaSexps = Just . unquoteSplicingRecursive - -metaSexp :: Sexp.Sexp -> Maybe ExpQ -metaSexp = Just . unquoteRecursive - --- 뻘짓뻘짓뻘짓뻘짓뻘짓 -class Lift1 f where - liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp - -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 [|SL.Fix|] (lift1 inner) - -instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where - 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)|] - -instance Lift1 List where - liftLift l xs = listE $ l <$> xs - -instance Lift1 SL.SexpF where - liftLift l = \case - SL.AtomF a -> [|SL.AtomF $(lift a)|] - SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|] - SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|] - SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|] - SL.ModifiedF p e -> [|SL.ModifiedF $(lift p) $(l e)|] - --- deriving instance Lift a => Lift (SL.SexpF a) -deriving instance Lift SL.Atom -deriving instance Lift SL.Position -deriving instance Lift SL.Prefix - -encodeOrShow :: (SexpIso a, Show a, IsString s) => a -> s -encodeOrShow a = fromString case encode a of - Left _ -> show a - Right e -> T.unpack e - -extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r -extQ f g a = maybe (f a) g (cast a) - -makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter -makeSxs f = QuasiQuoter - { quoteExp = \str -> do - pos <- getPos - case readSexpsWithPos pos (T.pack str) of - Left e -> fail e - Right xs -> [| $(unTypeCode f) $e |] - where - e = dataToExpQ - (const Nothing `extQ` metaSexp `extQ` metaSexps) - xs - , quotePat = undefined - , quoteType = undefined - , quoteDec = undefined - } - --- | An untyped variant of 'makeSx', useful when the user function is --- polymorphic in its return value. -makeSx' :: ExpQ -> QuasiQuoter -makeSx' f = QuasiQuoter - { quoteExp = \str -> do - pos <- getPos - case readSexpWithPos pos (T.pack str) of - Left e -> fail e - Right x -> [| $f $e |] - where - e = dataToExpQ - (const Nothing `extQ` metaSexp `extQ` metaSexps) - x - , quotePat = undefined - , quoteType = undefined - , quoteDec = undefined - } - -makeSx :: Data r => Code Q (Sexp -> r) -> QuasiQuoter -makeSx = makeSx' . unTypeCode - -sxs = makeSxs [||id||] -sx = makeSx [||id||] diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index a75e1c8..0188a30 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -7,6 +7,7 @@ module Gyehoek.Sexp.Grammar , toData , fromData , encodeWith + , encodeWith' , encodeDataWith , decodeWith , encodeTest @@ -18,6 +19,10 @@ module Gyehoek.Sexp.Grammar , with , match , Coproduct (..) + , fromDatumUnsafe + , Control.Category.id + , encodeOrShow' + , decodeDataWith ) where @@ -32,6 +37,9 @@ import qualified Data.Text.IO as TIO import Text.Pretty.Simple (pPrintNoColor) import Data.InvertibleGrammar.Generic import qualified Control.Category +import qualified Data.Vector as V +import Data.String (IsString (fromString)) +import qualified Data.Text as T toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum @@ -52,6 +60,9 @@ fromDatum g = >>> runGrammar noAnn >>> either (throwError . GrammarError) pure +fromDatumUnsafe :: DatumGrammar a -> Datum -> a +fromDatumUnsafe g = runJalmotUnsafe . fromDatum g + fromData :: Jalmot :> es => DataGrammar a -> List Datum -> Eff es a fromData g = forward (sealed g) @@ -70,6 +81,10 @@ encodeWith' g = toDatum g >>> fmap printDatum' decodeWith :: forall es a. Jalmot :> es => DatumGrammar a -> Text -> Eff es a decodeWith g = Read.readString1 @es >=> fromDatum g +decodeDataWith + :: forall es a. Jalmot :> es => DataGrammar a -> Text -> Eff es a +decodeDataWith g = Read.readString @es >=> fromData g + -- | run a grammar, quick and dirty. decodeTest :: Show a => DatumGrammar a -> Text -> IO () decodeTest g = pPrintNoColor <=< (runJalmotIO . decodeWith g) @@ -82,6 +97,12 @@ encodeTest g = TIO.putStrLn <=< (runJalmotIO . encodeWith' g) encodeTestColour :: DatumGrammar a -> a -> IO () encodeTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeWith g) +encodeOrShow' :: (IsString s, Show a) => DatumGrammar a -> a -> s +encodeOrShow' g x = fromString $ + case runPureEff . runJalmot . encodeWith' g $ x of + Left _ -> show x + Right t -> T.unpack t + class DatumIso a where datumIso :: DatumGrammar a @@ -101,3 +122,10 @@ instance DatumIso Datum where datumIso = Control.Category.id instance DatumIso a => DataIso (List a) where dataIso = onHead . traversed . sealed $ datumIso @a + +instance DatumIso a => DataIso (V.Vector a) where + dataIso = iso fromList V.toList + >>> (onHead . traversed . sealed $ datumIso @a) + +instance (DatumIso a, DatumIso b) => DatumIso (a, b) where + datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2 diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs index 481280b..8224108 100644 --- a/src/Gyehoek/Sexp/Grammar/Base.hs +++ b/src/Gyehoek/Sexp/Grammar/Base.hs @@ -1,6 +1,8 @@ -- | cribbed from sexp-grammar:Language.SexpGrammar.Base module Gyehoek.Sexp.Grammar.Base ( module Gyehoek.Sexp.Syntax + , module Data.InvertibleGrammar.Combinators + , expected, unexpected -- * types , G , Grammar @@ -31,15 +33,17 @@ module Gyehoek.Sexp.Grammar.Base , headTagged0 , lambdaLike , lambdaKeyword + , kappaKeyword , beginLike + , prismIso + , isoIso ) where import Data.InvertibleGrammar import Data.InvertibleGrammar.Base +import Data.InvertibleGrammar.Combinators import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple) import Gyehoek.Sexp.Syntax hiding (position) -import Gyehoek.Sexp qualified as GS -import qualified Gyehoek.Sexp as GS import Gyehoek.Sexp.Print (printDatum') import Data.Scientific (Scientific) import qualified Data.Scientific as Sci @@ -249,10 +253,10 @@ ifLike -- | condition -> DatumGrammar a -- | consequent (then-branch) - -> DatumGrammar a + -> DatumGrammar b -- | alternative (else-branch) - -> DatumGrammar a - -> G (Datum :- t) (a :- a :- a :- t) + -> DatumGrammar c + -> G (Datum :- t) (c :- b :- a :- t) ifLike kw c t f = list $ el (symBuiltin kw) >>> el c >>> el t >>> el f symBuiltin :: Text -> G (Datum :- t) t @@ -282,7 +286,10 @@ lambdaLike kw formals body = listWithIndentation (NSpecial 1) $ >>> body lambdaKeyword :: G (Datum :- t) t -lambdaKeyword = coproduct [ sym "lambda", sym "λ" ] +lambdaKeyword = coproduct [ sym "λ", sym "lambda" ] + +kappaKeyword :: G (Datum :- t) t +kappaKeyword = coproduct [ sym "κ", sym "kappa" ] beginLike :: Text @@ -291,3 +298,11 @@ beginLike beginLike kw g = listWithIndentation (NSpecial 0) $ el (symBuiltin kw) >>> rest g + +isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t) +isoIso l = iso (view l) (review l) + +prismIso :: Mismatch -> Prism' s a -> Grammar p (s :- t) (a :- t) +prismIso mm p = partialOsi + (maybe (Left mm) Right . preview p) + (review p) diff --git a/src/Gyehoek/Sexp/QQ.hs b/src/Gyehoek/Sexp/QQ.hs index 12834cd..7a4d93b 100644 --- a/src/Gyehoek/Sexp/QQ.hs +++ b/src/Gyehoek/Sexp/QQ.hs @@ -5,6 +5,7 @@ module Gyehoek.Sexp.QQ , makeSx' , sx , sxs + , QuasiQuoter ) where import Data.Data (Typeable, cast) @@ -124,5 +125,5 @@ makeSx :: Data r => Code Q (Datum -> r) -> QuasiQuoter makeSx = makeSx' . unTypeCode sx, sxs :: QuasiQuoter -sxs = makeSxs [|| id @(List Datum) ||] -sx = makeSx [|| id @Datum ||] +sxs = makeSxs [|| Prelude.id @(List Datum) ||] +sx = makeSx [|| Prelude.id @Datum ||] diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index d3b1c64..2c65802 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -10,8 +10,8 @@ module Gyehoek.Wasm , Expr -- ** quasiquoters , expr - , Gyehoek.Sexp.sx - , Gyehoek.Sexp.sxs + , S.sx + , S.sxs -- * GenMod effect , GenMod , runGenMod @@ -29,10 +29,6 @@ module Gyehoek.Wasm ) where -import Language.SexpGrammar - ( SexpIso(..), (>>>) ) -import Language.SexpGrammar qualified as Sexp -import Language.SexpGrammar.Generic import Data.List (List) import GHC.Generics (Generic) import Data.Text (Text) @@ -43,16 +39,16 @@ import Effectful.State.Dynamic import Control.Lens import Data.Vector.Strict (Vector) import qualified Data.Vector.Strict as V -import Language.Sexp.Located -import qualified Gyehoek.Sexp import GHC.IsList (IsList(..)) import Language.Haskell.TH.Quote (QuasiQuoter) import Data.Data (Data) -import Gyehoek.Sexp (sx) +import Gyehoek.Sexp qualified as S +import Gyehoek.Sexp (Datum, sx, (>>>)) import Data.Foldable (traverse_) +import Data.Coerce (coerce) -newtype Module = MkModule { inner :: Vector Sexp } +newtype Module = MkModule { inner :: Vector Datum } deriving (Show, Generic) deriving newtype (Semigroup, Monoid) @@ -65,7 +61,7 @@ instance IsList Expr where fromList = MkExpr . V.fromList toList = V.toList . view #inner -newtype Instr = MkInstr { inner :: Sexp } +newtype Instr = MkInstr { inner :: Datum } deriving (Show, Generic, Data, Eq) newtype Idx = MkIdx { inner :: Natural } @@ -102,38 +98,38 @@ instance Monoid GenModState where } data GenMod :: Effect where - DefineFunction :: Sexp -> GenMod m Idx - DefineType :: Sexp -> GenMod m Idx - DefineGlobal :: Sexp -> GenMod m Idx - Emit :: Sexp -> GenMod m () + 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 => Sexp -> Eff es Idx +defineFunction :: GenMod :> es => Datum -> Eff es Idx defineFunction = send . DefineFunction -defineFunctions :: GenMod :> es => List Sexp -> Eff es (List Idx) +defineFunctions :: GenMod :> es => List Datum -> Eff es (List Idx) defineFunctions = traverse (send . DefineFunction) -defineType :: GenMod :> es => Sexp -> Eff es Idx +defineType :: GenMod :> es => Datum -> Eff es Idx defineType = send . DefineType -defineTypes :: GenMod :> es => List Sexp -> Eff es (List Idx) +defineTypes :: GenMod :> es => List Datum -> Eff es (List Idx) defineTypes = traverse (send . DefineType) -defineGlobal :: GenMod :> es => Sexp -> Eff es Idx +defineGlobal :: GenMod :> es => Datum -> Eff es Idx defineGlobal = send . DefineGlobal -defineGlobals :: GenMod :> es => List Sexp -> Eff es (List Idx) +defineGlobals :: GenMod :> es => List Datum -> Eff es (List Idx) defineGlobals = traverse (send . DefineGlobal) -emit :: GenMod :> es => List Sexp -> Eff es () +emit :: GenMod :> es => List Datum -> Eff es () emit = traverse_ (send . Emit) appendAndIncrement :: State GenModState :> es => LensLike' ((,) Natural) GenModState Natural - -> Sexp + -> Datum -> Eff es Idx appendAndIncrement l s = state \st -> st @@ -154,39 +150,38 @@ execGenMod :: Eff (GenMod : es) a -> Eff es Module execGenMod = fmap snd . runGenMod renderModule :: Module -> Text -renderModule (MkModule ss) = Gyehoek.Sexp.format [sx| +renderModule (MkModule ss) = S.encodeWith' S.datumIso [sx| (module ##{ss}) |] --- SexpIso instances +-- DatumIso instances -instance SexpIso Idx where - sexpIso = with \idx -> - Sexp.integer >>> Sexp.partialOsi f g +instance S.DatumIso Idx where + datumIso = S.with \idx -> + S.integer >>> S.partialOsi f g >>> idx where - f n | n < 0 = Left $ Sexp.unexpected "negative" - <> Sexp.expected "natural" + f n | n < 0 = Left $ S.unexpected "negative" + <> S.expected "natural" | otherwise = Right $ fromIntegral n g = fromIntegral -instance SexpIso Instr where - sexpIso = with id +instance S.DatumIso Instr where + datumIso = S.with S.id -instance Gyehoek.Sexp.SpliceSexp Expr where - spliceSexp = toListOf $ #inner . each . #inner +instance S.DataIso Expr where + dataIso = S.dataIso @(Vector Instr) >>> S.iso coerce coerce -- quasiquoters expr :: QuasiQuoter -expr = Gyehoek.Sexp.makeSxs - [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation) - . fmap (Gyehoek.Sexp.fromSexp @Instr) ||] +expr = S.makeSxs + [|| MkExpr . V.fromList . fmap (S.fromDatumUnsafe $ S.datumIso @Instr) ||] wat :: QuasiQuoter -wat = Gyehoek.Sexp.makeSx [|| id ||] +wat = S.makeSx [|| id ||] wats :: QuasiQuoter -wats = Gyehoek.Sexp.makeSxs [|| id ||] +wats = S.makeSxs [|| id ||] diff --git a/test/Gyehoek/Test/Sexp.hs b/test/Gyehoek/Test/Sexp.hs deleted file mode 100644 index 3f8f950..0000000 --- a/test/Gyehoek/Test/Sexp.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Gyehoek.Test.Sexp where - -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit -import Language.Sexp.Located qualified as SL -import Language.SexpGrammar () -import Gyehoek.Sexp (sx, equivalent) -import Data.Function (on) - - -test_root = testGroup "sexp" $ - [ sxTree - ] - -newtype EquivSexp = MkEquiv SL.Sexp - deriving newtype (Show) - -instance Eq EquivSexp where - MkEquiv x == MkEquiv y = equivalent x y - -assertEquiv - :: HasCallStack - => String -> SL.Sexp -> SL.Sexp -> Assertion -assertEquiv prefix = assertEqual prefix `on` MkEquiv - -equivto = assertEquiv "" - -sxTree :: TestTree -sxTree = testGroup "sx" - [ testCase "quotation" do - equivto (SL.Symbol "abc") [sx|abc|] - equivto (SL.ParenList [SL.Symbol "a", SL.Symbol "b"]) [sx|(a b)|] - , testCase "antiquotation" do - equivto [sx|123|] - let meta = 123 :: Int - in [sx|#{meta}|] - equivto [sx|(blah (blah blah) blah)|] - let meta = [sx|blah|] - in [sx|(#{meta} (#{meta} #{meta}) #{meta})|] - , testCase "splicing" do - equivto [sx|(a b c d e f g)|] - let metas = SL.Symbol <$> ["c","d","e"] - in [sx|(a b ##{metas} f g)|] - equivto [sx|(a (b c d) e f g)|] - let - e1 = SL.Symbol "c" - e2 = SL.Symbol <$> ["e","f"] - in [sx|(a (b #{e1} d) ##{e2} g)|] - ]