6a34482 · elk · git.iko.soy

Elm.cabal+2

compare with master

unifiedsplit

@@ -65,6 +65,7 @@ Library

65

66 Build-depends: base >=4.2 && <5,

67 containers >= 0.3,

68+ uniplate >= 1.6,

68 transformers >= 0.2,

69 transformers >= 0.2,

69 mtl >= 2,

70 mtl >= 2,

70 deepseq,

71 deepseq,

@@ -119,6 +120,7 @@ Executable elm

119

120

120 Build-depends: base >=4.2 && <5,

121 Build-depends: base >=4.2 && <5,

121 containers >= 0.3,

122 containers >= 0.3,

123+ uniplate >= 1.6,

122 transformers >= 0.2,

124 transformers >= 0.2,

123 mtl >= 2,

125 mtl >= 2,

124 deepseq,

126 deepseq,

compiler/Gen/CompileToJS.hs+9−6

@@ -7,6 +7,7 @@ import Data.List (intercalate,sortBy,inits,foldl')

7import qualified Data.Map as Map

8import Data.Either (partitionEithers)

9import qualified Text.Pandoc as Pan

10+import Data.Maybe (maybeToList)

10

11

11import Ast

12import Ast

12import Located

13import Located

@@ -82,14 +83,14 @@ getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)

82

83

83 op = ("_.$op = "++) . jsObj $ map opPair ops

84 op = ("_.$op = "++) . jsObj $ map opPair ops

84

85

85− get' (FnDef x _ _) = Left x

86+ get' (FnDef x _ _) = Just (Left x)

86− get' (OpDef op _ _ _) = Right op

87+ get' (OpDef op _ _ _) = Just (Right op)

88+ get' (TypeAnnotation _ _) = Nothing

87− get s = case s of Definition d -> [ get' d ]

89+ get s = case s of Definition d -> maybeToList (get' d)

88 Datatype _ _ tcs -> map (Left . fst) tcs

90 Datatype _ _ tcs -> map (Left . fst) tcs

89 ImportEvent _ _ x _ -> [ Left x ]

91 ImportEvent _ _ x _ -> [ Left x ]

90 ExportEvent _ _ _ -> []

92 ExportEvent _ _ _ -> []

91 TypeAlias _ _ _ -> []

93 TypeAlias _ _ _ -> []

92− TypeAnnotation _ _ -> []

93

94

95

95jsImport (modul, how) =

96jsImport (modul, how) =

@@ -129,10 +130,10 @@ stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)

129 ImportEvent _ _ _ _ -> 2

130 ImportEvent _ _ _ _ -> 2

130 Definition (FnDef f [] _) ->

131 Definition (FnDef f [] _) ->

131 if derename f == "main" then 5 else 4

132 if derename f == "main" then 5 else 4

133+ Definition (TypeAnnotation _ _) -> 0

132 Definition _ -> 3

134 Definition _ -> 3

133 ExportEvent _ _ _ -> 6

135 ExportEvent _ _ _ -> 6

134 TypeAlias _ _ _ -> 0

136 TypeAlias _ _ _ -> 0

135− TypeAnnotation _ _ -> 0

136

137

137class ToJS a where

138class ToJS a where

138 toJS :: a -> GuidCounter String

139 toJS :: a -> GuidCounter String

@@ -148,6 +149,8 @@ instance ToJS Def where

148 do body <- toJS' e

149 do body <- toJS' e

149 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))

150 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))

150 return (globalAssign ("$op['" ++ op ++ "']") func)

151 return (globalAssign ("$op['" ++ op ++ "']") func)

152+ toJS (TypeAnnotation _ _) = return ""

153+

151

154

152instance ToJS Statement where

155instance ToJS Statement where

153 toJS stmt =

156 toJS stmt =

@@ -170,7 +173,6 @@ instance ToJS Statement where

170 , "e.initEvent('", js, "_' + elm.id, true, true);"

173 , "e.initEvent('", js, "_' + elm.id, true, true);"

171 , "e.value = v;"

174 , "e.value = v;"

172 , "document.dispatchEvent(e); return v; })(", elm, ");" ]

175 , "document.dispatchEvent(e); return v; })(", elm, ");" ]

173− TypeAnnotation _ _ -> return ""

