e80ea9e · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Add support for pattern matching on literals.

e80ea9eEvan Czaplicki13 years ago

compiler/Generate/Cases.hs+56−26

compare with master

unifiedsplit

@@ -1,4 +1,3 @@

1−

2module Generate.Cases (caseToMatch, Match (..), Clause (..), matchSubst) where

1module Generate.Cases (caseToMatch, Match (..), Clause (..), matchSubst) where

4import Control.Arrow (first)

3import Control.Arrow (first)

@@ -8,6 +7,7 @@ import Data.Maybe (fromMaybe)

9import Unique

8import Unique

10import SourceSyntax.Location

9import SourceSyntax.Location

10+import SourceSyntax.Literal

11import SourceSyntax.Pattern

12import SourceSyntax.Expression

13import Transform.Substitute

@@ -28,7 +28,7 @@ data Match t v

28 deriving Show

30data Clause t v =

31− Clause String [String] (Match t v)

31+ Clause (Either String Literal) [String] (Match t v)

32 deriving Show

34matchSubst :: [(String,String)] -> Match t v -> Match t v

@@ -43,8 +43,11 @@ matchSubst pairs (Match n cs m) =

43 clauseSubst (Clause c vs m) =

44 Clause c (map varSubst vs) (matchSubst pairs m)

46−isCon (PData _ _ : _, _) = True

46+isCon (p:ps, _) =

47+ case p of

48+ PData _ _ -> True

49+ PLiteral _ -> True

47−isCon _ = False

50+ _ -> False

49isVar p = not (isCon p)

52isVar p = not (isCon p)

@@ -58,36 +61,63 @@ match vs cs def

58 | all isCon cs = matchCon vs cs def

61 | all isCon cs = matchCon vs cs def

59 | otherwise = matchMix vs cs def

62 | otherwise = matchMix vs cs def

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)

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

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

63 where

67 where

64− subVar (p:ps, ce@(L t s e)) =

68+ subVar (p:ps, ce@(L t s e)) = (ps, L t s $ subOnePattern p)

65− let

69+ where

66 loc = L t s

70 loc = L t s

71+ subOnePattern pattern =

72+ case pattern of

67− subOnePattern (PVar x) = subst x (Var v) e

73+ PVar x -> subst x (Var v) e

68− subOnePattern (PAlias x p) =

69− subst x (Var v) e

74+ PAlias x p -> subst x (Var v) e

70− subOnePattern PAnything = e

75+ PAnything -> e

71− subOnePattern (PRecord fs) =

76+ PRecord fs ->

72− foldr (\x -> subst x (Access (loc (Var v)) x)) e fs

77+ foldr (\x -> subst x (Access (loc (Var v)) x)) e fs

73− in

78+

74− (ps, L t s $ subOnePattern p)

75−

76−matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)

79+matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v

80+ -> Unique (Match t v)

77matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css

81matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css

82+ where

78− where css = groupBy (withName (==)) $ sortBy (withName compare) cs

83+ css = groupBy eq (sortBy cmp cs)

84+

85+ cmp (p1:_,_) (p2:_,_) =

86+ case (p1,p2) of

79− withName f (PData n1 _:_,_) (PData n2 _:_,_) = f n1 n2

87+ (PData n1 _, PData n2 _) -> compare n1 n2

80− toClause cs = let (PData name _ : _ , _) = head cs in

88+ _ -> compare p1 p2

81− matchClause name (v:vs) cs Break

89+

90+ eq (p1:_,_) (p2:_,_) =

91+ case (p1,p2) of

92+ (PData n1 _, PData n2 _) -> n1 == n2

93+ _ -> p1 == p2

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)

84matchClause c (v:vs) cs def =

105matchClause c (v:vs) cs def =

85 do vs' <- getVars

106 do vs' <- getVars

86 Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def

107 Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def

108+ where

109+

87− where flatten (PData _ ps' : ps, e) = (ps' ++ ps, e)

110+ flatten (p:ps, e) =

111+ case p of

112+ PData _ ps' -> (ps' ++ ps, e)

113+ PLiteral _ -> (ps, e)

114+

88− getVars = let (PData _ ps : _, _) = head cs in

115+ getVars =

116+ case head cs of

89− mapM (\_ -> newVar) ps

117+ (PData _ ps : _, _) -> mapM (\_ -> newVar) ps

