parse meta vars

golden/read/meta-expression/read

@@ -0,0 +1,12 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-expression/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleMeta "aHaskellVariable + abc * 2" )
+]

golden/read/meta-expression/source.scm

@@ -0,0 +1 @@
+#{aHaskellVariable + abc * 2}

golden/read/meta-splice-expression/read

@@ -0,0 +1,12 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-splice-expression/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleMetaSplice "takeWhile (\x -> even x) aHaskellList" )
+]

golden/read/meta-splice-expression/source.scm

@@ -0,0 +1 @@
+##{takeWhile (\x -> even x) aHaskellList}

golden/read/meta-splice-variable/read

@@ -0,0 +1,12 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-splice-variable/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleMetaSplice "aHaskellList" )
+]

golden/read/meta-splice-variable/source.scm

@@ -0,0 +1 @@
+##{aHaskellList}

golden/read/meta-variable/read

@@ -0,0 +1,12 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-variable/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleMeta "aHaskellVariable" )
+]

golden/read/meta-variable/source.scm

@@ -0,0 +1 @@
+#{aHaskellVariable}

gyehoek.cabal

@@ -131,7 +131,9 @@ test-suite test
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp
     Gyehoek.Test.Sexp.Print
+    Gyehoek.Test.Sexp.Read
     Gyehoek.Test.Stack.VM
+    Gyehoek.TestUtil
     Root
 
   build-depends:

src/Gyehoek/CPS/Syntax.hs

@@ -18,7 +18,6 @@ module Gyehoek.CPS.Syntax
   , Imm(..)
   , Obj(..)
   , Hob(..)
-  , pattern Void
   , pattern Halt
   , pattern Halt1
   , _MkKappa
@@ -43,7 +42,7 @@ module Gyehoek.CPS.Syntax
 
 import Language.SexpGrammar qualified as S
 import Gyehoek.Sexp qualified
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..))
 import Language.SexpGrammar.Generic
 import Control.Category
 import Prelude hiding ((.), id)

src/Gyehoek/Jalmot.hs

@@ -2,6 +2,7 @@ module Gyehoek.Jalmot
   ( Jalmot
   , Exception(..)
   , AJalmot(..)
+  , AJalmotCS(..)
   , module Effectful.Error.Static
   , runJalmot
   , runJalmotIO
@@ -12,7 +13,7 @@ module Gyehoek.Jalmot
 import Gyehoek.Prelude
 import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
 import Data.Void (Void)
-import Control.Exception.Base (Exception(..), throwIO)
+import Effectful.Exception
 import Effectful.Error.Static
 import qualified Data.InvertibleGrammar as Grammar
 import Gyehoek.Sexp.Syntax (Ann)
@@ -28,7 +29,7 @@ data AJalmot
   | GrammarError (Grammar.ErrorMessage Ann)
   deriving (Show, Generic, Data)
 
-data AJalmotWithCallStack = MkAJalmotWithCallStack !CallStack !AJalmot
+data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
   deriving (Show)
 
 type Jalmot = Error AJalmot
@@ -40,7 +41,7 @@ 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
+    Left (cs,jm) -> throwIO $ MkAJalmotCS cs jm
 
 runJalmotIO :: Eff '[Jalmot, IOE] a -> IO a
 runJalmotIO = runEff . runJalmotIOE
@@ -53,7 +54,7 @@ instance Exception AJalmot where
         & layoutPretty defaultLayoutOptions
         & renderString
 
-instance Exception AJalmotWithCallStack where
+instance Exception AJalmotCS where
   backtraceDesired = const False
-  displayException (MkAJalmotWithCallStack cs jm) =
+  displayException (MkAJalmotCS cs jm) =
     "\n" <> displayException jm <> "\n\n" <> prettyCallStack cs

src/Gyehoek/Sexp/Read.hs

@@ -11,23 +11,14 @@ import Data.Void (Void)
 import Gyehoek.Sexp.Syntax
 import Gyehoek.Prelude hiding (Simple, (:<))
 import qualified Data.Text.IO as T
-import System.IO (stderr, hPutStrLn)
 import Prelude hiding (readFile)
-import Data.Functor (($>), void)
+import Data.Functor (($>))
 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
-newtype ReaderError = MkReaderError String
-  deriving (Show)
-
-instance Exception ReaderError where
-  displayException (MkReaderError x) = x
-
 readFile :: (Jalmot :> es, IOE :> es) => FilePath -> Eff es (List Datum)
 readFile f = do
   s <- liftIO . T.readFile $ f
@@ -52,7 +43,9 @@ type P = Parsec Void Text
 
 --- lexer helpers
 
--- TODO: check R⁷RS
+-- TODO: check R⁷RS's definition of ⟨atmosphere⟩.
+-- TODO: datum comments.
+-- | whitespace consumer.
 sc :: P ()
 sc = L.space space1
   (L.skipLineComment ";")
@@ -61,6 +54,7 @@ sc = L.space space1
 lexeme :: P a -> P a
 lexeme = L.lexeme sc
 
+-- | verbatim text.
 verb :: Text -> P Text
 verb = L.symbol sc
 
@@ -92,6 +86,7 @@ identifier = label "identifier" . lexeme . choice $
       , ModifierSymbol, OtherSymbol, PrivateUse ]
       || c == '\x200c' || c == '\x200d')
       && c /= ';' && c /= '|' && c /= '"' && c /= '.'
