datum grammar

cabal.project

@@ -1,5 +1,7 @@
 packages: *.cabal
 tests: True
+-- required for doctest-parallel
+write-ghc-environment-files: always
 
 source-repository-package
     type: git

gyehoek.cabal

@@ -60,12 +60,14 @@ library
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
+    Gyehoek.Jalmot
     Gyehoek.Language
     Gyehoek.Options
     Gyehoek.Prelude
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Sexp.Grammar
+    Gyehoek.Sexp.Grammar.Base
     Gyehoek.Sexp.Print
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
@@ -151,3 +153,12 @@ test-suite test
     , text
 
   default-language:   GHC2024
+
+test-suite doctest
+  import:         ghcstuffs, ghcstuffs-dev
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is:        doctest.hs
+  build-depends:
+    , base
+    , doctest-parallel  >=0.1

src/Gyehoek/Jalmot.hs

@@ -0,0 +1,59 @@
+module Gyehoek.Jalmot
+  ( Jalmot
+  , Exception(..)
+  , AJalmot(..)
+  , module Effectful.Error.Static
+  , runJalmot
+  , runJalmotIO
+  , runJalmotIOE
+  )
+  where
+
+import Gyehoek.Prelude
+import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
+import Data.Void (Void)
+import Control.Exception.Base (Exception(..), throwIO)
+import Effectful.Error.Static
+import qualified Data.InvertibleGrammar as Grammar
+import Gyehoek.Sexp.Syntax (Ann)
+import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty)
+import Prettyprinter.Render.String (renderString)
+
+
+deriving instance Show p => Show (Grammar.ErrorMessage p) 
+deriving instance Data p => Data (Grammar.ErrorMessage p) 
+
+data AJalmot
+  = ReaderError (ParseErrorBundle Text Void)
+  | GrammarError (Grammar.ErrorMessage Ann)
+  deriving (Show, Generic, Data)
+
+data AJalmotWithCallStack = MkAJalmotWithCallStack !CallStack !AJalmot
+  deriving (Show)
+
+type Jalmot = Error AJalmot
+
+runJalmot :: Eff (Jalmot : es) a -> Eff es (Either (CallStack, AJalmot) a)
+runJalmot = runError
+
+runJalmotIOE :: IOE :> es => Eff (Jalmot : es) a -> Eff es a
+runJalmotIOE eff =
+  runJalmot eff >>= \case
+    Right a -> pure a
+    Left (cs,jm) -> liftIO . throwIO $ MkAJalmotWithCallStack cs jm
+
+runJalmotIO :: Eff '[Jalmot, IOE] a -> IO a
+runJalmotIO = runEff . runJalmotIOE
+
+instance Exception AJalmot where
+  displayException = \case
+    ReaderError eb -> errorBundlePretty eb
+    GrammarError err ->
+        pretty err
+        & layoutPretty defaultLayoutOptions
+        & renderString
+
+instance Exception AJalmotWithCallStack where
+  backtraceDesired = const False
+  displayException (MkAJalmotWithCallStack cs jm) =
+    "\n" <> displayException jm <> "\n\n" <> prettyCallStack cs

src/Gyehoek/Prelude.hs

@@ -17,9 +17,11 @@ module Gyehoek.Prelude
   , NonEmpty((:|))
   , Natural
   , (>>>)
+  , (>=>)
+  , (<=<)
   ) where
 
-import Control.Lens
+import Control.Lens hiding (List)
 import Data.List (List)
 import Data.Text (Text)
 import Effectful
@@ -37,4 +39,5 @@ import Data.Hashable (Hashable)
 import Data.List.NonEmpty (NonEmpty((:|)))
 import Numeric.Natural (Natural)
 import Control.Category ((>>>))
+import Control.Monad
 

src/Gyehoek/Scheme/Syntax.hs

@@ -17,11 +17,9 @@ module Gyehoek.Scheme.Syntax
   , Def(..)
   , Exp(..)
   , ExpF(..)
-  , Sexp(..)
   , Program(..)
   , CommandOrDef(..)
-  , primSexpIso
+  , primDatumIso
-  , pattern Void
   , free
   , subst
   , getName
@@ -36,10 +34,6 @@ module Gyehoek.Scheme.Syntax
   where
 
 import Data.List (intersperse)
-import Language.SexpGrammar
-  ( SexpIso(..), list, el, rest, sym, symbol )
-import Language.SexpGrammar qualified as Sexp
-import Language.SexpGrammar.Generic
 import Effectful
 import Prelude hiding ((.), id)
 import Control.Category
