git.iko.soy/elk
on fdcaaed help sign in
elk/src/Generate/Cases.hs
210 lines 6.1 kB history raw
1module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where
3import Control.Applicative ((<$>))
4import Control.Arrow (first)
5import Control.Monad.State (State)
6import qualified Control.Monad.State as State
7import Data.List (groupBy,sortBy)
8import Data.Maybe (fromMaybe)
10import qualified AST.Annotation as A
11import qualified AST.Expression.General as Expr
12import qualified AST.Expression.Canonical as Canonical
13import qualified AST.Literal as Literal
14import qualified AST.Pattern as P
15import qualified AST.Variable as Var
16import Transform.Substitute (subst)
18toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)
19toMatch patterns = do
20 v <- newVar
21 (,) v <$> match [v] (map (first (:[])) patterns) Fail
24newVar :: State Int String
25newVar =
26 do n <- State.get
27 State.modify (+1)
28 return $ "_v" ++ show n
31data Match
32 = Match String [Clause] Match
33 | Break
34 | Fail
35 | Other Canonical.Expr
36 | Seq [Match]
37 deriving Show
40data Clause =
41 Clause (Either Var.Canonical Literal.Literal) [String] Match
42 deriving Show
45type Case =
46 ([P.CanonicalPattern], Canonical.Expr)
49matchSubst :: [(String,String)] -> Match -> Match
50matchSubst pairs match =
51 case match of
52 Break -> Break
54 Fail -> Fail
56 Seq ms ->
57 Seq (map (matchSubst pairs) ms)
59 Other (A.A a e) ->
60 Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs
62 Match n cs m ->
63 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
64 where
65 varSubst v = fromMaybe v (lookup v pairs)
66 clauseSubst (Clause c vs m) =
67 Clause c (map varSubst vs) (matchSubst pairs m)
70isCon :: ([P.Pattern var], expr) -> Bool
71isCon ([] , _) = noMatch "isCon"
72isCon (p:_, _) =
73 case p of
74 P.Data _ _ -> True
75 P.Literal _ -> True
76 _ -> False
79isVar :: ([P.Pattern var], expr) -> Bool
80isVar p = not (isCon p)
83match :: [String] -> [Case] -> Match -> State Int Match
84match variables cases match =
85 case (variables, cases, match) of
86 ([], [], _) ->
87 return match
89 ([], [([], expr)], Fail) ->
90 return $ Other expr
92 ([], [([], expr)], Break) ->
93 return $ Other expr
95 ([], _, _) ->
96 return $ Seq (map (Other . snd) cases ++ [match])
98 (var:_, _, _)
99 | all isVar cases' -> matchVar variables cases' match
100 | all isCon cases' -> matchCon variables cases' match
101 | otherwise -> matchMix variables cases' match
102 where
103 cases' = map (dealias var) cases
106dealias :: String -> Case -> Case
107dealias _ ([], _) = noMatch "dealias"
108dealias v c@(p:ps, A.A a e) =
109 case p of
110 P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)
111 _ -> c
114matchVar :: [String] -> [Case] -> Match -> State Int Match
115matchVar [] _ _ = noMatch "matchVar"
116matchVar (v:vs) cs def =
117 match vs (map subVar cs) def
118 where
119 subVar ([], _) = noMatch "matchVar.subVar"
120 subVar (p:ps, (A.A a expr)) =
121 (ps, A.A a $ subOnePattern p expr)
122 where
123 subOnePattern pattern expr =
124 case pattern of
125 P.Anything -> expr
127 P.Var x ->
128 subst x (Expr.localVar v) expr
130 P.Record fs ->
131 foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) expr fs
133 _ -> noMatch "matchVar.subVar"
136matchCon :: [String] -> [Case] -> Match -> State Int Match
137matchCon variables cases match =
138 case variables of
139 [] -> noMatch "matchCon"
141 var : _vars ->
142 flip (Match var) match <$> mapM toClause caseGroups
143 where
144 caseGroups :: [[Case]]
145 caseGroups =
146 groupBy eq (sortBy cmp cases)
148 eq :: Case -> Case -> Bool
149 eq (patterns1, _) (patterns2, _) =
150 case (patterns1, patterns2) of
151 (pattern1:_, pattern2:_) ->
152 case (pattern1, pattern2) of
153 (P.Data name1 _, P.Data name2 _) -> name1 == name2
154 (_, _) -> pattern1 == pattern2
155 (_, _) -> noMatch "matchCon.eq"
157 cmp :: Case -> Case -> Ordering
158 cmp (patterns1, _) (patterns2, _) =
159 case (patterns1, patterns2) of
160 (pattern1:_, pattern2:_) ->
161 case (pattern1, pattern2) of
162 (P.Data name1 _, P.Data name2 _) -> compare name1 name2
163 (_, _) -> compare pattern1 pattern2
164 (_, _) -> noMatch "matchCon.cmp"
166 toClause :: [Case] -> State Int Clause
167 toClause cases =
168 case head cases of
169 (P.Data name _ : _, _) ->
170 matchClause (Left name) variables cases Break
172 (P.Literal lit : _, _) ->
173 matchClause (Right lit) variables cases Break
175 _ -> noMatch "matchCon"
178matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match
179 -> State Int Clause
180matchClause _ [] _ _ = noMatch "matchClause"
181matchClause c (_:vs) cs mtch =
182 do vs' <- getVars
183 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) mtch
184 where
185 flatten ([], _) = noMatch "matchClause.flatten"
186 flatten (p:ps, e) =
187 case p of
188 P.Data _ ps' -> (ps' ++ ps, e)
189 P.Literal _ -> (ps, e)
190 _ -> noMatch "matchClause.flatten"
192 getVars :: State Int [String]
193 getVars =
194 case head cs of
195 (P.Data _ ps : _, _) -> State.forM ps (const newVar)
196 (P.Literal _ : _, _) -> return []
197 _ -> noMatch "matchClause.getVars"
200matchMix :: [String] -> [Case] -> Match -> State Int Match
201matchMix vs cs def =
202 State.foldM (flip $ match vs) def (reverse css)
203 where
204 css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
207noMatch :: String -> a
208noMatch name =
209 error $ "unexpected pattern in '" ++ name ++
210 "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."