diff --git a/src/Gyehoek/Scheme/Expand.hs b/src/Gyehoek/Scheme/Expand.hs index 7bfa994..0f1acfe 100644 --- a/src/Gyehoek/Scheme/Expand.hs +++ b/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' (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 - & fmap (fmap (fmap (:[])) . match' p) - & foldr (liftA2 $ H.unionWith (<>)) mempty - & fmap (fmap List) - pure $ r <> rest' - where - f (These a b) = (,[]) <$> match' a b - f (This a) = empty - f (That b) = pure (mempty,[b]) - -match' (PatList ps Nothing (Just p)) (DotList es e) = - matches (p:|ps) (NE.cons e es) - -match' _ _ = _ - -matchPrefix - :: (Semialign f, Foldable f) - => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum, List Datum) -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 - :: (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 + match' :: Pat -> Datum -> Ap Maybe (HashMap Name Datum) + + match' PatWildcard _ = pure mempty + + 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 + & fmap (fmap (fmap (:[])) . match' p) + & foldr (liftA2 $ H.unionWith (<>)) mempty + & fmap (fmap List) + pure $ r <> rest' + where + f (These a b) = (,[]) <$> match' a b + f (This a) = empty + f (That b) = pure (mempty,[b]) + + match' (PatList ps Nothing (Just p)) (DotList es e) = + matches (p:|ps) (NE.cons e es) + + match' _ _ = _ + + matchPrefix + :: (Semialign f, Foldable f) + => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum, List Datum) + 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 + :: (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