989d878 · elk · git.iko.soy

compiler/Gen/Cases.hs+10−7

compare with master

unifiedsplit

@@ -59,13 +59,16 @@ matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

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

60 where

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

62+ let

62− let loc = L t s in

63+ loc = L t s

63− (ps, case p of

64+ subOnePattern (PVar x) = subst x (Var v) e

64− PVar x -> L t s $ subst x (Var v) e

65+ subOnePattern (PAsVar x p) =

65− PAnything -> ce

66+ subst x (Var v) e

67+ subOnePattern PAnything = e

66− PRecord fs ->

68+ subOnePattern (PRecord fs) =

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

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

68− )

70+ in

71+ (ps, L t s $ subOnePattern p)

69

72

70matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

73matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

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

74matchCon (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]

20

21data Pattern = PData String [Pattern]

22 | PRecord [String]

23+ | PAsVar String Pattern

23 | PVar String

24 | PVar String

24 | PAnything

25 | PAnything

25 deriving (Eq, Data, Typeable)

26 deriving (Eq, Data, Typeable)

@@ -83,6 +84,7 @@ instance Show Pattern where

83 case p of

84 case p of

84 PRecord fs -> brkt (intercalate ", " fs)

85 PRecord fs -> brkt (intercalate ", " fs)

85 PVar x -> x

86 PVar x -> x

87+ PAsVar x p -> show p ++ " as " ++ x

86 PAnything -> "_"

88 PAnything -> "_"

87 PData "Cons" [hd@(PData "Cons" _),tl] ->

89 PData "Cons" [hd@(PData "Cons" _),tl] ->

88 parens (show hd) ++ " :: " ++ show tl

90 parens (show hd) ++ " :: " ++ show tl

compiler/Parse/Parser.hs−1

@@ -14,7 +14,6 @@ import Parse.Types

14import Parse.Modules

15import Parse.Foreign

16

17−

18statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"

17statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"

19 where defs = map ((:[]) <$>) [ foreignDef, datatype ]

18 where defs = map ((:[]) <$>) [ foreignDef, datatype ]

20

19

compiler/Parse/Patterns.hs+21−4

@@ -3,7 +3,7 @@ module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) wh

3

4import Ast

5import Located

6−import Control.Applicative ((<$>),(<*>))

6+import Control.Applicative ((<$>),(<*>),(*>),pure)

7import Control.Monad

8import Control.Monad.State

9import Data.Char (isUpper)

@@ -19,6 +19,12 @@ patternBasic =

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

20 ]

21

22+patternMaybeAsVar :: Pattern -> IParser Pattern

23+patternMaybeAsVar x =

24+ choice [ PAsVar <$>

25+ (optional whitespace *> reserved "as" *> whitespace *> lowVar) <*> pure x,

26+ pure x ]

27+

22patternRecord :: IParser Pattern

28patternRecord :: IParser Pattern

23patternRecord = PRecord <$> brackets (commaSep1 lowVar)

29patternRecord = PRecord <$> brackets (commaSep1 lowVar)

24

30

@@ -30,14 +36,17 @@ patternList :: IParser Pattern

30patternList = plist <$> braces (commaSep patternExpr)

36patternList = plist <$> braces (commaSep patternExpr)

31

37

32patternTerm :: IParser Pattern

38patternTerm :: IParser Pattern

33−patternTerm = choice [ patternRecord, patternTuple, patternList, patternBasic ]

39+patternTerm = (choice [ patternRecord, patternTuple, patternList,

40+ patternBasic ])

34− <?> "pattern"

41+ <?> "pattern"

35

42

36patternConstructor :: IParser Pattern

43patternConstructor :: IParser Pattern

37patternConstructor = PData <$> capVar <*> spacePrefix patternTerm

44patternConstructor = PData <$> capVar <*> spacePrefix patternTerm

38

45

39patternExpr :: IParser Pattern

46patternExpr :: IParser Pattern

47+patternExpr = (patternMaybeAsVar =<<

40−patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"

48+ (foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm)))

49+ <?> "pattern"

41

50

42makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr

51makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr

43makeLambda pats body = go (reverse pats) body

52makeLambda pats body = go (reverse pats) body

@@ -53,6 +62,10 @@ extract pattern body@(L t s _) =

53 case pattern of

62 case pattern of

54 PAnything -> return $ fn "_" body

63 PAnything -> return $ fn "_" body

55 PVar x -> return $ fn x body

64 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')

56 PData name ps -> do

69 PData name ps -> do

57 x <- guid

70 x <- guid

58 let a = '_' : show x

71 let a = '_' : show x

@@ -97,6 +110,10 @@ matchSingle pat exp@(L t s _) p =

97 PVar x ->

110 PVar x ->

98 return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]

111 return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]

99

112

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+

100 PRecord fs -> do

117 PRecord fs -> do

101 a <- (\x -> '_' : show x) `liftM` guid

118 a <- (\x -> '_' : show x) `liftM` guid

102 let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

119 let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

compiler/Transform/Rename.hs+4

@@ -130,6 +130,10 @@ patternExtend pattern env =

130 case pattern of

131 PAnything -> return (PAnything, env)

132 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'')

133 PData name ps ->

137 PData name ps ->

134 first (PData name . reverse) `liftM` foldM f ([], env) ps

138 first (PData name . reverse) `liftM` foldM f ([], env) ps

135 where f (rps,env') p = do (rp,env'') <- patternExtend p env'

139 where f (rps,env') p = do (rp,env'') <- patternExtend p env'

compiler/Transform/Replace.hs+1

@@ -33,6 +33,7 @@ patternVars pattern =

33 case pattern of

34 PData _ ps -> unions (map patternVars ps)

35 PVar x -> singleton x

36+ PAsVar _ p -> patternVars p

36 PAnything -> empty

37 PAnything -> empty

37

38

38depth :: Expr -> Integer

39depth :: Expr -> Integer

compiler/Types/Constrain.hs+10

@@ -249,10 +249,20 @@ patternGen :: (Constraint -> Located Constraint)

249patternGen loc tipe as pattern =

250 case pattern of

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

252+

252 PVar v -> do

253 PVar v -> do

253 b <- beta

254 b <- beta

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

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

255 return ( Map.delete v as, loc (b :=: tipe) : cs, b )

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

256 PData name ps -> do

266 PData name ps -> do

257 constr <- guid

267 constr <- guid

258 output <- beta

268 output <- beta

compiler/Types/Substitutions.hs+4−1

@@ -39,7 +39,10 @@ instance Subst Scheme where

39instance Subst Constraint where

40 subst ss (t1 :=: t2) = subst ss t1 :=: subst ss t2

41 subst ss (t :<: super) = subst ss t :<: super

42+ subst ss (x :<<: poly) = (case lookup x ss of

43+ Just (VarT y) -> y

44+ _ -> x

42− subst ss (x :<<: poly) = x :<<: subst ss poly

45+ ) :<<: subst ss poly

43

46

44instance Subst a => Subst (Located a) where

47instance Subst a => Subst (Located a) where

45 subst ss (L str span c) = L str span (subst ss c)

48 subst ss (L str span c) = L str span (subst ss c)