tests pass!

golden/read/meta-expression/read

@@ -7,6 +7,5 @@
             , sourceColumn = Pos 1
             }
         )
-    } :< SimpleF
+    } :< MetaF "aHaskellVariable + abc * 2"
-    ( SimpleMeta "aHaskellVariable + abc * 2" )
 ]

golden/read/meta-splice-expression/read

@@ -7,6 +7,5 @@
             , sourceColumn = Pos 1
             }
         )
-    } :< SimpleF
+    } :< MetaSpliceF "takeWhile (\x -> even x) aHaskellList"
-    ( SimpleMetaSplice "takeWhile (\x -> even x) aHaskellList" )
 ]

golden/read/meta-splice-variable/read

@@ -7,6 +7,5 @@
             , sourceColumn = Pos 1
             }
         )
-    } :< SimpleF
+    } :< MetaSpliceF "aHaskellList"
-    ( SimpleMetaSplice "aHaskellList" )
 ]

golden/read/meta-variable/read

@@ -7,6 +7,5 @@
             , sourceColumn = Pos 1
             }
         )
-    } :< SimpleF
+    } :< MetaF "aHaskellVariable"
-    ( SimpleMeta "aHaskellVariable" )
 ]

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

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 :: Natural -> S.Datum
-getArgRegister n = SL.Symbol [i|$arg#{n}|]
+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
+lower' g e = error . S.encodeOrShow' S.datumIso $ e
-  Left _ -> show e
-  Right x -> T.unpack x
 
 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'})
   |]

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
+instance Plated Exp where plate = uniplate
-  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
 
 
--- SexpIso instances
+-- DatumIso instances
 
-instance S.SexpIso Val where
+instance S.DatumIso Val where
-  sexpIso = match
+  datumIso = S.match
-    $ With (\imm -> imm . S.sexpIso)
+    $ S.With (\imm -> imm . S.datumIso)
-    $ With (\var -> var . S.sexpIso)
+    $ S.With (\var -> var . S.datumIso)
-    $ End
+    $ S.End
 
-instance S.SexpIso Obj where
+instance S.DatumIso Obj where
-  sexpIso = match
+  datumIso = S.match
-    $ With (\imm -> imm . S.sexpIso)
+    $ S.With (\imm -> imm . S.datumIso)
-    $ With (\hob -> hob . S.sexpIso)
+    $ S.With (\hob -> hob . S.datumIso)
-    $ End
+    $ S.End
 
-instance S.SexpIso Imm where
+instance S.DatumIso Imm where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. S.int)
+    $ S.With (. S.int)
-    $ With (. GS.schemeBool)
+    $ S.With (. S.datumIso)
-    $ With (. labelName)
+    $ S.With (. labelName)
-    $ End
+    $ 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
+instance S.DatumIso Hob where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. closure)
+    $ S.With (. closure)
-    $ End
+    $ 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|(<closure> #{code} ##{env})|] :- t)
         (const . Left $ mempty)
 
-instance S.SexpIso Lambda where
+instance S.DatumIso Lambda where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. lambda)
+    $ S.With (. lambda)
-    $ End
+    $ S.End
     where
       lambda = S.list $
-        S.el Gyehoek.Sexp.lambdaKeyword
+        S.el S.lambdaKeyword
         >>> S.el binders
-        >>> S.el S.sexpIso
+        >>> S.el S.datumIso
-      binders :: forall t.
+      binders :: forall t. G (Datum :- t) (Name :- List Name :- t)
-        IG.Grammar S.Position (Sexp :- 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
+instance S.DatumIso Kappa where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. kappa)
+    $ S.With (. kappa)
-    $ End
+    $ S.End
     where
       kappa = S.list $
-        S.el Gyehoek.Sexp.kappaKeyword
+        S.el S.kappaKeyword
-        >>> S.el (S.list $ S.rest S.sexpIso)
+        >>> S.el (S.list $ S.rest S.datumIso)
-        >>> S.el S.sexpIso
+        >>> S.el S.datumIso
 
-instance S.SexpIso Abs where
+instance S.DatumIso Abs where
-  sexpIso = match
+  datumIso = S.match
-    $ With (\lambda -> lambda . S.sexpIso)
+    $ S.With (\lambda -> lambda . S.datumIso)
-    $ With (\kappa -> kappa . S.sexpIso)
+    $ S.With (\kappa -> kappa . S.datumIso)
-    $ End
+    $ S.End
 
-instance S.SexpIso Exp where
+instance S.DatumIso Exp where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. prim)
+    $ S.With (. prim)
-    $ With (. letrec)
+    $ S.With (. letrec)
-    $ With (. continue)
+    $ S.With (. continue)
-    $ With (. if_)
+    $ S.With (. if_)
-    $ With (. app)
+    $ S.With (. app)
-    $ End
+    $ S.End
     where
       continue = S.list $
         S.el (S.sym "continue")
-        >>> S.el S.sexpIso
+        >>> S.el S.datumIso
-        >>> S.rest S.sexpIso
+        >>> S.rest S.datumIso
-      letrec = Gyehoek.Sexp.let_ "letrec" S.sexpIso S.sexpIso S.sexpIso
+      letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso
-      if_ = S.list $ S.el (S.sym "if")
+      if_ = S.ifLike "if"
-        >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
+        S.datumIso S.datumIso S.datumIso
       app :: forall t.
