git.iko.soy/elk
on master help sign in
Merge branch 'master' into dev

Conflicts: compiler/Model/Ast.hs compiler/Types/Constrain.hs

commit989d878ac58089c972d15615c8167c09d2ecf776 authorevancz <info@elm-lang.org> dateThu 6 Jun 2013, 22:36 (13 years ago) parent951df07ba5cd88
8 files changed+52−13
compare with master
unifiedsplit
compiler/Gen/Cases.hs+10−7 compiler/Model/Ast.hs+2 compiler/Parse/Parser.hs−1 compiler/Parse/Patterns.hs+21−4 compiler/Transform/Rename.hs+4 compiler/Transform/Replace.hs+1 compiler/Types/Constrain.hs+10 compiler/Types/Substitutions.hs+4−1
compiler/Gen/Cases.hs+10−7
@@ -59,13 +59,16 @@ matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
5959matchVar (v:vs) cs def = match vs (map subVar cs) def
6060 where
6161 subVar (p:ps, ce@(L t s e)) =
62− let loc = L t s in
63− (ps, case p of
64− PVar x -> L t s $ subst x (Var v) e
65− PAnything -> ce
66− PRecord fs ->
67− loc $ foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
68− )
62+ let
63+ loc = L t s
64+ subOnePattern (PVar x) = subst x (Var v) e
65+ subOnePattern (PAsVar x p) =
66+ subst x (Var v) e
67+ subOnePattern PAnything = e
68+ subOnePattern (PRecord fs) =
69+ foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
70+ in
71+ (ps, L t s $ subOnePattern p)
6972
7073matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
7174matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css
compiler/Model/Ast.hs+2
@@ -20,6 +20,7 @@ data ImportMethod = As String | Importing [String] | Hiding [String]
2020
2121data Pattern = PData String [Pattern]
2222 | PRecord [String]
23+ | PAsVar String Pattern
2324 | PVar String
2425 | PAnything
2526 deriving (Eq, Data, Typeable)
@@ -83,6 +84,7 @@ instance Show Pattern where
8384 case p of
8485 PRecord fs -> brkt (intercalate ", " fs)
8586 PVar x -> x
87+ PAsVar x p -> show p ++ " as " ++ x
8688 PAnything -> "_"
8789 PData "Cons" [hd@(PData "Cons" _),tl] ->
8890 parens (show hd) ++ " :: " ++ show tl
compiler/Parse/Parser.hs−1
@@ -14,7 +14,6 @@ import Parse.Types
1414import Parse.Modules
1515import Parse.Foreign
1616
17−
1817statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"
1918 where defs = map ((:[]) <$>) [ foreignDef, datatype ]
2019
compiler/Parse/Patterns.hs+21−4
@@ -3,7 +3,7 @@ module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) wh
33
44import Ast
55import Located
6−import Control.Applicative ((<$>),(<*>))
6+import Control.Applicative ((<$>),(<*>),(*>),pure)
77import Control.Monad
88import Control.Monad.State
99import Data.Char (isUpper)
@@ -19,6 +19,12 @@ patternBasic =
1919 return $ if isUpper c then PData x [] else PVar x
2020 ]
2121
22+patternMaybeAsVar :: Pattern -> IParser Pattern
23+patternMaybeAsVar x =
24+ choice [ PAsVar <$>
25+ (optional whitespace *> reserved "as" *> whitespace *> lowVar) <*> pure x,
26+ pure x ]
27+
2228patternRecord :: IParser Pattern
2329patternRecord = PRecord <$> brackets (commaSep1 lowVar)
2430
@@ -30,14 +36,17 @@ patternList :: IParser Pattern
3036patternList = plist <$> braces (commaSep patternExpr)
3137
3238patternTerm :: IParser Pattern
33−patternTerm = choice [ patternRecord, patternTuple, patternList, patternBasic ]
34− <?> "pattern"
39+patternTerm = (choice [ patternRecord, patternTuple, patternList,
40+ patternBasic ])
41+ <?> "pattern"
3542
3643patternConstructor :: IParser Pattern
3744patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
3845
3946patternExpr :: IParser Pattern
40−patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"
47+patternExpr = (patternMaybeAsVar =<<
48+ (foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm)))
49+ <?> "pattern"
4150
4251makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr
4352makeLambda pats body = go (reverse pats) body
@@ -53,6 +62,10 @@ extract pattern body@(L t s _) =
5362 case pattern of
5463 PAnything -> return $ fn "_" body
5564 PVar x -> return $ fn x body
65+ PAsVar x PAnything -> return $ fn x body
66+ PAsVar x p -> do
67+ (x', body') <- extract p body
68+ return $ fn x (loc $ Let [FnDef x' [] (loc $ Var x)] body')
5669 PData name ps -> do
5770 x <- guid
5871 let a = '_' : show x
@@ -97,6 +110,10 @@ matchSingle pat exp@(L t s _) p =
97110 PVar x ->
98111 return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]
99112
113+ PAsVar x p' -> do
114+ subPat <- matchSingle p' (loc $ Var x) p'
115+ return $ (FnDef x [] (loc $ Case exp [(pat, loc $ Var x)])):subPat
116+
100117 PRecord fs -> do
101118 a <- (\x -> '_' : show x) `liftM` guid
102119 let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
compiler/Transform/Rename.hs+4
@@ -130,6 +130,10 @@ patternExtend pattern env =
130130 case pattern of
131131 PAnything -> return (PAnything, env)
132132 PVar x -> first PVar `liftM` extend env x
133+ PAsVar x p -> do
134+ (x', env') <- extend env x
135+ (p', env'') <- patternExtend p env'
136+ return (PAsVar x' p', env'')
133137 PData name ps ->
134138 first (PData name . reverse) `liftM` foldM f ([], env) ps
135139 where f (rps,env') p = do (rp,env'') <- patternExtend p env'
compiler/Transform/Replace.hs+1
@@ -33,6 +33,7 @@ patternVars pattern =
3333 case pattern of
3434 PData _ ps -> unions (map patternVars ps)
3535 PVar x -> singleton x
36+ PAsVar _ p -> patternVars p
3637 PAnything -> empty
3738
3839depth :: Expr -> Integer
compiler/Types/Constrain.hs+10
@@ -249,10 +249,20 @@ patternGen :: (Constraint -> Located Constraint)
249249patternGen loc tipe as pattern =
250250 case pattern of
251251 PAnything -> do b <- beta ; return ( as, [], b )
252+
252253 PVar v -> do
253254 b <- beta
254255 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
255256 return ( Map.delete v as, loc (b :=: tipe) : cs, b )
257+
258+ PAsVar v p -> do
259+ b <- beta
260+ let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
261+ (as', cs', tipe') <- patternGen loc b as p
262+ return (Map.delete v as',
263+ cs' ++ [ loc (b :=: tipe), loc (b :=: tipe') ] ++ cs,
264+ b)
265+
256266 PData name ps -> do
257267 constr <- guid
258268 output <- beta
compiler/Types/Substitutions.hs+4−1
@@ -39,7 +39,10 @@ instance Subst Scheme where
3939instance Subst Constraint where
4040 subst ss (t1 :=: t2) = subst ss t1 :=: subst ss t2
4141 subst ss (t :<: super) = subst ss t :<: super
42− subst ss (x :<<: poly) = x :<<: subst ss poly
42+ subst ss (x :<<: poly) = (case lookup x ss of
43+ Just (VarT y) -> y
44+ _ -> x
45+ ) :<<: subst ss poly
4346
4447instance Subst a => Subst (Located a) where
4548 subst ss (L str span c) = L str span (subst ss c)