9cbd9ba · elk · git.iko.soy

3

4import Control.Applicative ((<$>))

5import Control.Arrow (first)

6+import Control.Monad.State (State)

6import qualified Control.Monad.State as State

7import qualified Control.Monad.State as State

7import Data.List (groupBy,sortBy)

8import Data.List (groupBy,sortBy)

8import Data.Maybe (fromMaybe)

9import Data.Maybe (fromMaybe)

9

10

10import qualified AST.Annotation as A

11import qualified AST.Annotation as A

11import qualified AST.Expression.General as Expr

12import qualified AST.Expression.General as Expr

12−import AST.Expression.Canonical as Canonical

13+import qualified AST.Expression.Canonical as Canonical

13import qualified AST.Literal as Literal

14import qualified AST.Literal as Literal

14import qualified AST.Pattern as P

15import qualified AST.Pattern as P

15import qualified AST.Variable as Var

16import qualified AST.Variable as Var

16import Transform.Substitute (subst)

17import Transform.Substitute (subst)

17

18

18−toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State.State Int (String, Match)

19+toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

19toMatch patterns = do

20toMatch patterns = do

20 v <- newVar

21 v <- newVar

21 (,) v <$> match [v] (map (first (:[])) patterns) Fail

22 (,) v <$> match [v] (map (first (:[])) patterns) Fail

22

23

24+

23−newVar :: State.State Int String

25+newVar :: State Int String

24newVar =

26newVar =

25− do n <- State.get

27+ do n <- State.get

26− State.modify (+1)

28+ State.modify (+1)

27− return $ "_v" ++ show n

29+ return $ "_v" ++ show n

30+

28

31

29data Match

32data Match

30 = Match String [Clause] Match

33 = Match String [Clause] Match

34 | Seq [Match]

37 | Seq [Match]

35 deriving Show

38 deriving Show

36

39

40+

37data Clause =

41data Clause =

38 Clause (Either Var.Canonical Literal.Literal) [String] Match

42 Clause (Either Var.Canonical Literal.Literal) [String] Match

39 deriving Show

43 deriving Show

40

44

45+

46+type Case =

47+ ([P.CanonicalPattern], Canonical.Expr)

48+

49+

41matchSubst :: [(String,String)] -> Match -> Match

50matchSubst :: [(String,String)] -> Match -> Match

42matchSubst pairs match =

51matchSubst pairs match =

43 case match of

52 case match of

44 Break -> Break

53 Break -> Break

54+

45− Fail -> Fail

55+ Fail -> Fail

56+

57+ Seq ms ->

46− Seq ms -> Seq (map (matchSubst pairs) ms)

58+ Seq (map (matchSubst pairs) ms)

59+

47 Other (A.A a e) ->

60 Other (A.A a e) ->

48 Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs

61 Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs

62+

49 Match n cs m ->

63 Match n cs m ->

50 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

64 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

51− where

65+ where

52− varSubst v = fromMaybe v (lookup v pairs)

66+ varSubst v = fromMaybe v (lookup v pairs)

53− clauseSubst (Clause c vs m) =

67+ clauseSubst (Clause c vs m) =

54− Clause c (map varSubst vs) (matchSubst pairs m)

68+ Clause c (map varSubst vs) (matchSubst pairs m)

69+

55

70

56isCon :: ([P.Pattern var], expr) -> Bool

71isCon :: ([P.Pattern var], expr) -> Bool

57isCon ([] , _) = noMatch "isCon"

72isCon ([] , _) = noMatch "isCon"

58isCon (p:_, _) =

73isCon (p:_, _) =

59− case p of

74+ case p of

60− P.Data _ _ -> True

75+ P.Data _ _ -> True

61− P.Literal _ -> True

76+ P.Literal _ -> True

62− _ -> False

77+ _ -> False

78+

63

79

64isVar :: ([P.Pattern var], expr) -> Bool

80isVar :: ([P.Pattern var], expr) -> Bool

65isVar p = not (isCon p)

81isVar p = not (isCon p)

66

82

83+

67−match :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State.State Int Match

84+match :: [String] -> [Case] -> Match -> State Int Match

68match variables cases match =

85match variables cases match =

69 case (variables, cases, match) of

86 case (variables, cases, match) of

70 ([], [], _) ->

87 ([], [], _) ->

87 cases' = map (dealias var) cases

104 cases' = map (dealias var) cases

88

105

89

106

90−dealias :: String -> ([P.CanonicalPattern], Canonical.Expr) -> ([P.CanonicalPattern], Canonical.Expr)

107+dealias :: String -> Case -> Case

91dealias _ ([], _) = noMatch "dealias"

108dealias _ ([], _) = noMatch "dealias"

92dealias v c@(p:ps, A.A a e) =

109dealias v c@(p:ps, A.A a e) =

93 case p of

110 case p of

94 P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)

111 P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)

95 _ -> c

112 _ -> c

96

113

114+

97−matchVar :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State.State Int Match

115+matchVar :: [String] -> [Case] -> Match -> State Int Match

98matchVar [] _ _ = noMatch "matchVar"

116matchVar [] _ _ = noMatch "matchVar"

117+matchVar (v:vs) cs def =

99−matchVar (v:vs) cs def = match vs (map subVar cs) def

118+ match vs (map subVar cs) def

100 where

119 where

101 subVar ([], _) = noMatch "matchVar.subVar"