174 TypeAlias n _ t -> return ""

176 TypeAlias n _ t -> return ""

175

177

176toJS' :: CExpr -> GuidCounter String

178toJS' :: CExpr -> GuidCounter String

@@ -275,6 +277,7 @@ jsLet defs e' = do ds <- jsDefs defs

275 valueOf (FnDef _ [] _) = 2

277 valueOf (FnDef _ [] _) = 2

276 valueOf (FnDef _ _ _) = 1

278 valueOf (FnDef _ _ _) = 1

277 valueOf (OpDef _ _ _ _) = 1

279 valueOf (OpDef _ _ _ _) = 1

280+ valueOf (TypeAnnotation _ _) = 0

278

281

279caseToJS span e ps = do

282caseToJS span e ps = do

280 match <- caseToMatch ps

283 match <- caseToMatch ps

compiler/Gen/ExtractNoscript.hs+1

@@ -21,6 +21,7 @@ instance Extract Statement where

21instance Extract Def where

22 extract (FnDef _ _ e) = extract e

23 extract (OpDef _ _ _ e) = extract e

24+ extract _ = []

24

25

25instance Extract e => Extract (Located e) where

26instance Extract e => Extract (Located e) where

26 extract (L _ _ e) = extract e

27 extract (L _ _ e) = extract e

compiler/Model/Ast.hs+9−7

@@ -1,4 +1,4 @@

1−

1+{-# LANGUAGE DeriveDataTypeable #-}

2module Ast where

3

4import Located

@@ -6,6 +6,7 @@ import Data.Char (isDigit, isSymbol)

6import Data.List (intercalate)

7import Types.Types

8import qualified Text.Pandoc as Pandoc

9+import Data.Data

9

10

10data Module = Module [String] Exports Imports [Statement]

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

11

12

@@ -13,14 +14,14 @@ type Exports = [String]

13

14

14type Imports = [(String, ImportMethod)]

15type Imports = [(String, ImportMethod)]

15data ImportMethod = As String | Importing [String] | Hiding [String]

16data ImportMethod = As String | Importing [String] | Hiding [String]

16− deriving (Eq, Ord, Show)

17+ deriving (Eq, Ord, Show, Data, Typeable)

17

18

19

19data Pattern = PData String [Pattern]

20data Pattern = PData String [Pattern]

20 | PRecord [String]

21 | PRecord [String]

21 | PVar String

22 | PVar String

22 | PAnything

23 | PAnything

23− deriving (Eq)

24+ deriving (Eq, Data, Typeable)

24

25

25type CExpr = Located Expr

26type CExpr = Located Expr

26data Expr = IntNum Int

27data Expr = IntNum Int

@@ -44,19 +45,19 @@ data Expr = IntNum Int

44 | Case CExpr [(Pattern,CExpr)]

45 | Case CExpr [(Pattern,CExpr)]

45 | Data String [CExpr]

46 | Data String [CExpr]

46 | Markdown Pandoc.Pandoc

47 | Markdown Pandoc.Pandoc

47− deriving (Eq)

48+ deriving (Eq, Data, Typeable)

48

49

49data Def = FnDef String [String] CExpr

50data Def = FnDef String [String] CExpr

50 | OpDef String String String CExpr

51 | OpDef String String String CExpr

52+ | TypeAnnotation String Type

51− deriving (Eq)

53+ deriving (Eq, Data, Typeable)

52

54

53data Statement = Definition Def

55data Statement = Definition Def

54 | Datatype String [X] [(String,[Type])]

56 | Datatype String [X] [(String,[Type])]

55 | TypeAlias String [X] Type

57 | TypeAlias String [X] Type

56− | TypeAnnotation String Type

57 | ImportEvent String CExpr String Type

58 | ImportEvent String CExpr String Type

58 | ExportEvent String String Type

59 | ExportEvent String String Type

59− deriving (Eq,Show)

60+ deriving (Eq, Show, Data, Typeable)

60

61

61cons h t = epos h t (Data "Cons" [h,t])

62cons h t = epos h t (Data "Cons" [h,t])

62nil = L (Just "[]") NoSpan (Data "Nil" [])

63nil = L (Just "[]") NoSpan (Data "Nil" [])

@@ -136,6 +137,7 @@ instance Show Def where

136 FnDef v [] e -> v ++ " = " ++ show e

137 FnDef v [] e -> v ++ " = " ++ show e

137 FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e

138 FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e

138 OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e

139 OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e

140+ TypeAnnotation n t -> n ++ " : " ++ show t

139

141

140getLambdas (L _ _ (Lambda x e)) = (x:xs,e')

142getLambdas (L _ _ (Lambda x e)) = (x:xs,e')

141 where (xs,e') = getLambdas e

143 where (xs,e') = getLambdas e

compiler/Model/Located.hs+5−5

@@ -1,16 +1,16 @@

1−

1+{-# LANGUAGE DeriveDataTypeable #-}

2module Located where

3

4import Text.Parsec.Pos

5−

5+import Data.Data

6

7data SrcPos = Pos Int Int

8− deriving (Eq,Ord)

8+ deriving (Eq, Ord, Data, Typeable)

9

10data SrcSpan = Span SrcPos SrcPos | NoSpan

11− deriving (Eq,Ord)

11+ deriving (Eq, Ord, Data, Typeable)

12

13−data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord)

13+data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord, Data, Typeable)

14

15

16instance Show SrcPos where

compiler/Parse/Expr.hs+6−2

@@ -13,6 +13,7 @@ import qualified Text.Pandoc as Pan

13import Parse.Library

14import Parse.Patterns

15import Parse.Binops

16+import Parse.Types

16

17

17import Guid

18import Guid

18import Types.Types (Type (VarT), Scheme (Forall))

19import Types.Types (Type (VarT), Scheme (Forall))

@@ -164,7 +165,7 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

164 return . run $ makeLambda pats e

165 return . run $ makeLambda pats e

165

166

166defSet :: IParser [Def]

167defSet :: IParser [Def]

167−defSet = concat <$> block (do d <- assignExpr ; whitespace ; return d)

168+defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)

168

169

169letExpr :: IParser Expr

170letExpr :: IParser Expr

170letExpr = do

171letExpr = do

@@ -207,8 +208,11 @@ assignExpr = withPos $ do

207 n <- sourceLine <$> getPosition

208 n <- sourceLine <$> getPosition

208 runAt (1000 * n) $ flattenPatterns fDefs e

209 runAt (1000 * n) $ flattenPatterns fDefs e

209

210

211+anyDef =

212+ ((\d -> [d]) <$> typeAnnotation) <|>

210−def = map Definition <$> assignExpr

213+ assignExpr

211

214

215+def = map Definition <$> anyDef

212

216

213parseDef str =

217parseDef str =

214 case iParse def "" str of

218 case iParse def "" str of

compiler/Parse/Parser.hs+1−1

@@ -15,7 +15,7 @@ import Parse.Foreign

15

16

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

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

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

19

20freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

21 freshLine

compiler/Parse/Types.hs+1−1

@@ -95,7 +95,7 @@ toConstructor start end alias kvs =

95 rec = map (\a -> (a, [], loc (Var a))) args

96

97

98−typeAnnotation :: IParser Statement

98+typeAnnotation :: IParser Def

99typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)

100 where start = do v <- lowVar <|> parens symOp

101 whitespace ; hasType ; whitespace ; return v

compiler/Transform/LetBoundVars.hs+1

@@ -22,6 +22,7 @@ instance LetBoundVars Statement where

22instance LetBoundVars Def where

23 letBoundVars (FnDef n _ e) = n : letBoundVars e

24 letBoundVars (OpDef _ _ _ e) = letBoundVars e

25+ letBoundVars _ = []

25

26

26instance LetBoundVars e => LetBoundVars (Context e) where

27instance LetBoundVars e => LetBoundVars (Context e) where

27 letBoundVars (C _ _ e) = letBoundVars e

28 letBoundVars (C _ _ e) = letBoundVars e

compiler/Transform/Optimize.hs+1

@@ -23,6 +23,7 @@ instance Simplify Statement where

23instance Simplify Def where

24 simp (FnDef func args e) = FnDef func args (simp e)

25 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)

26+ simp x = x

26

27

27instance Simplify e => Simplify (Located e) where

28instance Simplify e => Simplify (Located e) where

28 simp (L t s e) = L t s (simp e)

29 simp (L t s e) = L t s (simp e)

compiler/Transform/Rename.hs+3−2

@@ -30,6 +30,8 @@ instance Rename Def where

30 rename env (FnDef f args e) =

31 do env' <- extends env args

32 FnDef (env f) (map env' args) `liftM` rename env' e

33+ rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)

34+

33

35

34instance Rename Statement where

36instance Rename Statement where

35 rename env stmt =

37 rename env stmt =

@@ -38,7 +40,6 @@ instance Rename Statement where

38 Datatype name args tcs ->

40 Datatype name args tcs ->

39 return $ Datatype name args $ map (first env) tcs

41 return $ Datatype name args $ map (first env) tcs

40 TypeAlias n xs t -> return (TypeAlias n xs t)

42 TypeAlias n xs t -> return (TypeAlias n xs t)

41− TypeAnnotation n t -> return (TypeAnnotation (env n) t)

42 ImportEvent js base elm tipe ->

43 ImportEvent js base elm tipe ->

43 do base' <- rename env base

44 do base' <- rename env base

44 return $ ImportEvent js base' (env elm) tipe

45 return $ ImportEvent js base' (env elm) tipe

@@ -146,4 +147,4 @@ renameLet env defs e = do env' <- extends env $ concatMap getNames defs

146 defs' <- mapM (rename env') defs

