3c71ee1 · 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 (PAtVar 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+3−1

@@ -8,7 +8,7 @@ import Types.Types

8import qualified Text.Pandoc as Pandoc

9import Data.Data

10

11−data Module = Module [String] Exports Imports [Statement]

11+data Module = Module [String] Exports Imports [Statement] deriving (Show)

12

13type Exports = [String]

14

@@ -19,6 +19,7 @@ data ImportMethod = As String | Importing [String] | Hiding [String]

19

20data Pattern = PData String [Pattern]

21 | PRecord [String]

22+ | PAtVar String Pattern

22 | PVar String

23 | PVar String

23 | PAnything

24 | PAnything

24 deriving (Eq, Data, Typeable)

25 deriving (Eq, Data, Typeable)

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

82 case p of

83 case p of

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

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

84 PVar x -> x

85 PVar x -> x

86+ PAtVar x p -> x ++ "@(" ++ show p ++ ")"

85 PAnything -> "_"

87 PAnything -> "_"

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

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

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

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

compiler/Parse/Parser.hs−1

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

13import Parse.Modules

14import Parse.Foreign

15

16−

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

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

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

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

19

18

compiler/Parse/Patterns.hs+17−1

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

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

20 ]

21

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+

22patternRecord :: IParser Pattern

29patternRecord :: IParser Pattern

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

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

24

31

@@ -30,7 +37,8 @@ patternList :: IParser Pattern

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

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

31

38

32patternTerm :: IParser Pattern

39patternTerm :: IParser Pattern

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

40+patternTerm = choice [ patternRecord, patternTuple, patternList,

41+ patternMaybeAtVar =<< patternBasic ]

34 <?> "pattern"

42 <?> "pattern"

35

43

36patternConstructor :: IParser Pattern

44patternConstructor :: IParser Pattern

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

53 case pattern of

61 case pattern of

54 PAnything -> return $ fn "_" body

62 PAnything -> return $ fn "_" body

55 PVar x -> return $ fn x body

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

56 PData name ps -> do

68 PData name ps -> do

57 x <- guid

69 x <- guid

58 let a = '_' : show x

70 let a = '_' : show x

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

97 PVar x ->

109 PVar x ->

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

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

99

111

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+

100 PRecord fs -> do

116 PRecord fs -> do

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

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

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

118 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+ PAtVar x p -> do

134+ (x', env') <- extend env x

135+ (p', env'') <- patternExtend p env'

136+ return (PAtVar 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+ PAtVar _ p -> patternVars p

36 PAnything -> empty

37 PAnything -> empty

37

38

38depth :: Expr -> Integer

39depth :: Expr -> Integer

compiler/Types/Constrain.hs+9

@@ -259,6 +259,15 @@ patternGen loc tipe as pattern =

259 b <- beta

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

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

262 PData name ps -> do

271 PData name ps -> do

263 constr <- guid

272 constr <- guid

264 output <- beta

273 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)