src/Gyehoek/Scheme/Expand.hs

@@ -60,7 +60,7 @@ data PrimLet e = MkPrimLet (Maybe Name) (List (Name, e)) (List e)
   deriving (Show, Generic, Functor, Foldable, Traversable)
 data PrimIf e = MkPrimIf e e (Maybe e)
   deriving (Show, Generic, Functor, Foldable, Traversable)
-data PrimLetSyntax e = MkPrimLetSyntax (List (Name, Trans)) (List e)
+data PrimLetSyntax e = MkPrimLetSyntax (List (Name, e)) (List e)
   deriving (Show, Generic, Functor, Foldable, Traversable)
 
 data Prim e
@@ -68,166 +68,15 @@ data Prim e
   | PrimLet (PrimLet e)
   | PrimIf (PrimIf e)
   | PrimLetSyntax (PrimLetSyntax e)
+  | PrimSyntaxRules Trans
   deriving (Show, Generic)
 
-data Trans = MkTrans
-  { ellipsis :: Name
-  , keywords :: List Name
-  , rules :: List Rule
-  }
-  deriving (Show, Generic)
-
-data Rule = MkRule
-  { rhs :: Pat
-  , lhs :: Tem
-  }
-  deriving (Show, Generic, Data)
-
-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)
-
-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)
-
-data El
-  -- | @⟨template⟩ ⟨ellipsis⟩@
-  = Ellipsis Tem
-  -- | @⟨template⟩@
-  | El Tem
-  deriving (Show, Generic, Data)
-
 data Key = MkKey Name (HashSet Scope)
   deriving stock (Show, Generic, Eq)
   deriving anyclass (Hashable)
 
 
 
-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 [] = []
-
 instance S.DatumIso Scope where
   datumIso = S.with (S.datumIso >>>)
 
@@ -307,7 +156,7 @@ prim_let_syntax :: S.DatumIso e => S.DatumGrammar (PrimLetSyntax e)
 prim_let_syntax = S.with \g ->
   (S.listWithIndentation (NSpecial 1) $
     S.el (anykw "let-syntax")
-    >>> S.el (S.list $ S.rest $ S.datumIso @(Name,Trans))
+    >>> S.el (S.list $ S.rest $ S.datumIso)
     >>> S.rest S.datumIso)
   >>> g
 
@@ -436,6 +285,8 @@ data Denot
   = DenotVar
   | DenotMacro Trans
   | DenotPrim Name
+  | DenotSyntax Datum
+  | DenotKeyword Name
   deriving stock (Show, Generic)
 
 newtype Env = MkEnv { names :: HashMap Bind Denot }
@@ -574,7 +425,7 @@ expand g scopes datum = case datum of
 expandMacro
   :: (Expand es, Jalmot :> es)
   => Env -> ScopeSet -> Trans -> Datum -> Eff es CommandOrDef
-expandMacro = _
+expandMacro g scopes trans datum = _
 
 expandPrim 
   :: (Expand es, Jalmot :> es)
@@ -582,6 +433,17 @@ expandPrim
 expandPrim g scopes primName datum
   | Just prim <- parsePrim @Datum primName datum
   = case prim of
