git.iko.soy/elk
on ea343fc help sign in
elk/src/Generate/Cases.hs
262 lines 6.8 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 qualified Data.List as List
8import Data.Maybe (fromMaybe)
10import qualified AST.Expression.General as Expr
11import qualified AST.Expression.Canonical as Canonical
12import qualified AST.Literal as Literal
13import qualified AST.Pattern as P
14import qualified AST.Variable as Var
15import qualified Generate.Substitute as S
16import qualified Reporting.Annotation as A
19-- MATCHES
21data Match
22 = Match String [Clause] Match
23 | Break
24 | Fail
25 | Other Canonical.Expr
26 | Seq [Match]
27 deriving Show
30data Clause =
31 Clause (Either Var.Canonical Literal.Literal) [String] Match
32 deriving Show
35type Branch =
36 ([P.CanonicalPattern], Canonical.Expr)
39-- PUBLIC FUNCTIONS
41toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)
42toMatch patterns =
43 do v <- newVar
44 (,) v <$> buildMatch [v] (map (first (:[])) patterns) Fail
47newVar :: State Int String
48newVar =
49 do n <- State.get
50 State.modify (+1)
51 return $ "_v" ++ show n
54matchSubst :: [(String,String)] -> Match -> Match
55matchSubst pairs match =
56 case match of
57 Break -> Break
59 Fail -> Fail
61 Seq ms ->
62 Seq (map (matchSubst pairs) ms)
64 Other (A.A a e) ->
65 Other . A.A a $ foldr ($) e $ map (\(x,y) -> S.subst x (Expr.localVar y)) pairs
67 Match n cs m ->
68 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
69 where
70 varSubst v = fromMaybe v (lookup v pairs)
71 clauseSubst (Clause c vs m) =
72 Clause c (map varSubst vs) (matchSubst pairs m)
75-- BUILD MATCHES
77buildMatch :: [String] -> [Branch] -> Match -> State Int Match
78buildMatch variables branches match =
79 case (variables, branches, match) of
80 ([], [], _) ->
81 return match
83 ([], [([], expr)], Fail) ->
84 return $ Other expr
86 ([], [([], expr)], Break) ->
87 return $ Other expr
89 ([], _, _) ->
90 return $ Seq (map (Other . snd) branches ++ [match])
92 (var:_, _, _)
93 | all isVar branches' -> matchVar variables branches' match
94 | all isCon branches' -> matchCon variables branches' match
95 | otherwise -> matchMix variables branches' match
96 where
97 branches' = map (dealias var) branches
100dealias :: String -> Branch -> Branch
101dealias _ ([], _) = noMatch "dealias"
102dealias var branch@(p:ps, A.A ann e) =
103 case p of
104 A.A _ (P.Alias alias pattern) ->
105 ( pattern:ps
106 , A.A ann (S.subst alias (Expr.localVar var) e)
107 )
109 _ ->
110 branch
113isCon :: ([P.Pattern ann var], expr) -> Bool
114isCon ([], _) = noMatch "isCon"
115isCon (A.A _ pattern : _, _) =
116 case pattern of
117 P.Data _ _ -> True
118 P.Literal _ -> True
119 _ -> False
122isVar :: ([P.Pattern ann var], expr) -> Bool
123isVar p =
124 not (isCon p)
127-- VARIABLE MATCHES
129matchVar :: [String] -> [Branch] -> Match -> State Int Match
130matchVar [] _ _ = noMatch "matchVar"
131matchVar (var:vars) branches match =
132 buildMatch vars (map subVar branches) match
133 where
134 subVar ([], _) = noMatch "matchVar.subVar"
135 subVar (A.A _ pattern : patterns, (A.A ann expr)) =
136 ( patterns
137 , A.A ann (subOnePattern pattern expr)
138 )
139 where
140 subOnePattern pattern expr =
141 case pattern of
142 P.Anything ->
143 expr
145 P.Var x ->
146 S.subst x (Expr.localVar var) expr
148 P.Record fields ->
149 let access = Expr.Access (A.A ann (Expr.localVar var))
150 in
151 foldr (\x -> S.subst x (access x)) expr fields
153 _ ->
154 noMatch "matchVar.subVar"
157-- CONSTRUCTOR MATCHES
159matchCon :: [String] -> [Branch] -> Match -> State Int Match
160matchCon variables branches match =
161 case variables of
162 [] -> noMatch "matchCon"
164 var : _vars ->
165 flip (Match var) match <$> mapM toClause caseGroups
166 where
167 caseGroups :: [[Branch]]
168 caseGroups =
169 List.groupBy branchEq (List.sortBy branchCmp branches)
171 toClause :: [Branch] -> State Int Clause
172 toClause branches =
173 case head branches of
174 (A.A _ (P.Data name _) : _, _) ->
175 matchClause (Left name) variables branches Break
177 (A.A _ (P.Literal lit) : _, _) ->
178 matchClause (Right lit) variables branches Break
180 _ -> noMatch "matchCon"
183matchClause
184 :: Either Var.Canonical Literal.Literal
185 -> [String]
186 -> [Branch]
187 -> Match
188 -> State Int Clause
189matchClause _ [] _ _ = noMatch "matchClause"
190matchClause c (_:vs) branches match =
191 do vs' <- getVars
192 Clause c vs' <$> buildMatch (vs' ++ vs) (map flatten branches) match
193 where
194 flatten ([], _) = noMatch "matchClause.flatten"
195 flatten (A.A _ pattern : patterns, expr) =
196 case pattern of
197 P.Data _ argPatterns ->
198 (argPatterns ++ patterns, expr)
200 P.Literal _ ->
201 (patterns, expr)
203 _ ->
204 noMatch "matchClause.flatten"
206 getVars :: State Int [String]
207 getVars =
208 case head branches of
209 (A.A _ (P.Data _ argPatterns) : _, _) ->
210 State.forM argPatterns (const newVar)
212 (A.A _ (P.Literal _) : _, _) ->
213 return []
215 _ ->
216 noMatch "matchClause.getVars"
219branchEq :: Branch -> Branch -> Bool
220branchEq (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
221 case (pattern, pattern') of
222 (P.Data name _, P.Data name' _) ->
223 name == name'
225 (P.Literal lit, P.Literal lit') ->
226 lit == lit'
228 (_, _) ->
229 noMatch "matchCon.branchEq"
231branchEq _ _ = noMatch "matchCon.branchEq"
234branchCmp :: Branch -> Branch -> Ordering
235branchCmp (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
236 case (pattern, pattern') of
237 (P.Data name _, P.Data name' _) ->
238 compare name name'
240 (P.Literal lit, P.Literal lit') ->
241 compare lit lit'
243 (_, _) ->
244 noMatch "matchCon.branchCmp"
246branchCmp _ _ = noMatch "matchCon.branchCmp"
249-- MIX MATCHES
251matchMix :: [String] -> [Branch] -> Match -> State Int Match
252matchMix vs branches def =
253 State.foldM (flip $ buildMatch vs) def (reverse branchGroups)
254 where
255 branchGroups =
256 List.groupBy (\p1 p2 -> isCon p1 == isCon p2) branches
259noMatch :: String -> a
260noMatch name =
261 error $ "unexpected pattern in '" ++ name ++
262 "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."