git.iko.soy/elk
on ac4e451 help sign in
elk/src/Optimize/Cases.hs
266 lines 6.9 kB history raw
1module Optimize.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.Optimized as Optimized
12import qualified AST.Literal as Literal
13import qualified AST.Pattern as P
14import qualified AST.Variable as Var
15import qualified Optimize.Substitute as S
16import qualified Reporting.Annotation as A
19-- MATCHES
21data Match
22 = Match String [Clause] Match
23 | Break
24 | Fail
25 | Other Optimized.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.Optimized], Optimized.Expr)
39-- PUBLIC FUNCTIONS
41toMatch :: [(P.Optimized, Optimized.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 ann expr) ->
65 let
66 substitutions =
67 map (\(x,y) -> S.subst x (Expr.localVar y)) pairs
68 in
69 Other $ A.A ann $ foldr ($) expr substitutions
71 Match n cs m ->
72 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
73 where
74 varSubst v = fromMaybe v (lookup v pairs)
75 clauseSubst (Clause c vs m) =
76 Clause c (map varSubst vs) (matchSubst pairs m)
79-- BUILD MATCHES
81buildMatch :: [String] -> [Branch] -> Match -> State Int Match
82buildMatch variables branches match =
83 case (variables, branches, match) of
84 ([], [], _) ->
85 return match
87 ([], [([], expr)], Fail) ->
88 return $ Other expr
90 ([], [([], expr)], Break) ->
91 return $ Other expr
93 ([], _, _) ->
94 return $ Seq (map (Other . snd) branches ++ [match])
96 (var:_, _, _)
97 | all isVar branches' -> matchVar variables branches' match
98 | all isCon branches' -> matchCon variables branches' match
99 | otherwise -> matchMix variables branches' match
100 where
101 branches' = map (dealias var) branches
104dealias :: String -> Branch -> Branch
105dealias _ ([], _) = noMatch "dealias"
106dealias var branch@(p:ps, A.A ann e) =
107 case p of
108 A.A _ (P.Alias alias pattern) ->
109 ( pattern:ps
110 , A.A ann (S.subst alias (Expr.localVar var) e)
111 )
113 _ ->
114 branch
117isCon :: ([P.Pattern ann var], expr) -> Bool
118isCon ([], _) = noMatch "isCon"
119isCon (A.A _ pattern : _, _) =
120 case pattern of
121 P.Data _ _ -> True
122 P.Literal _ -> True
123 _ -> False
126isVar :: ([P.Pattern ann var], expr) -> Bool
127isVar p =
128 not (isCon p)
131-- VARIABLE MATCHES
133matchVar :: [String] -> [Branch] -> Match -> State Int Match
134matchVar [] _ _ = noMatch "matchVar"
135matchVar (var:vars) branches match =
136 buildMatch vars (map subVar branches) match
137 where
138 subVar ([], _) = noMatch "matchVar.subVar"
139 subVar (A.A _ pattern : patterns, (A.A ann expr)) =
140 ( patterns
141 , A.A ann (subOnePattern pattern expr)
142 )
143 where
144 subOnePattern pattern expr =
145 case pattern of
146 P.Anything ->
147 expr
149 P.Var x ->
150 S.subst x (Expr.localVar var) expr
152 P.Record fields ->
153 let access = Expr.Access (A.A ann (Expr.localVar var))
154 in
155 foldr (\x -> S.subst x (access x)) expr fields
157 _ ->
158 noMatch "matchVar.subVar"
161-- CONSTRUCTOR MATCHES
163matchCon :: [String] -> [Branch] -> Match -> State Int Match
164matchCon variables branches match =
165 case variables of
166 [] -> noMatch "matchCon"
168 var : _vars ->
169 flip (Match var) match <$> mapM toClause caseGroups
170 where
171 caseGroups :: [[Branch]]
172 caseGroups =
173 List.groupBy branchEq (List.sortBy branchCmp branches)
175 toClause :: [Branch] -> State Int Clause
176 toClause branches =
177 case head branches of
178 (A.A _ (P.Data name _) : _, _) ->
179 matchClause (Left name) variables branches Break
181 (A.A _ (P.Literal lit) : _, _) ->
182 matchClause (Right lit) variables branches Break
184 _ -> noMatch "matchCon"
187matchClause
188 :: Either Var.Canonical Literal.Literal
189 -> [String]
190 -> [Branch]
191 -> Match
192 -> State Int Clause
193matchClause _ [] _ _ = noMatch "matchClause"
194matchClause c (_:vs) branches match =
195 do vs' <- getVars
196 Clause c vs' <$> buildMatch (vs' ++ vs) (map flatten branches) match
197 where
198 flatten ([], _) = noMatch "matchClause.flatten"
199 flatten (A.A _ pattern : patterns, expr) =
200 case pattern of
201 P.Data _ argPatterns ->
202 (argPatterns ++ patterns, expr)
204 P.Literal _ ->
205 (patterns, expr)
207 _ ->
208 noMatch "matchClause.flatten"
210 getVars :: State Int [String]
211 getVars =
212 case head branches of
213 (A.A _ (P.Data _ argPatterns) : _, _) ->
214 State.forM argPatterns (const newVar)
216 (A.A _ (P.Literal _) : _, _) ->
217 return []
219 _ ->
220 noMatch "matchClause.getVars"
223branchEq :: Branch -> Branch -> Bool
224branchEq (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
225 case (pattern, pattern') of
226 (P.Data name _, P.Data name' _) ->
227 name == name'
229 (P.Literal lit, P.Literal lit') ->
230 lit == lit'
232 (_, _) ->
233 noMatch "matchCon.branchEq"
235branchEq _ _ = noMatch "matchCon.branchEq"
238branchCmp :: Branch -> Branch -> Ordering
239branchCmp (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
240 case (pattern, pattern') of
241 (P.Data name _, P.Data name' _) ->
242 compare name name'
244 (P.Literal lit, P.Literal lit') ->
245 compare lit lit'
247 (_, _) ->
248 noMatch "matchCon.branchCmp"
250branchCmp _ _ = noMatch "matchCon.branchCmp"
253-- MIX MATCHES
255matchMix :: [String] -> [Branch] -> Match -> State Int Match
256matchMix vs branches def =
257 State.foldM (flip $ buildMatch vs) def (reverse branchGroups)
258 where
259 branchGroups =
260 List.groupBy (\p1 p2 -> isCon p1 == isCon p2) branches
263noMatch :: String -> a
264noMatch name =
265 error $ "unexpected pattern in `" ++ name ++
266 "` function. Report a compiler issue to <https://github.com/elm-lang/Elm>."