@@ -58,6 +52,9 @@ import qualified Effectful.FileSystem.IO as FS
 import qualified Data.Text.Encoding as T
 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.Prelude
 
 
@@ -97,16 +94,11 @@ instance Each (Prim e) (Prim e') e e'
 
 data Lit
   = LitInt Int
-  | LitNil
   | LitBool Bool
   | LitString Text
-  | LitQuote Sexp
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
-pattern Void :: Lit
-pattern Void = LitNil
-
 data Def
   = DefConstant Name Exp
   | DefProcedure Name (List Name) (List Exp)
@@ -126,13 +118,6 @@ data Exp
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-data Sexp
-  = SexpCons Sexp Sexp
-  | SexpSymbol Text
-  | SexpLit Lit
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData)
-
 data CommandOrDef
   = Command Exp
   | Definition Def
@@ -159,96 +144,82 @@ makeBaseFunctor ''Exp
 
 
 
-instance SexpIso Name where
+instance DatumIso Name where
-  sexpIso = symbol >>> Sexp.partialOsi f g
+  datumIso = S.symbol >>> S.iso MkName (review _Unwrapped')
+
+primDatumIso
+  :: (Text -> Text)
+  -> S.DatumGrammar a -> S.DatumGrammar (Prim a)
+primDatumIso namefn a = S.match
+    $ S.With (. ht2 "+")
+    $ S.With (. ht2 "-")
+    $ S.With (. ht2 "*")
+    $ S.With (. ht2 "/")
+    $ S.With (. ht2 "cons")
+    $ S.With (. ht1 "car")
+    $ S.With (. ht1 "cdr")
+    $ S.With (. ht1 "immediate?")
+    $ S.With (. ht1 "cons?")
+    $ S.With (. ht1 "integer?")
+    $ S.With (. ht1 "write")
+    $ S.With (. ht1 "zero?")
+    $ S.With (. nullop "newline")
+    $ S.With (. ht1' "make-closure")
+    $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
+    $ S.With (. ht1 "env-code")
+    $ S.With (. ht1 "call/cc")
+    $ S.End
     where
-      f = Right . MkName
+      idn = S.el . S.sym . namefn
-      g (MkName s) = s
+      nullop s = S.list $ idn s
+      ht1 s = S.headTagged1 (namefn s) a
+      ht2 s = S.headTagged2 (namefn s) a a
+      ht1' s = S.headTagged1' (namefn s) a a
 
-primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
+instance DatumIso a => DatumIso (Prim a) where
-primSexpIso namefn a = match
+  -- datumIso = primDatumIso ("prim:"<>) datumIso
-    $ With (. ht2 "+")
+  datumIso = primDatumIso id S.datumIso
-    $ With (. ht2 "-")
+
-    $ With (. ht2 "*")
+instance DatumIso Lit where
-    $ With (. ht2 "/")
+  datumIso = S.match
-    $ With (. ht2 "cons")
+    $ S.With (. S.int)
-    $ With (. ht1 "car")
+    $ S.With (. S.boolean)
-    $ With (. ht1 "cdr")
+    $ S.With (. S.string)
-    $ With (. ht1 "immediate?")
+    $ S.End
-    $ With (. ht1 "cons?")
+
-    $ With (. ht1 "integer?")
+instance DatumIso Def where
-    $ With (. ht1 "write")
+  datumIso = S.match
-    $ With (. ht1 "zero?")
+    $ S.With (. defconst)
-    $ With (. nullop "newline")
+    $ S.With (. defun)
-    $ With (. ht1' "make-closure")
+    $ S.End
-    $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
-    $ With (. ht1 "env-code")
-    $ With (. ht1 "call/cc")
-    $ End
     where
-      idn s = el (sym (namefn s))
+      defconst = S.list $ S.el (S.sym "define")
-      nullop s = list $ idn s
+        >>> S.el S.datumIso >>> S.el S.datumIso
-      ht1 s = GS.headTagged1 (namefn s) a
+      defun = S.list $ S.el (S.sym "define")
-      ht2 s = GS.headTagged2 (namefn s) a a
+        >>> S.el args >>> S.rest S.datumIso
-      ht1' s = GS.headTagged1' (namefn s) a a
+      args = S.list $ S.el S.datumIso >>> S.rest S.datumIso
-
-instance SexpIso a => SexpIso (Prim a) where
-  -- sexpIso = primSexpIso ("prim:"<>) sexpIso
-  sexpIso = primSexpIso id sexpIso
-
-instance SexpIso Lit where
-  sexpIso = match
-    $ With (. sexpIso)
-    $ With (. sym "nil")
-    $ With (. GS.schemeBool)
-    $ With (. sexpIso)
-    $ With (. GS.prefixSugar "quote" Sexp.Quote sexpIso)
-    $ End
-
-instance SexpIso Sexp where
-  sexpIso = match
-    $ With (\conss -> conss . GS.todo)
-    $ With (\s -> s . symbol)
-    $ With (\lit -> lit . sexpIso)
-    $ End
-
-instance SexpIso Def where
-  sexpIso = match
-    $ With (. defconst)
-    $ With (. defun)
-    $ End
-    where
-      defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
-      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
-      args = list $ el sexpIso >>> rest sexpIso
   
-instance SexpIso Exp where
+instance DatumIso Exp where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. GS.let_ "let" sexpIso sexpIso sexpIso)
+    $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
-    $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso)
+    $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
-    $ With (. sexpIso)
+    $ S.With (. S.datumIso)
-    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
+    $ S.With (. S.beginLike "begin" S.datumIso)
-    $ With (. if_)
+    $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso)
-    $ With (. sexpIso)
+    $ S.With (. S.datumIso)
-    $ With (. lam)
+    $ S.With (. lam)
-    $ With (. sexpIso)
+    $ S.With (. S.datumIso)
-    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
+    $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso))
-    $ End
+    $ S.End
     where
