@@ -3,28 +3,31 @@ module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) whe
33
44import Control.Applicative ((<$>))
55import Control.Arrow (first)
6+import Control.Monad.State (State)
67import qualified Control.Monad.State as State
78import Data.List (groupBy,sortBy)
89import Data.Maybe (fromMaybe)
910
1011import qualified AST.Annotation as A
1112import qualified AST.Expression.General as Expr
12−import AST.Expression.Canonical as Canonical
13+import qualified AST.Expression.Canonical as Canonical
1314import qualified AST.Literal as Literal
1415import qualified AST.Pattern as P
1516import qualified AST.Variable as Var
1617import Transform.Substitute (subst)
1718
18−toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State.State Int (String, Match)
19+toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)
1920toMatch patterns = do
2021 v <- newVar
2122 (,) v <$> match [v] (map (first (:[])) patterns) Fail
2223
23−newVar :: State.State Int String
24+
25+newVar :: State Int String
2426newVar =
25− do n <- State.get
26− State.modify (+1)
27− return $ "_v" ++ show n
27+ do n <- State.get
28+ State.modify (+1)
29+ return $ "_v" ++ show n
30+
2831
2932data Match
3033 = Match String [Clause] Match
@@ -34,37 +37,51 @@ data Match
3437 | Seq [Match]
3538 deriving Show
3639
40+
3741data Clause =
3842 Clause (Either Var.Canonical Literal.Literal) [String] Match
3943 deriving Show
4044
45+
46+type Case =
47+ ([P.CanonicalPattern], Canonical.Expr)
48+
49+
4150matchSubst :: [(String,String)] -> Match -> Match
4251matchSubst pairs match =
4352 case match of
4453 Break -> Break
45− Fail -> Fail
46− Seq ms -> Seq (map (matchSubst pairs) ms)
54+
55+ Fail -> Fail
56+
57+ Seq ms ->
58+ Seq (map (matchSubst pairs) ms)
59+
4760 Other (A.A a e) ->
4861 Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs
62+
4963 Match n cs m ->
5064 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
51− where
52− varSubst v = fromMaybe v (lookup v pairs)
53− clauseSubst (Clause c vs m) =
54− Clause c (map varSubst vs) (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)
69+
5570
5671isCon :: ([P.Pattern var], expr) -> Bool
5772isCon ([] , _) = noMatch "isCon"
5873isCon (p:_, _) =
59− case p of
60− P.Data _ _ -> True
61− P.Literal _ -> True
62− _ -> False
74+ case p of
75+ P.Data _ _ -> True
76+ P.Literal _ -> True
77+ _ -> False
78+
6379
6480isVar :: ([P.Pattern var], expr) -> Bool
6581isVar p = not (isCon p)
6682
67−match :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State.State Int Match
83+
84+match :: [String] -> [Case] -> Match -> State Int Match
6885match variables cases match =
6986 case (variables, cases, match) of
7087 ([], [], _) ->
@@ -87,61 +104,84 @@ match variables cases match =
87104 cases' = map (dealias var) cases
88105
89106
90−dealias :: String -> ([P.CanonicalPattern], Canonical.Expr) -> ([P.CanonicalPattern], Canonical.Expr)
107+dealias :: String -> Case -> Case
91108dealias _ ([], _) = noMatch "dealias"
92109dealias v c@(p:ps, A.A a e) =
93110 case p of
94111 P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)
95112 _ -> c
96113
97−matchVar :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State.State Int Match
114+
115+matchVar :: [String] -> [Case] -> Match -> State Int Match
98116matchVar [] _ _ = noMatch "matchVar"
99−matchVar (v:vs) cs def = match vs (map subVar cs) def
117+matchVar (v:vs) cs def =
118+ match vs (map subVar cs) def
100119 where
101120 subVar ([], _) = noMatch "matchVar.subVar"
102− subVar (p:ps, (A.A a e)) = (ps, A.A a $ subOnePattern p e)
103− where
104− subOnePattern pattern e =
121+ subVar (p:ps, (A.A a expr)) =
122+ (ps, A.A a $ subOnePattern p expr)
123+ where
124+ subOnePattern pattern expr =
105125 case pattern of
106− P.Var x -> subst x (Expr.localVar v) e
107− P.Anything -> e
126+ P.Anything -> expr
127+
128+ P.Var x ->
129+ subst x (Expr.localVar v) expr
130+
108131 P.Record fs ->
109− foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) e fs
132+ foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) expr fs
133+
110134 _ -> noMatch "matchVar.subVar"
111135
112−matchCon :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State.State Int Match
113−matchCon [] _ _ = noMatch "matchCon"
114−matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
115− where
116− css = groupBy eq (sortBy cmp cs)
117−
118− cmp (p1:_,_) (p2:_,_) =
119− case (p1,p2) of
120− (P.Data n1 _, P.Data n2 _) -> compare n1 n2
121− _ -> compare p1 p2
122− cmp _ _ = noMatch "matchCon.cmp"
123−
124− eq (p1:_,_) (p2:_,_) =
125− case (p1,p2) of
126− (P.Data n1 _, P.Data n2 _) -> n1 == n2
127− _ -> p1 == p2
128− eq _ _ = noMatch "matchCon.eq"
129−
130− toClause cs =
131− case head cs of
132− (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
133− (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
134− _ -> noMatch "matchCon"
135−
136−matchClause :: Either Var.Canonical Literal.Literal
137− -> [String]
138− -> [([P.CanonicalPattern], Canonical.Expr)]
139− -> Match
140− -> State.State Int Clause
136+
137+matchCon :: [String] -> [Case] -> Match -> State Int Match
138+matchCon variables cases match =
139+ case variables of
140+ [] -> noMatch "matchCon"
141+
142+ var : _vars ->
143+ flip (Match var) match <$> mapM toClause caseGroups
144+ where
145+ caseGroups :: [[Case]]
146+ caseGroups =
147+ groupBy eq (sortBy cmp cases)
148+
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"
157+
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"
166+
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
172+
173+ (P.Literal lit : _, _) ->
174+ matchClause (Right lit) variables cases Break
175+
176+ _ -> noMatch "matchCon"
177+
178+
179+matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match
180+ -> State Int Clause
141181matchClause _ [] _ _ = noMatch "matchClause"
142−matchClause c (_:vs) cs def =
182+matchClause c (_:vs) cs mtch =
143183 do vs' <- getVars
144− Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def
184+ Clause c vs' <$> match (vs' ++ vs) (map flatten cs) mtch
145185 where
146186 flatten ([], _) = noMatch "matchClause.flatten"
147187 flatten (p:ps, e) =
@@ -150,18 +190,21 @@ matchClause c (_:vs) cs def =
150190 P.Literal _ -> (ps, e)
151191 _ -> noMatch "matchClause.flatten"
152192
193+ getVars :: State Int [String]
153194 getVars =
154195 case head cs of
155196 (P.Data _ ps : _, _) -> State.forM ps (const newVar)
156197 (P.Literal _ : _, _) -> return []
157198 _ -> noMatch "matchClause.getVars"
158199
159−matchMix :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State.State Int Match
200+
201+matchMix :: [String] -> [Case] -> Match -> State Int Match
160202matchMix vs cs def =
161203 State.foldM (flip $ match vs) def (reverse css)
162204 where
163205 css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
164206
207+
165208noMatch :: String -> a
166209noMatch name =
167210 error $ "unexpected pattern in '" ++ name ++