147 defs' <- mapM (rename env') defs

147 Let defs' `liftM` rename env' e

148 Let defs' `liftM` rename env' e

148 where getNames (FnDef n _ _) = [n]

149 where getNames (FnDef n _ _) = [n]

149− getNames (OpDef _ _ _ _) = []

150+ getNames _ = []

compiler/Transform/Substitute.hs+1

@@ -22,6 +22,7 @@ subst old new expr =

22 Let defs e -> Let (map substDef defs) (f e)

23 where substDef (FnDef name vs e) = FnDef name vs (f e)

24 substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)

25+ substDef x = x

25 Var x -> if x == old then new else expr

26 Var x -> if x == old then new else expr

26 Case e cases -> Case (f e) $ map (second f) cases

27 Case e cases -> Case (f e) $ map (second f) cases

27 Data name es -> Data name (map f es)

28 Data name es -> Data name (map f es)

compiler/Types/Alias.hs+49−50

@@ -1,13 +1,16 @@

1−

1+{-# LANGUAGE PatternGuards #-}

2module Types.Alias (dealias, get, mistakes) where

3

4import Ast

5+import Located

5import Control.Arrow (second)

6import Control.Arrow (second)

6import Data.List (group,sort)

7import Data.List (group,sort)

8+import Data.Maybe (mapMaybe)

7import qualified Data.Map as Map

9import qualified Data.Map as Map

8import qualified Data.Set as Set

10import qualified Data.Set as Set

9import Types.Substitutions (subst)

11import Types.Substitutions (subst)

10import Types.Types

12import Types.Types

13+import Data.Generics.Uniplate.Data

11

14

12builtins :: [(String,([X],Type))]

15builtins :: [(String,([X],Type))]

13builtins =

16builtins =

@@ -48,68 +51,59 @@ mistakes :: [Statement] -> [String]

48mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts

51mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts

49

52

50badKinds :: [Statement] -> [String]

53badKinds :: [Statement] -> [String]

51−badKinds stmts = map msg (concatMap badS stmts)

54+badKinds stmts = [msg tname | t <- universeBi stmts, tname <- badT t]

52 where

55 where

53 msg x = "Type Error: Type alias '" ++ x ++

56 msg x = "Type Error: Type alias '" ++ x ++

54 "' was given the wrong number of arguments."

57 "' was given the wrong number of arguments."

55

58

56 badT :: Type -> [String]

59 badT :: Type -> [String]

57− badT t =

58− case t of

59− ADT name ts ->

60+ badT (ADT name ts)

60− case Map.lookup name (get stmts) of

61+ | Just (xs, _) <- Map.lookup name (get stmts),

61− Just (xs,t) | length xs == length ts -> []

62+ length xs /= length ts = [name]

62− | otherwise -> [name]

63+ badT _ = []

63− Nothing -> concatMap badT ts

64+

64− LambdaT t u -> badT t ++ badT u

65− RecordT r t -> badT t ++ concatMap badT (concat (Map.elems r))

66− _ -> []

67−

68− badS :: Statement -> [String]

69− badS s =

70− case s of

71− Datatype _ _ tcs -> concatMap badT (concatMap snd tcs)

72− ExportEvent _ _ tipe -> badT tipe

73− ImportEvent _ _ _ tipe -> badT tipe

74− TypeAnnotation _ tipe -> badT tipe

75− TypeAlias _ _ tipe -> badT tipe

76− Definition _ -> []

77−

78−annotation :: Statement -> [String]

65+annotation :: Def -> Maybe String

79annotation s =

66annotation s =

80 case s of

67 case s of

81− TypeAnnotation name _ -> [name]

68+ TypeAnnotation name _ -> Just name

82− _ -> []

69+ _ -> Nothing

83

70

84−definition :: Statement -> [String]

71+definition :: Def -> Maybe String

85definition s =

72definition s =

86 case s of

73 case s of

87− Definition d -> [defName d]

88− _ -> []

89−

90−defName :: Def -> String

91−defName d =

92− case d of

93− FnDef n _ _ -> n

74+ FnDef name _ _ -> Just name

94− OpDef n _ _ _ -> n

75+ OpDef name _ _ _ -> Just name

76+ _ -> Nothing

77+

78+checkTopLevelAndLets :: [Statement] -> (String -> [Def] -> [a]) -> [a]

79+checkTopLevelAndLets stmts fcheck =

80+ fcheck "at top-level" topLevelDefs ++

81+ concatMap (fcheck "in let binding") allLetDefs

82+ where

83+ topLevelDefs = mapMaybe maybeDef stmts

84+ maybeDef (Definition d) = Just d

85+ maybeDef _ = Nothing

86+ allLetDefs = [defList | Let defList _ <- universeBi stmts]

95

87

96dups :: [Statement] -> [String]

88dups :: [Statement] -> [String]

97−dups stmts = map defMsg (dup definition) ++ map annMsg (dup annotation)

89+dups stmts = checkTopLevelAndLets stmts $ \ctxt defs ->

98− where

90+ let

99− dup :: (Statement -> [String]) -> [String]

91+ dup :: (Def -> Maybe String) -> [String]

100− dup f = map head . filter ((>1) . length) . group . sort $ concatMap f stmts

92+ dup f = map head . filter ((>1) . length) . group . sort $ mapMaybe f defs

101

93

102 msg = "Syntax Error: There can only be one "

94 msg = "Syntax Error: There can only be one "

103− defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."

95+ defMsg x = msg ++ "definition of '" ++ x ++ "' " ++ ctxt ++ "."

104− annMsg x = msg ++ "type annotation for '" ++ x ++ "'."

96+ annMsg x = msg ++ "type annotation for '" ++ x ++ "'" ++ ctxt ++ "."

97+ in

98+ map defMsg (dup definition) ++ map annMsg (dup annotation)

105

99

106badOrder :: [Statement] -> [String]

100badOrder :: [Statement] -> [String]

107−badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs stmts)

101+badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->

108− where

102+ let

109 msg x = "Syntax Error: The type annotation for '" ++ x ++

103 msg x = "Syntax Error: The type annotation for '" ++ x ++

110− "' must be directly above its definition."

104+ "' must be directly above its definition in " ++ ctxt ++ "."

111− as = sort $ concatMap annotation stmts

105+ as = sort $ mapMaybe annotation defs

112− ds = sort $ concatMap definition stmts

106+ ds = sort $ mapMaybe definition defs

113

107

114 expectedPairs :: [String] -> [String] -> [String]

108 expectedPairs :: [String] -> [String] -> [String]

115 expectedPairs as ds =

109 expectedPairs as ds =

@@ -120,11 +114,14 @@ badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualP

120 GT -> expectedPairs (x:xs) ys

114 GT -> expectedPairs (x:xs) ys

121 ( _ , _ ) -> []

115 ( _ , _ ) -> []

122

116

123− actualPairs :: [Statement] -> [String]

117+ actualPairs :: [Def] -> [String]

124 actualPairs stmts =

118 actualPairs stmts =

125 case stmts of

119 case stmts of

126− TypeAnnotation n _ : Definition d : rest ->

120+ TypeAnnotation n _ : rest@(d : _) ->

121+ (if Just n == definition d

122+ then [n]

123+ else []

127− (if n == defName d then [n] else []) ++ actualPairs rest

124+ ) ++ actualPairs rest