+    PrimLetSyntax (MkPrimLetSyntax bs [body]) -> do
+      scopes' <- flip HS.insert scopes <$> gensym
+      (rhss,g') <- (_2 %~ (g<>) . fold) . Prelude.unzip <$> for bs \(x,trans) ->
+        expandAsExp g scopes trans >>= \case
+          ExpSyntaxRules trans' ->
+            (trans',) <$> bindLexical scopes' x (DenotMacro trans')
+          e -> err [i|syntax-rules를 원하는데 이것 받는다: #{e}|]
+      Command <$> (ExpLetSyntax
+        (zip (bs ^.. each . _1) rhss)
+        <$> expandAsExp g' scopes' body
+        )
     PrimLet (MkPrimLet Nothing bs [body]) -> do
       scopes' <- flip HS.insert scopes <$> gensym
       g' <- (g<>) . fold <$> for (bs ^.. each . _1) \x ->

src/Gyehoek/Scheme/Syntax.hs

@@ -20,6 +20,11 @@ module Gyehoek.Scheme.Syntax
   , ExpF(..)
   , Program(..)
   , CommandOrDef(..)
+  , Trans(..)
+  , Rule(..)
+  , Pat(..)
+  , Tem(..)
+  , El(..)
   , primDatumIso
   , free
   , subst
@@ -115,6 +120,7 @@ data Def
 
 data Exp
   = ExpLet (List (Name, Exp)) Exp
+  | ExpLetSyntax (List (Name, Trans)) Exp
   | ExpLetRec (List (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (NonEmpty Exp)
@@ -122,10 +128,63 @@ data Exp
   | ExpLit Lit
   | ExpLambda (List Name) Exp
   | ExpVar Name
+  | ExpSyntaxRules Trans
   | ExpApply Exp (List Exp)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
+data Trans = MkTrans
+  { ellipsis :: Name
+  , keywords :: List Name
+  , rules :: List Rule
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Rule = MkRule
+  { rhs :: Pat
+  , lhs :: Tem
+  }
+  deriving (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+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)
+  deriving anyclass (NFData)
+
+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)
+  deriving anyclass (NFData)
+
+data El
+  -- | @⟨template⟩ ⟨ellipsis⟩@
+  = Ellipsis Tem
+  -- | @⟨template⟩@
+  | El Tem
+  deriving (Show, Generic, Data)
+  deriving anyclass (NFData)
+
 data CommandOrDef
   = Command Exp
   | Definition Def
@@ -248,20 +307,42 @@ instance DatumIso Def where
         >>> S.el args >>> S.rest S.datumIso
       args = S.list $ S.el S.datumIso >>> S.rest S.datumIso
   
+instance DatumIso Trans where
+  datumIso = S.with \g ->
+    S.listWithIndentation
+      (S.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 DatumIso Exp where
   datumIso = S.match
     $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
+    $ S.With (letsyntax >>>)
     $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
     $ S.With (. S.datumIso)
     $ S.With (. begin)
-    $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso)
+    $ S.With (. if_)
     $ S.With (. S.datumIso)
     $ S.With (. lam)
     $ S.With (. S.datumIso)
+    $ S.With (. S.datumIso)
     $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso))
     $ S.End
     where
+      letsyntax = S.listWithIndentation (S.NSpecial 1) $
+        S.el (S.symBuiltin "let-syntax")
+        >>> S.el (S.list $ S.rest $ S.datumIso)
+        >>> S.el S.datumIso
       lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
+      if_ = S.ifLike "if" S.datumIso S.datumIso $ S.datumIso @Exp >>> S.iso
+        Just
+        \case
+          Just x -> x
+          Nothing -> error "안 괜찮다ㅠㅠ"
       begin :: forall t. G (S.Datum :- t) (NonEmpty Exp :- t)
       begin = S.beginLike "begin" $
         S.el (S.datumIso @Exp) >>> S.rest (S.datumIso @Exp)
@@ -269,6 +350,101 @@ instance DatumIso Exp where
           (\(xs:-x:-t) -> (x:|xs):-t)
           (\((x:|xs):-t) -> xs:-x:-t))
 
+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 (S.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 S.Datum :- t)
+            (Maybe (List S.Datum) :- List S.Datum :- t)
+      split = S.Iso
+        (\(ps0:-t) ->
+          let (ps,ell) = splitEllipsis ps0
+          in ell :- ps :- t)
+        (\(ell:-ps:-t) -> (ps ++ foldMap ([S.Symbol "..."]++) ell) :- t)
+
+splitEllipsis :: List S.Datum -> (List S.Datum, Maybe (List S.Datum))
+splitEllipsis [] = ([], Nothing)
+splitEllipsis (S.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 [S.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 S.Datum -> List (S.Datum, Bool)
+      affixEllipses (x : S.Symbol "..." : xs) = (x,True) : affixEllipses xs
+      affixEllipses (x : xs) = (x,False) : affixEllipses xs
+      affixEllipses [] = []
+
+
 instance DatumIso CommandOrDef where
   datumIso = S.match
     $ S.With (\_Command -> _Command . S.datumIso)