git.iko.soy/elk
on 2a930fd help sign in
elk/src/Generate/Cases.hs
211 lines 6.2 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where
4import Control.Applicative ((<$>))
5import Control.Arrow (first)
6import Control.Monad.State (State)
7import qualified Control.Monad.State as State
8import Data.List (groupBy,sortBy)
9import Data.Maybe (fromMaybe)
11import qualified AST.Annotation as A
12import qualified AST.Expression.General as Expr
13import qualified AST.Expression.Canonical as Canonical
14import qualified AST.Literal as Literal
15import qualified AST.Pattern as P
16import qualified AST.Variable as Var
17import Transform.Substitute (subst)
19toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)
20toMatch patterns = do
21 v <- newVar
22 (,) v <$> match [v] (map (first (:[])) patterns) Fail
25newVar :: State Int String
26newVar =
27 do n <- State.get
28 State.modify (+1)
29 return $ "_v" ++ show n
32data Match
33 = Match String [Clause] Match
34 | Break
35 | Fail
36 | Other Canonical.Expr
37 | Seq [Match]
38 deriving Show
41data Clause =
42 Clause (Either Var.Canonical Literal.Literal) [String] Match
43 deriving Show
46type Case =
47 ([P.CanonicalPattern], Canonical.Expr)
50matchSubst :: [(String,String)] -> Match -> Match
51matchSubst pairs match =
52 case match of
53 Break -> Break
55 Fail -> Fail
57 Seq ms ->
58 Seq (map (matchSubst pairs) ms)
60 Other (A.A a e) ->
61 Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs
63 Match n cs m ->
64 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
65 where
66 varSubst v = fromMaybe v (lookup v pairs)
67 clauseSubst (Clause c vs m) =
68 Clause c (map varSubst vs) (matchSubst pairs m)
71isCon :: ([P.Pattern var], expr) -> Bool
72isCon ([] , _) = noMatch "isCon"
73isCon (p:_, _) =
74 case p of
75 P.Data _ _ -> True
76 P.Literal _ -> True
77 _ -> False
80isVar :: ([P.Pattern var], expr) -> Bool
81isVar p = not (isCon p)
84match :: [String] -> [Case] -> Match -> State Int Match
85match variables cases match =
86 case (variables, cases, match) of
87 ([], [], _) ->
88 return match
90 ([], [([], expr)], Fail) ->
91 return $ Other expr
93 ([], [([], expr)], Break) ->
94 return $ Other expr
96 ([], _, _) ->
97 return $ Seq (map (Other . snd) cases ++ [match])
99 (var:_, _, _)
100 | all isVar cases' -> matchVar variables cases' match
101 | all isCon cases' -> matchCon variables cases' match
102 | otherwise -> matchMix variables cases' match
103 where
104 cases' = map (dealias var) cases
107dealias :: String -> Case -> Case
108dealias _ ([], _) = noMatch "dealias"
109dealias v c@(p:ps, A.A a e) =
110 case p of
111 P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)
112 _ -> c
115matchVar :: [String] -> [Case] -> Match -> State Int Match
116matchVar [] _ _ = noMatch "matchVar"
117matchVar (v:vs) cs def =
118 match vs (map subVar cs) def
119 where
120 subVar ([], _) = noMatch "matchVar.subVar"
121 subVar (p:ps, (A.A a expr)) =
122 (ps, A.A a $ subOnePattern p expr)
123 where
124 subOnePattern pattern expr =
125 case pattern of
126 P.Anything -> expr
128 P.Var x ->
129 subst x (Expr.localVar v) expr
131 P.Record fs ->
132 foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) expr fs
134 _ -> noMatch "matchVar.subVar"
137matchCon :: [String] -> [Case] -> Match -> State Int Match
138matchCon variables cases match =
139 case variables of
140 [] -> noMatch "matchCon"
142 var : _vars ->
143 flip (Match var) match <$> mapM toClause caseGroups
144 where
145 caseGroups :: [[Case]]
146 caseGroups =
147 groupBy eq (sortBy cmp cases)
149 eq :: Case -> Case -> Bool
150 eq (patterns1, _) (patterns2, _) =
151 case (patterns1, patterns2) of
152 (pattern1:_, pattern2:_) ->
153 case (pattern1, pattern2) of
154 (P.Data name1 _, P.Data name2 _) -> name1 == name2
155 (_, _) -> pattern1 == pattern2
156 (_, _) -> noMatch "matchCon.eq"
158 cmp :: Case -> Case -> Ordering
159 cmp (patterns1, _) (patterns2, _) =
160 case (patterns1, patterns2) of
161 (pattern1:_, pattern2:_) ->
162 case (pattern1, pattern2) of
163 (P.Data name1 _, P.Data name2 _) -> compare name1 name2
164 (_, _) -> compare pattern1 pattern2
165 (_, _) -> noMatch "matchCon.cmp"
167 toClause :: [Case] -> State Int Clause
168 toClause cases =
169 case head cases of
170 (P.Data name _ : _, _) ->
171 matchClause (Left name) variables cases Break
173 (P.Literal lit : _, _) ->
174 matchClause (Right lit) variables cases Break
176 _ -> noMatch "matchCon"
179matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match
180 -> State Int Clause
181matchClause _ [] _ _ = noMatch "matchClause"
182matchClause c (_:vs) cs mtch =
183 do vs' <- getVars
184 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) mtch
185 where
186 flatten ([], _) = noMatch "matchClause.flatten"
187 flatten (p:ps, e) =
188 case p of
189 P.Data _ ps' -> (ps' ++ ps, e)
190 P.Literal _ -> (ps, e)
191 _ -> noMatch "matchClause.flatten"
193 getVars :: State Int [String]
194 getVars =
195 case head cs of
196 (P.Data _ ps : _, _) -> State.forM ps (const newVar)
197 (P.Literal _ : _, _) -> return []
198 _ -> noMatch "matchClause.getVars"
201matchMix :: [String] -> [Case] -> Match -> State Int Match
202matchMix vs cs def =
203 State.foldM (flip $ match vs) def (reverse css)
204 where
205 css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
208noMatch :: String -> a
209noMatch name =
210 error $ "unexpected pattern in '" ++ name ++
211 "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."