git.iko.soy/elk
on 4bec310 help sign in
elk/compiler/Generate/Cases.hs
133 lines 4.1 kB history raw
1module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where
3import Control.Applicative ((<$>))
4import Control.Arrow (first)
5import Control.Monad.State
6import Data.List (groupBy,sortBy)
7import Data.Maybe (fromMaybe)
9import SourceSyntax.Annotation
10import SourceSyntax.Expression
11import SourceSyntax.Literal
12import qualified SourceSyntax.Pattern as P
13import qualified SourceSyntax.Variable as V
14import Transform.Substitute
16toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
17toMatch patterns = do
18 v <- newVar
19 (,) v <$> match [v] (map (first (:[])) patterns) Fail
21newVar :: State Int String
22newVar = do n <- get
23 modify (+1)
24 return $ "_v" ++ show n
26data Match
27 = Match String [Clause] Match
28 | Break
29 | Fail
30 | Other Expr
31 | Seq [Match]
32 deriving Show
34data Clause =
35 Clause (Either String Literal) [String] Match
36 deriving Show
38matchSubst :: [(String,String)] -> Match -> Match
39matchSubst pairs match =
40 case match of
41 Break -> Break
42 Fail -> Fail
43 Seq ms -> Seq (map (matchSubst pairs) ms)
44 Other (A a e) ->
45 Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
46 Match n cs m ->
47 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
48 where
49 varSubst v = fromMaybe v (lookup v pairs)
50 clauseSubst (Clause c vs m) =
51 Clause c (map varSubst vs) (matchSubst pairs m)
53isCon (p:_, _) =
54 case p of
55 P.Data _ _ -> True
56 P.Literal _ -> True
57 _ -> False
59isVar p = not (isCon p)
61match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
62match [] [] def = return def
63match [] [([],e)] Fail = return $ Other e
64match [] [([],e)] Break = return $ Other e
65match [] cs def = return $ Seq (map (Other . snd) cs ++ [def])
66match vs@(v:_) cs def
67 | all isVar cs' = matchVar vs cs' def
68 | all isCon cs' = matchCon vs cs' def
69 | otherwise = matchMix vs cs' def
70 where
71 cs' = map (dealias v) cs
73dealias :: String -> ([P.Pattern],Expr) -> ([P.Pattern],Expr)
74dealias v c@(p:ps, A a e) =
75 case p of
76 P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)
77 _ -> c
79matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
80matchVar (v:vs) cs def = match vs (map subVar cs) def
81 where
82 subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)
83 where
84 subOnePattern pattern e =
85 case pattern of
86 P.Var x -> subst x (rawVar v) e
87 P.Anything -> e
88 P.Record fs ->
89 foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs
91matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
92matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
93 where
94 css = groupBy eq (sortBy cmp cs)
96 cmp (p1:_,_) (p2:_,_) =
97 case (p1,p2) of
98 (P.Data n1 _, P.Data n2 _) -> compare n1 n2
99 _ -> compare p1 p2
101 eq (p1:_,_) (p2:_,_) =
102 case (p1,p2) of
103 (P.Data n1 _, P.Data n2 _) -> n1 == n2
104 _ -> p1 == p2
106 toClause cs =
107 case head cs of
108 (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
109 (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
111matchClause :: Either String Literal
112 -> [String]
113 -> [([P.Pattern],Expr)]
114 -> Match
115 -> State Int Clause
116matchClause c (_:vs) cs def =
117 do vs' <- getVars
118 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def
119 where
121 flatten (p:ps, e) =
122 case p of
123 P.Data _ ps' -> (ps' ++ ps, e)
124 P.Literal _ -> (ps, e)
126 getVars =
127 case head cs of
128 (P.Data _ ps : _, _) -> forM ps (const newVar)
129 (P.Literal _ : _, _) -> return []
131matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
132matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
133 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs