diff --git a/cabal.project b/cabal.project index b50cb5f..610c695 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,7 @@ packages: *.cabal tests: True +-- required for doctest-parallel +write-ghc-environment-files: always source-repository-package type: git diff --git a/gyehoek.cabal b/gyehoek.cabal index 1edac77..9259fd7 100644 --- a/gyehoek.cabal +++ b/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 diff --git a/src/Gyehoek/Jalmot.hs b/src/Gyehoek/Jalmot.hs new file mode 100644 index 0000000..705a911 --- /dev/null +++ b/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 diff --git a/src/Gyehoek/Prelude.hs b/src/Gyehoek/Prelude.hs index ff3314a..5327396 100644 --- a/src/Gyehoek/Prelude.hs +++ b/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 diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 8981c54..8f3da10 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -17,11 +17,9 @@ module Gyehoek.Scheme.Syntax , Def(..) , Exp(..) , ExpF(..) - , Sexp(..) , Program(..) , CommandOrDef(..) - , primSexpIso - , pattern Void + , primDatumIso , 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 - sexpIso = symbol >>> Sexp.partialOsi f g +instance DatumIso Name where + 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 - g (MkName s) = s + idn = S.el . S.sym . namefn + 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) -primSexpIso namefn a = match - $ With (. ht2 "+") - $ With (. ht2 "-") - $ With (. ht2 "*") - $ With (. ht2 "/") - $ With (. ht2 "cons") - $ With (. ht1 "car") - $ With (. ht1 "cdr") - $ With (. ht1 "immediate?") - $ With (. ht1 "cons?") - $ With (. ht1 "integer?") - $ With (. ht1 "write") - $ With (. ht1 "zero?") - $ With (. nullop "newline") - $ With (. ht1' "make-closure") - $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int) - $ With (. ht1 "env-code") - $ With (. ht1 "call/cc") - $ End +instance DatumIso a => DatumIso (Prim a) where + -- datumIso = primDatumIso ("prim:"<>) datumIso + datumIso = primDatumIso id S.datumIso + +instance DatumIso Lit where + datumIso = S.match + $ S.With (. S.int) + $ S.With (. S.boolean) + $ S.With (. S.string) + $ S.End + +instance DatumIso Def where + datumIso = S.match + $ S.With (. defconst) + $ S.With (. defun) + $ S.End where - idn s = el (sym (namefn s)) - nullop s = list $ idn s - ht1 s = GS.headTagged1 (namefn s) a - ht2 s = GS.headTagged2 (namefn s) a a - ht1' s = GS.headTagged1' (namefn s) a a - -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 + defconst = S.list $ S.el (S.sym "define") + >>> S.el S.datumIso >>> S.el S.datumIso + defun = S.list $ S.el (S.sym "define") + >>> S.el args >>> S.rest S.datumIso + args = S.list $ S.el S.datumIso >>> S.rest S.datumIso -instance SexpIso Exp where - sexpIso = match - $ With (. GS.let_ "let" sexpIso sexpIso sexpIso) - $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso) - $ With (. sexpIso) - $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso)) - $ With (. if_) - $ With (. sexpIso) - $ With (. lam) - $ With (. sexpIso) - $ With (\app -> app . list (el sexpIso >>> rest sexpIso)) - $ End +instance DatumIso Exp where + datumIso = S.match + $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso) + $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso) + $ S.With (. S.datumIso) + $ S.With (. S.beginLike "begin" S.datumIso) + $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso) + $ S.With (. S.datumIso) + $ S.With (. lam) + $ S.With (. S.datumIso) + $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso)) + $ S.End where - if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso - lam = list - ( el GS.lambdaKeyword - >>> el (sexpIso @(List Name)) - >>> el sexpIso ) + lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso) -instance SexpIso CommandOrDef where - sexpIso = match - $ With (\_Command -> _Command . sexpIso) - $ With (\_Definition -> _Definition . sexpIso) - $ With (\_Begin -> _Begin . bgn) - $ End - where - bgn = list $ el (sym "begin") >>> rest sexpIso +instance DatumIso CommandOrDef where + datumIso = S.match + $ S.With (\_Command -> _Command . S.datumIso) + $ S.With (\_Definition -> _Definition . S.datumIso) + $ S.With (\_Begin -> _Begin . S.beginLike "begin" S.datumIso) + $ S.End -- utilities diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index 1d908f3..b321b5b 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -1,4 +1,97 @@ module Gyehoek.Sexp.Grammar - ( - ) where + ( module Gyehoek.Sexp.Grammar.Base + , 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 diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs new file mode 100644 index 0000000..481280b --- /dev/null +++ b/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: +-- :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 diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index 7d0421c..aba1df2 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/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 - syn :< SimpleF s -> annotate syn $ prettySimple depth s - syn :< CompoundF compound -> case compound of - ListF indent xs -> - case indent of - NSpecial n | keyword:args <- xs -> - let (specialArgs,body) = splitAt n args - in pparen depth . nest 2 . vsep $ - [ group . nest 2 . hcat $ - [ prettyDatum (depth+1) keyword - , if null specialArgs then mempty else softline - , hsep $ prettyDatum (depth+1) <$> specialArgs - ] - , vsep $ prettyDatum (depth+1) <$> body +prettyDatum depth datum = case datum of + Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp + List' indent xs -> + case indent of + NSpecial n | keyword:args <- xs -> + let (specialArgs,body) = splitAt n args + in pparen depth . nest 2 . vsep $ + [ group . nest 2 . hcat $ + [ prettyDatum (depth+1) keyword + , if null specialArgs then mempty else softline + , hsep $ prettyDatum (depth+1) <$> specialArgs ] - Ordinary; NSpecial _ -> pparen depth $ - group . align . vsep $ - prettyDatum (depth+1) <$> xs + , vsep $ prettyDatum (depth+1) <$> body + ] + 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") diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index ebccb9c..11c3a72 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/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 -rd = runEff . readString - -readFile :: IOE :> es => FilePath -> Eff es (List Datum) +readFile :: (Jalmot :> es, 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 - liftIO . throw . MkReaderError . errorBundlePretty $ e + Left eb -> throwError . ReaderError $ eb -readString :: IOE :> es => Text -> Eff es (List Datum) +readString :: Jalmot :> es => Text -> Eff es (List Datum) readString s = case runParser file "" s of Right x -> pure x - Left e -> do - liftIO . throw . MkReaderError . errorBundlePretty $ e + Left eb -> throwError . ReaderError $ eb + +readString1 :: Jalmot :> es => Text -> Eff es Datum +readString1 s = + case runParser (sc *> datum <* eof) "" 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 - [ (SynNone :<) . CompoundF <$> compoundDatum - , (SynNone :<) . SimpleF <$> simpleDatum - -- , labeled - -- , labelRef - ] +datum = do + pos <- getSourcePos + (position ?~ pos) <$> choice + [ Compound <$> compoundDatum + , Simple <$> simpleDatum + -- , labeled + -- , labelRef + ] simpleDatum :: P Simple simpleDatum = choice diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index e8c2def..63aac31 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/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 "" 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) diff --git a/test/Main.hs b/test/Main.hs index d4deb30..c023cf9 100644 --- a/test/Main.hs +++ b/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 diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 index 0000000..85fa358 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.DocTest (mainFromCabal) +import System.Environment (getArgs) + +main :: IO () +main = mainFromCabal "gyehoek" =<< getArgs