parse/print libraries

src/Gyehoek/Scheme/Syntax.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE OrPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE ViewPatterns #-}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Prim(..)
@@ -53,6 +54,8 @@ import Gyehoek.Sexp.Grammar qualified as Sexp
 import Gyehoek.Sexp.Grammar qualified as S
 import Gyehoek.Sexp.Grammar (DatumIso, G, DataIso, (:-)((:-)))
 import Gyehoek.Prelude
+import Control.Lens.Extras (is)
+import qualified Data.Scientific as Sci
 
 
 newtype Name = MkName { inner :: Text }
@@ -130,8 +133,37 @@ data CommandOrDef
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-newtype Program = MkProgram
-  { commandsAndDefs :: List CommandOrDef
+newtype LibName = MkLibName { inner :: NonEmpty Name }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data ImportSet
+  = ImportLib LibName
+  | ImportOnly ImportSet (NonEmpty Name)
+  | ImportExcept ImportSet (NonEmpty Name)
+  | ImportPrefix ImportSet Name
+  | ImportRename ImportSet (NonEmpty (Name, Name))
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+newtype ImportDecl = MkImportDecl (NonEmpty ImportSet)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data LibDecl
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Lib = MkLib
+  { name :: LibName
+  , decls :: List LibDecl
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Program = MkProgram
+  { imports :: List ImportDecl
+  , commandsAndDefs :: List CommandOrDef
   }
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -244,8 +276,58 @@ instance DatumIso CommandOrDef where
     $ S.With (\_Begin -> _Begin . S.beginLike "begin" (S.rest S.datumIso))
     $ S.End
 
+instance DatumIso LibName where
+  datumIso = S.with \g ->
+    S.list (S.restData $ S.nonEmptyData comp)
+    >>> g
+    where
+      comp = S.partialOsi
+        (\case
+          S.Symbol s -> Right $ MkName s
+          S.Number (Sci.floatingOrInteger @Double @Int -> Right n)
+            | n > 0 -> Right $ MkName [i|#{n}|]
+          _ -> Left $ S.expected "library name part"
+          )
+        \(MkName s) -> S.Symbol s
+
+instance DatumIso ImportSet where
+  datumIso = S.match
+    $ S.With (S.datumIso @LibName >>>)
+    $ S.With (imp "only" >>>)
+    $ S.With (imp "except" >>>)
+    $ S.With (imp' "prefix" >>>)
+    $ S.With (imp "rename" >>>)
+    $ S.End
+    where
+      imp s = S.list $ S.el (S.symBuiltin s)
+        >>> S.el S.datumIso >>> S.restData S.dataIso
+      imp' s = S.list $
+        S.el (S.symBuiltin s)
+        >>> S.el S.datumIso
+        >>> S.el S.datumIso
+
+instance DatumIso ImportDecl where
+  datumIso = S.with \decl ->
+    S.list (S.el (S.symBuiltin "import") >>> S.restData S.dataIso)
+    >>> decl
+
 instance DataIso Program where
-  dataIso = S.dataIso @(List CommandOrDef) >>> S.iso coerce coerce
+  dataIso = S.with \g ->
+    splitG
+    >>> S.onHead (S.sealed S.dataIso)
+    >>> S.onTail (S.onHead . S.sealed $ S.dataIso)
+    >>> g
+    where
+      isImport = \case
+        S.List (S.Symbol "import" : _) -> True
+        _ -> False
+      splitG :: G (List S.Datum :- t) (List S.Datum :- List S.Datum :- t)
+      splitG = S.Iso
+        (\(xs:-t) ->
+          let (ys,zs) = span isImport xs
+          in zs :- ys :- t
+        )
+        \(zs:-ys:-t) -> (ys ++ zs) :- t
 
 
 -- utilities

src/Gyehoek/Sexp/Grammar.hs

@@ -49,6 +49,7 @@ import qualified Data.Vector as V
 import Data.String (IsString (fromString))
 import qualified Data.Text as T
 import System.Environment (lookupEnv)
+import Data.Foldable (toList)
 
 
 toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
@@ -187,5 +188,8 @@ instance DatumIso a => DataIso (V.Vector a) where
   dataIso = iso fromList V.toList
     >>> (onHead . traversed . sealed $ datumIso @a)
 
+instance DatumIso a => DataIso (NonEmpty a) where
+  dataIso = nonEmptyData datumIso
+
 instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
   datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -17,6 +17,7 @@ module Gyehoek.Sexp.Grammar.Base
   , el
   , rest
   , restData
+  , nonEmptyData
   , headTagged0'
   , headTagged0
   , headTagged1'
@@ -32,6 +33,8 @@ module Gyehoek.Sexp.Grammar.Base
   , integer
   , int
   , unreadable
+  -- ** symbols
+  , symBuiltin
   -- * TODO: sort lol
   , prismIso
   , isoIso, decorate
@@ -49,7 +52,7 @@ import Data.InvertibleGrammar.Base
 import Data.InvertibleGrammar.Base as Re
   ( Grammar(..))
 import Data.InvertibleGrammar.Combinators
-import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple)
+import Gyehoek.Prelude hiding (traversed, iso, cons, coerced, Iso, Simple, simple)
 import Gyehoek.Sexp.Syntax hiding (position)
 import Gyehoek.Sexp.Print (printDatum')
 import Data.Scientific (Scientific)
@@ -57,6 +60,7 @@ import qualified Data.Scientific as Sci
 import qualified Data.Text as T
 import Control.Monad.RWS (modify)
 import qualified Data.List.NonEmpty as NE
+import Data.Foldable (toList)
 
 
 -- $setup
@@ -238,6 +242,14 @@ restData g =
   >>> g
   >>> push (MkListContext []) (const True) mempty
 
+nonEmptyData :: DatumGrammar a -> DataGrammar (NonEmpty a)
+nonEmptyData g = partialOsi
+    (\case
+      [] -> Left $ expected "non-empty sequence"
+      x:xs -> Right $ x:|xs)
+    toList
+  >>> (onHead . traversed . sealed $ g)
+
 snoced
   :: Snoc s s a a
   => Grammar p (s :- a :- t) (s :- t)