118+ (PLiteral _ : _, _) -> return []

119

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)

92matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

122matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

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

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

compiler/Generate/JavaScript.hs+13−4

@@ -299,8 +299,12 @@ matchToJS span match =

299 Match name clauses def ->

300 do cases <- concat `liftM` mapM (clauseToJS span name) clauses

301 finally <- matchToJS span def

302+ let isLiteral p = case p of

303+ Clause (Right _) _ _ -> True

304+ _ -> False

305+ access = if any isLiteral clauses then "" else ".ctor"

302− return $ concat [ "\nswitch (", name, ".ctor) {",

306+ return $ concat [ "\nswitch (", name, access, ") {"

303− indent cases, "\n}", finally ]

307+ , indent cases, "\n}", finally ]

304 Fail -> return ("_E.Case" ++ parens (quoted (show span)))

308 Fail -> return ("_E.Case" ++ parens (quoted (show span)))

305 Break -> return "break;"

309 Break -> return "break;"

306 Other e -> ret `liftM` toJS' e

310 Other e -> ret `liftM` toJS' e

@@ -312,10 +316,15 @@ matchToJS span match =

312 Other _ -> acc ++ [m]

316 Other _ -> acc ++ [m]

313 _ -> dropEnd (acc ++ [m]) ms

317 _ -> dropEnd (acc ++ [m]) ms

314

318

315−clauseToJS span var (Clause name vars e) = do

319+clauseToJS span var (Clause value vars e) = do

316 let vars' = map (\n -> var ++ "._" ++ show n) [0..]

320 let vars' = map (\n -> var ++ "._" ++ show n) [0..]

