@@ -1,4 +1,3 @@
1−
21module Generate.Cases (caseToMatch, Match (..), Clause (..), matchSubst) where
32
43import Control.Arrow (first)
@@ -8,6 +7,7 @@ import Data.Maybe (fromMaybe)
87
98import Unique
109import SourceSyntax.Location
10+import SourceSyntax.Literal
1111import SourceSyntax.Pattern
1212import SourceSyntax.Expression
1313import Transform.Substitute
@@ -28,7 +28,7 @@ data Match t v
2828 deriving Show
2929
3030data Clause t v =
31− Clause String [String] (Match t v)
31+ Clause (Either String Literal) [String] (Match t v)
3232 deriving Show
3333
3434matchSubst :: [(String,String)] -> Match t v -> Match t v
@@ -43,8 +43,11 @@ matchSubst pairs (Match n cs m) =
4343 clauseSubst (Clause c vs m) =
4444 Clause c (map varSubst vs) (matchSubst pairs m)
4545
46−isCon (PData _ _ : _, _) = True
47−isCon _ = False
46+isCon (p:ps, _) =
47+ case p of
48+ PData _ _ -> True
49+ PLiteral _ -> True
50+ _ -> False
4851
4952isVar p = not (isCon p)
5053
@@ -58,36 +61,63 @@ match vs cs def
5861 | all isCon cs = matchCon vs cs def
5962 | otherwise = matchMix vs cs def
6063
61−matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)
64+matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v
65+ -> Unique (Match t v)
6266matchVar (v:vs) cs def = match vs (map subVar cs) def
6367 where
64− subVar (p:ps, ce@(L t s e)) =
65− let
68+ subVar (p:ps, ce@(L t s e)) = (ps, L t s $ subOnePattern p)
69+ where
6670 loc = L t s
67− subOnePattern (PVar x) = subst x (Var v) e
68− subOnePattern (PAlias x p) =
69− subst x (Var v) e
70− subOnePattern PAnything = e
71− subOnePattern (PRecord fs) =
72− foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
73− in
74− (ps, L t s $ subOnePattern p)
75−
76−matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)
71+ subOnePattern pattern =
72+ case pattern of
73+ PVar x -> subst x (Var v) e
74+ PAlias x p -> subst x (Var v) e
75+ PAnything -> e
76+ PRecord fs ->
77+ foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
78+
79+matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v
80+ -> Unique (Match t v)
7781matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css
78− where css = groupBy (withName (==)) $ sortBy (withName compare) cs
79− withName f (PData n1 _:_,_) (PData n2 _:_,_) = f n1 n2
80− toClause cs = let (PData name _ : _ , _) = head cs in
81− matchClause name (v:vs) cs Break
82+ where
83+ css = groupBy eq (sortBy cmp cs)
84+
85+ cmp (p1:_,_) (p2:_,_) =
86+ case (p1,p2) of
87+ (PData n1 _, PData n2 _) -> compare n1 n2
88+ _ -> compare p1 p2
89+
90+ eq (p1:_,_) (p2:_,_) =
91+ case (p1,p2) of
92+ (PData n1 _, PData n2 _) -> n1 == n2
93+ _ -> p1 == p2
8294
83−matchClause :: String -> [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Clause t v)
95+ toClause cs =
96+ case head cs of
97+ (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
98+ (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
99+
100+matchClause :: Either String Literal
101+ -> [String]
102+ -> [([Pattern],LExpr t v)]
103+ -> Match t v
104+ -> Unique (Clause t v)
84105matchClause c (v:vs) cs def =
85106 do vs' <- getVars
86107 Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def
87− where flatten (PData _ ps' : ps, e) = (ps' ++ ps, e)
88− getVars = let (PData _ ps : _, _) = head cs in
89− mapM (\_ -> newVar) ps
108+ where
109+
110+ flatten (p:ps, e) =
111+ case p of
112+ PData _ ps' -> (ps' ++ ps, e)
113+ PLiteral _ -> (ps, e)
114+
115+ getVars =
116+ case head cs of
117+ (PData _ ps : _, _) -> mapM (\_ -> newVar) ps
118+ (PLiteral _ : _, _) -> return []
90119
91−matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)
120+matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v
121+ -> Unique (Match t v)
92122matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
93123 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs