git.iko.soy/elk
on master help sign in
Support @ patterns as in Haskell
commit3c71ee1c4d598b33b01661d5ad43afc566080ae9 authorAndrew Miller <ak.miller@auckland.ac.nz> dateThu 6 Jun 2013, 21:27 (13 years ago) parent8d13b0b
8 files changed+48−11
compare with master
unifiedsplit
compiler/Gen/Cases.hs+10−7 compiler/Model/Ast.hs+3−1 compiler/Parse/Parser.hs−1 compiler/Parse/Patterns.hs+17−1 compiler/Transform/Rename.hs+4 compiler/Transform/Replace.hs+1 compiler/Types/Constrain.hs+9 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 (PAtVar 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+3−1
@@ -8,7 +8,7 @@ import Types.Types
88import qualified Text.Pandoc as Pandoc
99import Data.Data
1010
11−data Module = Module [String] Exports Imports [Statement]
11+data Module = Module [String] Exports Imports [Statement] deriving (Show)
1212
1313type Exports = [String]
1414
@@ -19,6 +19,7 @@ data ImportMethod = As String | Importing [String] | Hiding [String]
1919
2020data Pattern = PData String [Pattern]
2121 | PRecord [String]
22+ | PAtVar String Pattern
2223 | PVar String
2324 | PAnything
2425 deriving (Eq, Data, Typeable)
@@ -82,6 +83,7 @@ instance Show Pattern where
8283 case p of
8384 PRecord fs -> brkt (intercalate ", " fs)
8485 PVar x -> x
86+ PAtVar x p -> x ++ "@(" ++ show p ++ ")"
8587 PAnything -> "_"
8688 PData "Cons" [hd@(PData "Cons" _),tl] ->
8789 parens (show hd) ++ " :: " ++ show tl
compiler/Parse/Parser.hs−1
@@ -13,7 +13,6 @@ import Parse.Types
1313import Parse.Modules
1414import Parse.Foreign
1515
16−
1716statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"
1817 where defs = map ((:[]) <$>) [ foreignDef, datatype ]
1918
compiler/Parse/Patterns.hs+17−1
@@ -19,6 +19,13 @@ patternBasic =
1919 return $ if isUpper c then PData x [] else PVar x
2020 ]
2121
22+patternMaybeAtVar :: Pattern -> IParser Pattern
23+patternMaybeAtVar (PVar x) =
24+ (char '@' >>
25+ PAtVar x <$> patternExpr) <|>
26+ ({- empty -} return $ PVar x)
27+patternMaybeAtVar x = return x
28+
2229patternRecord :: IParser Pattern
2330patternRecord = PRecord <$> brackets (commaSep1 lowVar)
2431
@@ -30,7 +37,8 @@ patternList :: IParser Pattern
3037patternList = plist <$> braces (commaSep patternExpr)
3138
3239patternTerm :: IParser Pattern
33−patternTerm = choice [ patternRecord, patternTuple, patternList, patternBasic ]
40+patternTerm = choice [ patternRecord, patternTuple, patternList,
41+ patternMaybeAtVar =<< patternBasic ]
3442 <?> "pattern"
3543
3644patternConstructor :: IParser Pattern
@@ -53,6 +61,10 @@ extract pattern body@(L t s _) =
5361 case pattern of
5462 PAnything -> return $ fn "_" body
5563 PVar x -> return $ fn x body
64+ PAtVar x PAnything -> return $ fn x body
65+ PAtVar x p -> do
66+ (x', body') <- extract p body
67+ return $ fn x (loc $ Let [FnDef x' [] (loc $ Var x)] body')
5668 PData name ps -> do
5769 x <- guid
5870 let a = '_' : show x
@@ -97,6 +109,10 @@ matchSingle pat exp@(L t s _) p =
97109 PVar x ->
98110 return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]
99111
112+ PAtVar x p' -> do
113+ subPat <- matchSingle p' (loc $ Var x) p'
114+ return $ (FnDef x [] (loc $ Case exp [(pat, loc $ Var x)])):subPat
115+
100116 PRecord fs -> do
101117 a <- (\x -> '_' : show x) `liftM` guid
102118 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+ PAtVar x p -> do
134+ (x', env') <- extend env x
135+ (p', env'') <- patternExtend p env'
136+ return (PAtVar 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+ PAtVar _ p -> patternVars p
3637 PAnything -> empty
3738
3839depth :: Expr -> Integer
compiler/Types/Constrain.hs+9
@@ -259,6 +259,15 @@ patternGen loc tipe as pattern =
259259 b <- beta
260260 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
261261 return ( Map.delete v as, Set.fromList (loc (b :=: tipe) : cs), b )
262+ PAtVar v p -> do
263+ b <- beta
264+ let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
265+ (as', cs', tipe') <- patternGen loc b as p
266+ return (Map.delete v as',
267+ cs' `Set.union`
268+ (Set.fromList $ (loc (b :=: tipe)):(loc (b :=: tipe')):cs),
269+ b)
270+
262271 PData name ps -> do
263272 constr <- guid
264273 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)