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,57 +332,77 @@ 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
-  let (ps',p) = ps ^?! _Snoc
+    | coerce x `elem` kws = case e of
-  (r,rest) <- fold $ alignWith f ps' es
+      Symbol x' | coerce x == x' -> pure mempty
-  rest' <- rest
+      _                          -> empty
-    & fmap (fmap (fmap (:[])) . match' p)
+    | otherwise = pure $ H.singleton x e
-    & foldr (liftA2 $ H.unionWith (<>)) mempty
+  
-    & fmap (fmap List)
+  match' (PatList ps Nothing Nothing) (List es) = matches ps es
-  pure $ r <> rest'
+  
-  where
+  match' (PatList ps (Just []) Nothing) (List es) = do
-    f (These a b) = (,[]) <$> match' a b
+    let (ps',p) = ps ^?! _Snoc
-    f (This a) = empty
+    (r,rest) <- fold $ alignWith f ps' es
-    f (That b) = pure (mempty,[b])
+    rest' <- rest
-
+      & fmap (fmap (fmap (:[])) . match' p)
-match' (PatList ps Nothing (Just p)) (DotList es e) =
+      & foldr (liftA2 $ H.unionWith (<>)) mempty
-  matches (p:|ps) (NE.cons e es)
+      & fmap (fmap List)
-
+    pure $ r <> rest'
-match' _ _ = _
+    where
-
+      f (These a b) = (,[]) <$> match' a b
-matchPrefix
+      f (This a) = empty
-  :: (Semialign f, Foldable f)
+      f (That b) = pure (mempty,[b])
-  => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum, List Datum)
+  
-matchPrefix ps es = fold $ alignWith f ps es
+  match' (PatList ps Nothing (Just p)) (DotList es e) =
-  where
+    matches (p:|ps) (NE.cons e es)
-    f (These a b) = (,[]) <$> match' a b
+  
-    f (This a) = empty
+  match' _ _ = _
-    f (That b) = pure (mempty,[b])
+  
-
+  matchPrefix
-matches
+    :: (Semialign f, Foldable f)
-  :: (Semialign f, Foldable f)
+    => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum, List Datum)
-  => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum)
+  matchPrefix ps es = fold $ alignWith f ps es
-matches ps es = fold $ alignWith matchThese ps es
+    where
-
+      f (These a b) = (,[]) <$> match' a b
-matchThese (These a b) = match' a b
+      f (This a) = empty
-matchThese _ = empty
+      f (That b) = pure (mempty,[b])
+  
+  matches
+    :: (Semialign f, Foldable f)
+    => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum)
+  matches ps es = fold $ alignWith matchThese ps es
+  
+  matchThese (These a b) = match' a b
+  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