152ad77 · 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+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+ | PAsVar 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+ PAsVar 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+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+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+ PAsVar 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)