git.iko.soy/elk
on 727d708 help sign in
elk/compiler/Generate/Cases.hs
129 lines 3.9 kB history raw
1module Generate.Cases (caseToMatch, Match (..), Clause (..), matchSubst) where
3import Control.Arrow (first)
4import Control.Monad (liftM,foldM)
5import Data.List (groupBy,sortBy,lookup)
6import Data.Maybe (fromMaybe)
8import Unique
9import SourceSyntax.Location
10import SourceSyntax.Literal
11import SourceSyntax.Pattern
12import SourceSyntax.Expression
13import Transform.Substitute
15caseToMatch patterns = do
16 v <- newVar
17 match [v] (map (first (:[])) patterns) Fail
19newVar = do n <- guid
20 return $ "case" ++ show n
22data Match t v
23 = Match String [Clause t v] (Match t v)
24 | Break
25 | Fail
26 | Other (LExpr t v)
27 | Seq [Match t v]
28 deriving Show
30data Clause t v =
31 Clause (Either String Literal) [String] (Match t v)
32 deriving Show
34matchSubst :: [(String,String)] -> Match t v -> Match t v
35matchSubst _ Break = Break
36matchSubst _ Fail = Fail
37matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
38matchSubst pairs (Other (L t s e)) =
39 Other . L t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
40matchSubst pairs (Match n cs m) =
41 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
42 where varSubst v = fromMaybe v (lookup v pairs)
43 clauseSubst (Clause c vs m) =
44 Clause c (map varSubst vs) (matchSubst pairs m)
46isCon (p:ps, e) =
47 case p of
48 PData _ _ -> True
49 PLiteral _ -> True
50 _ -> False
52isVar p = not (isCon p)
54match :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)
55match [] [] def = return def
56match [] [([],e)] Fail = return $ Other e
57match [] [([],e)] Break = return $ Other e
58match [] cs def = return $ Seq (map (Other . snd) cs ++ [def])
59match vs@(v:_) cs def
60 | all isVar cs' = matchVar vs cs' def
61 | all isCon cs' = matchCon vs cs' def
62 | otherwise = matchMix vs cs' def
63 where
64 cs' = map (dealias v) cs
66dealias v c@(p:ps, L t s e) =
67 case p of
68 PAlias x pattern -> (pattern:ps, L t s $ subst x (Var v) e)
69 _ -> c
71matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v
72 -> Unique (Match t v)
73matchVar (v:vs) cs def = match vs (map subVar cs) def
74 where
75 subVar (p:ps, ce@(L t s e)) = (ps, L t s $ subOnePattern p e)
76 where
77 loc = L t s
78 subOnePattern pattern e =
79 case pattern of
80 PVar x -> subst x (Var v) e
81 PAnything -> e
82 PRecord fs ->
83 foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
85matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v
86 -> Unique (Match t v)
87matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css
88 where
89 css = groupBy eq (sortBy cmp cs)
91 cmp (p1:_,_) (p2:_,_) =
92 case (p1,p2) of
93 (PData n1 _, PData n2 _) -> compare n1 n2
94 _ -> compare p1 p2
96 eq (p1:_,_) (p2:_,_) =
97 case (p1,p2) of
98 (PData n1 _, PData n2 _) -> n1 == n2
99 _ -> p1 == p2
101 toClause cs =
102 case head cs of
103 (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
104 (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
106matchClause :: Either String Literal
107 -> [String]
108 -> [([Pattern],LExpr t v)]
109 -> Match t v
110 -> Unique (Clause t v)
111matchClause c (v:vs) cs def =
112 do vs' <- getVars
113 Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def
114 where
116 flatten (p:ps, e) =
117 case p of
118 PData _ ps' -> (ps' ++ ps, e)
119 PLiteral _ -> (ps, e)
121 getVars =
122 case head cs of
123 (PData _ ps : _, _) -> mapM (\_ -> newVar) ps
124 (PLiteral _ : _, _) -> return []
126matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v
127 -> Unique (Match t v)
128matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
129 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs