git.iko.soy/elk
on 577fc17 help sign in
elk/compiler/Generate/Cases.hs
154 lines 5.1 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
7import Data.List (groupBy,sortBy)
8import Data.Maybe (fromMaybe)
10import AST.Annotation
11import AST.Expression.General
12import AST.Expression.Canonical as Canonical
13import AST.Literal
14import qualified AST.Pattern as P
15import qualified AST.Variable as Var
16import Transform.Substitute
18toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)
19toMatch patterns = do
20 v <- newVar
21 (,) v <$> match [v] (map (first (:[])) patterns) Fail
23newVar :: State Int String
24newVar = do n <- get
25 modify (+1)
26 return $ "_v" ++ show n
28data Match
29 = Match String [Clause] Match
30 | Break
31 | Fail
32 | Other Canonical.Expr
33 | Seq [Match]
34 deriving Show
36data Clause =
37 Clause (Either Var.Canonical Literal) [String] Match
38 deriving Show
40matchSubst :: [(String,String)] -> Match -> Match
41matchSubst pairs match =
42 case match of
43 Break -> Break
44 Fail -> Fail
45 Seq ms -> Seq (map (matchSubst pairs) ms)
46 Other (A a e) ->
47 Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (localVar y)) pairs
48 Match n cs m ->
49 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
50 where
51 varSubst v = fromMaybe v (lookup v pairs)
52 clauseSubst (Clause c vs m) =
53 Clause c (map varSubst vs) (matchSubst pairs m)
55isCon :: ([P.Pattern var], expr) -> Bool
56isCon ([] , _) = noMatch "isCon"
57isCon (p:_, _) =
58 case p of
59 P.Data _ _ -> True
60 P.Literal _ -> True
61 _ -> False
63isVar :: ([P.Pattern var], expr) -> Bool
64isVar p = not (isCon p)
66match :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match
67match [] [] def = return def
68match [] [([],e)] Fail = return $ Other e
69match [] [([],e)] Break = return $ Other e
70match [] cs def = return $ Seq (map (Other . snd) cs ++ [def])
71match vs@(v:_) cs def
72 | all isVar cs' = matchVar vs cs' def
73 | all isCon cs' = matchCon vs cs' def
74 | otherwise = matchMix vs cs' def
75 where
76 cs' = map (dealias v) cs
78dealias :: String -> ([P.CanonicalPattern], Canonical.Expr) -> ([P.CanonicalPattern], Canonical.Expr)
79dealias _ ([], _) = noMatch "dealias"
80dealias v c@(p:ps, A a e) =
81 case p of
82 P.Alias x pattern -> (pattern:ps, A a $ subst x (localVar v) e)
83 _ -> c
85matchVar :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match
86matchVar [] _ _ = noMatch "matchVar"
87matchVar (v:vs) cs def = match vs (map subVar cs) def
88 where
89 subVar ([], _) = noMatch "matchVar.subVar"
90 subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)
91 where
92 subOnePattern pattern e =
93 case pattern of
94 P.Var x -> subst x (localVar v) e
95 P.Anything -> e
96 P.Record fs ->
97 foldr (\x -> subst x (Access (A a (localVar v)) x)) e fs
98 _ -> noMatch "matchVar.subVar"
100matchCon :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match
101matchCon [] _ _ = noMatch "matchCon"
102matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
103 where
104 css = groupBy eq (sortBy cmp cs)
106 cmp (p1:_,_) (p2:_,_) =
107 case (p1,p2) of
108 (P.Data n1 _, P.Data n2 _) -> compare n1 n2
109 _ -> compare p1 p2
110 cmp _ _ = noMatch "matchCon.cmp"
112 eq (p1:_,_) (p2:_,_) =
113 case (p1,p2) of
114 (P.Data n1 _, P.Data n2 _) -> n1 == n2
115 _ -> p1 == p2
116 eq _ _ = noMatch "matchCon.eq"
118 toClause cs =
119 case head cs of
120 (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
121 (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
122 _ -> noMatch "matchCon"
124matchClause :: Either Var.Canonical Literal
125 -> [String]
126 -> [([P.CanonicalPattern], Canonical.Expr)]
127 -> Match
128 -> State Int Clause
129matchClause _ [] _ _ = noMatch "matchClause"
130matchClause c (_:vs) cs def =
131 do vs' <- getVars
132 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def
133 where
134 flatten ([], _) = noMatch "matchClause.flatten"
135 flatten (p:ps, e) =
136 case p of
137 P.Data _ ps' -> (ps' ++ ps, e)
138 P.Literal _ -> (ps, e)
139 _ -> noMatch "matchClause.flatten"
141 getVars =
142 case head cs of
143 (P.Data _ ps : _, _) -> forM ps (const newVar)
144 (P.Literal _ : _, _) -> return []
145 _ -> noMatch "matchClause.getVars"
147matchMix :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match
148matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
149 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
151noMatch :: String -> a
152noMatch name =
153 error $ "unexpected pattern in '" ++ name ++
154 "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."