-      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
+      lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
-      lam = list
-        ( el GS.lambdaKeyword
-          >>> el (sexpIso @(List Name))
-          >>> el sexpIso )
 
-instance SexpIso CommandOrDef where
+instance DatumIso CommandOrDef where
-  sexpIso = match
+  datumIso = S.match
-    $ With (\_Command -> _Command . sexpIso)
+    $ S.With (\_Command -> _Command . S.datumIso)
-    $ With (\_Definition -> _Definition . sexpIso)
+    $ S.With (\_Definition -> _Definition . S.datumIso)
-    $ With (\_Begin -> _Begin . bgn)
+    $ S.With (\_Begin -> _Begin . S.beginLike "begin" S.datumIso)
-    $ End
+    $ S.End
-    where
-      bgn = list $ el (sym "begin") >>> rest sexpIso
 
 
 -- utilities

src/Gyehoek/Sexp/Grammar.hs

@@ -1,4 +1,97 @@
 module Gyehoek.Sexp.Grammar
-  (
+  ( module Gyehoek.Sexp.Grammar.Base
-  ) where
+  , module Data.InvertibleGrammar.Combinators
+  , (>>>)
+  , toDatum
+  , fromDatum
+  , toData
+  , fromData
+  , encodeWith
+  , encodeDataWith
+  , decodeWith
+  , encodeTest
+  , encodeTestColour
+  , decodeTest
+  , DataIso(..)
+  , DatumIso(..)
+  -- * generics
+  , with
+  , match
+  , Coproduct (..)
+  )
+  where
 