120 subVar ([], _) = noMatch "matchVar.subVar"

121+ subVar (p:ps, (A.A a expr)) =

102− subVar (p:ps, (A.A a e)) = (ps, A.A a $ subOnePattern p e)

122+ (ps, A.A a $ subOnePattern p expr)

103− where

123+ where

104− subOnePattern pattern e =

124+ subOnePattern pattern expr =

105 case pattern of

125 case pattern of

126+ P.Anything -> expr

127+

128+ P.Var x ->

106− P.Var x -> subst x (Expr.localVar v) e

129+ subst x (Expr.localVar v) expr

107− P.Anything -> e

130+

108 P.Record fs ->

131 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+

110 _ -> noMatch "matchVar.subVar"

134 _ -> noMatch "matchVar.subVar"

111

135

136+

112−matchCon :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State.State Int Match

137+matchCon :: [String] -> [Case] -> Match -> State Int Match

138+matchCon variables cases match =

139+ case variables of

113−matchCon [] _ _ = noMatch "matchCon"

140+ [] -> noMatch "matchCon"

141+

142+ var : _vars ->

114−matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

143+ flip (Match var) match <$> mapM toClause caseGroups

115− where

144+ where

145+ caseGroups :: [[Case]]

146+ caseGroups =

116− css = groupBy eq (sortBy cmp cs)

147+ groupBy eq (sortBy cmp cases)

117−

148+

118− cmp (p1:_,_) (p2:_,_) =

149+ eq :: Case -> Case -> Bool

119− case (p1,p2) of

150+ eq (patterns1, _) (patterns2, _) =

151+ case (patterns1, patterns2) of

152+ (pattern1:_, pattern2:_) ->

153+ case (pattern1, pattern2) of

120− (P.Data n1 _, P.Data n2 _) -> compare n1 n2

154+ (P.Data name1 _, P.Data name2 _) -> name1 == name2

121− _ -> compare p1 p2

155+ (_, _) -> pattern1 == pattern2

122− cmp _ _ = noMatch "matchCon.cmp"

156+ (_, _) -> noMatch "matchCon.eq"

123−

157+

124− eq (p1:_,_) (p2:_,_) =

158+ cmp :: Case -> Case -> Ordering

125− case (p1,p2) of

159+ cmp (patterns1, _) (patterns2, _) =

160+ case (patterns1, patterns2) of

161+ (pattern1:_, pattern2:_) ->

162+ case (pattern1, pattern2) of

126− (P.Data n1 _, P.Data n2 _) -> n1 == n2

163+ (P.Data name1 _, P.Data name2 _) -> compare name1 name2

127− _ -> p1 == p2

164+ (_, _) -> compare pattern1 pattern2

128− eq _ _ = noMatch "matchCon.eq"

165+ (_, _) -> noMatch "matchCon.cmp"

129−

166+

167+ toClause :: [Case] -> State Int Clause

130− toClause cs =

168+ toClause cases =

131− case head cs of

169+ case head cases of

170+ (P.Data name _ : _, _) ->

132− (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break

171+ matchClause (Left name) variables cases Break

172+

173+ (P.Literal lit : _, _) ->

133− (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break

174+ matchClause (Right lit) variables cases Break

175+

134− _ -> noMatch "matchCon"

176+ _ -> noMatch "matchCon"

135−

177+

178+

136−matchClause :: Either Var.Canonical Literal.Literal

179+matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match

137− -> [String]

138− -> [([P.CanonicalPattern], Canonical.Expr)]

139− -> Match

140− -> State.State Int Clause

180+ -> State Int Clause

141matchClause _ [] _ _ = noMatch "matchClause"

181matchClause _ [] _ _ = noMatch "matchClause"

142−matchClause c (_:vs) cs def =

182+matchClause c (_:vs) cs mtch =

143 do vs' <- getVars

183 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

145 where

185 where

146 flatten ([], _) = noMatch "matchClause.flatten"

186 flatten ([], _) = noMatch "matchClause.flatten"

147 flatten (p:ps, e) =

187 flatten (p:ps, e) =

150 P.Literal _ -> (ps, e)

190 P.Literal _ -> (ps, e)

151 _ -> noMatch "matchClause.flatten"

191 _ -> noMatch "matchClause.flatten"

152

192

193+ getVars :: State Int [String]

153 getVars =

194 getVars =

154 case head cs of

195 case head cs of

155 (P.Data _ ps : _, _) -> State.forM ps (const newVar)

196 (P.Data _ ps : _, _) -> State.forM ps (const newVar)

156 (P.Literal _ : _, _) -> return []

197 (P.Literal _ : _, _) -> return []

157 _ -> noMatch "matchClause.getVars"

198 _ -> noMatch "matchClause.getVars"

158

199

200+

159−matchMix :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State.State Int Match

201+matchMix :: [String] -> [Case] -> Match -> State Int Match

160matchMix vs cs def =

202matchMix vs cs def =

161 State.foldM (flip $ match vs) def (reverse css)

203 State.foldM (flip $ match vs) def (reverse css)

162 where

204 where

163 css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

205 css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

164

206

207+

165noMatch :: String -> a

208noMatch :: String -> a

166noMatch name =

209noMatch name =

167 error $ "unexpected pattern in '" ++ name ++

210 error $ "unexpected pattern in '" ++ name ++