src/Gyehoek/Scheme/Expand.hs

@@ -81,7 +81,7 @@ data Rule = MkRule
   { rhs :: Pat
   , lhs :: Tem
   }
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Pat
   = PatWildcard
@@ -95,7 +95,7 @@ data Pat
   --   { init :: List Pat
   --   , ellipsis :: Maybe (List Pat)
   --   }
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Tem
   -- | @(⟨element⟩ …)@
@@ -108,14 +108,14 @@ data Tem
   | TemTrail Tem
   | TemLit Lit
   | TemVar Name
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data El
   -- | @⟨template⟩ ⟨ellipsis⟩@
   = Ellipsis Tem
   -- | @⟨template⟩@
   | El Tem
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Key = MkKey Name (HashSet Scope)
   deriving stock (Show, Generic, Eq)
@@ -332,24 +332,44 @@ t_prim_let = prism'
 
 
 
--- |
+{- |
--- >>> 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 p = getAp . match' p
 
-match' :: Pat -> Datum -> Ap Maybe (HashMap Name Datum)
+* Examples
 
-match' PatWildcard _ = pure mempty
+>>> :set -XTemplateHaskellQuotes
+>>> pat = S.makeSx [|| S.fromDatumUnsafe @Pat S.datumIso ||]
+>>> match [] [pat|(x . y)|] [S.sx|(1 2 . 2)|]
+Nothing
+>>> match [] [pat|(x . y)|] [S.sx|(1 . 2)|]
+Just
+...
+>>> match ["=>"] [pat|(x => y)|] [S.sx|(1 => 2)|]
+Just
+...
+>>> match ["=>"] [pat|(x => y)|] [S.sx|(1 -> 2)|]
+Nothing
+-}
+match :: Foldable f
+  => f Text
+  -- ^ Literal keywords
+  -> Pat
+  -> Datum
+  -> Maybe (HashMap Name Datum)
+match kws p = getAp . match' p where
 
-match' (PatVar x) e = pure $ H.singleton x e
+  match' :: Pat -> Datum -> Ap Maybe (HashMap Name Datum)
   
-match' (PatList ps Nothing Nothing) (List es) = matches ps es
+  match' PatWildcard _ = pure mempty
   
-match' (PatList ps (Just []) Nothing) (List es) = do
+  match' (PatVar x) e
+    | coerce x `elem` kws = case e of
+      Symbol x' | coerce x == x' -> pure mempty
+      _                          -> empty
+    | otherwise = pure $ H.singleton x e
+  
+  match' (PatList ps Nothing Nothing) (List es) = matches ps es
+  
+  match' (PatList ps (Just []) Nothing) (List es) = do
     let (ps',p) = ps ^?! _Snoc
     (r,rest) <- fold $ alignWith f ps' es
     rest' <- rest
@@ -362,27 +382,27 @@ match' (PatList ps (Just []) Nothing) (List es) = do
       f (This a) = empty
       f (That b) = pure (mempty,[b])
   
-match' (PatList ps Nothing (Just p)) (DotList es e) =
+  match' (PatList ps Nothing (Just p)) (DotList es e) =
     matches (p:|ps) (NE.cons e es)
   
-match' _ _ = _
+  match' _ _ = _
   
-matchPrefix
+  matchPrefix
     :: (Semialign f, Foldable f)
     => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum, List Datum)
-matchPrefix ps es = fold $ alignWith f ps es
+  matchPrefix ps es = fold $ alignWith f ps es
     where
       f (These a b) = (,[]) <$> match' a b
       f (This a) = empty
       f (That b) = pure (mempty,[b])
   
-matches
+  matches
     :: (Semialign f, Foldable f)
     => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum)
-matches ps es = fold $ alignWith matchThese ps es
+  matches ps es = fold $ alignWith matchThese ps es
   
-matchThese (These a b) = match' a b
+  matchThese (These a b) = match' a b
-matchThese _ = empty
+  matchThese _ = empty
 
 
 
@@ -539,6 +559,7 @@ expand g scopes datum@(List (Symbol s : es)) = do
     DenotVar -> Command . ExpApply (ExpVar s')
       <$> traverse (expandAsExp g scopes) es
     DenotPrim x -> expandPrim g scopes x datum
+    DenotMacro trans -> expandMacro g scopes trans datum
 
 -- 신기하지 않은 경우들
 expand g scopes datum = case datum of
@@ -550,6 +571,11 @@ expand g scopes datum = case datum of
     go = expandAsExp g scopes
     lit = pure . Command . ExpLit
 
+expandMacro
+  :: (Expand es, Jalmot :> es)
+  => Env -> ScopeSet -> Trans -> Datum -> Eff es CommandOrDef
+expandMacro = _
+
 expandPrim 
   :: (Expand es, Jalmot :> es)
   => Env -> ScopeSet -> Name -> Datum -> Eff es CommandOrDef