flake.nix

@@ -55,7 +55,7 @@
                 nodejs
                 wasm-tools
                 wac-cli
-                guile
+                gauche
                 rust-analyzer
                 wasmtime
                 # bashInteractive is necessary to work around an

gyehoek.cabal

@@ -69,6 +69,7 @@ library
     Gyehoek.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
+    Gyehoek.Scheme.Expand
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Sexp.Grammar
@@ -110,13 +111,16 @@ library
     , recursion-schemes
     , scientific
     , string-interpolate
+    , tardis
     , template-haskell
     , text
     , text-short
     , typed-process
     , unordered-containers
     , vector
-    , tardis
+    , witherable
+    , semialign
+    , these
 
   hs-source-dirs:   src
   default-language: GHC2024

macroexpand.scm

@@ -0,0 +1,11 @@
+(define-syntax if-not
+  (syntax-rules ()
+    ((_ c t f) (if (not c) t f))
+    ((_ c t) (if (not c) t))))
+
+(write (macroexpand-1 '(if-not #t 123 456)))
+
+(define (main)
+  (let loop ((datum (read)))
+    (unless (eof-object? datum)
+      ())))

src/Gyehoek/Scheme/Expand.hs

@@ -0,0 +1,233 @@
+{-# LANGUAGE ViewPatterns #-}
+module Gyehoek.Scheme.Expand
+  (
+  ) where
+
+import Gyehoek.Sexp.Syntax
+import Gyehoek.Sexp qualified as S
+import Gyehoek.Prelude
+import Gyehoek.Scheme.Syntax (Name, Lit(..))
+import qualified Data.HashSet as HS
+import qualified Data.HashMap.Strict as H
+import Data.Foldable
+import Data.These
+import Data.Zip
+import Prelude hiding (zip)
+import qualified Data.List.NonEmpty as NE
+import Data.Monoid (Ap(Ap, getAp))
+import Gyehoek.Sexp.Grammar.Base ((:-)(..))
+import Control.Lens.Extras (is)
+
+
+data Scope = MkScope
+  { identity :: Natural
+  , bindings :: HashSet Name
+  }
+  deriving (Show, Generic)
+
+data Syntax
+  = SyntaxTrans Trans
+  | SyntaxPrim Prim
+  deriving (Show, Generic)
+
+data Prim
+  = PrimLambda
+  | PrimLet
+  | PrimIf
+  deriving (Show, Generic)
+
+data Trans = MkTrans
+  { ellipsis :: Name
+  , keywords :: List Name
+  , rules :: List Rule
+  }
+  deriving (Show, Generic)
+
+data Rule = MkRule Pat Tem
+  deriving (Show, Generic)
+
+data Pat
+  = PatWildcard
+  | PatVar Name
+  | PatList
+    { init :: List Pat
+    , ellipsis :: Maybe (List Pat)
+    , tail :: Maybe Pat
+    }
+  -- | PatVec
+  --   { init :: List Pat
+  --   , ellipsis :: Maybe (List Pat)
+  --   }
+  deriving (Show, Generic)
+
+data Tem
+  -- | @(⟨element⟩ …)@
+  -- @(⟨element⟩ ⟨element⟩ … . ⟨element⟩)@
+  = TemList
+    { init :: List El
+    , tail :: Maybe Tem
+    }
+  -- | @(⟨ellipsis⟩ ⟨template⟩)@
+  | TemTrail Tem
+  | TemLit Lit
+  | TemVar Name
+  deriving (Show, Generic)
+
+data El
+  -- | @⟨template⟩ ⟨ellipsis⟩@
+  = Ellipsis Tem
+  -- | @⟨template⟩@
+  | El Tem
+  deriving (Show, Generic)
+
+
+
+instance S.DatumIso Trans where
+  datumIso = S.with \g ->
+    S.listWithIndentation
+      (NSpecial 1)
+      ( S.el (S.symBuiltin "syntax-rules")
+      >>> S.Iso (\(ctx:-t) -> ctx:-"...":-t) (\(ctx:-_:-t) -> ctx:-t)
+      >>> S.el (S.list $ S.rest (S.datumIso @Name))
+      >>> S.rest (S.datumIso @Rule)
+      )
+    >>> g
+
+instance S.DatumIso Rule where
+  datumIso = S.with \g ->
+    S.list (S.el S.datumIso >>> S.el S.datumIso) >>> g
+
+instance S.DatumIso Pat where
+  datumIso = S.match
+    $ S.With (S.sym "_" >>>)
+    $ S.With (S.datumIso >>>)
+    $ S.With (lst >>>)
+    $ S.End
+    where
+      lst :: S.G (Datum :- t) (Maybe Pat :- Maybe (List Pat) :- List Pat :- t)
+      lst = S.coproduct
+        [ S.list $
+            ellipsis
+            >>> S.onTail (S.push Nothing (is _Nothing) (const mempty))
+        , S.dottedList
+            ellipsis
+            ( S.datumIso @Pat
+              >>> S.partialIso Just (maybe (Left mempty) Right) )
+        ]
+      ellipsis =
+        S.restData split
+            >>> S.onTail
+              ( S.onHead (S.traversed . S.traversed . S.sealed $
+                S.datumIso @Pat)
+              >>> S.onTail (S.onHead . S.traversed . S.sealed $
+                S.datumIso @Pat)
+              )
+      split
+        :: forall t. S.G (List Datum :- t)
+            (Maybe (List Datum) :- List Datum :- t)
+      split = S.Iso
+        (\(ps0:-t) ->
+          let (ps,ell) = splitEllipsis ps0
+          in ell :- ps :- t)
+        (\(ell:-ps:-t) -> (ps ++ foldMap ([Symbol "..."]++) ell) :- t)
+
+splitEllipsis :: List Datum -> (List Datum, Maybe (List Datum))
+splitEllipsis [] = ([], Nothing)
+splitEllipsis (Symbol "..." : xs) = ([], Just xs)
+splitEllipsis (x:xs) = splitEllipsis xs & _1 %~ (x:)
+
+instance S.DataIso El where
+  dataIso = S.match
+    $ S.With (ellipsis >>>)
+    $ S.With (noellipsis >>>)
+    $ S.End
+    where
+      ellipsis = S.recontextualise $
+        S.el (S.datumIso @Tem) >>> S.el (S.sym "...")
+      noellipsis = S.recontextualise $ S.el (S.datumIso @Tem)
+
+instance S.DatumIso Tem where
+  datumIso = S.match
+    $ S.With (lst >>>)
+    $ S.With (trail >>>)
+    $ S.With (S.datumIso @Lit >>>)
+    $ S.With (S.datumIso @Name >>>)
+    $ S.End
+    where
+      trail = S.list $ S.el (S.sym "...") >>> S.el (S.datumIso @Tem)
+
+      lst :: S.G (S.Datum :- t) (Maybe Tem :- List El :- t)
+      lst = S.coproduct
+        [ S.list els
+          >>> (S.push Nothing (is _Nothing) (const mempty))
+        , S.dottedList els $
+            S.datumIso @Tem
+            >>> S.partialIso Just (maybe (Left mempty) Right)
+        ]
+      els :: S.G (S.ListContext :- t) (S.ListContext :- List El :- t)
+      els =
+        S.iso
+          (\(S.MkListContext ds) -> affixEllipses ds)
+          (S.MkListContext . foldMap \(d,b) ->
+            d : if b then [Symbol "..."] else [])
+        >>> S.onHead (S.traversed . S.sealed $
+          S.flipped S.pair
+          >>> S.onTail (S.datumIso @Tem)
+          >>> S.pair
+          >>> S.iso
+            (\(t,b) -> if b then Ellipsis t else El t)
+            (\case
+              Ellipsis t -> (t,True)
+              El t -> (t,False)))
+        >>> S.push (S.MkListContext [])
+          (\(S.MkListContext xs) -> null xs)
+          (const mempty)
+      affixEllipses :: List Datum -> List (Datum, Bool)
+      affixEllipses (x : Symbol "..." : xs) = (x,True) : affixEllipses xs
+      affixEllipses (x : xs) = (x,False) : affixEllipses xs
+      affixEllipses [] = []
+
+
+
+-- |
+-- >>> match (PatList [PatVar "x"] Nothing (Just (PatVar "y"))) [S.sx|(1 2 . 2)|]
+-- Nothing
+-- >>> match (PatList [PatVar "x"] Nothing (Just (PatVar "y"))) [S.sx|(1 . 2)|]
+-- Just
+-- ...
+match :: Pat -> Datum -> Maybe (HashMap Name Datum)
+
+match PatWildcard _ = Just mempty
+
+match (PatVar x) e = Just $ H.singleton x e
+
+match (PatList ps Nothing Nothing) (List es) = matches ps es
+
+match (PatList ps Nothing (Just p)) (DotList es e) =
+  matches (p:|ps) (NE.cons e es)
+
+match _ _ = _
+
+matches
+  :: (Semialign f, Foldable f)
+  => f Pat -> f Datum -> Maybe (HashMap Name Datum)
+matches ps es = getAp . foldMap Ap $ alignWith f ps es
+  where
+    f (These a b) = match a b
+    f _ = Nothing
+
+
+
+trans_and :: Trans
+trans_and = MkTrans
+  { ellipsis = "..."
+  , keywords = []
+  , rules =
+    [ MkRule
+        (PatList
+          [PatVar "and"]
+          Nothing
+          Nothing)
+        (TemLit (LitBool True))
+    ]
+  }

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -44,7 +44,7 @@ module Gyehoek.Sexp.Grammar.Base
   , lambdaLike
   , lambdaKeyword
   , kappaKeyword
-  , beginLike, headTagged2', dottedList
+  , beginLike, headTagged2', dottedList, reifyContext, recontextualise, decontextualise
   ) where
 
 import Data.InvertibleGrammar
@@ -52,7 +52,7 @@ import Data.InvertibleGrammar.Base
 import Data.InvertibleGrammar.Base as Re
   ( Grammar(..))
 import Data.InvertibleGrammar.Combinators
-import Gyehoek.Prelude hiding (traversed, iso, cons, coerced, Iso, Simple, simple)
+import Gyehoek.Prelude hiding (flipped, traversed, iso, cons, coerced, Iso, Simple, simple)
 import Gyehoek.Sexp.Syntax hiding (position)
 import Gyehoek.Sexp.Print (printDatum')
 import Data.Scientific (Scientific)
@@ -169,6 +169,33 @@ el
   -> G (ListContext :- t) (ListContext :- t')
 el g = coerced (Flip cons >>> onTail g >>> Step)
 
+reifyContext :: G (ListContext :- t) (List Datum :- t)
+reifyContext = iso coerce coerce
+
+decontextualise
+  :: G (List Datum :- t) (List Datum :- t')
+  -> G (ListContext :- t) t'
+decontextualise g = reifyContext >>> g >>> end
+  where
+    end = Flip $ PartialIso
+      (\t -> [] :- t)
+      (\(lst :- t) ->
+         case lst of
+           [] -> Right t
+           d:_ -> Left $ unexpectedDatum d)
+
+recontextualise
+  :: G (ListContext :- t) (ListContext :- t')
+  -> G (List Datum :- t) t'
+recontextualise g = flipped reifyContext >>> g >>> end
+  where
+    end = Flip $ PartialIso
+      (\t -> MkListContext [] :- t)
+      (\(MkListContext lst :- t) ->
+         case lst of
+           [] -> Right t
+           d:_ -> Left $ unexpectedDatum d)
+
 -- | matches the remainder of a list as repetition of a given
 -- grammar.
 --
@@ -235,8 +262,8 @@ rest g =
 -- >>> encodeTest dataRestGrammar $ MkExample [1,2,3] "end"
 -- (1 2 3 end)
 restData
-  :: G (List Datum :- t) (a :- t)
+  :: G (List Datum :- t) t'
-  -> G (ListContext :- t) (ListContext :- a :- t)
+  -> G (ListContext :- t) (ListContext :- t')
 restData g =
   iso coerce coerce
   >>> g

t.scm

@@ -1,5 +1 @@
-((λ ()
+(define lambda 123)
-   (* 2 (call/cc
-         (λ (k)
-           (begin (k 6)
-                  3))))))