-        IG.Grammar S.Position (Sexp :- t) (Name :- ([Val] :- (Val :- t)))
+        G (Datum :- t) (Name :- ([Val] :- (Val :- t)))
-      app = S.list $ S.el (S.sexpIso @Val)
+      app = S.list $ S.el (S.datumIso @Val)
-        -- >>> S.flipped Gyehoek.Sexp.nonEmptyGrammar
+        -- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar
-        >>> S.rest (S.sexpIso @Val)
+        >>> 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 (primDatumIso id (S.datumIso @Val))
-        >>> S.el S.sexpIso
+        >>> S.el S.datumIso
 
-instance S.SexpIso Program where
+instance S.DatumIso Program where
-  sexpIso = with \prog -> S.sexpIso @Exp >>> prog
+  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 Exp where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Val where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Kappa where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Lambda where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Program where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso
 
-cps :: QuasiQuoter
+cps :: S.QuasiQuoter
-cps = Gyehoek.Sexp.makeSx' [| toCPS |]
+cps = S.makeSx' [| toCPS |]
 
 
 

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 "-" = "<interactive>"
 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
+    S.decodeDataWith @es S.dataIso =<< hGetContents h
-     >>= either error (pure . Scm.MkProgram)
 
 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

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

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 "-" = "<interactive>"
-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

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_
+  ( module Gyehoek.Sexp.QQ
-  , sexp
+  , module Gyehoek.Sexp.Syntax
-  , nonempty
+  , module Gyehoek.Sexp.Grammar
-  , 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
   )
   where
 
-import Data.Text (Text)
+import Gyehoek.Sexp.QQ
-import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
+import Gyehoek.Sexp.Syntax
-import Language.SexpGrammar qualified as Sexp
+import Gyehoek.Sexp.Grammar
-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
 
-
-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 "-" = "<interactive>"
-fileName e = e
-
-hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text
-hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
-
-readSxs
-  :: IOE :> es
-  => SexpGrammar a
-  -> FilePath -> Eff es (List a)
-readSxs g fp = FS.runFileSystem $
-  FS.withFile fp FS.ReadMode $ \h ->
-    parseSexpsWith g (fileName fp) <$> hGetContents h
-     >>= either error pure
-
-
-
-nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
-nonEmptyGrammar = IGB.Iso
-  (\((x:|xs) :- t) -> reverse xs :- x :- t)
-  (\(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||]

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

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
+  -> DatumGrammar c
-  -> G (Datum :- t) (a :- a :- a :- t)
+  -> 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)

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) ||]
+sxs = makeSxs [|| Prelude.id @(List Datum) ||]
-sx = makeSx [|| id @Datum ||]
+sx = makeSx [|| Prelude.id @Datum ||]

src/Gyehoek/Wasm.hs

@@ -10,8 +10,8 @@ module Gyehoek.Wasm
   , Expr
     -- ** quasiquoters
   , expr
-  , Gyehoek.Sexp.sx
+  , S.sx
-  , Gyehoek.Sexp.sxs
+  , 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
+  DefineFunction :: Datum -> GenMod m Idx
-  DefineType :: Sexp -> GenMod m Idx
+  DefineType :: Datum -> GenMod m Idx
-  DefineGlobal :: Sexp -> GenMod m Idx
+  DefineGlobal :: Datum -> GenMod m Idx
-  Emit :: Sexp -> GenMod m ()
+  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
+instance S.DatumIso Idx where
-  sexpIso = with \idx ->
+  datumIso = S.with \idx ->
-    Sexp.integer >>> Sexp.partialOsi f g
+    S.integer >>> S.partialOsi f g
     >>> idx
     where
-      f n | n < 0 = Left $ Sexp.unexpected "negative"
+      f n | n < 0 = Left $ S.unexpected "negative"
-                        <> Sexp.expected "natural"
+                        <> S.expected "natural"
           | otherwise = Right $ fromIntegral n
       g = fromIntegral
 
-instance SexpIso Instr where
+instance S.DatumIso Instr where
-  sexpIso = with id
+  datumIso = S.with S.id
 
-instance Gyehoek.Sexp.SpliceSexp Expr where
+instance S.DataIso Expr where
-  spliceSexp = toListOf $ #inner . each . #inner
+  dataIso = S.dataIso @(Vector Instr) >>> S.iso coerce coerce
 
 
 -- quasiquoters
 
 expr :: QuasiQuoter
-expr = Gyehoek.Sexp.makeSxs
+expr = S.makeSxs
-  [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation)
+  [|| MkExpr . V.fromList . fmap (S.fromDatumUnsafe $ S.datumIso @Instr) ||]
-   . fmap (Gyehoek.Sexp.fromSexp @Instr) ||]
 
 wat :: QuasiQuoter
-wat = Gyehoek.Sexp.makeSx [|| id ||]
+wat = S.makeSx [|| id ||]
 
 wats :: QuasiQuoter
-wats = Gyehoek.Sexp.makeSxs [|| id ||]
+wats = S.makeSxs [|| id ||]

test/Gyehoek/Test/Sexp.hs

@@ -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)|]
-  ]