+      && c /= ',' && c /= '#'
 
 boolean :: P Bool
 boolean = label "boolean" . lexeme $ choice
@@ -137,6 +132,14 @@ string = label "string" . lexeme $
       , "\\\\" $> '\\'
       ]
 
+metaSplice :: P Text
+metaSplice = label "splicing meta" . lexeme . between "##{" "}" $
+  takeWhileP Nothing (/= '}')
+
+meta :: P Text
+meta = label "meta" . lexeme . between "#{" "}" $
+  takeWhileP Nothing (/= '}')
+
 
 
 file :: P (List Datum)
@@ -160,6 +163,8 @@ simpleDatum = choice
   , SimpleString <$> string
   , SimpleSymbol <$> symbol
   -- , SimpleBytevector <$> bytevector
+  , SimpleMetaSplice <$> metaSplice
+  , SimpleMeta <$> meta
   ]
 
 compoundDatum :: P Compound

test/Gyehoek/Test/Golden.hs

@@ -35,12 +35,6 @@ brokenStackifyTests =
   -- , "callcc-nested1" -- requires closure-conversion
   -- ]
 
-brokenReaderTests =
-  [ "delimited-identifier"
-  , "string-line-continuation"
-  , "peculiar-identifier-dot"
-  ]
-
 test_root :: IO TestTree
 test_root = do
   all_cases <- listDirectory "golden/exec"
@@ -91,22 +85,3 @@ stackifyTests files = do
        resultfile
        action
        printProcResult
-
-test_reader :: IO TestTree
-test_reader = do
-  all_cases <- listDirectory "golden/read"
-  let tests = all_cases
-            & fmap ("golden/read"</>)
-  pure . testGroup "reader" $ tests <&> \test ->
-    let testname = takeFileName test
-        scmfile = test </> "source.scm"
-        resultfile = test </> "read"
-        action = runEff $ Read.readFile scmfile
-    in maybeBroken testname brokenReaderTests $ goldenVsAction
-        testname
-        resultfile
-        action
-        (view strict . pShowNoColor)
-
--- readTests files = pure . testGroup "reader" $ files <&> \test ->
---   let

test/Gyehoek/Test/Sexp/Read.hs

@@ -0,0 +1,58 @@
+module Gyehoek.Test.Sexp.Read where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Silver
+import System.FilePath
+import Data.List (List)
+import System.Directory
+import Gyehoek.Prelude
+import qualified Gyehoek.Sexp.Read as Read
+import Gyehoek.TestUtil
+import Gyehoek.Jalmot (runJalmotIO)
+import Text.Pretty.Simple (pShowNoColor)
+import Gyehoek.Sexp.Syntax
+import Test.Tasty.HUnit
+import Control.Exception (tryWithContext, ExceptionWithContext (..), rethrowIO)
+import Gyehoek.Jalmot
+
+
+brokenReaderTests :: List String
+brokenReaderTests =
+  [ "delimited-identifier"
+  , "string-line-continuation"
+  , "peculiar-identifier-dot"
+  ]
+
+test_golden :: IO TestTree
+test_golden = do
+  all_cases <- listDirectory "golden/read"
+  let tests = all_cases
+            & fmap ("golden/read"</>)
+  pure . testGroup "reader" $ tests <&> \test ->
+    let testname = takeFileName test
+        scmfile = test </> "source.scm"
+        resultfile = test </> "read"
+        action = runJalmotIO $ Read.readFile scmfile
+    in markIfBroken testname brokenReaderTests $ goldenVsAction
+        testname
+        resultfile
+        action
+        (view strict . pShowNoColor)
+
+readString1 = runJalmotIO . Read.readString1
+
+test_invalidIdentifiers :: TestTree
+test_invalidIdentifiers = testGroup "invalid identifiers"
+  [ testCase "dot" $ notIdentifier (readString1 ".")
+  , testCase "comma" $ notIdentifier (readString1 ",")
+  , testCase "pound" $ notIdentifier (readString1 "#")
+  , testCase "pound anything" $ notIdentifier (readString1 "#abc")
+  ]
+  where
+    notIdentifier m = tryWithContext m >>= \case
+      -- the reader is allowed to fail; we're just don't want it to
+      -- return a symbol.
+      Left (ExceptionWithContext _ (MkAJalmotCS _ (ReaderError _))) -> pure ()
+      Left e -> rethrowIO e
+      Right (Symbol s) -> assertFailure [i|got symbol #{s}|]
+      Right _ -> pure ()

test/Gyehoek/TestUtil.hs

@@ -0,0 +1,11 @@
+module Gyehoek.TestUtil
+  ( markIfBroken
+  ) where
+
+import Test.Tasty.ExpectedFailure (expectFail)
+import Data.Function
+import Test.Tasty (TestTree)
+
+
+markIfBroken :: Foldable f => String -> f String -> TestTree -> TestTree
+markIfBroken name brokenTests = applyWhen (name `elem` brokenTests) expectFail