wip: reader

golden/reader/bool/read

@@ -0,0 +1,9 @@
+[ Fix
+    ( SimpleF ( Boolean True ) )
+, Fix
+    ( SimpleF ( Boolean True ) )
+, Fix
+    ( SimpleF ( Boolean False ) )
+, Fix
+    ( SimpleF ( Boolean False ) )
+]

golden/reader/bool/source.scm

@@ -0,0 +1 @@
+#t #true #f #false

golden/reader/decimal/read

@@ -0,0 +1,15 @@
+[ Fix
+    ( SimpleF
+        ( Number 45.0 )
+    )
+, Fix
+    ( SimpleF
+        ( Number 5667.0 )
+    )
+, Fix
+    ( SimpleF
+        ( Number
+            ( -123.0 )
+        )
+    )
+]

golden/reader/decimal/source.scm

@@ -0,0 +1 @@
+45 +5667 -123

golden/reader/delimited-identifier/read

@@ -0,0 +1,5 @@
+[ Fix
+    ( SimpleF
+        ( Symbol "aaaa bc" )
+    )
+]

golden/reader/delimited-identifier/source.scm

@@ -0,0 +1 @@
+|aaaa bc|

golden/reader/empty/read

@@ -0,0 +1 @@
+[]

golden/reader/peculiar-identifier/read

@@ -0,0 +1,9 @@
+[ Fix
+    ( SimpleF
+        ( Symbol "+" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "-" )
+    )
+]

golden/reader/peculiar-identifier/source.scm

@@ -0,0 +1 @@
++ -

golden/reader/string-line-continuation/read

@@ -0,0 +1,5 @@
+[ Fix
+    ( SimpleF
+        ( String "가나다라마바" )
+    )
+]

golden/reader/string-line-continuation/source.scm

@@ -0,0 +1,2 @@
+"가나다\
+      라마바"

golden/reader/string/read

@@ -0,0 +1,5 @@
+[ Fix
+    ( SimpleF
+        ( String "가나다라" )
+    )
+]

golden/reader/string/source.scm

@@ -0,0 +1 @@
+"가나다라"

golden/reader/typical-identifier/read

@@ -0,0 +1,29 @@
+[ Fix
+    ( SimpleF
+        ( Symbol "abc" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "balahwa$" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "x!!!" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "z" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "z123" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "나는너무졸리다" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "學" )
+    )
+]

golden/reader/typical-identifier/source.scm

@@ -0,0 +1 @@
+abc balahwa$ x!!! z z123 나는너무졸리다 學

gyehoek.cabal

@@ -77,12 +77,16 @@ library
     , base                  ^>=4.21.2.0
     , binary
     , bytestring
+    , comonad
     , containers
+    , data-fix
     , deepseq
+    , deriving-compat
     , effectful
     , effectful-core
     , effectful-plugin
     , filepath
+    , free
     , generic-lens
     , hashable
     , invertible-grammar
@@ -114,6 +118,8 @@ test-suite test
   hs-source-dirs:     test
   main-is:            Main.hs
   build-tool-depends: tasty-discover:tasty-discover
+
+  -- cabal-fmt: expand test -Main
   other-modules:
     Gyehoek.Test.CPS.Eval
     Gyehoek.Test.CPS.Stackify
@@ -133,6 +139,7 @@ test-suite test
     , generic-lens
     , gyehoek
     , lens
+    , pretty-simple
     , process-extras
     , sexp-grammar
     , tasty

src/Gyehoek/Prelude.hs

@@ -21,7 +21,7 @@ module Gyehoek.Prelude
 import Control.Lens
 import Data.List (List)
 import Data.Text (Text)
-import Effectful (Eff, runEff, runPureEff, (:>))
+import Effectful
 import GHC.Generics (Generic)
 import Data.Data (Data)
 import Control.DeepSeq (NFData)

src/Gyehoek/Sexp/Read.hs

@@ -1,4 +1,133 @@
 module Gyehoek.Sexp.Read
-  (
+  ( readFile
   ) where
 
+import Text.Megaparsec
+import Text.Megaparsec.Char hiding (string)
+import qualified Text.Megaparsec.Char.Lexer as L
+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 (($>))
+import qualified Data.Text as T
+import Data.Char (GeneralCategory(..), generalCategory)
+import Control.Exception hiding (try)
+import Data.Scientific (Scientific)
+
+
+-- i'm lazy
+newtype ReaderError = MkReaderError String
+  deriving (Show)
+
+instance Exception ReaderError where
+  displayException (MkReaderError x) = x
+
+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
+      -- liftIO . hPutStrLn stderr . errorBundlePretty $ e
+      liftIO . throw . MkReaderError . errorBundlePretty $ e
+
+type P = Parsec Void Text
+
+
+--- lexer helpers
+
+-- TODO: check R⁷RS
+sc :: P ()
+sc = L.space space1
+  (L.skipLineComment ";")
+  (L.skipBlockCommentNested "#|" "|#")
+
+lexeme :: P a -> P a
+lexeme = L.lexeme sc
+
+verb :: Text -> P Text
+verb = L.symbol sc
+
+
+--- tokens
+
+identifier :: P Text
+identifier = label "identifier" . lexeme . choice $
+  [ typical-- , delimited, peculiar
+                    ]
+  where
+    typical = T.cons <$> initial <*> subsequent
+      where
+        subsequent = takeWhileP Nothing identChar
+        initial = satisfy \c ->
+          identChar c && not (c `hasCategory`
+            [DecimalNumber,SpacingCombiningMark,EnclosingMark])
+    delimited = _
+    peculiar = _
+
+    hasCategory c xs = generalCategory c `elem` xs
+    identChar c = c `hasCategory`
+      [ UppercaseLetter, LowercaseLetter, TitlecaseLetter, ModifierLetter
+      , OtherLetter, SpacingCombiningMark, EnclosingMark, DecimalNumber
+      , LetterNumber, OtherNumber, DashPunctuation, ConnectorPunctuation
+      , OpenPunctuation, CurrencySymbol, OtherPunctuation, MathSymbol
+      , ModifierSymbol, OtherSymbol, PrivateUse ]
+      || c == '\x200c' || c == '\x200d'
+
+boolean :: P Bool
+boolean = label "boolean" . lexeme $ choice
+  [ ("#true" <|> "#t") $> True
+  , ("#false" <|> "#f") $> False
+  ]
+
+symbol = identifier
+
+number :: P Scientific
+number = label "number" . lexeme $ num
+  where
+    num = L.signed (pure ()) L.decimal
+    -- prefix r = _
+    -- radix = \case
+    --   2 -> "#b"
+    --   8 -> "#o"
+    --   10 -> "" <|> "#d"
+    --   16 -> "#x"
+
+lparen = lexeme $ char '('
+rparen = lexeme $ char ')'
+
+string :: P Text
+string = label "string" . lexeme $
+  char '"' *> (T.pack <$> many element) <* char '"'
+  where
+    element = choice
+      [ satisfy (\c -> c /= '"' && c /= '\\')
+      , "\\\"" $> '"'
+      , "\\\\" $> '\\'
+      ]
+
+
+
+file :: P (List Datum)
+file = many datum <* eof
+
+datum :: P Datum
+datum = choice
+  [ Fix . SimpleF <$> simpleDatum
+  -- , Fix . CompoundF <$> compoundDatum
+  -- , labeled
+  -- , labelRef
+  ]
+
+simpleDatum :: P Simple
+simpleDatum = choice
+  [ Boolean <$> boolean
+  , Number <$> try number
+  -- , Character <$> character
+  , String <$> string
+  , Symbol <$> symbol
+  -- , Bytevector <$> bytevector
+  ]

src/Gyehoek/Sexp/Syntax.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Gyehoek.Sexp.Syntax
   ( DatumF(..)
   , Simple(..)
@@ -6,12 +7,22 @@ module Gyehoek.Sexp.Syntax
   , Prefix(..)
   , Delimiter(..)
   , Label(..)
+  , SourcePos(..)
+  , Datum
+  , Cofree((:<))
+  , Fix(..)
   ) where
 
 import Language.Haskell.TH.Syntax (Lift)
 import Data.Scientific (Scientific)
 import Data.ByteString (ByteString)
-import Gyehoek.Prelude hiding (Simple)
+import Gyehoek.Prelude hiding ((:<), Simple)
+import Text.Megaparsec.Pos (SourcePos(..))
+import Control.Comonad.Cofree (Cofree((:<)))
+import Data.Fix (Fix (..))
+import Data.Functor.Foldable
+import Text.Show.Deriving (deriveShow1)
+import qualified Control.Comonad.Trans.Cofree as F
 
 
 data DatumF a
@@ -19,16 +30,16 @@ data DatumF a
   | CompoundF (CompoundF a)
   | LabeledF Label a
   | LabelRefF Label
-  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
   deriving anyclass (NFData)
 
 data Simple
-  = SimpleBool Bool
+  = Boolean Bool
-  | SimpleNumber Scientific
+  | Number Scientific
-  | SimpleChar Char
+  | Character Char
-  | SimpleString Text
+  | String Text
-  | SimpleSymbol Text
+  | Symbol Text
-  | SimpleBytevector ByteString
+  | Bytevector ByteString
   deriving stock (Show, Eq, Data, Generic, Lift)
   deriving anyclass (NFData)
 
@@ -37,7 +48,7 @@ data CompoundF a
   | DotListF (NonEmpty a) a
   | VectorF (List a)
   | AbbrevF Prefix a
-  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
   deriving anyclass (NFData)
 
 data Prefix
@@ -56,3 +67,10 @@ newtype Label = MkLabel Natural
   deriving stock (Data, Generic, Lift)
   deriving newtype (Eq, Ord, Show)
   deriving anyclass (NFData)
+
+deriveShow1 ''CompoundF
+deriveShow1 ''DatumF
+
+
+
+type Datum = Fix DatumF

test/Gyehoek/Test/Golden.hs

@@ -16,6 +16,10 @@ import Data.Text qualified as T
 import System.Exit (ExitCode(..))
 import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
 import Control.DeepSeq (($!!))
+import Text.Pretty.Simple (pShow, pShowNoColor)
+import Control.Lens (strict, view)
+import Gyehoek.Sexp.Read qualified as Read
+import Effectful
 
 
 brokenWasmTests :: List String
@@ -31,12 +35,17 @@ brokenStackifyTests =
   -- , "callcc-nested1" -- requires closure-conversion
   -- ]
 