+import Gyehoek.Sexp.Grammar.Base
+import Gyehoek.Prelude
+import Data.InvertibleGrammar (backward, sealed, forward, runGrammar)
+import Gyehoek.Sexp.Print (printDatum, printDatum', printData)
+import Gyehoek.Jalmot
+import Data.InvertibleGrammar.Combinators
+import qualified Gyehoek.Sexp.Read as Read
+import qualified Data.Text.IO as TIO
+import Text.Pretty.Simple (pPrintNoColor)
+import Data.InvertibleGrammar.Generic
+
+
+toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
+toDatum g =
+  backward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+toData :: Jalmot :> es => DataGrammar a -> a -> Eff es (List Datum)
+toData g =
+  backward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+fromDatum :: Jalmot :> es => DatumGrammar a -> Datum -> Eff es a
+fromDatum g =
+  forward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+fromData :: Jalmot :> es => DataGrammar a -> List Datum -> Eff es a
+fromData g =
+  forward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+encodeWith :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text
+encodeWith g = toDatum g >>> fmap printDatum
+
+encodeDataWith :: Jalmot :> es => DataGrammar a -> a -> Eff es Text
+encodeDataWith g = toData g >>> fmap printData
+
+encodeWith' :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text
+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
+
+-- | run a grammar, quick and dirty.
+decodeTest :: Show a => DatumGrammar a -> Text -> IO ()
+decodeTest g = pPrintNoColor <=< (runJalmotIO . decodeWith g)
+
+-- | run a grammar, quick and dirty.
+encodeTest :: DatumGrammar a -> a -> IO ()
+encodeTest g = TIO.putStrLn <=< (runJalmotIO . encodeWith' g)
+
+-- | run a grammar, quick and dirty.
+encodeTestColour :: DatumGrammar a -> a -> IO ()
+encodeTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeWith g)
+
+class DatumIso a where
+  datumIso :: DatumGrammar a
+
+class DataIso a where
+  dataIso :: DataGrammar a
+
+
+
+instance DatumIso a => DatumIso (List a) where
+  datumIso = list $ rest datumIso
+
+instance DatumIso Bool where datumIso = boolean
+
+instance DatumIso Int where datumIso = int

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -0,0 +1,293 @@
+-- | cribbed from sexp-grammar:Language.SexpGrammar.Base
+module Gyehoek.Sexp.Grammar.Base
+  ( module Gyehoek.Sexp.Syntax
+  -- * types
+  , G
+  , Grammar
+  , DatumGrammar
+  , DataGrammar
+  , Grammar
+  , ListContext
+  , (:-)((:-))
+  -- * lists
+  , list
+  , el
+  , rest
+  -- * atoms
+  , simple
+  , string
+  , symbol
+  , sym
+  , boolean
+  , number
+  , integer
+  , headTagged1'
+  , headTagged1
+  , headTagged2
+  , int
+  , letLike
+  , ifLike
+  , headTagged0'
+  , headTagged0
+  , lambdaLike
+  , lambdaKeyword
+  , beginLike
+  ) where
+
+import Data.InvertibleGrammar
+import Data.InvertibleGrammar.Base
+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
+import qualified Data.Text as T
+import Control.Monad.RWS (modify)
+
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> import Gyehoek.Sexp.Grammar
+
+type G = Grammar Ann
+
+type DatumGrammar a = forall t. G (Datum :- t) (a :- t)
+type DataGrammar a = forall t. G (List Datum :- t) (a :- t)
+
+-- | extract\/inject an annotation from\/into a 'Datum'.
+position :: G (Datum :- t) (Ann :- Datum :- t)
+position = Iso
+  (\(s :- t) -> view ann s :- s :- t)
+  (\(a :- s :- t) -> (s & ann .~ a) :- t)
+
+locate :: G (Datum :- t) (Datum :- t)
+locate =
+  position
+  >>> onHead Locate
+  >>> Iso
+    (\(_ :- t) -> t)
+    (\t -> noAnn :- t)
+
+modifyAnn :: (Ann -> Ann) -> G (Datum :- t) (Datum :- t)
+modifyAnn f = Iso
+  (\(d:-t) -> (d & ann %~ f) :- t)
+  (\(d:-t) -> (d & ann %~ f) :- t)
+
+newtype ListContext = MkListContext (List Datum)
+
+unexpectedSimple :: Simple -> Mismatch
+unexpectedSimple = unexpected . printDatum' . Simple
+
+unexpectedDatum :: Datum -> Mismatch
+unexpectedDatum = unexpected . printDatum'
+
+list
+  :: G (ListContext :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
+list = listWithIndentation Ordinary
+
+listWithIndentation
+  :: Indentation
+  -> G (ListContext :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
+listWithIndentation ind g = begin >>> Dive (g >>> end)
+  where
+    begin = locate >>> partialOsi
+      (\case
+          List xs -> Right . MkListContext $ xs
+          _ -> Left $ expected "list")
+      (List' ind . coerce)
+    end = Flip $ PartialIso
+      (\t -> MkListContext [] :- t)
+      (\(MkListContext lst :- t) ->
+         case lst of
+           [] -> Right t
+           d:_ -> Left $ unexpectedDatum d)
+
+-- |
+-- >>> decodeTest (list $ el simple) "(in-here!)"
+-- SimpleSymbol "in-here!"
+el
+  :: G (Datum :- t) t'
+  -> G (ListContext :- t) (ListContext :- t')
+el g = coerced (Flip cons >>> onTail g >>> Step)
+
+-- | matches the remainder of a list
+--
+-- >>> decodeTest (list $ rest simple) "(ga na da ra)"
+-- [ SimpleSymbol "ga"
+-- , SimpleSymbol "na"
+-- , SimpleSymbol "da"
+-- , SimpleSymbol "ra"
+-- ]
+rest
+  :: (forall t'. G (Datum :- t') (a :- t'))
+  -> G (ListContext :- t) (ListContext :- List a :- t)
+rest g =
+  iso coerce coerce >>>
+  onHead (Traverse (sealed g >>> Step)) >>>
+  Iso (\a -> MkListContext [] :- a) (\(_ :- a) -> a)
+
+
+-- atoms
+
+-- | matches simple forms — atomic S-expressions.
+--
+-- >>> decodeTest simple "call/cc"
+-- SimpleSymbol "call/cc"
+simple :: G (Datum :- t) (Simple :- t)
+simple = locate >>> partialOsi
+  (\case Simple s -> Right s
+         _ -> Left . expected $ "atom")
+  Simple
+
+prismGrammar
+  -- | expected
+  :: Text
+  -- | unexpected
+  -> (s -> Mismatch)
+  -> Prism' s a
+  -> Grammar p (s :- t) (a :- t)
+prismGrammar exp unexp p =
+  partialOsi
+    ((_Left %~ \x -> expected exp <> unexp x) . matching p)
+    (review p)
+
+-- |
+-- >>> decodeTest symbol "symbolic-of-what???"
+-- "symbolic-of-what???"
+symbol :: G (Datum :- t) (Text :- t)
+symbol = simple >>> prismGrammar "symbol" unexpectedSimple #SimpleSymbol
+
+-- |
+-- >>> let grammar = list $ el (sym "a-specific-symbol") >>> el string
+-- >>> decodeTest grammar "(a-specific-symbol \"this works\")"
+-- "this works"
+-- >>> decodeTest grammar "(some-other-symbol \"this does not\")"
+-- *** Exception:
+-- <none>:1:2: mismatch:
+--     Expected: symbol a-specific-symbol
+--     But got:  some-other-symbol
+-- ...
+sym :: Text -> G (Datum :- t) t
+sym s = simple >>> Flip (PartialIso
+  (SimpleSymbol s :-)
+  (\(a :- t) ->
+      case a of
+        SimpleSymbol s' | s == s' -> Right t
+        other -> Left $ expected ("symbol " <> s) <>
+                        unexpectedSimple other))
+
+-- |
+-- >>> decodeTest string "\"these r annoying to escape\""
+-- "these r annoying to escape"
+-- >>> encodeTest string "john Haskell"
+-- "john Haskell"
+string :: G (Datum :- t) (Text :- t)
+string = simple >>> prismGrammar "string" unexpectedSimple #SimpleString
+
+-- |
+-- >>> decodeTest boolean "#t"
+-- True
+-- >>> decodeTest boolean "#false"
+-- False
+-- >>> encodeTest boolean True
+-- #t
+boolean :: G (Datum :- t) (Bool :- t)
+boolean = simple >>> prismGrammar "boolean" unexpectedSimple #SimpleBoolean
+
+-- |
+-- >>> decodeTest number "123"
+-- 123.0
+-- >>> encodeTest number (fromInteger 456)
+-- 456
+number :: G (Datum :- t) (Scientific :- t)
+number = simple >>> prismGrammar "number" unexpectedSimple #SimpleNumber
+
+-- |
+-- >>> decodeTest integer "123"
+-- 123
+-- >>> encodeTest number 456
+-- 456
+integer :: G (Datum :- t) (Integer :- t)
+integer = number >>> partialOsi
+  ((_Left %~ (unexpected . T.pack . show @Double)) . Sci.floatingOrInteger)
+  fromIntegral
+
+int :: G (Datum :- t) (Int :- t)
+int = integer >>> iso fromIntegral fromIntegral
+
+
+-- high-level combinators
+
+headTagged0 :: Text -> G (Datum :- t) t
+headTagged0 s = list $ el (sym s)
+
+headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
+headTagged0' s gt = list $ el (sym s) >>> rest gt
+
+headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
+headTagged1 s g1 = list $ el (sym s) >>> el g1
+
+headTagged1'
+  :: Text
+  -> DatumGrammar a -> DatumGrammar b
+  -> G (Datum :- t) (List b :- a :- t)
+headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt
+
+headTagged2
+  :: Text
+  -> DatumGrammar a -> DatumGrammar b
+  -> G (Datum :- t) (b :- a :- t)
+headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2
+
+ifLike
+  -- | keyword
+  :: Text
+  -- | condition
+  -> DatumGrammar a
+  -- | consequent (then-branch)
+  -> DatumGrammar a
+  -- | alternative (else-branch)
+  -> DatumGrammar a
+  -> G (Datum :- t) (a :- a :- a :- t)
+ifLike kw c t f = list $ el (symBuiltin kw) >>> el c >>> el t >>> el f
+
+symBuiltin :: Text -> G (Datum :- t) t
+symBuiltin s = modifyAnn (#syntax .~ SynBuiltin) >>> sym s
+
+letLike
+  :: Text
+  -> (forall t. G (Datum :- t) (a :- t))
+  -> (forall t. G (Datum :- t) (b :- t))
+  -> G (Datum :- (List (a, b) :- t1)) t2
+  -> G (Datum :- t1) t2
+letLike kw name rhs e = listWithIndentation (NSpecial 1) $
+  el (symBuiltin kw) >>> el bindings >>> el e
+  where
+    bindings = list $ rest binding
+    binding :: G (Datum :- t) ((_, _) :- t)
+    binding = list (el name >>> el rhs) >>> pair
+
+lambdaLike
+  :: (forall t. G (Datum :- t) t)
+  -> DatumGrammar a
+  -> G (ListContext :- a :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
+lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
+  el (modifyAnn (#syntax .~ SynBuiltin) >>> kw)
+  >>> el formals
+  >>> body
+
+lambdaKeyword :: G (Datum :- t) t
+lambdaKeyword = coproduct [ sym "lambda", sym "λ" ]
+
+beginLike
+  :: Text
+  -> DatumGrammar a
+  -> G (Datum :- t) (List a :- t)
+beginLike kw g =
+  listWithIndentation (NSpecial 0) $
+    el (symBuiltin kw) >>> rest g

src/Gyehoek/Sexp/Print.hs

@@ -1,6 +1,8 @@
 module Gyehoek.Sexp.Print
   ( printDatum
   , printDatumW
+  , printDatum'
+  , printData
   ) where
 
 import Gyehoek.Sexp.Syntax
@@ -9,16 +11,31 @@ import Data.Functor.Foldable
 import qualified Control.Comonad.Trans.Cofree as F
 import Prettyprinter.Util
 import Gyehoek.Prelude hiding (Simple, (:<))
-import Gyehoek.Sexp.Read (rd)
 import Data.Foldable (traverse_)
 import qualified Prettyprinter.Render.Terminal as ANSI
 import System.IO (stdout)
 import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold)
+import Prettyprinter.Render.Text (renderStrict)
+import qualified Data.Scientific as Sci
+import Data.List (intersperse)
 
 
+printDatum' :: Datum -> Text
+printDatum' =
+  prettyDatum 0
+  >>> layoutSmart opts
+  >>> renderStrict
+  where
+    opts = LayoutOptions
+      { layoutPageWidth = AvailablePerLine 80 1.0
+      }
+
 printDatum :: Datum -> Text
 printDatum = printDatumW 80
 
+printData :: List Datum -> Text
+printData = mconcat . intersperse "\n\n" . fmap printDatum
+
 printDatumW :: Int -> Datum -> Text
 printDatumW w =
   prettyDatum 0
@@ -31,24 +48,23 @@ printDatumW w =
       }
 
 prettyDatum :: Int -> Datum -> Doc Syn
-prettyDatum depth = \case
+prettyDatum depth datum = case datum of
-  syn :< SimpleF s -> annotate syn $ prettySimple depth s
+  Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
-  syn :< CompoundF compound -> case compound of
+  List' indent xs ->
-    ListF indent xs ->
+    case indent of
-      case indent of
+      NSpecial n | keyword:args <- xs ->
-        NSpecial n | keyword:args <- xs ->
+        let (specialArgs,body) = splitAt n args
-          let (specialArgs,body) = splitAt n args
+        in pparen depth . nest 2 . vsep $
-          in pparen depth . nest 2 . vsep $
+            [ group . nest 2 . hcat $
-              [ group . nest 2 . hcat $
+              [ prettyDatum (depth+1) keyword
-                [ prettyDatum (depth+1) keyword
+              , if null specialArgs then mempty else softline
-                , if null specialArgs then mempty else softline
+              , hsep $ prettyDatum (depth+1) <$> specialArgs
-                , hsep $ prettyDatum (depth+1) <$> specialArgs
-                ]
-              , vsep $ prettyDatum (depth+1) <$> body
               ]
-        Ordinary; NSpecial _ -> pparen depth $
+            , vsep $ prettyDatum (depth+1) <$> body
-          group . align . vsep $
+            ]
-            prettyDatum (depth+1) <$> xs
+      Ordinary; NSpecial _ -> pparen depth $
+        group . align . vsep $
+          prettyDatum (depth+1) <$> xs
 
 pparen depth = enclose (delim depth "(") (delim depth ")")
 delim depth = annotate (SynParen depth)
@@ -60,14 +76,13 @@ delimited depth open close =
 prettySimple :: Int -> Simple -> Doc Syn
 prettySimple depth = \case
   SimpleBoolean b -> annotate SynConstant $ if b then "#t" else "#f"
-  SimpleNumber n -> annotate SynConstant $ viaShow n
+  SimpleNumber n ->
+    Sci.floatingOrInteger n
+    & either viaShow viaShow
+    & annotate SynConstant
   SimpleString s -> annotate SynString $ viaShow s
   SimpleSymbol s -> pretty s
 
-rdpr n s = rd s >>= traverse_ \x -> do
-                                  putDocW n . prettyDatum 0 $ x
-                                  putStr "\n"
-
 putDoc :: Doc Syn -> IO ()
 putDoc = ANSI.renderIO stdout
   . reAnnotateS highlight . layoutSmart defaultLayoutOptions . (<>"\n")

src/Gyehoek/Sexp/Read.hs

@@ -1,7 +1,7 @@
 module Gyehoek.Sexp.Read
   ( readFile
   , readString
-  , rd
+  , readString1
   ) where
 
 import Text.Megaparsec
@@ -18,6 +18,7 @@ import qualified Data.Text as T
 import Data.Char (GeneralCategory(..), generalCategory)
 import Control.Exception hiding (try)
 import Data.Scientific (Scientific)
+import Gyehoek.Jalmot
 
 
 -- i'm lazy
@@ -27,23 +28,24 @@ newtype ReaderError = MkReaderError String
 instance Exception ReaderError where
   displayException (MkReaderError x) = x
 
-  -- temp
+readFile :: (Jalmot :> es, IOE :> es) => FilePath -> Eff es (List Datum)
-rd = runEff . readString
-
-readFile :: IOE :> es => FilePath -> Eff es (List Datum)
 readFile f = do
   s <- liftIO . T.readFile $ f
   case runParser file f s of
     Right x -> pure x
-    Left e -> do
+    Left eb -> throwError . ReaderError $ eb
-      liftIO . throw . MkReaderError . errorBundlePretty $ e
 
-readString :: IOE :> es => Text -> Eff es (List Datum)
+readString :: Jalmot :> es => Text -> Eff es (List Datum)
 readString s = 
   case runParser file "<none>" s of
     Right x -> pure x
-    Left e -> do
+    Left eb -> throwError . ReaderError $ eb
-      liftIO . throw . MkReaderError . errorBundlePretty $ e
+
+readString1 :: Jalmot :> es => Text -> Eff es Datum
+readString1 s = 
+  case runParser (sc *> datum <* eof) "<none>" s of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
 
 type P = Parsec Void Text
 
@@ -141,12 +143,14 @@ file :: P (List Datum)
 file = many datum <* eof
 
 datum :: P Datum
-datum = choice
+datum = do
-  [ (SynNone :<) . CompoundF <$> compoundDatum
+  pos <- getSourcePos
-  , (SynNone :<) . SimpleF <$> simpleDatum
+  (position ?~ pos) <$> choice
-  -- , labeled
+    [ Compound <$> compoundDatum
-  -- , labelRef
+    , Simple <$> simpleDatum
-  ]
+    -- , labeled
+    -- , labelRef
+    ]
 
 simpleDatum :: P Simple
 simpleDatum = choice

src/Gyehoek/Sexp/Syntax.hs

@@ -33,18 +33,24 @@ module Gyehoek.Sexp.Syntax
   , pattern Character
   , pattern Number
   , pattern Boolean
+  , Ann(..)
+  , noAnn
+  , ann
+  , pattern List'
+  , position
   ) where
 
 import Language.Haskell.TH.Syntax (Lift)
 import Data.Scientific (Scientific)
 import Data.ByteString (ByteString)
 import Gyehoek.Prelude hiding ((:<), Simple)
-import Text.Megaparsec.Pos (SourcePos(..))
+import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty)
 import Control.Comonad.Cofree (Cofree((:<)), _extract)
 import Data.Fix (Fix (..))
 import Data.Functor.Foldable
 import Text.Show.Deriving (deriveShow1)
 import qualified Control.Comonad.Trans.Cofree as F
+import Prettyprinter (Pretty (pretty), viaShow)
 
 
 data DatumF a
@@ -62,6 +68,8 @@ data Simple
   | SimpleString Text
   | SimpleSymbol Text
   | SimpleBytevector ByteString
+  | SimpleMeta Text
+  | SimpleMetaSplice Text
   deriving stock (Show, Eq, Data, Generic, Lift)
   deriving anyclass (NFData)
 
@@ -92,7 +100,7 @@ newtype Label = MkLabel Natural
 
 
 
-type Datum = Cofree DatumF Syn
+type Datum = Cofree DatumF Ann
 type Compound = CompoundF Datum
 
 data Indentation
@@ -109,15 +117,37 @@ data Syn
   | SynString
   | SynConstant
   | SynNone
-  deriving (Show, Read)
+  deriving (Show, Read, Data, Generic, Eq, Lift)
+
+data Ann = MkAnn
+  { syntax :: Syn
+  , position :: Maybe SourcePos
+  }
+  deriving (Show, Data, Eq, Generic)
+
+noAnn :: Ann
+noAnn = MkAnn
+  { syntax = SynNone
+  , position = Nothing
+  }
+
+-- requisite of the Pretty instance for invertible-grammar's error type.
+instance Pretty Ann where
+  pretty = pretty . maybe "<unknown>" sourcePosPretty . view #position
 
 
 
 deriveShow1 ''CompoundF
 deriveShow1 ''DatumF
 
+ann :: Lens' Datum Ann
+ann = _extract
+
 syntax :: Lens' Datum Syn
-syntax = _extract
+syntax = ann . #syntax
+
+position :: Lens' Datum (Maybe SourcePos)
+position = ann . #position
 
 indentation :: Traversal' Datum Indentation
 indentation k (syn :< CompoundF (ListF ind xs)) = do
@@ -126,42 +156,46 @@ indentation k (syn :< CompoundF (ListF ind xs)) = do
 indentation k a = pure a
 
 adorn :: Syn -> Datum -> Datum
-adorn syn (_ :< d) = syn :< d
+adorn = set syntax
 
 indentWith :: Indentation -> Datum -> Datum
 indentWith = set indentation
 
 pattern Simple :: Simple -> Datum
 pattern Simple a <- _ :< SimpleF a
-  where Simple a = SynNone :< SimpleF a
+  where Simple a = noAnn :< SimpleF a
 
 pattern Compound :: CompoundF Datum -> Datum
 pattern Compound a <- _ :< CompoundF a
-  where Compound a = SynNone :< CompoundF a
+  where Compound a = noAnn :< CompoundF a
 
 pattern Labeled :: Label -> Datum -> Datum
 pattern Labeled l a <- _ :< LabeledF l a
-  where Labeled l a = SynNone :< LabeledF l a
+  where Labeled l a = noAnn :< LabeledF l a
 
 pattern LabelRef :: Label -> Datum
 pattern LabelRef l <- _ :< LabelRefF l
-  where LabelRef l = SynNone :< LabelRefF l
+  where LabelRef l = noAnn :< LabelRefF l
 
 pattern List :: List Datum -> Datum
 pattern List a <- _ :< CompoundF (ListF _ a)
-  where List a = SynNone :< CompoundF (ListF Ordinary a)
+  where List a = noAnn :< CompoundF (ListF Ordinary a)
+
+pattern List' :: Indentation -> List Datum -> Datum
+pattern List' ind a <- _ :< CompoundF (ListF ind a)
+  where List' ind a = noAnn :< CompoundF (ListF ind a)
 
 pattern DotList :: NonEmpty Datum -> Datum -> Datum
 pattern DotList xs x <- _ :< CompoundF (DotListF xs x)
-  where DotList xs x = SynNone :< CompoundF (DotListF xs x)
+  where DotList xs x = noAnn :< CompoundF (DotListF xs x)
 
 pattern Vector :: [Datum] -> Datum
 pattern Vector xs <- _ :< CompoundF (VectorF xs)
-  where Vector xs = SynNone :< CompoundF (VectorF xs)
+  where Vector xs = noAnn :< CompoundF (VectorF xs)
 
 pattern Abbrev :: Prefix -> Datum -> Datum
 pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a)
-  where Abbrev p a = SynNone :< CompoundF (AbbrevF p a)
+  where Abbrev p a = noAnn :< CompoundF (AbbrevF p a)
 
 pattern Boolean a = Simple (SimpleBoolean a)
 pattern Number a = Simple (SimpleNumber a)

test/Main.hs

@@ -1,14 +1,6 @@
 module Main (main) where
 
--- import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Silver.Interactive (defaultMain)
--- import qualified Gyehoek.Test.Golden
--- import qualified Gyehoek.Test.Sexp
--- import qualified Gyehoek.Test.CPS.Syntax
--- import qualified Gyehoek.Test.Scheme.Syntax
--- import qualified Gyehoek.Test.Stack.VM
--- import qualified Gyehoek.Test.CPS.Stackify
--- import qualified Gyehoek.Test.CPS.Eval
 import qualified Root
 
 

test/doctest.hs

@@ -0,0 +1,7 @@
+module Main where
+
+import Test.DocTest (mainFromCabal)
+import System.Environment (getArgs)
+
+main :: IO ()
+main = mainFromCabal "gyehoek" =<< getArgs