wip: reader

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
-  | SimpleNumber Scientific
-  | SimpleChar Char
-  | SimpleString Text
-  | SimpleSymbol Text
-  | SimpleBytevector ByteString
+  = Boolean Bool
+  | Number Scientific
+  | Character Char
+  | String Text
+  | Symbol Text
+  | 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