+brokenReaderTests =
+  [ "delimited-identifier"
+  , "string-line-continuation"
+  ]
+
 test_root :: IO TestTree
 test_root = do
-  all_cases <- listDirectory "golden"
+  all_cases <- listDirectory "golden/exec"
   let tests = all_cases
-            & fmap ("golden"</>)
+            & fmap ("golden/exec"</>)
-  testGroup "golden" <$> sequenceA
+  testGroup "execution" <$> sequenceA
     [ ignoreTestBecause "wasm codegen is on the backburner"
       <$> wasmTests tests
     , stackifyTests tests
@@ -48,7 +57,7 @@ wasmTests :: List FilePath -> IO TestTree
 wasmTests files = do
   cmd <- getEnvDefault "GYEHOEK_RUNTIME"
     "runtime/target/debug/gyehoek-runtime"
-  pure $ testGroup "wasm execution" $ files <&> \test ->
+  pure $ testGroup "wasm" $ files <&> \test ->
     let testname = takeFileName test
         scmfile = test </> "source.scm"
         resultfile = test </> "exec"
@@ -64,7 +73,7 @@ wasmTests files = do
 
 stackifyTests :: List FilePath -> IO TestTree
 stackifyTests files = do
-  pure $ testGroup "stackified execution" $ files <&> \test ->
+  pure $ testGroup "stackified" $ files <&> \test ->
     let testname = takeFileName test
         scmfile = test </> "source.scm"
         resultfile = test </> "exec"
@@ -81,3 +90,22 @@ stackifyTests files = do
        resultfile
        action
        printProcResult
+
+test_reader :: IO TestTree
+test_reader = do
+  all_cases <- listDirectory "golden/reader"
+  let tests = all_cases
+            & fmap ("golden/reader"</>)
+  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