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