317 s <- matchToJS span $ matchSubst (zip vars vars') e

321 s <- matchToJS span $ matchSubst (zip vars vars') e

318− return $ concat [ "\ncase ", quoted name, ":", indent s ]

322+ return $ concat [ "\ncase ", case value of

323+ Left name -> quoted name

324+ Right (Boolean True) -> "true"

325+ Right (Boolean False) -> "false"

326+ Right lit -> show lit

327+ , ":", indent s ]

319

328

320jsNil = "_L.Nil"

329jsNil = "_L.Nil"

321jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"

330jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"

compiler/Parse/Literal.hs−5

@@ -6,11 +6,6 @@ import Text.Parsec hiding (newline,spaces)

6import Text.Parsec.Indent

8import Parse.Helpers

9−import qualified Parse.Pattern as Pattern

10−import qualified Parse.Type as Type

11−import Parse.Binop

12−

13−import SourceSyntax.Pattern hiding (tuple,list)

14import SourceSyntax.Literal

9import SourceSyntax.Literal

16literal = num <|> str <|> chr

11literal = num <|> str <|> chr

compiler/Parse/Pattern.hs+25−12

@@ -8,20 +8,27 @@ import Data.Char (isUpper)

8import Unique

9import Text.Parsec hiding (newline,spaces,State)

10import Text.Parsec.Indent

11−import Parse.Helpers

13−import SourceSyntax.Helpers (isOp)

12+import Parse.Helpers

14−import SourceSyntax.Location

13+import Parse.Literal

15−import SourceSyntax.Pattern hiding (tuple,list)

16import qualified SourceSyntax.Pattern as Pattern

14import qualified SourceSyntax.Pattern as Pattern

17−import SourceSyntax.Expression (Expr(..), Def(..), LExpr)

15+import SourceSyntax.Everything hiding (parens, tuple)

16+

19basic :: IParser Pattern

18basic :: IParser Pattern

20−basic =

19+basic = choice

21− choice [ char '_' >> return PAnything

20+ [ char '_' >> return PAnything

22− , do x@(c:_) <- var

21+ , do v <- var

22+ return $ case v of

23+ "True" -> PLiteral (Boolean True)

24+ "False" -> PLiteral (Boolean False)

23− return $ if isUpper c then PData x [] else PVar x

25+ c : _ -> if isUpper c then PData v [] else PVar v

26+ , do lit <- literal

27+ return $ case lit of

28+ Str s -> foldr combine (PData "[]" []) s

29+ where combine h t = PData "::" [PLiteral (Chr h),t]

30+ _ -> PLiteral lit

24− ]

31+ ]

26asPattern :: Pattern -> IParser Pattern

33asPattern :: Pattern -> IParser Pattern

27asPattern pattern = do

34asPattern pattern = do

@@ -41,10 +48,16 @@ list :: IParser Pattern

41list = Pattern.list <$> braces (commaSep expr)

48list = Pattern.list <$> braces (commaSep expr)

43term :: IParser Pattern

50term :: IParser Pattern

51+term =

44−term = (choice [ record, tuple, list, basic ]) <?> "pattern"

52+ (choice [ record, tuple, list, basic ]) <?> "pattern"

46patternConstructor :: IParser Pattern

54patternConstructor :: IParser Pattern

55+patternConstructor = do

56+ v <- capVar

57+ case v of

58+ "True" -> return $ PLiteral (Boolean True)

59+ "False" -> return $ PLiteral (Boolean False)

47−patternConstructor = PData <$> capVar <*> spacePrefix term

60+ _ -> PData v <$> spacePrefix term

49expr :: IParser Pattern

62expr :: IParser Pattern

50expr = do

63expr = do

compiler/SourceSyntax/Literal.hs+1−1

@@ -8,7 +8,7 @@ data Literal = IntNum Int

8 | Chr Char

9 | Str String

10 | Boolean Bool

11− deriving (Eq, Data, Typeable)

11+ deriving (Eq, Ord, Data, Typeable)

14instance Show Literal where

compiler/SourceSyntax/Pattern.hs+1−1

@@ -13,7 +13,7 @@ data Pattern = PData String [Pattern]

13 | PVar String

14 | PAnything

15 | PLiteral Literal.Literal

16− deriving (Eq, Data, Typeable)

16+ deriving (Eq, Ord, Data, Typeable)

18cons h t = PData "::" [h,t]

19nil = PData "[]" []

compiler/SourceSyntax/Variable.hsnew file+2

@@ -0,0 +1,2 @@

1+module SourceSyntax.Variable where

compiler/Types/Constrain.hs+18−11

@@ -142,13 +142,13 @@ gen (L _ span expr) =

142 Case e cases ->

143 do (as,cs,t) <- gen e

144 (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases

145+ b <- beta

145 return ( unionsA $ as:ass

146 return ( unionsA $ as:ass

146 , let cases' = map snd cases

147 , let cases' = map snd cases

147 locs = zipWith merge cases' (tail cases')

148 locs = zipWith merge cases' (tail cases')

148− csts = zipWith (:=:) ts (tail ts)

149− cs' = zipWith ($) locs csts

149+ cs' = zipWith (\t loc -> loc (b :=: t)) ts locs

150 in concat $ cs' : cs : css

151− , head ts)

151+ , b)

152

153 ExplicitList es ->

154 do (ass,css,ts) <- unzip3 `liftM` mapM gen es

@@ -221,14 +221,19 @@ gen (L _ span expr) =

221 , t2 )

222

223 Markdown _ -> primitive element

224− Literal lit ->

224+ Literal lit -> literalGen loc' lit

225+

226+literalGen :: (Constraint -> Located Constraint)

227+ -> Literal

228+ -> Unique (TVarMap, Constraints, Type)

229+literalGen loc lit =

225− case lit of

230+ case lit of

226− IntNum _ -> do t <- beta

231+ IntNum _ -> do t <- beta

227− return (Map.empty, [loc' $ t :<: number], t)

232+ return (Map.empty, [loc $ t :<: number], t)

228− FloatNum _ -> primitive float

233+ FloatNum _ -> primitive float

234+ Boolean _ -> primitive bool

229− Chr _ -> primitive char

235+ Chr _ -> primitive char

230− Str _ -> primitive string

236+ Str _ -> primitive string

231− Boolean _ -> primitive bool

232

237

233

238

234primitive :: Type -> Unique (TVarMap, Constraints, Type)

239primitive :: Type -> Unique (TVarMap, Constraints, Type)

@@ -251,6 +256,8 @@ patternGen loc tipe as pattern =

251 case pattern of

256 case pattern of

252 PAnything -> do b <- beta ; return ( as, [], b )

257 PAnything -> do b <- beta ; return ( as, [], b )

253

258

259+ PLiteral lit -> literalGen loc lit

260+

254 PVar v -> do

261 PVar v -> do

255 b <- beta

262 b <- beta

256 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)

263 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)