128 t:s:rest -> actualPairs (s:rest)

125 t:s:rest -> actualPairs (s:rest)

129 _ -> []

126 _ -> []

130

127

@@ -136,4 +133,6 @@ badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualP

136 EQ -> missings es as

133 EQ -> missings es as

137 GT -> a : missings (e:es) as

134 GT -> a : missings (e:es) as

138 ( [] , _ ) -> actual

135 ( [] , _ ) -> actual

139− ( _ , [] ) -> expected

136+ ( _ , [] ) -> expected

137+ in

138+ map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)

compiler/Types/Constrain.hs+4−4

@@ -128,6 +128,7 @@ gen (L _ span expr) =

128 let assumptions = unionsA (as:ass)

129 getName d = case d of FnDef f _ _ -> f

130 OpDef op _ _ _ -> op

131+ TypeAnnotation n _ -> n

131 names = map getName defs

132 names = map getName defs

132 genCs name s = do

133 genCs name s = do

133 v <- guid

134 v <- guid

@@ -286,6 +287,9 @@ defScheme def = do (as,cs,hint) <- defGen def

286defGen def = case def of

287defGen def = case def of

287 FnDef f args e -> defGenHelp f args e

288 FnDef f args e -> defGenHelp f args e

288 OpDef op a1 a2 e -> defGenHelp op [a1,a2] e

289 OpDef op a1 a2 e -> defGenHelp op [a1,a2] e

290+ TypeAnnotation name tipe -> do

291+ schm <- Subs.generalize [] =<< Subs.superize name tipe

292+ return (Map.empty, Set.empty, (name, schm))

289

293

290defGenHelp name args e = do

294defGenHelp name args e = do

291 argDict <- mapM (\a -> liftM ((,) a) guid) args

295 argDict <- mapM (\a -> liftM ((,) a) guid) args

@@ -325,8 +329,4 @@ stmtGen stmt =

325 , Set.insert (L txt span (signalOf t :=: tipe)) cs

329 , Set.insert (L txt span (signalOf t :=: tipe)) cs

326 , Map.singleton elm (Forall [] [] tipe) )

330 , Map.singleton elm (Forall [] [] tipe) )

327

331

328− TypeAnnotation name tipe ->

329− do schm <- Subs.generalize [] =<< Subs.superize name tipe

330− return (Map.empty, Set.empty, Map.singleton name schm)

331−

332 TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)

compiler/Types/Types.hs+5−4

@@ -1,4 +1,4 @@

1−

1+{-# LANGUAGE DeriveDataTypeable #-}

2module Types.Types where

3

4import Located

@@ -6,6 +6,7 @@ import Data.Char (isDigit)

6import Data.List (intercalate,isPrefixOf)

7import qualified Data.Set as Set

8import qualified Data.Map as Map

9+import Data.Data

9

10

10type X = Int

11type X = Int

11

12

@@ -15,14 +16,14 @@ data Type = LambdaT Type Type

15 | EmptyRecord

16 | EmptyRecord

16 | RecordT (Map.Map String [Type]) Type

17 | RecordT (Map.Map String [Type]) Type

17 | Super (Set.Set Type)

18 | Super (Set.Set Type)

18− deriving (Eq, Ord)

19+ deriving (Eq, Ord, Data, Typeable)

19

20

20−data Scheme = Forall [X] [Located Constraint] Type deriving (Eq, Ord, Show)

21+data Scheme = Forall [X] [Located Constraint] Type deriving (Eq, Ord, Show, Data, Typeable)

21

22

22data Constraint = Type :=: Type

23data Constraint = Type :=: Type

23 | Type :<: Type

24 | Type :<: Type

24 | X :<<: Scheme

25 | X :<<: Scheme

25− deriving (Eq, Ord, Show)

26+ deriving (Eq, Ord, Show, Data, Typeable)

26

27

27recordT :: [(String,Type)] -> Map.Map String [Type]

28recordT :: [(String,Type)] -> Map.Map String [Type]

28recordT fields =

29recordT fields =