7be0e81 · elk · git.iko.soy

elm-compiler.cabal+29−26

@@ -46,41 +46,37 @@ Library

4646 Elm.Utils

4747

4848 other-modules:

49− AST.Annotation,

5049 AST.Declaration,

50+ AST.Expression.Canonical,

5151 AST.Expression.General,

5252 AST.Expression.Source,

5353 AST.Expression.Valid,

54− AST.Expression.Canonical,

5554 AST.Helpers,

5655 AST.Literal,

5756 AST.Module,

5857 AST.Pattern,

59− AST.PrettyPrint,

6058 AST.Type,

6159 AST.Variable,

60+ Canonicalize,

61+ Canonicalize.Declaration,

62+ Canonicalize.Environment,

63+ Canonicalize.Port,

64+ Canonicalize.Result,

65+ Canonicalize.Setup,

66+ Canonicalize.Sort,

67+ Canonicalize.Type,

68+ Canonicalize.Variable,

6269 Compile,

70+ Elm.Compiler.Imports,

6371 Elm.Compiler.Type.Extract,

6472 Elm.Compiler.Version,

73+ Generate.Cases,

6574 Generate.JavaScript,

6675 Generate.JavaScript.Helpers,

6776 Generate.JavaScript.Port,

6877 Generate.JavaScript.Variable,

69− Generate.Cases,

70− Transform.AddDefaultImports,

71− Transform.Canonicalize,

72− Transform.Canonicalize.Environment,

73− Transform.Canonicalize.Port,

74− Transform.Canonicalize.Setup,

75− Transform.Canonicalize.Type,

76− Transform.Canonicalize.Variable,

77− Transform.Check,

78− Transform.Expression,

79− Transform.Declaration,

80− Transform.Definition,

81− Transform.Interface,

82− Transform.SortDefinitions,

83− Transform.Substitute,

78+ Generate.Substitute,

79+ Nitpick.TopLevelTypes,

8480 Parse.Binop,

8581 Parse.Declaration,

8682 Parse.Expression,

@@ -90,19 +86,28 @@ Library

9086 Parse.Parse,

9187 Parse.Pattern,

9288 Parse.Type,

89+ Reporting.Annotation,

90+ Reporting.Error,

91+ Reporting.Error.Canonicalize,

92+ Reporting.Error.Syntax,

93+ Reporting.Error.Type,

94+ Reporting.PrettyPrint,

95+ Reporting.Region,

96+ Reporting.Report,

97+ Reporting.Result,

98+ Reporting.Warning,

9399 Type.Constrain.Expression,

94100 Type.Constrain.Literal,

95101 Type.Constrain.Pattern,

96102 Type.Environment,

97− Type.ExtraChecks,

98103 Type.Fragment,

99− Type.Hint,

100104 Type.Inference,

101105 Type.PrettyPrint,

102106 Type.Solve,

103107 Type.State,

104108 Type.Type,

105109 Type.Unify,

110+ Validate,

106111 Paths_elm_compiler

107112

108113 Build-depends:

@@ -121,7 +126,7 @@ Library

121126 indents >= 0.3 && < 0.4,

122127 language-ecmascript >= 0.15 && < 0.18,

123128 language-glsl >= 0.0.2 && < 0.2,

124− mtl >= 2 && < 3,

129+ mtl >= 2.2 && < 3,

125130 parsec >= 3.1.1 && < 3.5,

126131 pretty >= 1.0 && < 2.0,

127132 process,

@@ -143,14 +148,12 @@ Executable elm-doc

143148

144149 other-modules:

145150 Elm.Compiler.Version,

146− AST.Annotation,

147151 AST.Declaration,

148152 AST.Expression.General,

149153 AST.Helpers,

150154 AST.Literal,

151155 AST.Module,

152156 AST.Pattern,

153− AST.PrettyPrint,

154157 AST.Type,

155158 AST.Variable,

156159 Parse.Binop,

@@ -174,7 +177,7 @@ Executable elm-doc

174177 filepath >= 1 && < 2.0,

175178 indents >= 0.3 && < 0.4,

176179 language-glsl >= 0.0.2 && < 0.2,

177− mtl >= 2 && < 3,

180+ mtl >= 2.2 && < 3,

178181 parsec >= 3.1.1 && < 3.5,

179182 pretty >= 1.0 && < 2.0,

180183 process,

@@ -208,7 +211,7 @@ Executable elm

208211 filepath >= 1 && < 2.0,

209212 indents >= 0.3 && < 0.4,

210213 language-glsl >= 0.0.2 && < 0.2,

211− mtl >= 2 && < 3,

214+ mtl >= 2.2 && < 3,

212215 parsec >= 3.1.1 && < 3.5,

213216 pretty >= 1.0 && < 2.0,

214217 process,

@@ -258,7 +261,7 @@ Test-Suite compiler-tests

258261 indents >= 0.3 && < 0.4,

259262 language-ecmascript >= 0.15 && < 0.18,

260263 language-glsl >= 0.0.2 && < 0.2,

261− mtl >= 2 && < 3,

264+ mtl >= 2.2 && < 3,

262265 parsec >= 3.1.1 && < 3.5,

263266 pretty >= 1.0 && < 2.0,

264267 process,

src/AST/Annotation.hsdeleted−111

@@ -1,111 +0,0 @@

1−module AST.Annotation where

2−

3−import qualified Text.Parsec.Pos as Parsec

4−import qualified Text.PrettyPrint as P

5−import AST.PrettyPrint

6−

7−

8−data Annotated annotation expr

9− = A annotation expr

10− deriving (Show)

11−

12−

13−data Region

14− = Span Position Position P.Doc

15− | None P.Doc

16− deriving (Show)

17−

18−

19−data Position = Position

20− { line :: Int

21− , column :: Int

22− }

23− deriving (Show)

24−

25−

26−type Located expr =

27− Annotated Region expr

28−

29−

30−none :: (Pretty expr) => expr -> Located expr

31−none e =

32− A (None (pretty e)) e

33−

34−

35−noneNoDocs :: a -> Located a

36−noneNoDocs e =

37− A (None P.empty) e

38−

39−

40−at :: (Pretty expr)

41− => Parsec.SourcePos

42− -> Parsec.SourcePos

43− -> expr

44− -> Annotated Region expr

45−at start end e =

46− A (Span (position start) (position end) (pretty e)) e

47− where

48− position loc =

49− Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)

50−

51−

52−merge :: (Pretty expr) => Located a -> Located b -> expr -> Located expr

53−merge (A s1 _) (A s2 _) e =

54− A (span (pretty e)) e

55− where

56− span =

57− case (s1,s2) of

58− (Span start _ _, Span _ end _) ->

59− Span start end

60−

61− (Span start end _, _) ->

62− Span start end

63−

64− (_, Span start end _) ->

65− Span start end

66−

67− (_, _) -> None

68−

69−

70−mergeOldDocs :: Located a -> Located b -> c -> Located c

71−mergeOldDocs (A s1 _) (A s2 _) e =

72− A span e

73− where

74− span =

75− case (s1,s2) of

76− (Span start _ d1, Span _ end d2) ->

77− Span start end (P.vcat [d1, P.text "\n", d2])

78−

79− (Span _ _ _, _) -> s1

80−

81− (_, Span _ _ _) -> s2

82−

83− (_, _) -> None P.empty

84−

85−

86−sameAs :: Annotated a expr -> expr' -> Annotated a expr'

87−sameAs (A annotation _) expr =

88− A annotation expr

89−

90−

91−getRegionDocs :: Region -> P.Doc

92−getRegionDocs region =

93− case region of

94− Span _ _ doc -> doc

95− None doc -> doc

96−

97−

98−instance Pretty Region where

99− pretty span =

100− case span of

101− None _ -> P.empty

102− Span start end _ ->

103− P.text $

104− case line start == line end of

105− False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)

106− True -> "on line " ++ show (line end) ++ ", column " ++

107− show (column start) ++ " to " ++ show (column end)

108−

109−

110−instance Pretty e => Pretty (Annotated a e) where

111− pretty (A _ e) = pretty e

src/AST/Declaration.hs+27−116

@@ -2,58 +2,71 @@

22module AST.Declaration where

33

44import Data.Binary

5+

56import qualified AST.Expression.General as General

67import qualified AST.Expression.Source as Source

78import qualified AST.Expression.Valid as Valid

89import qualified AST.Expression.Canonical as Canonical

9−import qualified AST.Type as T

10−import qualified AST.Variable as Var

11−import AST.PrettyPrint

12−import Text.PrettyPrint as P

10+import qualified AST.Type as Type

11+import qualified Reporting.Annotation as A

1312

1413

1514-- DECLARATIONS

1615

17−data Declaration' port def var expr

16+data Declaration' port def tipe expr

1817 = Definition def

19− | Datatype String [String] [(String, [T.Type var])]

20− | TypeAlias String [String] (T.Type var)

18+ | Datatype String [String] [(String, [tipe])]

19+ | TypeAlias String [String] tipe

2120 | Port port

2221 | Fixity Assoc Int String

2322

2423

24+-- INFIX STUFF

25+

2526data Assoc = L | N | R

2627 deriving (Eq)

2728

2829

30+assocToString :: Assoc -> String

31+assocToString assoc =

32+ case assoc of

33+ L -> "left"

34+ N -> "non"

35+ R -> "right"

36+

37+

2938-- DECLARATION PHASES

3039

40+type SourceDecl' =

41+ Declaration' SourcePort Source.Def Type.Raw Source.Expr

42+

43+

3144type SourceDecl =

32− Declaration' SourcePort Source.Def Var.Raw Source.Expr

45+ A.Located SourceDecl'

3346

3447

3548type ValidDecl =

36− Declaration' ValidPort Valid.Def Var.Raw Valid.Expr

49+ A.Located (Declaration' ValidPort Valid.Def Type.Raw Valid.Expr)

3750

3851

3952type CanonicalDecl =

40− Declaration' CanonicalPort Canonical.Def Var.Canonical Canonical.Expr

53+ A.Located (Declaration' CanonicalPort Canonical.Def Type.Canonical Canonical.Expr)

4154

4255

4356-- PORTS

4457

4558data SourcePort

46− = PortAnnotation String T.RawType

59+ = PortAnnotation String Type.Raw

4760 | PortDefinition String Source.Expr

4861

4962

5063data ValidPort

51− = In String T.RawType

52− | Out String Valid.Expr T.RawType

64+ = In String Type.Raw

65+ | Out String Valid.Expr Type.Raw

5366

5467

5568newtype CanonicalPort

56− = CanonicalPort (General.PortImpl Canonical.Expr Var.Canonical)

69+ = CanonicalPort (General.PortImpl Canonical.Expr Type.Canonical)

5770

5871

5972validPortName :: ValidPort -> String

@@ -80,105 +93,3 @@ instance Binary Assoc where

8093 L -> 0

8194 N -> 1

8295 R -> 2

83−

84−

85−-- PRETTY STRINGS

86−

87−assocToString :: Assoc -> String

88−assocToString assoc =

89− case assoc of

90− L -> "left"

91− N -> "non"

92− R -> "right"

93−

94−

95−instance (Pretty port, Pretty def, Pretty var, Var.ToString var, Pretty expr) =>

96− Pretty (Declaration' port def var expr) where

97− pretty decl =

98− case decl of

99− Definition def -> pretty def

100−

101− Datatype tipe tvars ctors ->

102− P.hang

103− (P.text "type" <+> P.text tipe <+> P.hsep (map P.text tvars))

104− 4

105− (P.sep $ zipWith (<+>) seperators (map prettyCtor ctors))

106− where

107− seperators =

108− map P.text ("=" : repeat "|")

109−

110− prettyCtor (name, tipes) =

111− P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))

112−

113− TypeAlias name tvars tipe ->

114− P.hang

115− (P.text "type" <+> P.text "alias" <+> name' <+> P.equals)

116− 4

117− (pretty tipe)

118− where

119− name' =

120− P.text name <+> P.hsep (map P.text tvars)

121−

122− Port port ->

123− pretty port

124−

125− Fixity assoc prec op ->

126− P.text "infix" <> assoc' <+> P.int prec <+> P.text op

127− where

128− assoc' =

129− case assoc of

130− L -> P.text "l"

131− N -> P.empty

132− R -> P.text "r"

133−

134−

135−instance Pretty SourcePort where

136− pretty port =

137− case port of

138− PortAnnotation name tipe ->

139− prettyPortType name tipe

140−

141− PortDefinition name expr ->

142− prettyPortDef name expr

143−

144−

145−instance Pretty ValidPort where

146− pretty port =

147− case port of

148− In name tipe ->

149− prettyPortType name tipe

150−

151− Out name expr tipe ->

152− prettyPort name expr tipe

153−

154−

155−instance Pretty CanonicalPort where

156− pretty (CanonicalPort impl) =

157− case impl of

158− General.In name tipe ->

159− prettyPortType name tipe

160−

161− General.Out name expr tipe ->

162− prettyPort name expr tipe

163−

164− General.Task name expr tipe ->

165− prettyPort name expr tipe

166−

167−

168−

169−prettyPort :: (Pretty expr, Pretty tipe) => String -> expr -> tipe -> P.Doc

170−prettyPort name expr tipe =

171− P.vcat

172− [ prettyPortType name tipe

173− , prettyPortDef name expr

174− ]

175−

176−

177−prettyPortType :: (Pretty tipe) => String -> tipe -> P.Doc

178−prettyPortType name tipe =

179− P.text "port" <+> P.text name <+> P.colon <+> pretty tipe

180−

181−

182−prettyPortDef :: (Pretty expr) => String -> expr -> P.Doc

183−prettyPortDef name expr =

184− P.hang (P.text "port" <+> P.text name <+> P.equals) 4 (pretty expr)

src/AST/Expression/Canonical.hs+12−11

@@ -1,37 +1,38 @@

11{-# OPTIONS_GHC -Wall #-}

2−

32module AST.Expression.Canonical where

43

5−import AST.PrettyPrint

64import Text.PrettyPrint as P

5+

76import qualified AST.Expression.General as General

8−import AST.Type (CanonicalType)

9−import qualified AST.Annotation as Annotation

107import qualified AST.Pattern as Pattern

8+import qualified AST.Type as Type

119import qualified AST.Variable as Var

10+import qualified Reporting.PrettyPrint as P

11+import qualified Reporting.Region as R

1212

1313

1414{-| Canonicalized expressions. All variables are fully resolved to the module

1515they came from.

1616-}

1717type Expr =

18− General.Expr Annotation.Region Def Var.Canonical

18+ General.Expr R.Region Def Var.Canonical Type.Canonical

1919

2020

2121type Expr' =

22− General.Expr' Annotation.Region Def Var.Canonical

22+ General.Expr' R.Region Def Var.Canonical Type.Canonical

2323

2424

25−data Def = Definition Pattern.CanonicalPattern Expr (Maybe CanonicalType)

25+data Def

26+ = Definition Pattern.CanonicalPattern Expr (Maybe Type.Canonical)

2627 deriving (Show)

2728

2829

29−instance Pretty Def where

30− pretty (Definition pattern expr maybeTipe) =

30+instance P.Pretty Def where

31+ pretty _ (Definition pattern expr maybeTipe) =

3132 P.vcat [ annotation, definition ]

3233 where

3334 definition =

34− pretty pattern <+> P.equals <+> pretty expr

35+ P.pretty True pattern <+> P.equals <+> P.pretty False expr

3536

3637 annotation =

3738 case maybeTipe of

@@ -39,4 +40,4 @@ instance Pretty Def where

3940 P.empty

4041

4142 Just tipe ->

42− pretty pattern <+> P.colon <+> pretty tipe

43+ P.pretty True pattern <+> P.colon <+> P.pretty False tipe

src/AST/Expression/General.hs+127−92

@@ -8,15 +8,15 @@ enrich the AST with more information.

88-}

99module AST.Expression.General where

1010

11−import AST.PrettyPrint

1211import Text.PrettyPrint as P

1312

14−import qualified AST.Annotation as Annotation

1513import qualified AST.Helpers as Help

1614import qualified AST.Literal as Literal

1715import qualified AST.Pattern as Pattern

1816import qualified AST.Type as Type

1917import qualified AST.Variable as Var

18+import qualified Reporting.Annotation as A

19+import qualified Reporting.PrettyPrint as P

2020

2121

2222---- GENERAL AST ----

@@ -36,43 +36,43 @@ move through the compilation process. The type holes are used to represent:

3636 with information about what module a variable came from.

3737

3838-}

39−type Expr annotation definition variable =

40− Annotation.Annotated annotation (Expr' annotation definition variable)

39+type Expr annotation definition variable tipe =

40+ A.Annotated annotation (Expr' annotation definition variable tipe)

4141

4242

43−data Expr' ann def var

43+data Expr' ann def var typ

4444 = Literal Literal.Literal

4545 | Var var

46− | Range (Expr ann def var) (Expr ann def var)

47− | ExplicitList [Expr ann def var]

48− | Binop var (Expr ann def var) (Expr ann def var)

49− | Lambda (Pattern.Pattern var) (Expr ann def var)

50− | App (Expr ann def var) (Expr ann def var)

51− | MultiIf [(Expr ann def var,Expr ann def var)]

52− | Let [def] (Expr ann def var)

53− | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)]

54− | Data String [Expr ann def var]

55− | Access (Expr ann def var) String

56− | Remove (Expr ann def var) String

57− | Insert (Expr ann def var) String (Expr ann def var)

58− | Modify (Expr ann def var) [(String, Expr ann def var)]

59− | Record [(String, Expr ann def var)]

46+ | Range (Expr ann def var typ) (Expr ann def var typ)

47+ | ExplicitList [Expr ann def var typ]

48+ | Binop var (Expr ann def var typ) (Expr ann def var typ)

49+ | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)

50+ | App (Expr ann def var typ) (Expr ann def var typ)

51+ | MultiIf [(Expr ann def var typ,Expr ann def var typ)]

52+ | Let [def] (Expr ann def var typ)

53+ | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]

54+ | Data String [Expr ann def var typ]

55+ | Access (Expr ann def var typ) String

56+ | Remove (Expr ann def var typ) String

57+ | Insert (Expr ann def var typ) String (Expr ann def var typ)

58+ | Modify (Expr ann def var typ) [(String, Expr ann def var typ)]

59+ | Record [(String, Expr ann def var typ)]

6060 -- for type checking and code gen only

61− | Port (PortImpl (Expr ann def var) var)

61+ | Port (PortImpl (Expr ann def var typ) typ)

6262 | GLShader String String Literal.GLShaderTipe

6363 deriving (Show)

6464

6565

6666-- PORTS

6767

68−data PortImpl expr var

69− = In String (Type.PortType var)

70− | Out String expr (Type.PortType var)

71− | Task String expr (Type.PortType var)

68+data PortImpl expr tipe

69+ = In String (Type.Port tipe)

70+ | Out String expr (Type.Port tipe)

71+ | Task String expr (Type.Port tipe)

7272 deriving (Show)

7373

7474

75−portName :: PortImpl expr var -> String

75+portName :: PortImpl expr tipe -> String

7676portName impl =

7777 case impl of

7878 In name _ -> name

@@ -82,17 +82,17 @@ portName impl =

8282

8383---- UTILITIES ----

8484

85−rawVar :: String -> Expr' ann def Var.Raw

85+rawVar :: String -> Expr' ann def Var.Raw typ

8686rawVar x =

8787 Var (Var.Raw x)

8888

8989

90−localVar :: String -> Expr' ann def Var.Canonical

90+localVar :: String -> Expr' ann def Var.Canonical typ

9191localVar x =

9292 Var (Var.Canonical Var.Local x)

9393

9494

95−tuple :: [Expr ann def var] -> Expr' ann def var

95+tuple :: [Expr ann def var typ] -> Expr' ann def var typ

9696tuple expressions =

9797 Data ("_Tuple" ++ show (length expressions)) expressions

9898

@@ -102,102 +102,151 @@ saveEnvName =

102102 "_save_the_environment!!!"

103103

104104

105−dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical

105+dummyLet :: (P.Pretty def) => [def] -> Expr ann def Var.Canonical typ

106106dummyLet defs =

107− Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))

107+ let body =

108+ A.A undefined (Var (Var.builtin saveEnvName))

109+ in

110+ A.A undefined (Let defs body)

108111

109112

110−instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where

111− pretty expression =

113+-- PRETTY PRINTING

114+

115+instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where

116+ pretty needsParens expression =

112117 case expression of

113118 Literal literal ->

114− pretty literal

119+ P.pretty needsParens literal

115120

116121 Var x ->

117− pretty x

122+ P.pretty needsParens x

118123

119124 Range lowExpr highExpr ->

120− P.brackets (pretty lowExpr <> P.text ".." <> pretty highExpr)

125+ P.brackets $

126+ P.pretty False lowExpr

127+ <> P.text ".."

128+ <> P.pretty False highExpr

121129

122130 ExplicitList elements ->

123− P.brackets (commaCat (map pretty elements))

131+ P.brackets (P.commaCat (map (P.pretty False) elements))

124132

125− Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) expr

133+ Binop op (A.A _ (Literal (Literal.IntNum 0))) expr

126134 | Var.toString op == "-" ->

127− P.text "-" <> prettyParens expr

135+ P.text "-" <> P.pretty True expr

128136

129137 Binop op leftExpr rightExpr ->

130− P.hang (prettyParens leftExpr) 2 (P.text op'' <+> prettyParens rightExpr)

138+ P.parensIf needsParens $

139+ P.hang

140+ (P.pretty True leftExpr)

141+ 2

142+ (P.text op'' <+> P.pretty True rightExpr)

131143 where

132144 op' = Var.toString op

133145 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"

134146

135147 Lambda pattern expr ->

136− P.text "\\" <> args <+> P.text "->" <+> pretty body

148+ P.parensIf needsParens $

149+ P.text "\\" <> args <+> P.text "->" <+> P.pretty False body

137150 where

138− (patterns, body) = collectLambdas expr

139− args = P.sep (map Pattern.prettyParens (pattern : patterns))

151+ (patterns, body) =

152+ collectLambdas expr

153+

154+ args =

155+ P.sep (map (P.pretty True) (pattern : patterns))

140156

141157 App expr arg ->

142− P.hang func 2 (P.sep args)

158+ P.parensIf needsParens $

159+ P.hang func 2 (P.sep args)

143160 where

144161 func:args =

145− map prettyParens (collectApps expr ++ [arg])

162+ map (P.pretty True) (collectApps expr ++ [arg])

146163

147164 MultiIf branches ->

148− P.text "if" $$ nest 3 (vcat $ map iff branches)

165+ P.parensIf needsParens $

166+ P.text "if" $$ nest 3 (vcat $ map iff branches)

149167 where

150− iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)

168+ iff (condition, branch) =

169+ P.text "|" <+>

170+ P.hang

171+ (P.pretty False condition <+> P.text "->")

172+ 2

173+ (P.pretty False branch)

151174

152175 Let defs body ->

153− P.sep

154− [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))

155− , P.text "in" <+> pretty body

156− ]

176+ P.parensIf needsParens $

177+ P.sep

178+ [ P.hang

179+ (P.text "let")

180+ 4

181+ (P.vcat (map (P.pretty False) defs))

182+ , P.text "in" <+> P.pretty False body

183+ ]

157184

158185 Case expr branches ->

159− P.hang pexpr 2 (P.vcat (map pretty' branches))

186+ P.parensIf needsParens $

187+ P.hang pexpr 2 (P.vcat (map pretty' branches))

160188 where

161− pexpr = P.sep [ P.text "case" <+> pretty expr, P.text "of" ]

189+ pexpr =

190+ P.text "case" <+> P.pretty False expr <+> P.text "of"

191+

162192 pretty' (pattern, branch) =

163− pretty pattern <+> P.text "->" <+> pretty branch

193+ P.pretty False pattern

194+ <+> P.text "->"

195+ <+> P.pretty False branch

164196

165197 Data "::" [hd,tl] ->

166− pretty hd <+> P.text "::" <+> pretty tl

198+ P.parensIf needsParens $

199+ P.pretty True hd <+> P.text "::" <+> P.pretty True tl

167200

168201 Data "[]" [] ->

169202 P.text "[]"

170203

171− Data name exprs

172− | Help.isTuple name ->

173− P.parens (commaCat (map pretty exprs))

174− | otherwise ->

175− P.hang (P.text name) 2 (P.sep (map prettyParens exprs))

204+ Data name exprs ->

205+ if Help.isTuple name

206+ then

207+ P.parens (P.commaCat (map (P.pretty False) exprs))

208+ else

209+ P.parensIf (needsParens && not (null exprs)) $

210+ P.hang

211+ (P.text name)

212+ 2

213+ (P.sep (map (P.pretty True) exprs))

176214

177215 Access record field ->

178− prettyParens record <> P.text "." <> variable field

216+ P.pretty True record <> P.text "." <> P.text field

179217

180218 Remove record field ->

181− P.braces (pretty record <+> P.text "-" <+> variable field)

219+ P.braces (P.pretty False record <+> P.text "-" <+> P.text field)

182220

183− Insert (Annotation.A _ (Remove record y)) x v ->

221+ Insert (A.A _ (Remove record oldField)) newField expr ->

184222 P.braces $

185223 P.hsep

186− [ pretty record, P.text "-", variable y, P.text "|"

187− , variable x, P.equals, pretty v

224+ [ P.pretty False record

225+ , P.text "-"

226+ , P.text oldField

227+ , P.text "|"

228+ , P.text newField

229+ , P.equals

230+ , P.pretty False expr

188231 ]

189232

190233 Insert record field expr ->

191− P.braces (pretty record <+> P.text "|" <+> variable field <+> P.equals <+> pretty expr)

234+ P.braces $

235+ P.pretty False record

236+ <+> P.text "|"

237+ <+> P.text field

238+ <+> P.equals

239+ <+> P.pretty False expr

192240

193241 Modify record fields ->

194242 P.braces $

195243 P.hang

196− (pretty record <+> P.text "|")

244+ (P.pretty False record <+> P.text "|")

197245 4

198− (commaSep $ map field fields)

246+ (P.commaSep $ map prettyField fields)

199247 where

200− field (k,v) = variable k <+> P.text "<-" <+> pretty v

248+ prettyField (field, expr) =

249+ P.text field <+> P.text "<-" <+> P.pretty False expr

201250

202251 Record fields ->

203252 P.sep

@@ -206,48 +255,34 @@ instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var

206255 ]

207256 where

208257 field (name, expr) =

209− variable name <+> P.equals <+> pretty expr

258+ P.text name <+> P.equals <+> P.pretty False expr

210259

211260 GLShader _ _ _ ->

212261 P.text "[glsl| ... |]"

213262

214263 Port portImpl ->

215− pretty portImpl

264+ P.pretty needsParens portImpl

216265

217266

218−instance (Pretty expr, Pretty var) => Pretty (PortImpl expr var) where

219− pretty impl =

267+instance P.Pretty (PortImpl expr tipe) where

268+ pretty _ impl =

220269 P.text ("<port:" ++ portName impl ++ ">")

221270

222271

223−collectApps :: Expr ann def var -> [Expr ann def var]

224−collectApps annExpr@(Annotation.A _ expr) =

272+collectApps :: Expr ann def var typ -> [Expr ann def var typ]

273+collectApps annExpr@(A.A _ expr) =

225274 case expr of

226275 App a b -> collectApps a ++ [b]

227276 _ -> [annExpr]

228277

229278

230−collectLambdas :: Expr ann def var -> ([Pattern.Pattern var], Expr ann def var)

231−collectLambdas lexpr@(Annotation.A _ expr) =

279+collectLambdas

280+ :: Expr ann def var typ

281+ -> ([Pattern.Pattern ann var], Expr ann def var typ)

282+collectLambdas lexpr@(A.A _ expr) =

232283 case expr of

233284 Lambda pattern body ->

234285 let (ps, body') = collectLambdas body

235286 in (pattern : ps, body')

236287

237288 _ -> ([], lexpr)

238−

239−

240−prettyParens :: (Pretty def, Pretty var, Var.ToString var) => Expr ann def var -> Doc

241−prettyParens (Annotation.A _ expr) =

242− parensIf needed (pretty expr)

243− where

244− needed =

245− case expr of

246− Binop _ _ _ -> True

247− Lambda _ _ -> True

248− App _ _ -> True

249− MultiIf _ -> True

250− Let _ _ -> True

251− Case _ _ -> True

252− Data name (_:_) -> not (name == "::" || Help.isTuple name)

253− _ -> False

src/AST/Expression/Source.hs+12−20

@@ -1,14 +1,12 @@

11{-# OPTIONS_GHC -Wall #-}

2−

32module AST.Expression.Source where

43

5−import AST.PrettyPrint

6−import Text.PrettyPrint as P

74import qualified AST.Expression.General as General

8−import AST.Type (RawType)

9−import qualified AST.Variable as Var

10−import qualified AST.Annotation as Annotation

115import qualified AST.Pattern as Pattern

6+import qualified AST.Type as Type

7+import qualified AST.Variable as Var

8+import qualified Reporting.Annotation as A

9+import qualified Reporting.Region as R

1210

1311

1412{-| Expressions created by the parser. These use a split representation of type

@@ -16,24 +14,18 @@ annotations and definitions, which is how they appear in source code and how

1614they are parsed.

1715-}

1816type Expr =

19− General.Expr Annotation.Region Def Var.Raw

17+ General.Expr R.Region Def Var.Raw Type.Raw

2018

2119

2220type Expr' =

23− General.Expr' Annotation.Region Def Var.Raw

24−

21+ General.Expr' R.Region Def Var.Raw Type.Raw

2522

26−data Def

27− = Definition Pattern.RawPattern Expr

28− | TypeAnnotation String RawType

29− deriving (Show)

3023

24+type Def =

25+ A.Located Def'

3126

32−instance Pretty Def where

33− pretty def =

34− case def of

35− TypeAnnotation name tipe ->

36− variable name <+> P.colon <+> pretty tipe

3727

38− Definition pattern expr ->

39− pretty pattern <+> P.equals <+> pretty expr

28+data Def'

29+ = Definition Pattern.RawPattern Expr

30+ | TypeAnnotation String Type.Raw

31+ deriving (Show)

src/AST/Expression/Valid.hs+7−25

@@ -1,14 +1,11 @@

11{-# OPTIONS_GHC -Wall #-}

2−

32module AST.Expression.Valid where

43

5−import AST.PrettyPrint

6−import Text.PrettyPrint as P

74import qualified AST.Expression.General as General

8−import AST.Type (RawType)

9−import qualified AST.Variable as Var

10−import qualified AST.Annotation as Annotation

115import qualified AST.Pattern as Pattern

6+import qualified AST.Type as Type

7+import qualified AST.Variable as Var

8+import qualified Reporting.Region as R

129

1310

1411{-| "Normal" expressions. When the compiler checks that type annotations and

@@ -16,28 +13,13 @@ ports are all paired with definitions in the appropriate order, it collapses

1613them into a Def that is easier to work with in later phases of compilation.

1714-}

1815type Expr =

19− General.Expr Annotation.Region Def Var.Raw

16+ General.Expr R.Region Def Var.Raw Type.Raw

2017

2118

2219type Expr' =

23− General.Expr' Annotation.Region Def Var.Raw

20+ General.Expr' R.Region Def Var.Raw Type.Raw

2421

2522

26−data Def = Definition Pattern.RawPattern Expr (Maybe RawType)

23+data Def

24+ = Definition Pattern.RawPattern Expr (Maybe Type.Raw)

2725 deriving (Show)

28−

29−

30−instance Pretty Def where

31− pretty (Definition pattern expr maybeTipe) =

32− P.vcat [ annotation, definition ]

33− where

34− definition =

35− pretty pattern <+> P.equals <+> pretty expr

36−

37− annotation =

38− case maybeTipe of

39− Nothing ->

40− P.empty

41−

42− Just tipe ->

43− pretty pattern <+> P.colon <+> pretty tipe

src/AST/Literal.hs+15−13

@@ -1,9 +1,11 @@

11{-# OPTIONS_GHC -Wall #-}

22module AST.Literal where

33

4−import AST.PrettyPrint

5−import Data.Map (Map)

6−import qualified Text.PrettyPrint as PP

4+import qualified Data.Map as Map

5+import qualified Text.PrettyPrint as P

6+

7+import qualified Reporting.PrettyPrint as P

8+

79

810data Literal

911 = IntNum Int

@@ -14,14 +16,14 @@ data Literal

1416 deriving (Eq, Ord, Show)

1517

1618

17−instance Pretty Literal where

18− pretty literal =

19+instance P.Pretty Literal where

20+ pretty _ literal =

1921 case literal of

20− IntNum n -> PP.int n

21− FloatNum n -> PP.double n

22− Chr c -> PP.text . show $ c

23− Str s -> PP.text . show $ s

24− Boolean bool -> PP.text (show bool)

22+ IntNum n -> P.int n

23+ FloatNum n -> P.double n

24+ Chr c -> P.text . show $ c

25+ Str s -> P.text . show $ s

26+ Boolean bool -> P.text (show bool)

2527

2628

2729data GLTipe

@@ -48,8 +50,8 @@ glTipeName glTipe =

4850

4951

5052data GLShaderTipe = GLShaderTipe

51− { attribute :: Map String GLTipe

52− , uniform :: Map String GLTipe

53− , varying :: Map String GLTipe

53+ { attribute :: Map.Map String GLTipe

54+ , uniform :: Map.Map String GLTipe

55+ , varying :: Map.Map String GLTipe

5456 }

5557 deriving (Show)

src/AST/Module.hs+38−70

@@ -4,55 +4,62 @@ module AST.Module

44 , AdtInfo, CanonicalAdt

55 , SourceModule, ValidModule, CanonicalModule

66 , Module(..), CanonicalBody(..)

7− , HeaderAndImports(..)

7+ , Header(..)

88 , Name, nameToString, nameIsNative

99 , Interface(..), toInterface

10− , ImportMethod(..)

10+ , UserImport, DefaultImport, ImportMethod(..)

1111 ) where

1212

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

1314import Data.Binary

1415import qualified Data.List as List

1516import qualified Data.Map as Map

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

1717

18−import qualified AST.Expression.Canonical as Canonical

1918import qualified AST.Declaration as Decl

19+import qualified AST.Expression.Canonical as Canonical

2020import qualified AST.Type as Type

2121import qualified AST.Variable as Var

22−import AST.PrettyPrint

2322import qualified Elm.Compiler.Version as Compiler

24−import Text.PrettyPrint as P

23+import qualified Reporting.Annotation as A

2524

2625

2726-- HELPFUL TYPE ALIASES

2827

2928type Interfaces = Map.Map Name Interface

3029

31−type Types = Map.Map String Type.CanonicalType

32−type Aliases = Map.Map String ([String], Type.CanonicalType)

30+type Types = Map.Map String Type.Canonical

31+type Aliases = Map.Map String ([String], Type.Canonical)

3332type ADTs = Map.Map String (AdtInfo String)

3433

35−type AdtInfo v = ( [String], [(v, [Type.CanonicalType])] )

34+type AdtInfo v = ( [String], [(v, [Type.Canonical])] )

3635type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)

3736

3837

3938-- MODULES

4039

4140type SourceModule =

42− Module (Var.Listing Var.Value) [Decl.SourceDecl]

41+ Module

42+ [UserImport]

43+ (Var.Listing (A.Located Var.Value))

44+ [Decl.SourceDecl]

45+

4346

4447type ValidModule =

45− Module (Var.Listing Var.Value) [Decl.ValidDecl]

48+ Module

49+ ([DefaultImport], [UserImport])

50+ (Var.Listing (A.Located Var.Value))

51+ [Decl.ValidDecl]

52+

4653

4754type CanonicalModule =

48− Module [Var.Value] CanonicalBody

55+ Module [Name] [Var.Value] CanonicalBody

4956

5057

51−data Module exports body = Module

58+data Module imports exports body = Module

5259 { names :: Name

5360 , path :: FilePath

5461 , exports :: exports

55− , imports :: [(Name, ImportMethod)]

62+ , imports :: imports

5663 , body :: body

5764 }

5865

@@ -69,10 +76,10 @@ data CanonicalBody = CanonicalBody

6976-- HEADERS

7077

7178{-| Basic info needed to identify modules and determine dependencies. -}

72−data HeaderAndImports = HeaderAndImports

79+data Header imports = Header

7380 { _names :: Name

74− , _exports :: Var.Listing Var.Value

75− , _imports :: [(Name, ImportMethod)]

81+ , _exports :: Var.Listing (A.Located Var.Value)

82+ , _imports :: imports

7683 }

7784

7885

@@ -91,6 +98,19 @@ nameIsNative name =

9198 _ -> False

9299

93100

101+-- IMPORTs

102+

103+type UserImport = A.Located (Name, ImportMethod)

104+

105+

106+type DefaultImport = (Name, ImportMethod)

107+

108+

109+data ImportMethod = ImportMethod

110+ { alias :: Maybe String

111+ , exposedVars :: !(Var.Listing Var.Value)

112+ }

113+

94114

95115-- INTERFACES

96116

@@ -99,7 +119,7 @@ data Interface = Interface

99119 { iVersion :: String

100120 , iExports :: [Var.Value]

101121 , iTypes :: Types

102− , iImports :: [(Name, ImportMethod)]

122+ , iImports :: [Name]

103123 , iAdts :: ADTs

104124 , iAliases :: Aliases

105125 , iFixities :: [(Decl.Assoc, Int, String)]

@@ -131,55 +151,3 @@ instance Binary Interface where

131151 put (iAliases modul)

132152 put (iFixities modul)

133153 put (iPorts modul)

134−

135−

136−-- IMPORT METHOD

137−

138−data ImportMethod = ImportMethod

139− { alias :: Maybe String

140− , exposedVars :: !(Var.Listing Var.Value)

141− }

142−

143−

144−instance Binary ImportMethod where

145− put (ImportMethod alias exposedVars) =

146− do put alias

147− put exposedVars

148−

149− get =

150− ImportMethod <$> get <*> get

151−

152−

153−-- PRETTY PRINTING

154−

155−instance (Pretty exs, Pretty body) => Pretty (Module exs body) where

156− pretty (Module names _ exs ims body) =

157− P.vcat [modul, P.text "", prettyImports, P.text "", pretty body]

158− where

159− modul =

160− P.text "module" <+> name <+> pretty exs <+> P.text "where"

161−

162− name =

163− P.text (nameToString names)

164−

165− prettyImports =

166− P.vcat $ map prettyMethod ims

167−

168−

169−prettyMethod :: (Name, ImportMethod) -> Doc

170−prettyMethod (name, ImportMethod maybeAlias exposedVars) =

171− let prettyAlias =

172− case maybeAlias of

173− Nothing -> P.empty

174− Just alias ->

175− P.text "as" <+> P.text alias

176−

177− prettyExposed =

178− if exposedVars == Var.closedListing

179− then P.empty

180− else P.text "exposing" <+> pretty exposedVars

181− in

182− P.text "import"

183− <+> P.text (nameToString name)

184− <+> prettyAlias

185− <+> prettyExposed

src/AST/Pattern.hs+102−68

@@ -1,109 +1,143 @@

11{-# OPTIONS_GHC -Wall #-}

22module AST.Pattern where

33

4−import qualified AST.Helpers as Help

5−import AST.PrettyPrint

6−import Text.PrettyPrint as PP

74import qualified Data.Set as Set

5+import Text.PrettyPrint as P

86

7+import qualified AST.Helpers as Help

8+import qualified AST.Literal as L

99import qualified AST.Variable as Var

10−import AST.Literal as Literal

10+import qualified Reporting.Annotation as A

11+import qualified Reporting.PrettyPrint as P

12+import qualified Reporting.Region as R

13+

1114

15+type Pattern ann var =

16+ A.Annotated ann (Pattern' ann var)

1217

13−data Pattern var

14− = Data var [Pattern var]

18+

19+data Pattern' ann var

20+ = Data var [Pattern ann var]

1521 | Record [String]

16− | Alias String (Pattern var)

22+ | Alias String (Pattern ann var)

1723 | Var String

1824 | Anything

19− | Literal Literal.Literal

20− deriving (Eq, Ord, Show)

25+ | Literal L.Literal

26+ deriving (Show)

2127

2228

2329type RawPattern =

24− Pattern Var.Raw

30+ Pattern R.Region Var.Raw

2531

2632

27−type CanonicalPattern =

28− Pattern Var.Canonical

33+type RawPattern' =

34+ Pattern' R.Region Var.Raw

2935

3036

31−cons :: RawPattern -> RawPattern -> RawPattern

32−cons h t =

33− Data (Var.Raw "::") [h,t]

37+type CanonicalPattern =

38+ Pattern R.Region Var.Canonical

3439

3540

36−nil :: RawPattern

37−nil =

38− Data (Var.Raw "[]") []

41+list :: R.Position -> [RawPattern] -> RawPattern

42+list end patterns =

43+ case patterns of

44+ [] ->

45+ A.at end end (Data (Var.Raw "[]") [])

3946

47+ pattern@(A.A (R.Region start _) _) : rest ->

48+ A.at start end (Data (Var.Raw "::") [pattern, list end rest])

4049

41−list :: [RawPattern] -> RawPattern

42−list patterns =

43− foldr cons nil patterns

4450

51+consMany :: R.Position -> [RawPattern] -> RawPattern

52+consMany end patterns =

53+ let cons hd@(A.A (R.Region start _) _) tl =

54+ A.at start end (Data (Var.Raw "::") [hd, tl])

55+ in

56+ foldr1 cons patterns

4557

46−tuple :: [RawPattern] -> RawPattern

58+

59+tuple :: [RawPattern] -> RawPattern'

4760tuple patterns =

4861 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns

4962

5063

51−boundVarList :: Pattern var -> [String]

52−boundVarList pattern =

53− Set.toList (boundVars pattern)

54−

64+-- FIND VARIABLES

5565

56−boundVars :: Pattern var -> Set.Set String

57−boundVars pattern =

66+boundVars :: Pattern ann var -> [A.Annotated ann String]

67+boundVars (A.A ann pattern) =

5868 case pattern of

59− Var x -> Set.singleton x

60− Alias x p -> Set.insert x (boundVars p)

61− Data _ ps -> Set.unions (map boundVars ps)

62− Record fields -> Set.fromList fields

63− Anything -> Set.empty

64− Literal _ -> Set.empty

69+ Var x ->

70+ [A.A ann x]

71+

72+ Alias name realPattern ->

73+ A.A ann name : boundVars realPattern

74+

75+ Data _ patterns ->

76+ concatMap boundVars patterns

77+

78+ Record fields ->

79+ map (A.A ann) fields

80+

81+ Anything ->

82+ []

83+

84+ Literal _ ->

85+ []

86+

87+

88+member :: String -> Pattern ann var -> Bool

89+member name pattern =

90+ any (name==) (map A.drop (boundVars pattern))

91+

92+

93+boundVarSet :: Pattern ann var -> Set.Set String

94+boundVarSet pattern =

95+ Set.fromList (map A.drop (boundVars pattern))

96+

97+

98+boundVarList :: Pattern ann var -> [String]

99+boundVarList pattern =

100+ Set.toList (boundVarSet pattern)

101+

65102

103+-- PRETTY PRINTING

66104

67−instance Var.ToString var => Pretty (Pattern var) where

68− pretty pattern =

105+instance Var.ToString var => P.Pretty (Pattern' ann var) where

106+ pretty needsParens pattern =

69107 case pattern of

70− Var x ->

71− variable x

108+ Var name ->

109+ P.text name

72110

73111 Literal literal ->

74− pretty literal

112+ P.pretty needsParens literal

75113

76114 Record fields ->

77− PP.braces (commaCat (map variable fields))

115+ P.braces (P.commaCat (map P.text fields))

78116

79− Alias x p ->

80− prettyParens p <+> PP.text "as" <+> variable x

117+ Alias x ptrn ->

118+ P.parensIf needsParens $

119+ P.pretty True ptrn <+> P.text "as" <+> P.text x

81120

82121 Anything ->

83− PP.text "_"

84−

85− Data name [hd,tl] | Var.toString name == "::" ->

86− parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

87− where

88− isCons =

89− case hd of

90− Data ctor _ -> Var.toString ctor == "::"

91− _ -> False

92−

93− Data name ps ->

94− let name' = Var.toString name

95− in

122+ P.text "_"

123+

124+ Data name [A.A _ hd, A.A _ tl]

125+ | Var.toString name == "::" ->

126+ P.parensIf isCons (P.pretty False hd)

127+ <+> P.text "::"

128+ <+> P.pretty False tl

129+ where

130+ isCons =

131+ case hd of

132+ Data ctor _ -> Var.toString ctor == "::"

133+ _ -> False

134+

135+ Data name patterns ->

136+ let name' = Var.toString name

137+ in

96138 if Help.isTuple name'

97− then PP.parens (commaCat (map pretty ps))

98− else hsep (PP.text name' : map prettyParens ps)

99−

100−

101−prettyParens :: Var.ToString var => Pattern var -> Doc

102−prettyParens pattern =

103− parensIf needsThem (pretty pattern)

104− where

105− needsThem =

106− case pattern of

107− Data name (_:_) | not (Help.isTuple (Var.toString name)) -> True

108− Alias _ _ -> True

109− _ -> False

139+ then

140+ P.parens (P.commaCat (map (P.pretty False) patterns))

141+ else

142+ P.parensIf needsParens $

143+ P.hsep (P.text name' : map (P.pretty True) patterns)

src/AST/PrettyPrint.hsdeleted−64

@@ -1,64 +0,0 @@

1−{-# LANGUAGE FlexibleInstances #-}

2−module AST.PrettyPrint where

3−

4−import Control.Monad.Trans.Error

5−import Text.PrettyPrint as P

6−import qualified AST.Helpers as Help

7−

8−

9−class Pretty a where

10− pretty :: a -> Doc

11−

12−

13−instance Pretty Doc where

14− pretty doc = doc

15−

16−

17−instance Pretty String where

18− pretty = P.text

19−

20−

21−renderPretty :: (Pretty a) => a -> String

22−renderPretty e =

23− render (pretty e)

24−

25−

26−commaCat :: [Doc] -> Doc

27−commaCat docs =

28− cat (punctuate comma docs)

29−

30−

31−commaSep :: [Doc] -> Doc

32−commaSep docs =

33− sep (punctuate comma docs)

34−

35−

36−parensIf :: Bool -> Doc -> Doc

37−parensIf bool doc =

38− if bool then parens doc else doc

39−

40−

41−variable :: String -> Doc

42−variable x =

43− if Help.isOp x then parens (text x) else text x

44−

45−

46−eightyCharLines :: Int -> String -> String

47−eightyCharLines indent message = answer

48− where

49− (answer,_,_) = foldl step (spaces, indent-1, "") chunks

50−

51− chunks = map (\w -> (w, length w)) (words message)

52− spaces = replicate indent ' '

53− step (sentence, slen, space) (word, wlen)

54− | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")

55− | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")

56−

57−

58−instance Error Doc where

59− noMsg = P.empty

60− strMsg = P.text

61−

62−

63−instance ErrorList Doc where

64− listMsg str = [ P.text str ]

src/AST/Type.hs+216−116

@@ -1,57 +1,65 @@

11module AST.Type

2− ( Type(..), AliasType(..)

3− , RawType, CanonicalType

4− , PortType(..), portType

5− , fieldMap, recordOf, listOf, tupleOf

2+ ( Raw, Raw'(..)

3+ , Canonical(..), Aliased(..)

4+ , Port(..), portType

65 , deepDealias, dealias

76 , collectLambdas

8− , prettyParens

7+ , fieldMap

8+ , tuple

99 ) where

1010

1111import Control.Applicative ((<$>), (<*>))

1212import Control.Arrow (second)

1313import Data.Binary

1414import qualified Data.Map as Map

15+import qualified Data.Maybe as Maybe

16+import Text.PrettyPrint as P

1517

1618import qualified AST.Variable as Var

17−import AST.PrettyPrint

1819import qualified AST.Helpers as Help

19−import Text.PrettyPrint as P

20+import qualified Reporting.Annotation as A

21+import qualified Reporting.PrettyPrint as P

22+import qualified Reporting.Region as R

2023

2124

2225-- DEFINITION

2326

24−data Type var

25− = Lambda (Type var) (Type var)

26− | Var String

27− | Type var

28− | App (Type var) [Type var]

29− | Record [(String, Type var)] (Maybe (Type var))

30− | Aliased Var.Canonical [(String, Type var)] (AliasType var)

31− deriving (Eq, Ord, Show)

27+type Raw =

28+ A.Located Raw'

3229

3330

34−data AliasType var

35− = Holey (Type var)

36− | Filled (Type var)

37− deriving (Eq, Ord, Show)

31+data Raw'

32+ = RLambda Raw Raw

33+ | RVar String

34+ | RType Var.Raw

35+ | RApp Raw [Raw]

36+ | RRecord [(String, Raw)] (Maybe Raw)

37+ deriving (Show)

3838

3939

40−type RawType =

41− Type Var.Raw

40+data Canonical

41+ = Lambda Canonical Canonical

42+ | Var String

43+ | Type Var.Canonical

44+ | App Canonical [Canonical]

45+ | Record [(String, Canonical)] (Maybe Canonical)

46+ | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)

47+ deriving (Eq, Ord, Show)

4248

4349

44−type CanonicalType =

45− Type Var.Canonical

50+data Aliased t

51+ = Holey t

52+ | Filled t

53+ deriving (Eq, Ord, Show)

4654

4755

48−data PortType var

49− = Normal (Type var)

50− | Signal { root :: Type var, arg :: Type var }

56+data Port t

57+ = Normal t

58+ | Signal { root :: t, arg :: t }

5159 deriving (Show)

5260

5361

54−portType :: PortType var -> Type var

62+portType :: Port tipe -> tipe

5563portType portType =

5664 case portType of

5765 Normal tipe -> tipe

@@ -65,7 +73,7 @@ fieldMap fields =

6573 in

6674 foldl add Map.empty fields

6775

68−

76+{--

6977recordOf :: [(String, Type var)] -> Type var

7078recordOf fields =

7179 Record fields Nothing

@@ -74,18 +82,18 @@ recordOf fields =

7482listOf :: RawType -> RawType

7583listOf tipe =

7684 App (Type (Var.Raw "List")) [tipe]

85+--}

7786

78−

79−tupleOf :: [RawType] -> RawType

80−tupleOf types =

87+tuple :: R.Region -> [Raw] -> Raw

88+tuple region types =

8189 let name = Var.Raw ("_Tuple" ++ show (length types))

8290 in

83− App (Type name) types

91+ A.A region (RApp (A.A region (RType name)) types)

8492

8593

8694-- DEALIASING

8795

88−deepDealias :: Type v -> Type v

96+deepDealias :: Canonical -> Canonical

8997deepDealias tipe =

9098 let go = deepDealias in

9199 case tipe of

@@ -108,7 +116,7 @@ deepDealias tipe =

108116 App (go f) (map go args)

109117

110118

111−dealias :: [(String, Type v)] -> AliasType v -> Type v

119+dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical

112120dealias args aliasType =

113121 case aliasType of

114122 Holey tipe ->

@@ -118,7 +126,7 @@ dealias args aliasType =

118126 tipe

119127

120128

121−dealiasHelp :: Map.Map String (Type var) -> Type var -> Type var

129+dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical

122130dealiasHelp typeTable tipe =

123131 let go = dealiasHelp typeTable in

124132 case tipe of

@@ -143,120 +151,212 @@ dealiasHelp typeTable tipe =

143151

144152-- PRETTY PRINTING

145153

146−instance (Pretty var, Var.ToString var) => Pretty (PortType var) where

147− pretty portType =

154+instance (P.Pretty t) => P.Pretty (Port t) where

155+ pretty needsParens portType =

148156 case portType of

149157 Normal tipe ->

150− pretty tipe

158+ P.pretty needsParens tipe

151159

152160 Signal tipe _ ->

153− pretty tipe

161+ P.pretty needsParens tipe

154162

155163

156−instance (Var.ToString var, Pretty var) => Pretty (Type var) where

157− pretty tipe =

164+instance P.Pretty Raw' where

165+ pretty needsParens tipe =

158166 case tipe of

159− Lambda _ _ ->

160− P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

161− where

162− t:ts = map prettyLambda (collectLambdas tipe)

163− prettyLambda t =

164− case t of

165− Lambda _ _ -> P.parens (pretty t)

166− _ -> pretty t

167+ RLambda arg body ->

168+ P.parensIf needsParens (prettyLambda getRawLambda arg body)

169+

170+ RVar x ->

171+ P.text x

172+

173+ RType var ->

174+ prettyType var

175+

176+ RApp func args ->

177+ let

178+ isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)

179+ isTuple _ = False

180+ in

181+ prettyApp needsParens isTuple func args

182+

183+ RRecord fields ext ->

184+ prettyRecord (flattenRawRecord fields ext)

185+

186+

187+instance P.Pretty Canonical where

188+ pretty needsParens tipe =

189+ case tipe of

190+ Lambda arg body ->

191+ P.parensIf needsParens (prettyLambda getCanLambda arg body)

167192

168193 Var x ->

169194 P.text x

170195

171196 Type var ->

172− let v = Var.toString var

197+ prettyType var

198+

199+ App func args ->

200+ let

201+ isTuple (Type name) = Help.isTuple (Var.toString name)

202+ isTuple _ = False

173203 in

174− P.text (if v == "_Tuple0" then "()" else v)

204+ prettyApp needsParens isTuple func args

175205

176− App f args ->

177− case (f,args) of

178− (Type name, _)

179− | Help.isTuple (Var.toString name) ->

180− P.parens (P.sep (P.punctuate P.comma (map pretty args)))

181−

182− _ -> P.hang (pretty f) 2 (P.sep (map prettyParens args))

183−

184− Record _ _ ->

185− case flattenRecord tipe of

186− ([], Nothing) ->

187− P.text "{}"

188−

189− (fields, Nothing) ->

190− P.sep

191− [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))

192− , P.rbrace

193− ]

194−

195− (fields, Just x) ->

196− P.hang

197− (P.lbrace <+> P.text x <+> P.text "|")

198− 4

199− (P.sep

200− [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))

201− , P.rbrace

202− ])

203− where

204− prettyField (field, tipe) =

205− P.text field <+> P.text ":" <+> pretty tipe

206+ Record fields ext ->

207+ prettyRecord (flattenCanRecord fields ext)

206208

207209 Aliased name args _ ->

208− P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args))

210+ P.parensIf (needsParens && not (null args)) $

211+ P.hang

212+ (P.pretty False name)

213+ 2

214+ (P.sep (map (P.pretty True . snd) args))

209215

210216

211−collectLambdas :: Type var -> [Type var]

212−collectLambdas tipe =

217+-- PRETTY HELPERS

218+

219+prettyType :: (Var.ToString var) => var -> P.Doc

220+prettyType var =

221+ let

222+ v = Var.toString var

223+ in

224+ P.text (if v == "_Tuple0" then "()" else v)

225+

226+

227+-- PRETTY LAMBDAS

228+

229+prettyLambda :: (P.Pretty t) => (t -> Maybe (t,t)) -> t -> t -> P.Doc

230+prettyLambda getLambda arg body =

231+ let

232+ rest =

233+ gatherLambda getLambda body

234+

235+ prettyArg t =

236+ P.pretty (Maybe.isJust (getLambda t)) t

237+ in

238+ P.sep

239+ [ prettyArg arg

240+ , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)

241+ ]

242+

243+

244+getRawLambda :: Raw -> Maybe (Raw, Raw)

245+getRawLambda (A.A _ tipe) =

213246 case tipe of

214− Lambda arg body ->

215− arg : collectLambdas body

247+ RLambda arg body -> Just (arg, body)

248+ _ -> Nothing

216249

217− _ ->

250+

251+getCanLambda :: Canonical -> Maybe (Canonical, Canonical)

252+getCanLambda tipe =

253+ case tipe of

254+ Lambda arg body -> Just (arg, body)

255+ _ -> Nothing

256+

257+

258+gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]

259+gatherLambda get tipe =

260+ case get tipe of

261+ Just (arg, body) ->

262+ arg : gatherLambda get body

263+

264+ Nothing ->

218265 [tipe]

219266

220267

221−prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc

222−prettyParens tipe =

223− parensIf (needed tipe) (pretty tipe)

224− where

225− needed t =

226− case t of

227− Aliased _ [] _ -> False

268+collectLambdas :: Canonical -> [Canonical]

269+collectLambdas tipe =

270+ gatherLambda getCanLambda tipe

228271

229− Aliased _ _ _ -> True

230272

231− Lambda _ _ -> True

273+-- PRETTY APP

232274

233− App (Type name) _

234− | Help.isTuple (Var.toString name) ->

235− False

275+prettyApp :: (P.Pretty t) => Bool -> (t -> Bool) -> t -> [t] -> P.Doc

276+prettyApp needsParens isTuple func args

277+ | isTuple func =

278+ P.parens $ P.sep $

279+ P.punctuate P.comma (map (P.pretty False) args)

236280

237− App t' [] -> needed t'

281+ | null args =

282+ P.pretty needsParens func

238283

239− App _ _ -> True

284+ | otherwise =

285+ P.parensIf needsParens $

286+ P.hang

287+ (P.pretty True func)

288+ 2

289+ (P.sep (map (P.pretty True) args))

240290

241− _ -> False

242291

292+-- PRETTY RECORD

243293

244−flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )

245−flattenRecord tipe =

246− case tipe of

247− Var x ->

248− ([], Just x)

294+prettyRecord :: (P.Pretty t) => ([(String, t)], Maybe String) -> P.Doc

295+prettyRecord recordInfo =

296+ let

297+ prettyField (field, tipe) =

298+ P.hang

299+ (P.text field <+> P.text ":")

300+ 4

301+ (P.pretty False tipe)

302+ in

303+ case recordInfo of

304+ ([], Nothing) ->

305+ P.text "{}"

306+

307+ (fields, Nothing) ->

308+ P.sep

309+ [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))

310+ , P.rbrace

311+ ]

312+

313+ (fields, Just x) ->

314+ P.hang

315+ (P.lbrace <+> P.text x <+> P.text "|")

316+ 4

317+ (P.sep

318+ [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))

319+ , P.rbrace

320+ ]

321+ )

322+

323+

324+flattenRawRecord

325+ :: [(String, Raw)]

326+ -> Maybe Raw

327+ -> ( [(String, Raw)], Maybe String )

328+flattenRawRecord fields ext =

329+ case ext of

330+ Nothing ->

331+ (fields, Nothing)

332+

333+ Just (A.A _ (RVar x)) ->

334+ (fields, Just x)

249335

250− Record fields Nothing ->

336+ Just (A.A _ (RRecord fields' ext')) ->

337+ flattenRawRecord (fields' ++ fields) ext'

338+

339+ _ ->

340+ error "Trying to flatten ill-formed record."

341+

342+

343+flattenCanRecord

344+ :: [(String, Canonical)]

345+ -> Maybe Canonical

346+ -> ( [(String, Canonical)], Maybe String )

347+flattenCanRecord fields ext =

348+ case ext of

349+ Nothing ->

251350 (fields, Nothing)

252351

253− Record fields (Just ext) ->

254− let (fields',ext') = flattenRecord ext

255− in

256− (fields' ++ fields, ext')

352+ Just (Var x) ->

353+ (fields, Just x)

354+

355+ Just (Record fields' ext') ->

356+ flattenCanRecord (fields' ++ fields) ext'

257357

258− Aliased _ args tipe' ->

259− flattenRecord (dealias args tipe')

358+ Just (Aliased _ args tipe) ->

359+ flattenCanRecord fields (Just (dealias args tipe))

260360

261361 _ ->

262362 error "Trying to flatten ill-formed record."

@@ -264,7 +364,7 @@ flattenRecord tipe =

264364

265365-- BINARY

266366

267−instance Binary var => Binary (Type var) where

367+instance Binary Canonical where

268368 put tipe =

269369 case tipe of

270370 Lambda t1 t2 ->

@@ -297,7 +397,7 @@ instance Binary var => Binary (Type var) where

297397 _ -> error "Error reading a valid type from serialized string"

298398

299399

300−instance Binary var => Binary (AliasType var) where

400+instance Binary t => Binary (Aliased t) where

301401 put aliasType =

302402 case aliasType of

303403 Holey tipe ->

src/AST/Variable.hs+68−46

@@ -5,28 +5,29 @@ import Data.Binary

55import qualified Data.List as List

66import qualified Data.Maybe as Maybe

77import Text.PrettyPrint as P

8+

89import qualified AST.Helpers as Help

9−import AST.PrettyPrint

10+import qualified Reporting.PrettyPrint as P

1011

1112

1213-- VARIABLES

1314

1415newtype Raw = Raw String

15− deriving (Eq,Ord,Show)

16+ deriving (Eq, Ord, Show)

1617

1718

1819data Home

1920 = BuiltIn

2021 | Module [String]

2122 | Local

22− deriving (Eq,Ord,Show)

23+ deriving (Eq, Ord, Show)

2324

2425

2526data Canonical = Canonical

2627 { home :: !Home

2728 , name :: !String

2829 }

29− deriving (Eq,Ord,Show)

30+ deriving (Eq, Ord, Show)

3031

3132

3233local :: String -> Canonical

@@ -88,8 +89,10 @@ isTuple v =

8889isPrimitive :: Canonical -> Bool

8990isPrimitive v =

9091 case v of

91− Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]

92− _ -> False

92+ Canonical BuiltIn name ->

93+ name `elem` ["Int","Float","String","Bool"]

94+ _ ->

95+ False

9396

9497

9598isPrim :: String -> Canonical -> Bool

@@ -117,10 +120,10 @@ instance ToString Raw where

117120

118121instance ToString Canonical where

119122 toString (Canonical home name) =

120− case home of

121− BuiltIn -> name

122− Module path -> List.intercalate "." (path ++ [name])

123− Local -> name

123+ case home of

124+ BuiltIn -> name

125+ Module path -> List.intercalate "." (path ++ [name])

126+ Local -> name

124127

125128

126129-- LISTINGS

@@ -129,7 +132,8 @@ instance ToString Canonical where

129132data Listing a = Listing

130133 { _explicits :: [a]

131134 , _open :: Bool

132− } deriving (Eq,Ord,Show)

135+ }

136+ deriving (Eq, Ord, Show)

133137

134138

135139openListing :: Listing a

@@ -152,7 +156,7 @@ data Value

152156 = Value !String

153157 | Alias !String

154158 | Union !String !(Listing String)

155− deriving (Eq,Ord,Show)

159+ deriving (Eq, Ord, Show)

156160

157161

158162-- CATEGORIZING VALUES

@@ -198,30 +202,36 @@ getUnion value =

198202

199203-- PRETTY VARIABLES

200204

201−instance Pretty Raw where

202− pretty (Raw name) =

203− variable name

205+instance P.Pretty Raw where

206+ pretty _ (Raw name) =

207+ if Help.isOp name

208+ then P.parens (P.text name)

209+ else P.text name

204210

205211

206−instance Pretty Canonical where

207− pretty var =

212+instance P.Pretty Canonical where

213+ pretty _ var =

208214 P.text (toString var)

209215

210216

211−instance Pretty a => Pretty (Listing a) where

212− pretty (Listing explicits open) =

213− P.parens (commaCat (map pretty explicits ++ dots))

214− where

215− dots = [if open then P.text ".." else P.empty]

217+instance P.Pretty a => P.Pretty (Listing a) where

218+ pretty _ (Listing explicits open) =

219+ let dots = [if open then P.text ".." else P.empty]

220+ in

221+ P.parens (P.commaCat (map (P.pretty False) explicits ++ dots))

216222

217223

218−instance Pretty Value where

219− pretty portable =

224+instance P.Pretty Value where

225+ pretty _ portable =

220226 case portable of

221− Value name -> P.text name

222− Alias name -> P.text name

227+ Value name ->

228+ P.text name

229+

230+ Alias name ->

231+ P.text name

232+

223233 Union name ctors ->

224− P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })

234+ P.text name <> P.pretty False ctors

225235

226236

227237-- BINARY SERIALIZATION

@@ -229,31 +239,43 @@ instance Pretty Value where

229239instance Binary Canonical where

230240 put (Canonical home name) =

231241 case home of

232− BuiltIn -> putWord8 0 >> put name

233− Module path -> putWord8 1 >> put path >> put name

234− Local -> putWord8 2 >> put name

242+ BuiltIn ->

243+ putWord8 0 >> put name

244+

245+ Module path ->

246+ putWord8 1 >> put path >> put name

247+

248+ Local ->

249+ putWord8 2 >> put name

235250

236− get = do tag <- getWord8

237− case tag of

238− 0 -> Canonical BuiltIn <$> get

239− 1 -> Canonical . Module <$> get <*> get

240− 2 -> Canonical Local <$> get

241− _ -> error "Unexpected tag when deserializing canonical variable"

251+ get =

252+ do tag <- getWord8

253+ case tag of

254+ 0 -> Canonical BuiltIn <$> get

255+ 1 -> Canonical . Module <$> get <*> get

256+ 2 -> Canonical Local <$> get

257+ _ -> error "Unexpected tag when deserializing canonical variable"

242258

243259

244260instance Binary Value where

245261 put portable =

246262 case portable of

247− Value name -> putWord8 0 >> put name

248− Alias name -> putWord8 1 >> put name

249− Union name ctors -> putWord8 2 >> put name >> put ctors

250−

251− get = do tag <- getWord8

252− case tag of

253− 0 -> Value <$> get

254− 1 -> Alias <$> get

255− 2 -> Union <$> get <*> get

256− _ -> error "Error reading valid import/export information from serialized string"

263+ Value name ->

264+ putWord8 0 >> put name

265+

266+ Alias name ->

267+ putWord8 1 >> put name

268+

269+ Union name ctors ->

270+ putWord8 2 >> put name >> put ctors

271+

272+ get =

273+ do tag <- getWord8

274+ case tag of

275+ 0 -> Value <$> get

276+ 1 -> Alias <$> get

277+ 2 -> Union <$> get <*> get

278+ _ -> error "Error reading valid import/export information from serialized string"

257279

258280

259281instance (Binary a) => Binary (Listing a) where

src/Canonicalize.hsnew file+443

@@ -0,0 +1,443 @@

1+module Canonicalize (module') where

2+

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

4+import qualified Data.List as List

5+import qualified Data.Map as Map

6+import qualified Data.Maybe as Maybe

7+import qualified Data.Set as Set

8+import qualified Data.Traversable as T

9+

10+import AST.Expression.General (Expr'(..), dummyLet)

11+import AST.Module (CanonicalBody(..))

12+

13+import qualified AST.Declaration as D

14+import qualified AST.Expression.General as E

15+import qualified AST.Expression.Valid as Valid

16+import qualified AST.Expression.Canonical as Canonical

17+import qualified AST.Module as Module

18+import qualified AST.Pattern as P

19+import qualified AST.Type as Type

20+import qualified AST.Variable as Var

21+import qualified Reporting.Annotation as A

22+import qualified Reporting.Error as Error

23+import qualified Reporting.Error.Canonicalize as CError

24+import qualified Reporting.Result as R

25+import qualified Reporting.Warning as Warning

26+import qualified Canonicalize.Declaration as Decls

27+import qualified Canonicalize.Environment as Env

28+import qualified Canonicalize.Port as Port

29+import qualified Canonicalize.Result as Result

30+import qualified Canonicalize.Setup as Setup

31+import qualified Canonicalize.Sort as Sort

32+import qualified Canonicalize.Type as Canonicalize

33+import qualified Canonicalize.Variable as Canonicalize

34+

35+

36+-- MODULES

37+

38+module'

39+ :: Module.Interfaces

40+ -> Module.ValidModule

41+ -> R.Result Warning.Warning Error.Error Module.CanonicalModule

42+module' interfaces modul =

43+ let (Result.Result uses rawResults) =

44+ moduleHelp interfaces modul

45+ in

46+ case rawResults of

47+ Result.Ok almostCanonicalModule ->

48+ filterImports uses almostCanonicalModule

49+

50+ Result.Err msgs ->

51+ R.throwMany (map (A.map Error.Canonicalize) msgs)

52+

53+

54+type AlmostCanonicalModule =

55+ Module.Module

56+ ([Module.DefaultImport], [Module.UserImport])

57+ [Var.Value]

58+ Module.CanonicalBody

59+

60+

61+moduleHelp

62+ :: Module.Interfaces

63+ -> Module.ValidModule

64+ -> Result.ResultErr AlmostCanonicalModule

65+moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =

66+ canonicalModule

67+ <$> canonicalDeclsResult

68+ <*> resolveExports locals exports

69+ where

70+ canonicalModule canonicalDecls canonicalExports =

71+ modul

72+ { Module.exports = canonicalExports

73+ , Module.body = body canonicalDecls

74+ }

75+

76+ locals :: [Var.Value]

77+ locals =

78+ concatMap declToValue decls

79+

80+ canonicalDeclsResult =

81+ Setup.environment interfaces modul

82+ `Result.andThen` \env -> T.traverse (declaration env) decls

83+

84+ body :: [D.CanonicalDecl] -> Module.CanonicalBody

85+ body decls =

86+ let nakedDecls = map A.drop decls

87+ in

88+ Module.CanonicalBody

89+ { program =

90+ let expr = Decls.toExpr (Module.names modul) decls

91+ in

92+ Sort.definitions (dummyLet expr)

93+

94+ , types =

95+ Map.empty

96+

97+ , datatypes =

98+ Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- nakedDecls ]

99+

100+ , fixities =

101+ [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]

102+

103+ , aliases =

104+ Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- nakedDecls ]

105+

106+ , ports =

107+ [ E.portName impl | D.Port (D.CanonicalPort impl) <- nakedDecls ]

108+ }

109+

110+

111+-- IMPORTS / EXPORTS

112+

113+filterImports

114+ :: Set.Set Module.Name

115+ -> AlmostCanonicalModule

116+ -> R.Result Warning.Warning e Module.CanonicalModule

117+filterImports uses modul@(Module.Module _ _ _ (defaults, imports) _) =

118+ do reducedImports <-

119+ Maybe.catMaybes <$> T.traverse checkImport imports

120+

121+ return $ modul

122+ { Module.imports =

123+ Set.toList (Set.fromList (map fst defaults ++ reducedImports))

124+ }

125+ where

126+ checkImport (A.A region (name, _method)) =

127+ if Set.member name uses

128+ then

129+ return (Just name)

130+ else

131+ do R.warn region (Warning.UnusedImport name)

132+ return Nothing

133+

134+

135+resolveExports

136+ :: [Var.Value]

137+ -> Var.Listing (A.Located Var.Value)

138+ -> Result.ResultErr [Var.Value]

139+resolveExports fullList (Var.Listing partialList open) =

140+ if open

141+ then Result.ok fullList

142+ else

143+ (\xs ys zs -> xs ++ ys ++ zs)

144+ <$> T.traverse getValueExport values

145+ <*> (concat <$> T.traverse getAliasExport aliases)

146+ <*> T.traverse getAdtExport adts

147+ where

148+ (allValues, allAliases, allAdts) =

149+ maybeUnzip3 (map splitValue fullList)

150+

151+ (values, aliases, adts) =

152+ maybeUnzip3 (map splitLocatedValue partialList)

153+

154+ allValuesSet = Set.fromList allValues

155+ adtTypes = map fst allAdts

156+

157+ getValueExport (A.A region name) =

158+ if Set.member name allValuesSet

159+ then Result.ok (Var.Value name)

160+ else manyNotFound region [name] allValues

161+

162+ getAliasExport (A.A region alias)

163+ | alias `elem` allAliases =

164+ Result.ok $ (:) (Var.Alias alias) $

165+ if alias `elem` allValues then [Var.Value alias] else []

166+

167+ | List.elem alias adtTypes =

168+ Result.ok [Var.Union alias (Var.Listing [] False)]

169+

170+ | otherwise =

171+ manyNotFound region [alias] (allAliases ++ adtTypes)

172+

173+ getAdtExport (A.A region (name, Var.Listing ctors open)) =

174+ case List.lookup name allAdts of

175+ Nothing ->

176+ manyNotFound region [name] adtTypes

177+

178+ Just (Var.Listing allCtors _)

179+ | open ->

180+ Result.ok (Var.Union name (Var.Listing allCtors False))

181+ | otherwise ->

182+ case filter (`notElem` allCtors) ctors of

183+ [] ->

184+ Result.ok (Var.Union name (Var.Listing ctors False))

185+ unfoundCtors ->

186+ manyNotFound region unfoundCtors allCtors

187+

188+ manyNotFound region nameList possibilities =

189+ Result.errors (map (notFound region possibilities) nameList)

190+

191+ notFound region possibilities name =

192+ A.A region $ CError.Export name $

193+ CError.nearbyNames id name possibilities

194+

195+

196+-- GROUPING VALUES

197+

198+maybeUnzip3 :: [(Maybe a, Maybe b, Maybe c)] -> ([a],[b],[c])

199+maybeUnzip3 tuples =

200+ let (as, bs, cs) = unzip3 tuples

201+ in

202+ (Maybe.catMaybes as, Maybe.catMaybes bs, Maybe.catMaybes cs)

203+

204+

205+splitValue

206+ :: Var.Value

207+ -> ( Maybe String, Maybe String, Maybe (String, Var.Listing String) )

208+splitValue value =

209+ case value of

210+ Var.Value name ->

211+ (Just name, Nothing, Nothing)

212+

213+ Var.Alias name ->

214+ (Nothing, Just name, Nothing)

215+

216+ Var.Union name listing ->

217+ (Nothing, Nothing, Just (name, listing))

218+

219+

220+splitLocatedValue

221+ :: A.Located Var.Value

222+ ->

223+ ( Maybe (A.Located String)

224+ , Maybe (A.Located String)

225+ , Maybe (A.Located (String, Var.Listing String))

226+ )

227+splitLocatedValue (A.A region value) =

228+ case value of

229+ Var.Value name ->

230+ (Just (A.A region name), Nothing, Nothing)

231+

232+ Var.Alias name ->

233+ (Nothing, Just (A.A region name), Nothing)

234+

235+ Var.Union name listing ->

236+ (Nothing, Nothing, Just (A.A region (name, listing)))

237+

238+

239+-- DECLARATIONS

240+

241+declToValue :: D.ValidDecl -> [Var.Value]

242+declToValue (A.A _ decl) =

243+ case decl of

244+ D.Definition (Valid.Definition pattern _ _) ->

245+ map Var.Value (P.boundVarList pattern)

246+

247+ D.Datatype name _tvs ctors ->

248+ [ Var.Union name (Var.Listing (map fst ctors) False) ]

249+

250+ D.TypeAlias name _ tipe ->

251+ case tipe of

252+ A.A _ (Type.RRecord _ _) ->

253+ [ Var.Alias name, Var.Value name ]

254+ _ -> [ Var.Alias name ]

255+

256+ _ -> []

257+

258+

259+declaration

260+ :: Env.Environment

261+ -> D.ValidDecl

262+ -> Result.ResultErr D.CanonicalDecl

263+declaration env (A.A region decl) =

264+ let canonicalize kind _context _pattern env v =

265+ kind env v

266+ in

267+ A.A region <$>

268+ case decl of

269+ D.Definition (Valid.Definition p e t) ->

270+ D.Definition <$> (

271+ Canonical.Definition

272+ <$> canonicalize pattern "definition" p env p

273+ <*> expression env e

274+ <*> T.traverse (canonicalize Canonicalize.tipe "definition" p env) t

275+ )

276+

277+ D.Datatype name tvars ctors ->

278+ D.Datatype name tvars <$> T.traverse canonicalize' ctors

279+ where

280+ canonicalize' (ctor,args) =

281+ (,) ctor <$> T.traverse (canonicalize Canonicalize.tipe "datatype" name env) args

282+

283+ D.TypeAlias name tvars expanded ->

284+ D.TypeAlias name tvars

285+ <$> canonicalize Canonicalize.tipe "type alias" name env expanded

286+

287+ D.Port validPort ->

288+ Result.addModule ["Native","Port"] $

289+ Result.addModule ["Native","Json"] $

290+ case validPort of

291+ D.In name tipe ->

292+ canonicalize Canonicalize.tipe "port" name env tipe

293+ `Result.andThen` \canonicalType ->

294+ D.Port <$> Port.check region name Nothing canonicalType

295+

296+ D.Out name expr tipe ->

297+ let exprTypeResult =

298+ (,)

299+ <$> expression env expr

300+ <*> canonicalize Canonicalize.tipe "port" name env tipe

301+ in

302+ exprTypeResult

303+ `Result.andThen` \(expr', tipe') ->

304+ D.Port <$> Port.check region name (Just expr') tipe'

305+

306+ D.Fixity assoc prec op ->

307+ Result.ok (D.Fixity assoc prec op)

308+

309+

310+expression

311+ :: Env.Environment

312+ -> Valid.Expr

313+ -> Result.ResultErr Canonical.Expr

314+expression env (A.A region validExpr) =

315+ let go = expression env

316+ in

317+ A.A region <$>

318+ case validExpr of

319+ Literal lit ->

320+ Result.ok (Literal lit)

321+

322+ Range lowExpr highExpr ->

323+ Range <$> go lowExpr <*> go highExpr

324+

325+ Access record field ->

326+ Access <$> go record <*> Result.ok field

327+

328+ Remove record field ->

329+ flip Remove field <$> go record

330+

331+ Insert record field expr ->

332+ flip Insert field <$> go record <*> go expr

333+

334+ Modify record fields ->

335+ Modify

336+ <$> go record

337+ <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields

338+

339+ Record fields ->

340+ Record

341+ <$> T.traverse (\(field,expr) -> (,) field <$> go expr) fields

342+

343+ Binop (Var.Raw op) leftExpr rightExpr ->

344+ Binop

345+ <$> Canonicalize.variable region env op

346+ <*> go leftExpr

347+ <*> go rightExpr

348+

349+ Lambda arg body ->

350+ let env' = Env.addPattern arg env

351+ in

352+ Lambda <$> pattern env' arg <*> expression env' body

353+

354+ App func arg ->

355+ App <$> go func <*> go arg

356+

357+ MultiIf branches ->

358+ MultiIf <$> T.traverse go' branches

359+ where

360+ go' (condition, branch) =

361+ (,) <$> go condition <*> go branch

362+

363+ Let defs body ->

364+ Let <$> T.traverse rename' defs <*> expression env' body

365+ where

366+ env' =

367+ foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs

368+

369+ rename' (Valid.Definition p body mtipe) =

370+ Canonical.Definition

371+ <$> pattern env' p

372+ <*> expression env' body

373+ <*> T.traverse (Canonicalize.tipe env') mtipe

374+

375+ Var (Var.Raw x) ->

376+ Var <$> Canonicalize.variable region env x

377+

378+ Data name exprs ->

379+ Data name <$> T.traverse go exprs

380+

381+ ExplicitList exprs ->

382+ ExplicitList <$> T.traverse go exprs

383+

384+ Case expr cases ->

385+ Case <$> go expr <*> T.traverse branch cases

386+ where

387+ branch (ptrn, brnch) =

388+ (,) <$> pattern env ptrn

389+ <*> expression (Env.addPattern ptrn env) brnch

390+

391+ Port impl ->

392+ let portType pt =

393+ case pt of

394+ Type.Normal t ->

395+ Type.Normal

396+ <$> Canonicalize.tipe env t

397+

398+ Type.Signal root arg ->

399+ Type.Signal

400+ <$> Canonicalize.tipe env root

401+ <*> Canonicalize.tipe env arg

402+ in

403+ Port <$>

404+ case impl of

405+ E.In name tipe ->

406+ E.In name <$> portType tipe

407+

408+ E.Out name expr tipe ->

409+ E.Out name <$> go expr <*> portType tipe

410+

411+ E.Task name expr tipe ->

412+ E.Task name <$> go expr <*> portType tipe

413+

414+ GLShader uid src tipe ->

415+ Result.ok (GLShader uid src tipe)

416+

417+

418+pattern

419+ :: Env.Environment

420+ -> P.RawPattern

421+ -> Result.ResultErr P.CanonicalPattern

422+pattern env (A.A region ptrn) =

423+ A.A region <$>

424+ case ptrn of

425+ P.Var x ->

426+ Result.ok (P.Var x)

427+

428+ P.Literal lit ->

429+ Result.ok (P.Literal lit)

430+

431+ P.Record fields ->

432+ Result.ok (P.Record fields)

433+

434+ P.Anything ->

435+ Result.ok P.Anything

436+

437+ P.Alias x p ->

438+ P.Alias x <$> pattern env p

439+

440+ P.Data (Var.Raw name) patterns ->

441+ P.Data

442+ <$> Canonicalize.pvar region env name (length patterns)

443+ <*> T.traverse (pattern env) patterns

src/Canonicalize/Declaration.hsnew file+101

@@ -0,0 +1,101 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Declaration (toExpr) where

3+

4+import qualified AST.Declaration as D

5+import qualified AST.Expression.General as E

6+import qualified AST.Expression.Canonical as Canonical

7+import qualified AST.Module as Module

8+import qualified AST.Pattern as P

9+import qualified AST.Type as T

10+import qualified AST.Variable as Var

11+import qualified Reporting.Annotation as A

12+

13+

14+toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]

15+toExpr moduleName decls =

16+ concatMap (toDefs moduleName) decls

17+

18+

19+toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]

20+toDefs moduleName (A.A region decl) =

21+ let typeVar = Var.fromModule moduleName

22+

23+ loc expr =

24+ A.A region expr

25+ in

26+ case decl of

27+ D.Definition def ->

28+ [def]

29+

30+ D.Datatype name tvars constructors ->

31+ concatMap toDefs' constructors

32+ where

33+ toDefs' (ctor, tipes) =

34+ let vars = take (length tipes) infiniteArgs

35+ tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)

36+ body = loc . E.Data ctor $ map (loc . E.localVar) vars

37+ in

38+ [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

39+

40+ D.TypeAlias name tvars tipe@(T.Record fields ext) ->

41+ [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]

42+ where

43+ result =

44+ T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)

45+

46+ args =

47+ map snd fields ++ maybe [] (:[]) ext

48+

49+ var = loc . E.localVar

50+ vars = take (length args) infiniteArgs

51+

52+ efields =

53+ zip (map fst fields) (map var vars)

54+

55+ record =

56+ case ext of

57+ Nothing ->

58+ loc (E.Record efields)

59+

60+ Just _ ->

61+ foldl (\r (f,v) -> loc (E.Insert r f v)) (var (last vars)) efields

62+

63+ -- Type aliases must be added to an extended equality dictionary,

64+ -- but they do not require any basic constraints.

65+ D.TypeAlias _ _ _ ->

66+ []

67+

68+ D.Port (D.CanonicalPort impl) ->

69+ let body = loc (E.Port impl)

70+ in

71+ case impl of

72+ E.In name tipe ->

73+ [ definition name body (T.portType tipe) ]

74+

75+ E.Out name _expr tipe ->

76+ [ definition name body (T.portType tipe) ]

77+

78+ E.Task name _expr tipe ->

79+ [ definition name body (T.portType tipe) ]

80+

81+ -- no constraints are needed for fixity declarations

82+ D.Fixity _ _ _ ->

83+ []

84+

85+

86+infiniteArgs :: [String]

87+infiniteArgs =

88+ map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

89+

90+

91+buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr

92+buildFunction body@(A.A ann _) vars =

93+ foldr

94+ (\pattern expr -> A.A ann (E.Lambda pattern expr))

95+ body

96+ (map (A.A ann . P.Var) vars)

97+

98+

99+definition :: String -> Canonical.Expr -> T.Canonical -> Canonical.Def

100+definition name expr@(A.A ann _) tipe =

101+ Canonical.Definition (A.A ann (P.Var name)) expr (Just tipe)

src/Canonicalize/Environment.hsnew file+106

@@ -0,0 +1,106 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Environment where

3+

4+import qualified Data.List as List

5+import qualified Data.Map as Map

6+import qualified Data.Set as Set

7+

8+import AST.Expression.General (saveEnvName)

9+import qualified AST.Module as Module

10+import qualified AST.Pattern as P

11+import qualified AST.Type as Type

12+import qualified AST.Variable as Var

13+

14+

15+-- ENVIRONMENT

16+

17+data Environment = Env

18+ { _home :: Module.Name

19+ , _values :: Dict Var.Canonical

20+ , _adts :: Dict Var.Canonical

21+ , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)

22+ , _patterns :: Dict (Var.Canonical, Int)

23+ }

24+

25+

26+type Dict a =

27+ Map.Map String (Set.Set a)

28+

29+

30+fromPatches :: Module.Name -> [Patch] -> Environment

31+fromPatches moduleName patches =

32+ addPatches

33+ patches

34+ (Env moduleName Map.empty Map.empty Map.empty Map.empty)

35+

36+

37+addPattern :: P.Pattern ann var -> Environment -> Environment

38+addPattern pattern env =

39+ let patches =

40+ map (\x -> Value x (Var.local x)) (P.boundVarList pattern)

41+ in

42+ addPatches patches env

43+

44+

45+-- PATCHES

46+

47+data Patch

48+ = Value String Var.Canonical

49+ | Union String Var.Canonical

50+ | Alias String (Var.Canonical, [String], Type.Canonical)

51+ | Pattern String (Var.Canonical, Int)

52+

53+

54+-- ADD PATCH TO ENVIRONMENT

55+

56+addPatches :: [Patch] -> Environment -> Environment

57+addPatches patches env =

58+ List.foldl' (flip addPatch) env patches

59+

60+

61+addPatch :: Patch -> Environment -> Environment

62+addPatch patch env =

63+ case patch of

64+ Value name var ->

65+ env { _values = insert name var (_values env) }

66+

67+ Union name var ->

68+ env { _adts = insert name var (_adts env) }

69+

70+ Alias name var ->

71+ env { _aliases = insert name var (_aliases env) }

72+

73+ Pattern name var ->

74+ env { _patterns = insert name var (_patterns env) }

75+

76+

77+insert :: (Ord a) => String -> a -> Dict a -> Dict a

78+insert key value =

79+ Map.insertWith Set.union key (Set.singleton value)

80+

81+

82+-- PATCH HELPERS

83+

84+builtinPatches :: [Patch]

85+builtinPatches =

86+ concat

87+ [ map (patch Value) (tupleNames ++ [saveEnvName])

88+ , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])

89+ , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])

90+ ]

91+ where

92+ patch mkPatch name =

93+ mkPatch name (Var.builtin name)

94+

95+ patternPatch (name, args) =

96+ Pattern name (Var.builtin name, args)

97+

98+ tupleNames =

99+ map fst tuples

100+

101+ tuples =

102+ map toTuple [0..9]

103+

104+ toTuple :: Int -> (String, Int)

105+ toTuple n =

106+ ("_Tuple" ++ show n, n)

src/Canonicalize/Port.hsnew file+124

@@ -0,0 +1,124 @@

1+module Canonicalize.Port (check) where

2+

3+import Control.Applicative ((<$>))

4+import qualified Data.Foldable as Foldable

5+

6+import qualified AST.Declaration as D

7+import qualified AST.Expression.General as E

8+import qualified AST.Expression.Canonical as Canonical

9+import qualified AST.Type as T

10+import qualified AST.Variable as Var

11+import qualified Reporting.Annotation as A

12+import qualified Reporting.Error.Canonicalize as Error

13+import qualified Reporting.Region as R

14+import qualified Canonicalize.Result as Result

15+

16+

17+-- CHECK FOR PORT

18+

19+check

20+ :: R.Region

21+ -> String

22+ -> Maybe Canonical.Expr

23+ -> T.Canonical

24+ -> Result.ResultErr D.CanonicalPort

25+check region name maybeExpr rootType =

26+ D.CanonicalPort <$> checkHelp region name maybeExpr rootType rootType

27+

28+

29+checkHelp

30+ :: R.Region

31+ -> String

32+ -> Maybe Canonical.Expr

33+ -> T.Canonical

34+ -> T.Canonical

35+ -> Result.ResultErr (E.PortImpl Canonical.Expr T.Canonical)

36+checkHelp region name maybeExpr rootType tipe =

37+ case (maybeExpr, tipe) of

38+ (_, T.Aliased _ args t) ->

39+ checkHelp region name maybeExpr rootType (T.dealias args t)

40+

41+ (Just expr, T.App (T.Type task) [ _x, _a ])

42+ | Var.isTask task ->

43+ Result.ok (E.Task name expr (T.Normal tipe))

44+

45+

46+ (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])

47+ | Var.isSignal signal && Var.isTask task ->

48+ Result.ok (E.Task name expr (T.Signal tipe arg))

49+

50+

51+ (_, T.App (T.Type signal) [arg])

52+ | Var.isSignal signal ->

53+ case maybeExpr of

54+ Nothing ->

55+ const (E.In name (T.Signal rootType arg))

56+ <$> validForeignType region name True arg arg

57+

58+ Just expr ->

59+ const (E.Out name expr (T.Signal rootType arg))

60+ <$> validForeignType region name False arg arg

61+

62+ _ ->

63+ case maybeExpr of

64+ Nothing ->

65+ const (E.In name (T.Normal rootType))

66+ <$> validForeignType region name True rootType tipe

67+

68+ Just expr ->

69+ const (E.Out name expr (T.Normal rootType))

70+ <$> validForeignType region name False rootType tipe

71+

72+

73+-- CHECK INBOUND AND OUTBOUND TYPES

74+

75+validForeignType

76+ :: R.Region

77+ -> String

78+ -> Bool

79+ -> T.Canonical

80+ -> T.Canonical

81+ -> Result.ResultErr ()

82+validForeignType region name isInbound rootType tipe =

83+ let valid localType =

84+ validForeignType region name isInbound rootType localType

85+

86+ err problem =

87+ Result.err $ A.A region $

88+ Error.port name isInbound rootType tipe problem

89+ in

90+ case tipe of

91+ T.Aliased _ args t ->

92+ valid (T.dealias args t)

93+

94+ T.Type v ->

95+ case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of

96+ True -> Result.ok ()

97+ False -> err Nothing

98+

99+ T.App t [] ->

100+ valid t

101+

102+ T.App (T.Type v) [t]

103+ | Var.isMaybe v -> valid t

104+ | Var.isArray v -> valid t

105+ | Var.isList v -> valid t

106+

107+ T.App (T.Type v) ts

108+ | Var.isTuple v ->

109+ Foldable.traverse_ valid ts

110+

111+ T.App _ _ ->

112+ err Nothing

113+

114+ T.Var _ ->

115+ err (Just "a free type variable")

116+

117+ T.Lambda _ _ ->

118+ err (Just "a function")

119+

120+ T.Record _ (Just _) ->

121+ err (Just "an extended record")

122+

123+ T.Record fields Nothing ->

124+ Foldable.traverse_ (\(k,v) -> (,) k <$> valid v) fields

src/Canonicalize/Result.hsnew file+117

@@ -0,0 +1,117 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Result where

3+

4+import Prelude hiding (foldl)

5+import qualified Control.Applicative as A

6+import qualified Data.Functor as F

7+import qualified Data.Set as Set

8+

9+import qualified AST.Module as Module

10+import qualified AST.Variable as Var

11+import qualified Reporting.Annotation as A

12+import qualified Reporting.Error.Canonicalize as Error

13+

14+

15+type ResultErr a = Result (A.Located Error.Error) a

16+

17+

18+data Result err a =

19+ Result (Set.Set Module.Name) (RawResult err a)

20+

21+

22+data RawResult err a

23+ = Ok a

24+ | Err [err]

25+

26+

27+-- RESULT HELPERS

28+

29+ok :: a -> Result e a

30+ok value =

31+ Result Set.empty (Ok value)

32+

33+

34+err :: e -> Result e a

35+err msg =

36+ errors [msg]

37+

38+

39+errors :: [e] -> Result e a

40+errors msgs =

41+ Result Set.empty (Err msgs)

42+

43+

44+foldl :: (a -> b -> Result e b) -> b -> [a] -> Result e b

45+foldl f acc list =

46+ case list of

47+ [] ->

48+ ok acc

49+

50+ x:xs ->

51+ f x acc `andThen` (\acc' -> foldl f acc' xs)

52+

53+

54+andThen :: Result e a -> (a -> Result e b) -> Result e b

55+andThen (Result uses rawResult) callback =

56+ case rawResult of

57+ Err msg ->

58+ Result uses (Err msg)

59+

60+ Ok value ->

61+ let (Result uses' rawResult') = callback value

62+ in

63+ Result (Set.union uses uses') rawResult'

64+

65+

66+instance F.Functor (Result e) where

67+ fmap func (Result uses result) =

68+ case result of

69+ Ok a ->

70+ Result uses (Ok (func a))

71+

72+ Err msgs ->

73+ Result uses (Err msgs)

74+

75+

76+instance A.Applicative (Result e) where

77+ pure value =

78+ ok value

79+

80+ (<*>) (Result uses resultFunc) (Result uses' resultVal) =

81+ Result (Set.union uses uses') $

82+ case (resultFunc, resultVal) of

83+ (Ok func, Ok val) ->

84+ Ok (func val)

85+

86+ (Err msgs, Err msgs') ->

87+ Err (msgs ++ msgs')

88+

89+ (Err msgs, _) ->

90+ Err msgs

91+

92+ (_, Err msgs) ->

93+ Err msgs

94+

95+

96+-- TRACK USES OF IMPORTS

97+

98+addModule :: Module.Name -> Result e a -> Result e a

99+addModule home (Result uses result) =

100+ Result (Set.insert home uses) result

101+

102+

103+var' :: (a -> Var.Canonical) -> a -> Result e a

104+var' toVar value =

105+ case toVar value of

106+ Var.Canonical (Var.Module moduleName) _name ->

107+ Result (Set.singleton moduleName) (Ok value)

108+

109+ Var.Canonical _ _ ->

110+ ok value

111+

112+

113+var :: Var.Canonical -> Result e Var.Canonical

114+var variable =

115+ var' id variable

116+

117+

src/Canonicalize/Setup.hsnew file+389

@@ -0,0 +1,389 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Setup (environment) where

3+

4+import Control.Applicative ((<$>))

5+import Control.Arrow (second)

6+import qualified Data.Graph as Graph

7+import qualified Data.Map as Map

8+import qualified Data.Maybe as Maybe

9+import qualified Data.Traversable as Trav

10+

11+import qualified AST.Declaration as D

12+import qualified AST.Expression.Valid as Valid

13+import qualified AST.Module as Module

14+import qualified AST.Pattern as P

15+import qualified AST.Type as Type

16+import qualified AST.Variable as Var

17+import Elm.Utils ((|>))

18+import qualified Reporting.Annotation as A

19+import qualified Reporting.Error.Canonicalize as Error

20+import qualified Reporting.Region as R

21+import qualified Canonicalize.Environment as Env

22+import qualified Canonicalize.Result as Result

23+import qualified Canonicalize.Type as Canonicalize

24+

25+

26+environment

27+ :: Module.Interfaces

28+ -> Module.ValidModule

29+ -> Result.ResultErr Env.Environment

30+environment interfaces modul@(Module.Module _ _ _ (defaults, imports) decls) =

31+ let moduleName =

32+ Module.names modul

33+

34+ allImports =

35+ imports ++ map (A.A (error "default import not found")) defaults

36+

37+ importPatchesResult =

38+ concat <$> Trav.traverse (importPatches interfaces) allImports

39+

40+ (typeAliasNodes, declPatches) =

41+ declarationsToPatches moduleName decls

42+

43+ patches =

44+ (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult

45+ in

46+ (Env.fromPatches moduleName <$> patches)

47+ `Result.andThen` addTypeAliases moduleName typeAliasNodes

48+

49+

50+-- PATCHES FOR IMPORTS

51+

52+importPatches

53+ :: Module.Interfaces

54+ -> A.Located (Module.Name, Module.ImportMethod)

55+ -> Result.ResultErr [Env.Patch]

56+importPatches allInterfaces (A.A region (importName, method)) =

57+ case restrictToPublicApi <$> Map.lookup importName allInterfaces of

58+ Nothing

59+ | Module.nameIsNative importName ->

60+ Result.ok []

61+

62+ | otherwise ->

63+ allInterfaces

64+ |> Map.keys

65+ |> Error.nearbyNames Module.nameToString importName

66+ |> Error.moduleNotFound importName

67+ |> A.A region

68+ |> Result.err

69+

70+ Just interface ->

71+ let (Module.ImportMethod maybeAlias listing) =

72+ method

73+

74+ (Var.Listing exposedValues open) =

75+ listing

76+

77+ qualifier =

78+ maybe (Module.nameToString importName) id maybeAlias

79+

80+ qualifiedPatches =

81+ interfacePatches importName (qualifier ++ ".") interface

82+

83+ unqualifiedPatches =

84+ if open

85+ then Result.ok (interfacePatches importName "" interface)

86+ else concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues

87+ in

88+ (++) qualifiedPatches <$> unqualifiedPatches

89+

90+

91+interfacePatches :: Module.Name -> String -> Module.Interface -> [Env.Patch]

92+interfacePatches moduleName prefix interface =

93+ let genericPatch mkPatch name value =

94+ mkPatch (prefix ++ name) value

95+

96+ patch mkPatch name =

97+ genericPatch mkPatch name (Var.fromModule moduleName name)

98+

99+ aliasPatch (name, (tvars, tipe)) =

100+ genericPatch Env.Alias name

101+ (Var.fromModule moduleName name, tvars, tipe)

102+

103+ patternPatch (name, args) =

104+ genericPatch Env.Pattern name

105+ (Var.fromModule moduleName name, length args)

106+

107+ ctors =

108+ concatMap snd (Map.elems (Module.iAdts interface))

109+

110+ ctorNames =

111+ map fst ctors

112+ in

113+ concat

114+ [ map (patch Env.Value) (Map.keys (Module.iTypes interface))

115+ , map (patch Env.Value) ctorNames

116+ , map (patch Env.Union) (Map.keys (Module.iAdts interface))

117+ , map aliasPatch (Map.toList (Module.iAliases interface))

118+ , map patternPatch ctors

119+ ]

120+

121+

122+-- PATCHES FOR INDIVIDUAL VALUES

123+

124+valueToPatches

125+ :: R.Region

126+ -> Module.Name

127+ -> Module.Interface

128+ -> Var.Value

129+ -> Result.ResultErr [Env.Patch]

130+valueToPatches region moduleName interface value =

131+ let patch mkPatch x =

132+ mkPatch x (Var.fromModule moduleName x)

133+

134+ patternPatch (x, numArgs) =

135+ Env.Pattern x (Var.fromModule moduleName x, numArgs)

136+

137+ notFound getNames x =

138+ Module.iExports interface

139+ |> getNames

140+ |> Error.nearbyNames id x

141+ |> Error.valueNotFound moduleName x

142+ |> A.A region

143+ |> Result.err

144+ in

145+ case value of

146+ Var.Value x

147+ | Map.notMember x (Module.iTypes interface) ->

148+ notFound Var.getValues x

149+

150+ | otherwise ->

151+ Result.ok [patch Env.Value x]

152+

153+ Var.Alias x ->

154+ case Map.lookup x (Module.iAliases interface) of

155+ Just (tvars, t) ->

156+ let alias =

157+ Env.Alias x (Var.fromModule moduleName x, tvars, t)

158+ in

159+ Result.ok $

160+ if Map.member x (Module.iTypes interface)

161+ then [alias, patch Env.Value x]

162+ else [alias]

163+

164+ Nothing ->

165+ case Map.lookup x (Module.iAdts interface) of

166+ Just (_,_) ->

167+ Result.ok [patch Env.Union x]

168+

169+ Nothing ->

170+ let getNames values =

171+ Var.getAliases values

172+ ++ map fst (Var.getUnions values)

173+ in

174+ notFound getNames x

175+

176+ Var.Union givenName (Var.Listing givenCtorNames open) ->

177+ case Map.lookup givenName (Module.iAdts interface) of

178+ Nothing ->

179+ notFound (map fst . Var.getUnions) givenName

180+

181+ Just (_tvars, realCtors) ->

182+ patches <$>

183+ if open

184+ then Result.ok realCtorList

185+ else Trav.traverse ctorExists givenCtorNames

186+ where

187+ realCtorList =

188+ map (second length) realCtors

189+

190+ realCtorDict =

191+ Map.fromList realCtorList

192+

193+ ctorExists givenCtorName =

194+ case Map.lookup givenCtorName realCtorDict of

195+ Just numArgs ->

196+ Result.ok (givenCtorName, numArgs)

197+ Nothing ->

198+ notFound (const (map fst realCtors)) givenCtorName

199+

200+ patches ctors =

201+ patch Env.Union givenName

202+ : map (patch Env.Value . fst) ctors

203+ ++ map patternPatch ctors

204+

205+

206+-- PATCHES FOR TYPE ALIASES

207+

208+type Node = ((R.Region, String, [String], Type.Raw), String, [String])

209+

210+

211+node :: R.Region -> String -> [String] -> Type.Raw -> Node

212+node region name tvars alias =

213+ ((region, name, tvars, alias), name, edges alias)

214+ where

215+ edges (A.A _ tipe) =

216+ case tipe of

217+ Type.RLambda t1 t2 ->

218+ edges t1 ++ edges t2

219+

220+ Type.RVar _ ->

221+ []

222+

223+ Type.RType (Var.Raw x) ->

224+ [x]

225+

226+ Type.RApp t ts ->

227+ edges t ++ concatMap edges ts

228+

229+ Type.RRecord fs ext ->

230+ maybe [] edges ext ++ concatMap (edges . snd) fs

231+

232+

233+addTypeAliases

234+ :: Module.Name

235+ -> [Node]

236+ -> Env.Environment

237+ -> Result.ResultErr Env.Environment

238+addTypeAliases moduleName typeAliasNodes initialEnv =

239+ Result.foldl

240+ (addTypeAlias moduleName)

241+ initialEnv

242+ (Graph.stronglyConnComp typeAliasNodes)

243+

244+

245+addTypeAlias

246+ :: Module.Name

247+ -> Graph.SCC (R.Region, String, [String], Type.Raw)

248+ -> Env.Environment

249+ -> Result.ResultErr Env.Environment

250+addTypeAlias moduleName scc env =

251+ case scc of

252+ Graph.AcyclicSCC (_, name, tvars, alias) ->

253+ addToEnv <$> Canonicalize.tipe env alias

254+ where

255+ addToEnv alias' =

256+ let value =

257+ (Var.fromModule moduleName name, tvars, alias')

258+ in

259+ env { Env._aliases = Env.insert name value (Env._aliases env) }

260+

261+ Graph.CyclicSCC [] ->

262+ Result.ok env

263+

264+ Graph.CyclicSCC [(region, name, tvars, alias)] ->

265+ Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))

266+

267+ Graph.CyclicSCC aliases@((region, _, _, _) : _) ->

268+ Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))

269+

270+

271+-- DECLARATIONS TO PATCHES

272+

273+declarationsToPatches

274+ :: Module.Name

275+ -> [D.ValidDecl]

276+ -> ([Node], [Env.Patch])

277+declarationsToPatches moduleName decls =

278+ let (maybeNodes, patchLists) =

279+ unzip (map (declToPatches moduleName) decls)

280+ in

281+ (Maybe.catMaybes maybeNodes, concat patchLists)

282+

283+

284+-- When canonicalizing, all _values should be Local, but all _adts and _patterns

285+-- should be fully namespaced. With _adts, they may appear in types that can

286+-- escape the module.

287+declToPatches

288+ :: Module.Name

289+ -> D.ValidDecl

290+ -> (Maybe Node, [Env.Patch])

291+declToPatches moduleName (A.A region decl) =

292+ let local mkPatch x =

293+ mkPatch x (Var.local x)

294+

295+ namespaced mkPatch x =

296+ mkPatch x (Var.fromModule moduleName x)

297+

298+ patternPatch (name, args) =

299+ Env.Pattern name (Var.fromModule moduleName name, length args)

300+ in

301+ case decl of

302+ D.Definition (Valid.Definition pattern _ _) ->

303+ ( Nothing

304+ , map (local Env.Value) (P.boundVarList pattern)

305+ )

306+

307+ D.Datatype name _ ctors ->

308+ let ctorNames = map fst ctors

309+ in

310+ ( Nothing

311+ , namespaced Env.Union name

312+ : map (local Env.Value) ctorNames

313+ ++ map patternPatch ctors

314+ )

315+

316+ D.TypeAlias name tvars alias ->

317+ ( Just (node region name tvars alias)

318+ , case alias of

319+ A.A _ (Type.RRecord _ _) ->

320+ [local Env.Value name]

321+ _ ->

322+ []

323+ )

324+

325+ D.Port port ->

326+ ( Nothing

327+ , [local Env.Value (D.validPortName port)]

328+ )

329+

330+ D.Fixity _ _ _ ->

331+ ( Nothing

332+ , []

333+ )

334+

335+

336+-- RESTRICT VISIBLE API OF INTERFACES

337+

338+restrictToPublicApi :: Module.Interface -> Module.Interface

339+restrictToPublicApi interface =

340+ interface

341+ { Module.iTypes =

342+ Map.fromList $

343+ Maybe.mapMaybe

344+ (get (Module.iTypes interface))

345+ (Var.getValues exports ++ ctors)

346+

347+ , Module.iAliases =

348+ Map.fromList $

349+ Maybe.mapMaybe

350+ (get (Module.iAliases interface))

351+ (Var.getAliases exports)

352+

353+ , Module.iAdts =

354+ Map.fromList

355+ (Maybe.mapMaybe (trimUnions interface) unions)

356+ }

357+ where

358+ exports :: [Var.Value]

359+ exports =

360+ Module.iExports interface

361+

362+ unions :: [(String, Var.Listing String)]

363+ unions =

364+ Var.getUnions exports

365+

366+ ctors :: [String]

367+ ctors =

368+ concatMap (\(_, Var.Listing ctorList _) -> ctorList) unions

369+

370+

371+get :: Map.Map String a -> String -> Maybe (String, a)

372+get dict key =

373+ case Map.lookup key dict of

374+ Nothing -> Nothing

375+ Just value -> Just (key, value)

376+

377+

378+trimUnions

379+ :: Module.Interface

380+ -> (String, Var.Listing String)

381+ -> Maybe (String, Module.AdtInfo String)

382+trimUnions interface (name, Var.Listing exportedCtors _) =

383+ case Map.lookup name (Module.iAdts interface) of

384+ Nothing -> Nothing

385+ Just (tvars, ctors) ->

386+ let isExported (ctor, _) =

387+ ctor `elem` exportedCtors

388+ in

389+ Just (name, (tvars, filter isExported ctors))

src/Transform/SortDefinitions.hs → src/Canonicalize/Sort.hsrenamed+68−50

@@ -1,5 +1,5 @@

11{-# OPTIONS_GHC -Wall #-}

2−module Transform.SortDefinitions (sortDefs) where

2+module Canonicalize.Sort (definitions) where

33

44import Control.Monad.State

55import Control.Applicative ((<$>),(<*>))

@@ -8,28 +8,18 @@ import qualified Data.Map as Map

88import qualified Data.Maybe as Maybe

99import qualified Data.Set as Set

1010

11−import AST.Annotation

1211import AST.Expression.General (Expr'(..), PortImpl(..))

1312import qualified AST.Expression.Canonical as Canonical

1413import qualified AST.Pattern as P

1514import qualified AST.Variable as V

15+import qualified Reporting.Annotation as A

1616

1717

18−ctors :: P.CanonicalPattern -> [String]

19−ctors pattern =

20− case pattern of

21− P.Var _ -> []

22− P.Alias _ p -> ctors p

23− P.Record _ -> []

24− P.Anything -> []

25− P.Literal _ -> []

26− P.Data (V.Canonical home name) ps ->

27− case home of

28− V.Local -> name : rest

29− V.BuiltIn -> rest

30− V.Module _ -> rest

31− where

32− rest = concatMap ctors ps

18+-- STARTING POINT

19+

20+definitions :: Canonical.Expr -> Canonical.Expr

21+definitions expression =

22+ evalState (reorder expression) Set.empty

3323

3424

3525free :: String -> State (Set.Set String) ()

@@ -45,19 +35,11 @@ freeIfLocal (V.Canonical home name) =

4535 V.Module _ -> return ()

4636

4737

48−bound :: Set.Set String -> State (Set.Set String) ()

49−bound boundVars =

50− modify (\freeVars -> Set.difference freeVars boundVars)

51−

52−

53−sortDefs :: Canonical.Expr -> Canonical.Expr

54−sortDefs expression =

55− evalState (reorder expression) Set.empty

56−

38+-- REORDER EXPRESSIONS

5739

5840reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr

59−reorder (A ann expression) =

60− A ann <$>

41+reorder (A.A ann expression) =

42+ A.A ann <$>

6143 case expression of

6244 -- Be careful adding and restricting freeVars

6345 Var var ->

@@ -135,49 +117,71 @@ reorder (A ann expression) =

135117 -- allows the programmer to write definitions in whatever

136118 -- order they please, we can still define things in order

137119 -- and generalize polymorphic functions when appropriate.

138− sccs <- Graph.stronglyConnComp <$> buildDefDict defs

120+ sccs <- Graph.stronglyConnComp <$> buildDefGraph defs

139121 let defss = map Graph.flattenSCC sccs

140122

141123 -- remove let-bound variables from the context

142124 forM_ defs $ \(Canonical.Definition pattern _ _) -> do

143− bound (P.boundVars pattern)

125+ bound pattern

144126 mapM free (ctors pattern)

145127

146− let A _ let' =

147− foldr (\ds bod -> A ann (Let ds bod)) body' defss

128+ let (A.A _ let') =

129+ foldr (\ds bod -> A.A ann (Let ds bod)) body' defss

148130

149131 return let'

150132

151133

134+ctors :: P.CanonicalPattern -> [String]

135+ctors (A.A _ pattern) =

136+ case pattern of

137+ P.Var _ ->

138+ []

139+

140+ P.Alias _ p ->

141+ ctors p

142+

143+ P.Record _ ->

144+ []

145+

146+ P.Anything ->

147+ []

148+

149+ P.Literal _ ->

150+ []

151+

152+ P.Data (V.Canonical home name) ps ->

153+ case home of

154+ V.Local -> name : rest

155+ V.BuiltIn -> rest

156+ V.Module _ -> rest

157+ where

158+ rest = concatMap ctors ps

159+

160+

161+bound :: P.CanonicalPattern -> State (Set.Set String) ()

162+bound pattern =

163+ let boundVars = P.boundVarSet pattern

164+ in

165+ modify (\freeVars -> Set.difference freeVars boundVars)

166+

167+

152168bindingReorder

153169 :: (P.CanonicalPattern, Canonical.Expr)

154170 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)

155−bindingReorder (pattern,expr) =

171+bindingReorder (pattern, expr) =

156172 do expr' <- reorder expr

157− bound (P.boundVars pattern)

173+ bound pattern

158174 mapM_ free (ctors pattern)

159175 return (pattern, expr')

160176

161177

162−reorderAndGetDependencies

163− :: Canonical.Def

164− -> State (Set.Set String) (Canonical.Def, [String])

165−reorderAndGetDependencies (Canonical.Definition pattern expr mType) =

166− do globalFrees <- get

167− -- work in a fresh environment

168− put Set.empty

169− expr' <- reorder expr

170− localFrees <- get

171− -- merge with global frees

172− modify (Set.union globalFrees)

173− return (Canonical.Definition pattern expr' mType, Set.toList localFrees)

174−

178+-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS

175179

176180-- This also reorders the all of the sub-expressions in the Def list.

177−buildDefDict

181+buildDefGraph

178182 :: [Canonical.Def]

179183 -> State (Set.Set String) [(Canonical.Def, Int, [Int])]

180−buildDefDict defs =

184+buildDefGraph defs =

181185 do pdefsDeps <- mapM reorderAndGetDependencies defs

182186 return $ realDeps (addKey pdefsDeps)

183187 where

@@ -187,7 +191,7 @@ buildDefDict defs =

187191

188192 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]

189193 variableToKey (Canonical.Definition pattern _ _, key, _) =

190− [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

194+ [ (var, key) | var <- P.boundVarList pattern ]

191195

192196 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int

193197 variableToKeyMap pdefsDeps =

@@ -200,3 +204,17 @@ buildDefDict defs =

200204 varDict = variableToKeyMap pdefsDeps

201205 convert (pdef, key, deps) =

202206 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

207+

208+

209+reorderAndGetDependencies

210+ :: Canonical.Def

211+ -> State (Set.Set String) (Canonical.Def, [String])

212+reorderAndGetDependencies (Canonical.Definition pattern expr mType) =

213+ do globalFrees <- get

214+ -- work in a fresh environment

215+ put Set.empty

216+ expr' <- reorder expr

217+ localFrees <- get

218+ -- merge with global frees

219+ modify (Set.union globalFrees)

220+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees)

src/Canonicalize/Type.hsnew file+88

@@ -0,0 +1,88 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Type (tipe) where

3+

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

5+import qualified Data.Traversable as Trav

6+

7+import qualified AST.Type as T

8+import qualified AST.Variable as Var

9+

10+import qualified Reporting.Annotation as A

11+import qualified Reporting.Error.Canonicalize as Error

12+import qualified Reporting.Region as R

13+import qualified Canonicalize.Environment as Env

14+import qualified Canonicalize.Result as Result

15+import qualified Canonicalize.Variable as Canonicalize

16+

17+

18+tipe

19+ :: Env.Environment

20+ -> T.Raw

21+ -> Result.ResultErr T.Canonical

22+tipe env typ@(A.A region typ') =

23+ let go = tipe env

24+ goSnd (name,t) =

25+ (,) name <$> go t

26+ in

27+ case typ' of

28+ T.RVar x ->

29+ Result.ok (T.Var x)

30+

31+ T.RType _ ->

32+ canonicalizeApp region env typ []

33+

34+ T.RApp t ts ->

35+ canonicalizeApp region env t ts

36+

37+ T.RLambda a b ->

38+ T.Lambda <$> go a <*> go b

39+

40+ T.RRecord fields ext ->

41+ T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext

42+

43+

44+canonicalizeApp

45+ :: R.Region

46+ -> Env.Environment

47+ -> T.Raw

48+ -> [T.Raw]

49+ -> Result.ResultErr T.Canonical

50+canonicalizeApp region env f args =

51+ case f of

52+ A.A _ (T.RType (Var.Raw rawName)) ->

53+ Canonicalize.tvar region env rawName

54+ `Result.andThen` canonicalizeWithTvar

55+

56+ _ ->

57+ T.App <$> tipe env f <*> Trav.traverse (tipe env) args

58+

59+ where

60+ canonicalizeWithTvar tvar =

61+ case tvar of

62+ Right alias ->

63+ canonicalizeAlias region env alias args

64+

65+ Left name ->

66+ case args of

67+ [] ->

68+ Result.ok (T.Type name)

69+ _ ->

70+ T.App (T.Type name) <$> Trav.traverse (tipe env) args

71+

72+

73+canonicalizeAlias

74+ :: R.Region

75+ -> Env.Environment

76+ -> (Var.Canonical, [String], T.Canonical)

77+ -> [T.Raw]

78+ -> Result.ResultErr T.Canonical

79+canonicalizeAlias region env (name, tvars, dealiasedTipe) types =

80+ if typesLen /= tvarsLen

81+ then Result.err (A.A region (Error.alias name tvarsLen typesLen))

82+ else toAlias <$> Trav.traverse (tipe env) types

83+ where

84+ typesLen = length types

85+ tvarsLen = length tvars

86+

87+ toAlias canonicalTypes =

88+ T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)

src/Canonicalize/Variable.hsnew file+226

@@ -0,0 +1,226 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Variable where

3+

4+import qualified Data.Either as Either

5+import qualified Data.Map as Map

6+import qualified Data.Set as Set

7+

8+import qualified AST.Helpers as Help

9+import qualified AST.Module as Module

10+import qualified AST.Type as Type

11+import qualified AST.Variable as Var

12+import qualified Reporting.Annotation as A

13+import qualified Reporting.Error.Canonicalize as Error

14+import qualified Reporting.Region as R

15+import qualified Canonicalize.Environment as Env

16+import qualified Canonicalize.Result as Result

17+import Elm.Utils ((|>))

18+

19+

20+variable :: R.Region -> Env.Environment -> String -> Result.ResultErr Var.Canonical

21+variable region env var =

22+ case toVarName var of

23+ Right (name, varName)

24+ | Module.nameIsNative name ->

25+ Result.var (Var.Canonical (Var.Module name) varName)

26+

27+ _ ->

28+ case Set.toList `fmap` Map.lookup var (Env._values env) of

29+ Just [v] ->

30+ Result.var v

31+

32+ Just vs ->

33+ preferLocals region env "variable" vs var

34+

35+ Nothing ->

36+ notFound region "variable" (Map.keys (Env._values env)) var

37+

38+

39+tvar

40+ :: R.Region

41+ -> Env.Environment

42+ -> String

43+ -> Result.ResultErr

44+ (Either

45+ Var.Canonical

46+ (Var.Canonical, [String], Type.Canonical)

47+ )

48+tvar region env var =

49+ case adts ++ aliases of

50+ [] -> notFound region "type" (Map.keys (Env._adts env) ++ Map.keys (Env._aliases env)) var

51+ [v] -> Result.var' extract v

52+ vs -> preferLocals' region env extract "type" vs var

53+ where

54+ adts =

55+ map Left (maybe [] Set.toList (Map.lookup var (Env._adts env)))

56+

57+ aliases =

58+ map Right (maybe [] Set.toList (Map.lookup var (Env._aliases env)))

59+

60+ extract value =

61+ case value of

62+ Left v -> v

63+ Right (v,_,_) -> v

64+

65+

66+pvar

67+ :: R.Region

68+ -> Env.Environment

69+ -> String

70+ -> Int

71+ -> Result.ResultErr Var.Canonical

72+pvar region env var actualArgs =

73+ case Set.toList `fmap` Map.lookup var (Env._patterns env) of

74+ Just [value] ->

75+ foundArgCheck value

76+

77+ Just values ->

78+ preferLocals' region env fst "pattern" values var

79+ `Result.andThen` foundArgCheck

80+

81+ Nothing ->

82+ notFound region "pattern" (Map.keys (Env._patterns env)) var

83+ where

84+ foundArgCheck (name, expectedArgs) =

85+ if actualArgs == expectedArgs

86+ then Result.var name

87+ else Result.err (A.A region (Error.argMismatch name expectedArgs actualArgs))

88+

89+

90+-- FOUND

91+

92+preferLocals

93+ :: R.Region

94+ -> Env.Environment

95+ -> String

96+ -> [Var.Canonical]

97+ -> String

98+ -> Result.ResultErr Var.Canonical

99+preferLocals region env =

100+ preferLocals' region env id

101+

102+

103+preferLocals'

104+ :: R.Region

105+ -> Env.Environment

106+ -> (a -> Var.Canonical)

107+ -> String

108+ -> [a]

109+ -> String

110+ -> Result.ResultErr a

111+preferLocals' region env extract kind possibilities var =

112+ case filter (isLocal . extract) possibilities of

113+ [] ->

114+ ambiguous possibilities

115+

116+ [v] ->

117+ Result.var' extract v

118+

119+ locals ->

120+ ambiguous locals

121+ where

122+ isLocal :: Var.Canonical -> Bool

123+ isLocal (Var.Canonical home _) =

124+ case home of

125+ Var.Local -> True

126+ Var.BuiltIn -> False

127+ Var.Module name ->

128+ name == Env._home env

129+

130+ ambiguous possibleVars =

131+ Result.err (A.A region (Error.variable kind var Error.Ambiguous vars))

132+ where

133+ vars = map (Var.toString . extract) possibleVars

134+

135+

136+-- NOT FOUND HELPERS

137+

138+type VarName =

139+ Either String (Module.Name, String)

140+

141+

142+toVarName :: String -> VarName

143+toVarName var =

144+ case Help.splitDots var of

145+ [x] -> Left x

146+ xs -> Right (init xs, last xs)

147+

148+

149+noQualifier :: VarName -> String

150+noQualifier name =

151+ case name of

152+ Left x -> x

153+ Right (_, x) -> x

154+

155+

156+qualifiedToString :: (Module.Name, String) -> String

157+qualifiedToString (modul, name) =

158+ Module.nameToString (modul ++ [name])

159+

160+

161+isOp :: VarName -> Bool

162+isOp name =

163+ Help.isOp (noQualifier name)

164+

165+

166+-- NOT FOUND

167+

168+notFound :: R.Region -> String -> [String] -> String -> Result.ResultErr a

169+notFound region kind possibilities var =

170+ let name =

171+ toVarName var

172+

173+ possibleNames =

174+ map toVarName possibilities

175+

176+ (problem, suggestions) =

177+ case name of

178+ Left _ ->

179+ exposedProblem name possibleNames

180+

181+ Right (modul, varName) ->

182+ qualifiedProblem modul varName (Either.rights possibleNames)

183+ in

184+ Result.err (A.A region (Error.variable kind var problem suggestions))

185+

186+

187+exposedProblem :: VarName -> [VarName] -> (Error.VarProblem, [String])

188+exposedProblem name possibleNames =

189+ let (exposed, qualified) =

190+ possibleNames

191+ |> filter (\n -> isOp name == isOp n)

192+ |> Error.nearbyNames noQualifier name

193+ |> Either.partitionEithers

194+ in

195+ ( Error.ExposedUnknown

196+ , exposed ++ map qualifiedToString qualified

197+ )

198+

199+

200+qualifiedProblem

201+ :: Module.Name

202+ -> String

203+ -> [(Module.Name, String)]

204+ -> (Error.VarProblem, [String])

205+qualifiedProblem moduleName name allQualified =

206+ let availableModules =

207+ Set.fromList (map fst allQualified)

208+

209+ moduleNameString =

210+ Module.nameToString moduleName

211+ in

212+ case Set.member moduleName availableModules of

213+ True ->

214+ ( Error.QualifiedUnknown moduleNameString

215+ , allQualified

216+ |> filter ((==) moduleName . fst)

217+ |> map snd

218+ |> Error.nearbyNames id name

219+ )

220+

221+ False ->

222+ ( Error.UnknownQualifier moduleNameString

223+ , Set.toList availableModules

224+ |> map Module.nameToString

225+ |> Error.nearbyNames id moduleNameString

226+ )

src/Compile.hs+23−23

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

11module Compile (compile) where

22

33import qualified Data.Map as Map

4−import Text.PrettyPrint (Doc)

54

65import qualified AST.Module as Module

6+import qualified Canonicalize

7+import Elm.Utils ((|>))

8+import qualified Nitpick.TopLevelTypes as Nitpick

79import qualified Parse.Helpers as Parse

810import qualified Parse.Parse as Parse

9−import qualified Transform.AddDefaultImports as DefaultImports

10−import qualified Transform.Check as Check

11+import qualified Reporting.Error as Error

12+import qualified Reporting.Result as Result

13+import qualified Reporting.Warning as Warning

1114import qualified Type.Inference as TI

12−import qualified Transform.Canonicalize as Canonical

13−import Elm.Utils ((|>))

1415

1516

1617compile

@@ -18,35 +19,34 @@ compile

1819 -> String

1920 -> Module.Interfaces

2021 -> String

21− -> Either [Doc] Module.CanonicalModule

22+ -> Result.Result Warning.Warning Error.Error Module.CanonicalModule

2223

2324compile user projectName interfaces source =

24− do

25− -- Parse the source code

26− parsedModule <-

27− Parse.program (getOpTable interfaces) source

28−

25+ do

2926 -- determine if default imports should be added

3027 -- only elm-lang/core is exempt

3128 let needsDefaults =

3229 not (user == "elm-lang" && projectName == "core")

3330

34− -- add default imports if necessary

35− let rawModule =

36− DefaultImports.add needsDefaults parsedModule

37−

38− -- validate module (e.g. all variables exist)

39− case Check.mistakes (Module.body rawModule) of

40− [] -> return ()

41− ms -> Left ms

31+ -- Parse the source code

32+ validModule <-

33+ Result.mapError Error.Syntax $

34+ Parse.program needsDefaults (getOpTable interfaces) source

4235

4336 -- Canonicalize all variables, pinning down where they came from.

44− canonicalModule <- Canonical.module' interfaces rawModule

37+ canonicalModule <-

38+ Canonicalize.module' interfaces validModule

4539

4640 -- Run type inference on the program.

47− types <- TI.infer interfaces canonicalModule

41+ types <-

42+ Result.from Error.Type $

43+ TI.infer interfaces canonicalModule

44+

45+ -- One last round of checks

46+ Result.mapError Error.Type $

47+ Nitpick.topLevelTypes types (Module.body validModule)

4848

49− -- Add the real list of tyes

49+ -- Add the real list of types

5050 let body = (Module.body canonicalModule) { Module.types = types }

5151

5252 return $ canonicalModule { Module.body = body }

@@ -57,4 +57,4 @@ getOpTable interfaces =

5757 Map.elems interfaces

5858 |> concatMap Module.iFixities

5959 |> map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

60− |> Map.fromList

60+ |> Map.fromList

src/Elm/Compiler.hs+48−28

@@ -1,23 +1,24 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE FlexibleContexts #-}

32module Elm.Compiler

43 ( version, rawVersion

54 , parseDependencies, compile

5+ , Error, errorToString

6+ , Warning

67 ) where

78

8−import Control.Monad.Error (MonadError, throwError)

9−import qualified Data.List as List

109import qualified Data.Map as Map

11−import qualified Text.PrettyPrint as P

1210

13−import qualified AST.Module as Module (HeaderAndImports(HeaderAndImports), toInterface)

11+import qualified AST.Module as Module

1412import qualified Compile

1513import qualified Elm.Compiler.Module as PublicModule

1614import qualified Elm.Compiler.Version as Version

17−import Elm.Utils ((|>))

1815import qualified Generate.JavaScript as JS

19−import qualified Parse.Helpers as Help

2016import qualified Parse.Module as Parse

17+import qualified Parse.Parse as Parse

18+import qualified Reporting.Annotation as A

19+import qualified Reporting.Error as Error

20+import qualified Reporting.Result as Result

21+import qualified Reporting.Warning as Warning

2122

2223

2324-- VERSION

@@ -35,19 +36,22 @@ rawVersion =

3536-- DEPENDENCIES

3637

3738parseDependencies

38− :: (MonadError String m)

39− => String

40− -> m (PublicModule.Name, [PublicModule.Name])

41−parseDependencies src =

42− case Help.iParse Parse.headerAndImports src of

43− Left msg ->

44− throwError (show msg)

39+ :: String

40+ -> Either [Error] (PublicModule.Name, [PublicModule.Name])

41+parseDependencies sourceCode =

42+ let

43+ (Result.Result _warnings rawResult) =

44+ Parse.parse sourceCode Parse.header

45+ in

46+ case rawResult of

47+ Result.Err msgs ->

48+ Left $ map (Error . A.map Error.Syntax) msgs

4549

46− Right (Module.HeaderAndImports names _exports imports) ->

47− return

48− ( PublicModule.Name names

49− , map (PublicModule.Name . fst) imports

50− )

50+ Result.Ok (Module.Header names _exports imports) ->

51+ Right

52+ ( PublicModule.Name names

53+ , map (PublicModule.Name . fst . A.drop) imports

54+ )

5155

5256

5357-- COMPILATION

@@ -58,17 +62,33 @@ compile

5862 -> String

5963 -> String

6064 -> Map.Map PublicModule.Name PublicModule.Interface

61− -> Either String (PublicModule.Interface, String)

65+ -> ([Warning], Either [Error] (PublicModule.Interface, String))

6266compile user packageName source interfaces =

6367 let unwrappedInterfaces =

64− Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces

68+ Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces

69+

70+ (Result.Result warnings rawResult) =

71+ Compile.compile user packageName unwrappedInterfaces source

6572 in

66− case Compile.compile user packageName unwrappedInterfaces source of

67− Right modul ->

73+ (,) (map Warning warnings) $

74+ case rawResult of

75+ Result.Ok modul ->

6876 Right (Module.toInterface modul, JS.generate modul)

6977

70− Left docs ->

71− map P.render docs

72− |> List.intersperse ""

73− |> unlines

74− |> Left

78+ Result.Err errors ->

79+ Left (map Error errors)

80+

81+

82+-- ERRORS

83+

84+newtype Error = Error (A.Located Error.Error)

85+

86+

87+errorToString :: String -> String -> Error -> String

88+errorToString location source (Error err) =

89+ Error.toString location source err

90+

91+

92+-- WARNINGS

93+

94+newtype Warning = Warning (A.Located Warning.Warning)

src/Transform/AddDefaultImports.hs → src/Elm/Compiler/Imports.hsrenamed+4−16

@@ -1,17 +1,17 @@

1−module Transform.AddDefaultImports (add, defaultImports) where

1+module Elm.Compiler.Imports (defaults) where

22

33import qualified AST.Module as Module

44import qualified AST.Variable as Var

55

66

7−-- DESCRIPTION OF DEFAULT IMPORTS

7+-- DEFAULT IMPORTS

88

99(==>) :: a -> b -> (a,b)

1010(==>) = (,)

1111

1212

13−defaultImports :: [(Module.Name, Module.ImportMethod)]

14−defaultImports =

13+defaults :: [Module.DefaultImport]

14+defaults =

1515 [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing

1616 , ["List"] ==> exposing [Var.Value "::"]

1717 , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]

@@ -23,15 +23,3 @@ defaultImports =

2323exposing :: [Var.Value] -> Module.ImportMethod

2424exposing vars =

2525 Module.ImportMethod Nothing (Var.listing vars)

26−

27−

28−-- ADDING DEFAULT IMPORTS TO A MODULE

29−

30−add :: Bool -> Module.Module exs body -> Module.Module exs body

31−add needsDefaults (Module.Module moduleName path exports imports decls) =

32− Module.Module moduleName path exports ammendedImports decls

33− where

34− ammendedImports =

35− if needsDefaults

36− then defaultImports ++ imports

37− else imports

src/Elm/Compiler/Module.hs+2−2

@@ -18,7 +18,7 @@ import qualified Data.Text as Text

1818import System.FilePath ((</>))

1919

2020import qualified AST.Module as Module

21−import qualified Transform.AddDefaultImports as Defaults

21+import qualified Elm.Compiler.Imports as Imports

2222import qualified Elm.Compiler.Type as Type

2323import qualified Elm.Compiler.Type.Extract as Extract

2424

@@ -34,7 +34,7 @@ newtype Name = Name [String]

3434

3535defaultImports :: [Name]

3636defaultImports =

37− map (Name . fst) Defaults.defaultImports

37+ map (Name . fst) Imports.defaults

3838

3939

4040-- POKING AROUND INTERFACES

src/Elm/Compiler/Type/Extract.hs+1−1

@@ -8,7 +8,7 @@ import qualified Elm.Compiler.Type as T

88

99-- INTERNAL TYPE to PUBLIC TYPE

1010

11−fromInternalType :: Var.ToString a => Type.Type a -> T.Type

11+fromInternalType :: Type.Canonical -> T.Type

1212fromInternalType astType =

1313 case astType of

1414 Type.Lambda t1 t2 ->

src/Elm/Utils.hs+1−1

@@ -2,7 +2,7 @@

22{-# LANGUAGE FlexibleContexts #-}

33module Elm.Utils ((|>), (<|), getAsset, run, unwrappedRun, CommandError(..)) where

44

5−import Control.Monad.Error (MonadError, MonadIO, liftIO, throwError)

5+import Control.Monad.Except (MonadError, MonadIO, liftIO, throwError)

66import System.Directory (doesFileExist)

77import System.Environment (getEnv)

88import System.Exit (ExitCode(ExitSuccess, ExitFailure))

src/Generate/Cases.hs+171−119

@@ -4,29 +4,19 @@ import Control.Applicative ((<$>))

44import Control.Arrow (first)

55import Control.Monad.State (State)

66import qualified Control.Monad.State as State

7−import Data.List (groupBy,sortBy)

7+import qualified Data.List as List

88import Data.Maybe (fromMaybe)

99

10−import qualified AST.Annotation as A

1110import qualified AST.Expression.General as Expr

1211import qualified AST.Expression.Canonical as Canonical

1312import qualified AST.Literal as Literal

1413import qualified AST.Pattern as P

1514import qualified AST.Variable as Var

16−import Transform.Substitute (subst)

15+import qualified Generate.Substitute as S

16+import qualified Reporting.Annotation as A

1717

18−toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

19−toMatch patterns = do

20− v <- newVar

21− (,) v <$> match [v] (map (first (:[])) patterns) Fail

22−

23−

24−newVar :: State Int String

25−newVar =

26− do n <- State.get

27− State.modify (+1)

28− return $ "_v" ++ show n

2918

19+-- MATCHES

3020

3121data Match

3222 = Match String [Clause] Match

@@ -42,47 +32,51 @@ data Clause =

4232 deriving Show

4333

4434

45−type Case =

35+type Branch =

4636 ([P.CanonicalPattern], Canonical.Expr)

4737

4838

39+-- PUBLIC FUNCTIONS

40+

41+toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

42+toMatch patterns =

43+ do v <- newVar

44+ (,) v <$> buildMatch [v] (map (first (:[])) patterns) Fail

45+

46+

47+newVar :: State Int String

48+newVar =

49+ do n <- State.get

50+ State.modify (+1)

51+ return $ "_v" ++ show n

52+

53+

4954matchSubst :: [(String,String)] -> Match -> Match

5055matchSubst pairs match =

51− case match of

52− Break -> Break

53−

54− Fail -> Fail

55−

56− Seq ms ->

57− Seq (map (matchSubst pairs) ms)

58−

59− Other (A.A a e) ->

60− Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs

61−

62− Match n cs m ->

63− Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

64− where

65− varSubst v = fromMaybe v (lookup v pairs)

66− clauseSubst (Clause c vs m) =

67− Clause c (map varSubst vs) (matchSubst pairs m)

56+ case match of

57+ Break -> Break

6858

59+ Fail -> Fail

6960

70−isCon :: ([P.Pattern var], expr) -> Bool

71−isCon ([] , _) = noMatch "isCon"

72−isCon (p:_, _) =

73− case p of

74− P.Data _ _ -> True

75− P.Literal _ -> True

76− _ -> False

61+ Seq ms ->

62+ Seq (map (matchSubst pairs) ms)

63+

64+ Other (A.A a e) ->

65+ Other . A.A a $ foldr ($) e $ map (\(x,y) -> S.subst x (Expr.localVar y)) pairs

7766

67+ Match n cs m ->

68+ Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

69+ where

70+ varSubst v = fromMaybe v (lookup v pairs)

71+ clauseSubst (Clause c vs m) =

72+ Clause c (map varSubst vs) (matchSubst pairs m)

7873

79−isVar :: ([P.Pattern var], expr) -> Bool

80−isVar p = not (isCon p)

8174

75+-- BUILD MATCHES

8276

83−match :: [String] -> [Case] -> Match -> State Int Match

84−match variables cases match =

85− case (variables, cases, match) of

77+buildMatch :: [String] -> [Branch] -> Match -> State Int Match

78+buildMatch variables branches match =

79+ case (variables, branches, match) of

8680 ([], [], _) ->

8781 return match

8882

@@ -93,115 +87,173 @@ match variables cases match =

9387 return $ Other expr

9488

9589 ([], _, _) ->

96− return $ Seq (map (Other . snd) cases ++ [match])

90+ return $ Seq (map (Other . snd) branches ++ [match])

9791

9892 (var:_, _, _)

99− | all isVar cases' -> matchVar variables cases' match

100− | all isCon cases' -> matchCon variables cases' match

101− | otherwise -> matchMix variables cases' match

93+ | all isVar branches' -> matchVar variables branches' match

94+ | all isCon branches' -> matchCon variables branches' match

95+ | otherwise -> matchMix variables branches' match

10296 where

103− cases' = map (dealias var) cases

97+ branches' = map (dealias var) branches

10498

10599

106−dealias :: String -> Case -> Case

100+dealias :: String -> Branch -> Branch

107101dealias _ ([], _) = noMatch "dealias"

108−dealias v c@(p:ps, A.A a e) =

102+dealias var branch@(p:ps, A.A ann e) =

109103 case p of

110− P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)

111− _ -> c

104+ A.A _ (P.Alias alias pattern) ->

105+ ( pattern:ps

106+ , A.A ann (S.subst alias (Expr.localVar var) e)

107+ )

112108

109+ _ ->

110+ branch

111+

112+

113+isCon :: ([P.Pattern ann var], expr) -> Bool

114+isCon ([], _) = noMatch "isCon"

115+isCon (A.A _ pattern : _, _) =

116+ case pattern of

117+ P.Data _ _ -> True

118+ P.Literal _ -> True

119+ _ -> False

113120

114−matchVar :: [String] -> [Case] -> Match -> State Int Match

121+

122+isVar :: ([P.Pattern ann var], expr) -> Bool

123+isVar p =

124+ not (isCon p)

125+

126+

127+-- VARIABLE MATCHES

128+

129+matchVar :: [String] -> [Branch] -> Match -> State Int Match

115130matchVar [] _ _ = noMatch "matchVar"

116−matchVar (v:vs) cs def =

117− match vs (map subVar cs) def

131+matchVar (var:vars) branches match =

132+ buildMatch vars (map subVar branches) match

118133 where

119134 subVar ([], _) = noMatch "matchVar.subVar"

120− subVar (p:ps, (A.A a expr)) =

121− (ps, A.A a $ subOnePattern p expr)

135+ subVar (A.A _ pattern : patterns, (A.A ann expr)) =

136+ ( patterns

137+ , A.A ann (subOnePattern pattern expr)

138+ )

122139 where

123140 subOnePattern pattern expr =

124141 case pattern of

125− P.Anything -> expr

142+ P.Anything ->

143+ expr

126144

127145 P.Var x ->

128− subst x (Expr.localVar v) expr

146+ S.subst x (Expr.localVar var) expr

129147

130− P.Record fs ->

131− foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) expr fs

148+ P.Record fields ->

149+ let access = Expr.Access (A.A ann (Expr.localVar var))

150+ in

151+ foldr (\x -> S.subst x (access x)) expr fields

132152

133− _ -> noMatch "matchVar.subVar"

153+ _ ->

154+ noMatch "matchVar.subVar"

134155

135156

136−matchCon :: [String] -> [Case] -> Match -> State Int Match

137−matchCon variables cases match =

157+-- CONSTRUCTOR MATCHES

158+

159+matchCon :: [String] -> [Branch] -> Match -> State Int Match

160+matchCon variables branches match =

138161 case variables of

139162 [] -> noMatch "matchCon"

140163

141164 var : _vars ->

142165 flip (Match var) match <$> mapM toClause caseGroups

143166 where

144− caseGroups :: [[Case]]

167+ caseGroups :: [[Branch]]

145168 caseGroups =

146− groupBy eq (sortBy cmp cases)

147−

148− eq :: Case -> Case -> Bool

149− eq (patterns1, _) (patterns2, _) =

150− case (patterns1, patterns2) of

151− (pattern1:_, pattern2:_) ->

152− case (pattern1, pattern2) of

153− (P.Data name1 _, P.Data name2 _) -> name1 == name2

154− (_, _) -> pattern1 == pattern2

155− (_, _) -> noMatch "matchCon.eq"

156−

157− cmp :: Case -> Case -> Ordering

158− cmp (patterns1, _) (patterns2, _) =

159− case (patterns1, patterns2) of

160− (pattern1:_, pattern2:_) ->

161− case (pattern1, pattern2) of

162− (P.Data name1 _, P.Data name2 _) -> compare name1 name2

163− (_, _) -> compare pattern1 pattern2

164− (_, _) -> noMatch "matchCon.cmp"

165−

166− toClause :: [Case] -> State Int Clause

167− toClause cases =

168− case head cases of

169− (P.Data name _ : _, _) ->

170− matchClause (Left name) variables cases Break

171−

172− (P.Literal lit : _, _) ->

173− matchClause (Right lit) variables cases Break

169+ List.groupBy branchEq (List.sortBy branchCmp branches)

170+

171+ toClause :: [Branch] -> State Int Clause

172+ toClause branches =

173+ case head branches of

174+ (A.A _ (P.Data name _) : _, _) ->

175+ matchClause (Left name) variables branches Break

176+

177+ (A.A _ (P.Literal lit) : _, _) ->

178+ matchClause (Right lit) variables branches Break

174179

175180 _ -> noMatch "matchCon"

176181

177182

178−matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match

179− -> State Int Clause

183+matchClause

184+ :: Either Var.Canonical Literal.Literal

185+ -> [String]

186+ -> [Branch]

187+ -> Match

188+ -> State Int Clause

180189matchClause _ [] _ _ = noMatch "matchClause"

181−matchClause c (_:vs) cs mtch =

182− do vs' <- getVars

183− Clause c vs' <$> match (vs' ++ vs) (map flatten cs) mtch

184− where

185− flatten ([], _) = noMatch "matchClause.flatten"

186− flatten (p:ps, e) =

187− case p of

188− P.Data _ ps' -> (ps' ++ ps, e)

189− P.Literal _ -> (ps, e)

190− _ -> noMatch "matchClause.flatten"

191−

192− getVars :: State Int [String]

193− getVars =

194− case head cs of

195− (P.Data _ ps : _, _) -> State.forM ps (const newVar)

196− (P.Literal _ : _, _) -> return []

197− _ -> noMatch "matchClause.getVars"

198−

199−

200−matchMix :: [String] -> [Case] -> Match -> State Int Match

201−matchMix vs cs def =

202− State.foldM (flip $ match vs) def (reverse css)

190+matchClause c (_:vs) branches match =

191+ do vs' <- getVars

192+ Clause c vs' <$> buildMatch (vs' ++ vs) (map flatten branches) match

193+ where

194+ flatten ([], _) = noMatch "matchClause.flatten"

195+ flatten (A.A _ pattern : patterns, expr) =

196+ case pattern of

197+ P.Data _ argPatterns ->

198+ (argPatterns ++ patterns, expr)

199+

200+ P.Literal _ ->

201+ (patterns, expr)

202+

203+ _ ->

204+ noMatch "matchClause.flatten"

205+

206+ getVars :: State Int [String]

207+ getVars =

208+ case head branches of

209+ (A.A _ (P.Data _ argPatterns) : _, _) ->

210+ State.forM argPatterns (const newVar)

211+

212+ (A.A _ (P.Literal _) : _, _) ->

213+ return []

214+

215+ _ ->

216+ noMatch "matchClause.getVars"

217+

218+

219+branchEq :: Branch -> Branch -> Bool

220+branchEq (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =

221+ case (pattern, pattern') of

222+ (P.Data name _, P.Data name' _) ->

223+ name == name'

224+

225+ (P.Literal lit, P.Literal lit') ->

226+ lit == lit'

227+

228+ (_, _) ->

229+ noMatch "matchCon.branchEq"

230+

231+branchEq _ _ = noMatch "matchCon.branchEq"

232+

233+

234+branchCmp :: Branch -> Branch -> Ordering

235+branchCmp (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =

236+ case (pattern, pattern') of

237+ (P.Data name _, P.Data name' _) ->

238+ compare name name'

239+

240+ (P.Literal lit, P.Literal lit') ->

241+ compare lit lit'

242+

243+ (_, _) ->

244+ noMatch "matchCon.branchCmp"

245+

246+branchCmp _ _ = noMatch "matchCon.branchCmp"

247+

248+

249+-- MIX MATCHES

250+

251+matchMix :: [String] -> [Branch] -> Match -> State Int Match

252+matchMix vs branches def =

253+ State.foldM (flip $ buildMatch vs) def (reverse branchGroups)

203254 where

204− css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

255+ branchGroups =

256+ List.groupBy (\p1 p2 -> isCon p1 == isCon p2) branches

205257

206258

207259noMatch :: String -> a

src/Generate/JavaScript.hs+81−56

@@ -9,12 +9,6 @@ import qualified Data.Set as Set

99import Language.ECMAScript3.PrettyPrint

1010import Language.ECMAScript3.Syntax

1111

12−import Generate.JavaScript.Helpers as Help

13−import qualified Generate.Cases as Case

14−import qualified Generate.JavaScript.Port as Port

15−import qualified Generate.JavaScript.Variable as Var

16−

17−import AST.Annotation

1812import AST.Module

1913import AST.Expression.General

2014import qualified AST.Expression.Canonical as Canonical

@@ -23,6 +17,13 @@ import AST.Literal

2317import qualified AST.Module as Module

2418import qualified AST.Pattern as P

2519import qualified AST.Variable as Var

20+import Elm.Utils ((|>))

21+import Generate.JavaScript.Helpers as Help

22+import qualified Generate.Cases as Case

23+import qualified Generate.JavaScript.Port as Port

24+import qualified Generate.JavaScript.Variable as Var

25+import qualified Reporting.Annotation as A

26+import qualified Reporting.Region as R

2627

2728

2829internalImports :: Module.Name -> [VarDecl ()]

@@ -59,7 +60,7 @@ literal lit =

5960

6061

6162expression :: Canonical.Expr -> State Int (Expression ())

62−expression (A region expr) =

63+expression (A.A region expr) =

6364 case expr of

6465 Var var ->

6566 return $ Var.canonical var

@@ -117,7 +118,7 @@ expression (A region expr) =

117118 Binop op e1 e2 ->

118119 binop region op e1 e2

119120

120− Lambda p e@(A ann _) ->

121+ Lambda pattern rawBody@(A.A ann _) ->

121122 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)

122123 body' <- expression body

123124 return $

@@ -127,17 +128,20 @@ expression (A region expr) =

127128 where

128129 depattern (args, body) pattern =

129130 case pattern of

130− P.Var x ->

131+ A.A _ (P.Var x) ->

131132 return (args ++ [ Var.varName x ], body)

133+

132134 _ ->

133135 do arg <- Case.newVar

134− return ( args ++ [arg]

135− , A ann (Case (A ann (localVar arg)) [(pattern, body)])

136− )

136+ return

137+ ( args ++ [arg]

138+ , A.A ann (Case (A.A ann (localVar arg)) [(pattern, body)])

139+ )

137140

138− (patterns, innerBody) = collect [p] e

141+ (patterns, innerBody) =

142+ collect [pattern] rawBody

139143

140− collect patterns lexpr@(A _ expr) =

144+ collect patterns lexpr@(A.A _ expr) =

141145 case expr of

142146 Lambda p e -> collect (p:patterns) e

143147 _ -> (patterns, lexpr)

@@ -155,7 +159,7 @@ expression (A region expr) =

155159 (func, args) = getArgs e1 [e2]

156160 getArgs func args =

157161 case func of

158− (A _ (App f arg)) -> getArgs f (arg : args)

162+ (A.A _ (App f arg)) -> getArgs f (arg : args)

159163 _ -> (func, args)

160164

161165 Let defs e ->

@@ -168,9 +172,9 @@ expression (A region expr) =

168172 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

169173 return $

170174 case last branches of

171− (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->

175+ (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->

172176 safeIfs branches'

173− (A _ (Literal (Boolean True)), _) ->

177+ (A.A _ (Literal (Boolean True)), _) ->

174178 safeIfs branches'

175179 _ ->

176180 ifs branches' (throw "badIf" region)

@@ -183,7 +187,7 @@ expression (A region expr) =

183187 do (tempVar,initialMatch) <- Case.toMatch cases

184188 (revisedMatch, stmt) <-

185189 case e of

186− A _ (Var (Var.Canonical Var.Local x)) ->

190+ A.A _ (Var (Var.Canonical Var.Local x)) ->

187191 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

188192 _ ->

189193 do e' <- expression e

@@ -221,9 +225,10 @@ expression (A region expr) =

221225

222226

223227definition :: Canonical.Def -> State Int [Statement ()]

224−definition (Canonical.Definition pattern expr@(A region _) _) =

228+definition (Canonical.Definition annPattern expr@(A.A region _) _) =

225229 do expr' <- expression expr

226230 let assign x = varDecl x expr'

231+ let (A.A patternRegion pattern) = annPattern

227232 case pattern of

228233 P.Var x

229234 | Help.isOp x ->

@@ -243,9 +248,12 @@ definition (Canonical.Definition pattern expr@(A region _) _) =

243248 vars = getVars patterns

244249 getVars patterns =

245250 case patterns of

246− P.Var x : rest -> (Var.varName x :) `fmap` getVars rest

247− [] -> Just []

248− _ -> Nothing

251+ A.A _ (P.Var x) : rest ->

252+ (Var.varName x :) `fmap` getVars rest

253+ [] ->

254+ Just []

255+ _ ->

256+ Nothing

249257

250258 decl x n = varDecl x (obj ["$","_" ++ show n])

251259 setup vars

@@ -260,15 +268,16 @@ definition (Canonical.Definition pattern expr@(A region _) _) =

260268 do defs' <- concat <$> mapM toDef vars

261269 return (VarDeclStmt () [assign "_"] : defs')

262270 where

263− vars = P.boundVarList pattern

264− mkVar = A region . localVar

271+ vars = P.boundVarList annPattern

272+ mkVar = A.A region . localVar

265273 toDef y =

266− let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]

274+ let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]

275+ pat = A.A patternRegion (P.Var y)

267276 in

268− definition $ Canonical.Definition (P.Var y) expr Nothing

277+ definition (Canonical.Definition pat expr Nothing)

269278

270279

271−match :: Region -> Case.Match -> State Int [Statement ()]

280+match :: R.Region -> Case.Match -> State Int [Statement ()]

272281match region mtch =

273282 case mtch of

274283 Case.Match name clauses mtch' ->

@@ -309,7 +318,7 @@ match region mtch =

309318 _ -> dropEnd (acc ++ [m]) ms

310319

311320

312−clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())

321+clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())

313322clause region variable (Case.Clause value vars mtch) =

314323 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)

315324 where

@@ -329,7 +338,7 @@ clause region variable (Case.Clause value vars mtch) =

329338

330339

331340flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

332−flattenLets defs lexpr@(A _ expr) =

341+flattenLets defs lexpr@(A.A _ expr) =

333342 case expr of

334343 Let ds body -> flattenLets (defs ++ ds) body

335344 _ -> (defs, lexpr)

@@ -359,13 +368,17 @@ generate modul =

359368 ]

360369

361370 localVars :: [VarDecl ()]

362− localVars = varDecl "_op" (ObjectLit () []) :

363− internalImports (Module.names modul) ++

364− explicitImports

371+ localVars =

372+ varDecl "_op" (ObjectLit () [])

373+ : internalImports (Module.names modul)

374+ ++ explicitImports

365375 where

366376 explicitImports :: [VarDecl ()]

367377 explicitImports =

368− map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul

378+ Module.imports modul

379+ |> Set.fromList

380+ |> Set.toList

381+ |> map jsImport

369382

370383 jsImport :: Module.Name -> VarDecl ()

371384 jsImport name =

@@ -373,29 +386,41 @@ generate modul =

373386 obj ("Elm" : name ++ ["make"]) <| ref localRuntime

374387

375388 body :: [Statement ()]

376− body = concat $ evalState defs 0

389+ body =

390+ concat (evalState defs 0)

377391 where

378− defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)

379−

380− setup namespace path = map create paths

392+ defs =

393+ Module.program (Module.body modul)

394+ |> flattenLets []

395+ |> fst

396+ |> mapM definition

397+

398+ setup namespace path =

399+ map create paths

381400 where

382− create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))

383− paths = drop 2 . init . List.inits $ namespace : path

384−

385− jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)

386− where

387− exs = map entry $ "_op" : concatMap extract (exports modul)

388− entry x = (prop x, ref x)

389− extract value =

390− case value of

391− Var.Alias _ -> []

401+ create name =

402+ assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))

403+ paths =

404+ namespace : path

405+ |> List.inits

406+ |> init

407+ |> drop 2

408+

409+ jsExports =

410+ assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)

411+ where

412+ exs = map entry $ "_op" : concatMap extract (exports modul)

413+ entry x = (prop x, ref x)

414+ extract value =

415+ case value of

416+ Var.Alias _ -> []

392417

393− Var.Value x

394− | Help.isOp x -> []

395− | otherwise -> [Var.varName x]

418+ Var.Value x

419+ | Help.isOp x -> []

420+ | otherwise -> [Var.varName x]

396421

397− Var.Union _ (Var.Listing ctors _) ->

398− map Var.varName ctors

422+ Var.Union _ (Var.Listing ctors _) ->

423+ map Var.varName ctors

399424

400425 assign path expr =

401426 case path of

@@ -406,7 +431,7 @@ generate modul =

406431

407432

408433binop

409− :: Region

434+ :: R.Region

410435 -> Var.Canonical

411436 -> Canonical.Expr

412437 -> Canonical.Expr

@@ -427,7 +452,7 @@ binop region func@(Var.Canonical home op) e1 e2 =

427452 return $ foldr (<|) e2' es

428453

429454 (Var.BuiltIn, "::") ->

430− expression (A region (Data "::" [e1,e2]))

455+ expression (A.A region (Data "::" [e1,e2]))

431456

432457 (Var.Module ["Basics"], _) ->

433458 do e1' <- expression e1

@@ -447,13 +472,13 @@ binop region func@(Var.Canonical home op) e1 e2 =

447472 where

448473 collectRightAssoc es e =

449474 case e of

450− A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->

475+ A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->

451476 collectRightAssoc (es ++ [e1]) e2

452477 _ -> es ++ [e]

453478

454479 collectLeftAssoc es e =

455480 case e of

456− A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->

481+ A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->

457482 collectLeftAssoc (e2 : es) e1

458483 _ -> e : es

459484

src/Generate/JavaScript/Helpers.hs+4−4

@@ -1,9 +1,9 @@

11module Generate.JavaScript.Helpers where

22

3−import AST.Annotation (Region)

4−import qualified AST.PrettyPrint as PP

53import Language.ECMAScript3.Syntax

64

5+import qualified Reporting.Region as R

6+

77

88localRuntime :: String

99localRuntime =

@@ -59,11 +59,11 @@ localModuleName =

5959 "$moduleName"

6060

6161

62−throw :: String -> Region -> Expression ()

62+throw :: String -> R.Region -> Expression ()

6363throw kind region =

6464 let args =

6565 [ ref localModuleName

66− , string (PP.renderPretty region)

66+ , string (R.toString region)

6767 ]

6868 in

6969 obj ["_U",kind] `call` args

src/Generate/JavaScript/Port.hs+34−34

@@ -3,15 +3,15 @@ module Generate.JavaScript.Port (inbound, outbound, task) where

33import qualified Data.List as List

44import Language.ECMAScript3.Syntax

55

6−import AST.PrettyPrint (pretty)

7−import AST.Type as T

6+import qualified AST.Type as T

87import qualified AST.Variable as Var

98import Generate.JavaScript.Helpers

9+import qualified Reporting.PrettyPrint as P

1010

1111

1212-- TASK

1313

14−task :: String -> Expression () -> T.PortType var -> Expression ()

14+task :: String -> Expression () -> T.Port t -> Expression ()

1515task name expr portType =

1616 case portType of

1717 T.Normal _ ->

@@ -90,42 +90,42 @@ check x jsType continue =

9090

9191-- INBOUND

9292

93−inbound :: String -> T.PortType Var.Canonical -> Expression ()

93+inbound :: String -> T.Port T.Canonical -> Expression ()

9494inbound name portType =

9595 case portType of

9696 T.Normal tipe ->

9797 _Port "inbound" `call`

9898 [ string name

99− , string (show (pretty tipe))

99+ , string (show (P.pretty False tipe))

100100 , toTypeFunction tipe

101101 ]

102102

103103 T.Signal _root arg ->

104104 _Port "inboundSignal" `call`

105105 [ string name

106− , string (show (pretty arg))

106+ , string (show (P.pretty False arg))

107107 , toTypeFunction arg

108108 ]

109109

110110

111−toTypeFunction :: CanonicalType -> Expression ()

111+toTypeFunction :: T.Canonical -> Expression ()

112112toTypeFunction tipe =

113113 ["v"] ==> toType tipe (ref "v")

114114

115115

116−toType :: CanonicalType -> Expression () -> Expression ()

116+toType :: T.Canonical -> Expression () -> Expression ()

117117toType tipe x =

118118 case tipe of

119− Lambda _ _ ->

119+ T.Lambda _ _ ->

120120 error "functions should not be allowed through input ports"

121121

122− Var _ ->

122+ T.Var _ ->

123123 error "type variables should not be allowed through input ports"

124124

125− Aliased _ args t ->

126− toType (dealias args t) x

125+ T.Aliased _ args t ->

126+ toType (T.dealias args t) x

127127

128− Type (Var.Canonical Var.BuiltIn name)

128+ T.Type (Var.Canonical Var.BuiltIn name)

129129 | name == "Int" -> from JSNumber

130130 | name == "Float" -> from JSNumber

131131 | name == "Bool" -> from JSBoolean

@@ -133,7 +133,7 @@ toType tipe x =

133133 where

134134 from checks = check x checks x

135135

136− Type name

136+ T.Type name

137137 | Var.isJson name ->

138138 x

139139

@@ -143,9 +143,9 @@ toType tipe x =

143143 | otherwise ->

144144 error "bad type got to foreign input conversion"

145145

146− App f args ->

146+ T.App f args ->

147147 case f : args of

148− Type name : [t]

148+ T.Type name : [t]

149149 | Var.isMaybe name ->

150150 CondExpr ()

151151 (equal x (NullLit ()))

@@ -160,16 +160,16 @@ toType tipe x =

160160 where

161161 array = DotRef () x (var "map") <| toTypeFunction t

162162

163− Type name : ts

163+ T.Type name : ts

164164 | Var.isTuple name ->

165165 toTuple ts x

166166

167167 _ -> error "bad ADT got to foreign input conversion"

168168

169− Record _ (Just _) ->

169+ T.Record _ (Just _) ->

170170 error "bad record got to foreign input conversion"

171171

172− Record fields Nothing ->

172+ T.Record fields Nothing ->

173173 check x (JSObject (map fst fields)) object

174174 where

175175 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys

@@ -177,7 +177,7 @@ toType tipe x =

177177 convert (f,t) = (prop f, toType t (DotRef () x (var f)))

178178

179179

180−toTuple :: [CanonicalType] -> Expression () -> Expression ()

180+toTuple :: [T.Canonical] -> Expression () -> Expression ()

181181toTuple types x =

182182 check x JSArray (ObjectLit () fields)

183183 where

@@ -195,7 +195,7 @@ toTuple types x =

195195

196196-- OUTBOUND

197197

198−outbound :: String -> Expression () -> T.PortType Var.Canonical -> Expression ()

198+outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()

199199outbound name expr portType =

200200 case portType of

201201 T.Normal tipe ->

@@ -205,18 +205,18 @@ outbound name expr portType =

205205 _Port "outboundSignal" `call` [ string name, fromTypeFunction arg, expr ]

206206

207207

208−fromTypeFunction :: CanonicalType -> Expression ()

208+fromTypeFunction :: T.Canonical -> Expression ()

209209fromTypeFunction tipe =

210210 ["v"] ==> fromType tipe (ref "v")

211211

212212

213−fromType :: CanonicalType -> Expression () -> Expression ()

213+fromType :: T.Canonical -> Expression () -> Expression ()

214214fromType tipe x =

215215 case tipe of

216− Aliased _ args t ->

217− fromType (dealias args t) x

216+ T.Aliased _ args t ->

217+ fromType (T.dealias args t) x

218218

219− Lambda _ _

219+ T.Lambda _ _

220220 | numArgs > 1 && numArgs < 10 ->

221221 func (ref ('A':show numArgs) `call` (x:values))

222222 | otherwise ->

@@ -232,21 +232,21 @@ fromType tipe x =

232232 , ret (fromType (last ts) (ref "_r"))

233233 ]

234234

235− Var _ ->

235+ T.Var _ ->

236236 error "type variables should not be allowed through outputs"

237237

238− Type (Var.Canonical Var.BuiltIn name)

238+ T.Type (Var.Canonical Var.BuiltIn name)

239239 | name `elem` ["Int","Float","Bool","String"] ->

240240 x

241241

242− Type name

242+ T.Type name

243243 | Var.isJson name -> x

244244 | Var.isTuple name -> ArrayLit () []

245245 | otherwise -> error "bad type got to an output"

246246

247− App f args ->

247+ T.App f args ->

248248 case f : args of

249− Type name : [t]

249+ T.Type name : [t]

250250 | Var.isMaybe name ->

251251 CondExpr ()

252252 (equal (DotRef () x (var "ctor")) (string "Nothing"))

@@ -259,17 +259,17 @@ fromType tipe x =

259259 | Var.isList name ->

260260 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t

261261

262− Type name : ts

262+ T.Type name : ts

263263 | Var.isTuple name ->

264264 let convert n t = fromType t $ DotRef () x $ var ('_':show n)

265265 in ArrayLit () $ zipWith convert [0..] ts

266266

267267 _ -> error "bad ADT got to an output"

268268

269− Record _ (Just _) ->

269+ T.Record _ (Just _) ->

270270 error "bad record got to an output"

271271

272− Record fields Nothing ->

272+ T.Record fields Nothing ->

273273 ObjectLit () keys

274274 where

275275 keys = map convert fields

src/Transform/Substitute.hs → src/Generate/Substitute.hsrenamed+23−16

@@ -1,19 +1,19 @@

11{-# OPTIONS_GHC -Wall #-}

2−module Transform.Substitute (subst) where

2+module Generate.Substitute (subst) where

33

44import Control.Arrow (second, (***))

5−import qualified Data.Set as Set

65

7−import AST.Annotation

86import AST.Expression.General (Expr'(..), PortImpl(..))

97import qualified AST.Expression.Canonical as Canonical

108import qualified AST.Pattern as Pattern

119import qualified AST.Variable as V

10+import Elm.Utils ((|>))

11+import qualified Reporting.Annotation as A

1212

1313

1414subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

1515subst old new expression =

16− let f (A a e) = A a (subst old new e) in

16+ let f (A.A a e) = A.A a (subst old new e) in

1717 case expression of

1818 Range e1 e2 ->

1919 Range (f e1) (f e2)

@@ -24,9 +24,10 @@ subst old new expression =

2424 Binop op e1 e2 ->

2525 Binop op (f e1) (f e2)

2626

27− Lambda pattern body

28− | Set.member old (Pattern.boundVars pattern) -> expression

29− | otherwise -> Lambda pattern (f body)

27+ Lambda pattern body ->

28+ if Pattern.member old pattern

29+ then expression

30+ else Lambda pattern (f body)

3031

3132 App e1 e2 ->

3233 App (f e1) (f e2)

@@ -34,28 +35,34 @@ subst old new expression =

3435 MultiIf branches ->

3536 MultiIf (map (f *** f) branches)

3637

37− Let defs body

38− | anyShadow -> expression

39− | otherwise -> Let (map substDef defs) (f body)

38+ Let defs body ->

39+ if anyShadow

40+ then expression

41+ else Let (map substDef defs) (f body)

4042 where

4143 substDef (Canonical.Definition p e t) =

4244 Canonical.Definition p (f e) t

4345

4446 anyShadow =

45− any (Set.member old . Pattern.boundVars)

46− [ pattern | Canonical.Definition pattern _ _ <- defs ]

47+ map (\(Canonical.Definition p _ _) -> p) defs

48+ |> any (Pattern.member old)

4749

4850 Var (V.Canonical home x) ->

4951 case home of

50− V.Module _ -> expression

51− V.BuiltIn -> expression

52− V.Local -> if x == old then new else expression

52+ V.Module _ ->

53+ expression

54+

55+ V.BuiltIn ->

56+ expression

57+

58+ V.Local ->

59+ if x == old then new else expression

5360

5461 Case e cases ->

5562 Case (f e) (map substCase cases)

5663 where

5764 substCase (pattern, expr) =

58− if Set.member old (Pattern.boundVars pattern)

65+ if Pattern.member old pattern

5966 then (pattern, expr)

6067 else (pattern, f expr)

6168

src/Nitpick/TopLevelTypes.hsnew file+115

@@ -0,0 +1,115 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Nitpick.TopLevelTypes (topLevelTypes) where

3+

4+import Prelude hiding (maybe)

5+import qualified Data.Foldable as F

6+import qualified Data.Map as Map

7+

8+import qualified AST.Expression.Valid as Valid

9+import qualified AST.Declaration as Decl

10+import qualified AST.Pattern as P

11+import qualified AST.Type as Type

12+import qualified AST.Variable as Var

13+import qualified Reporting.Annotation as A

14+import qualified Reporting.Error.Type as Error

15+import qualified Reporting.Result as Result

16+import qualified Reporting.Warning as Warning

17+

18+

19+topLevelTypes

20+ :: Map.Map String Type.Canonical

21+ -> [Decl.ValidDecl]

22+ -> Result.Result Warning.Warning Error.Error ()

23+topLevelTypes typeEnv validDecls =

24+ do F.traverse_ (warnMissingAnnotation typeEnv) validDecls

25+ checkMainType typeEnv validDecls

26+

27+

28+-- MISSING ANNOTATIONS

29+

30+warnMissingAnnotation

31+ :: Map.Map String Type.Canonical

32+ -> Decl.ValidDecl

33+ -> Result.Result Warning.Warning Error.Error ()

34+warnMissingAnnotation typeEnv (A.A region decl) =

35+ case decl of

36+ Decl.Definition (Valid.Definition (A.A _ (P.Var name)) _ Nothing) ->

37+ case Map.lookup name typeEnv of

38+ Nothing ->

39+ return ()

40+ Just tipe ->

41+ Result.warn region (Warning.MissingTypeAnnotation name tipe)

42+ _ ->

43+ return ()

44+

45+

46+-- MAIN TYPE

47+

48+checkMainType

49+ :: Map.Map String Type.Canonical

50+ -> [Decl.ValidDecl]

51+ -> Result.Result w Error.Error ()

52+checkMainType typeEnv decls =

53+ case decls of

54+ A.A region (Decl.Definition (Valid.Definition (A.A _ (P.Var "main")) _ _)) : _ ->

55+ case Map.lookup "main" typeEnv of

56+ Nothing ->

57+ return ()

58+

59+ Just typeOfMain ->

60+ let tipe = Type.deepDealias typeOfMain

61+ in

62+ if tipe `elem` validMainTypes

63+ then return ()

64+ else Result.throw region (Error.BadMain typeOfMain)

65+

66+ _ : remainingDecls ->

67+ checkMainType typeEnv remainingDecls

68+

69+ [] ->

70+ return ()

71+

72+

73+validMainTypes :: [Type.Canonical]

74+validMainTypes =

75+ [ element

76+ , html

77+ , signal element

78+ , signal html

79+ ]

80+ where

81+ fromModule :: [String] -> String -> Type.Canonical

82+ fromModule home name =

83+ Type.Type (Var.fromModule home name)

84+

85+ html =

86+ fromModule ["VirtualDom"] "Node"

87+

88+ signal tipe =

89+ Type.App (fromModule ["Signal"] "Signal") [ tipe ]

90+

91+ element =

92+ let builtin name =

93+ Type.Type (Var.builtin name)

94+

95+ maybe tipe =

96+ Type.App (fromModule ["Maybe"] "Maybe") [ tipe ]

97+ in

98+ Type.Record

99+ [ ("element", fromModule ["Graphics","Element"] "ElementPrim")

100+ , ("props",

101+ Type.Record

102+ [ ("click" , builtin "_Tuple0")

103+ , ("color" , maybe (fromModule ["Color"] "Color"))

104+ , ("height" , builtin "Int")

105+ , ("hover" , builtin "_Tuple0")

106+ , ("href" , builtin "String")

107+ , ("id" , builtin "Int")

108+ , ("opacity", builtin "Float")

109+ , ("tag" , builtin "String")

110+ , ("width" , builtin "Int")

111+ ]

112+ Nothing

113+ )

114+ ]

115+ Nothing

src/Parse/Binop.hs+102−55

@@ -5,81 +5,128 @@ import qualified Data.List as List

55import qualified Data.Map as Map

66import Text.Parsec ((<|>), choice, getState, try)

77

8−import AST.Annotation (merge)

98import AST.Declaration (Assoc(L, N, R))

109import AST.Expression.General (Expr'(Binop))

1110import qualified AST.Expression.Source as Source

1211import qualified AST.Variable as Var

1312import Parse.Helpers (IParser, OpTable, commitIf, failure, whitespace)

13+import qualified Reporting.Annotation as A

14+

1415

1516opLevel :: OpTable -> String -> Int

16−opLevel table op = fst $ Map.findWithDefault (9,L) op table

17+opLevel table op =

18+ fst $ Map.findWithDefault (9,L) op table

19+

1720

1821opAssoc :: OpTable -> String -> Assoc

19−opAssoc table op = snd $ Map.findWithDefault (9,L) op table

22+opAssoc table op =

23+ snd $ Map.findWithDefault (9,L) op table

24+

2025

2126hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool

22−hasLevel table n (op,_) = opLevel table op == n

27+hasLevel table n (op,_) =

28+ opLevel table op == n

29+

2330

24−binops :: IParser Source.Expr

25− -> IParser Source.Expr

26− -> IParser String

27− -> IParser Source.Expr

31+binops

32+ :: IParser Source.Expr

33+ -> IParser Source.Expr

34+ -> IParser String

35+ -> IParser Source.Expr

2836binops term last anyOp =

29− do e <- term

30− table <- getState

31− split table 0 e =<< nextOps

32− where

33− nextOps = choice [ commitIf (whitespace >> anyOp) $ do

34− whitespace ; op <- anyOp ; whitespace

35− expr <- Left <$> try term <|> Right <$> last

36− case expr of

37− Left t -> (:) (op,t) <$> nextOps

38− Right e -> return [(op,e)]

39− , return [] ]

40−

41−split :: OpTable

42− -> Int

43− -> Source.Expr

44− -> [(String, Source.Expr)]

45− -> IParser Source.Expr

46−split _ _ e [] = return e

47−split table n e eops = do

48− assoc <- getAssoc table n eops

49− es <- sequence (splitLevel table n e eops)

50− let ops = map fst (filter (hasLevel table n) eops)

51− case assoc of R -> joinR es ops

52− _ -> joinL es ops

53−

54−splitLevel :: OpTable -> Int -> Source.Expr -> [(String, Source.Expr)]

55− -> [IParser Source.Expr]

37+ do e <- term

38+ table <- getState

39+ split table 0 e =<< nextOps

40+ where

41+ nextOps =

42+ choice

43+ [ commitIf (whitespace >> anyOp) $

44+ do whitespace

45+ op <- anyOp

46+ whitespace

47+ expr <- Left <$> try term <|> Right <$> last

48+ case expr of

49+ Left t -> (:) (op,t) <$> nextOps

50+ Right e -> return [(op,e)]

51+ , return []

52+ ]

53+

54+

55+split

56+ :: OpTable

57+ -> Int

58+ -> Source.Expr

59+ -> [(String, Source.Expr)]

60+ -> IParser Source.Expr

61+split _ _ e [] = return e

62+split table n e eops =

63+ do assoc <- getAssoc table n eops

64+ es <- sequence (splitLevel table n e eops)

65+ let ops = map fst (filter (hasLevel table n) eops)

66+ case assoc of

67+ R -> joinR es ops

68+ _ -> joinL es ops

69+

70+

71+splitLevel

72+ :: OpTable

73+ -> Int

74+ -> Source.Expr

75+ -> [(String, Source.Expr)]

76+ -> [IParser Source.Expr]

5677splitLevel table n e eops =

57− case break (hasLevel table n) eops of

58− (lops, (_op,e'):rops) ->

59− split table (n+1) e lops : splitLevel table n e' rops

60− (lops, []) -> [ split table (n+1) e lops ]

78+ case break (hasLevel table n) eops of

79+ (lops, (_op,e'):rops) ->

80+ split table (n+1) e lops : splitLevel table n e' rops

81+

82+ (lops, []) ->

83+ [ split table (n+1) e lops ]

84+

6185

6286joinL :: [Source.Expr] -> [String] -> IParser Source.Expr

63−joinL [e] [] = return e

64−joinL (a:b:es) (op:ops) = joinL (merge a b (Binop (Var.Raw op) a b) : es) ops

65−joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

87+joinL exprs ops =

88+ case (exprs, ops) of

89+ ([expr], []) ->

90+ return expr

91+

92+ (a:b:remainingExprs, op:remainingOps) ->

93+ let binop = A.merge a b (Binop (Var.Raw op) a b)

94+ in

95+ joinL (binop : remainingExprs) remainingOps

96+

97+ (_, _) ->

98+ failure "Ill-formed binary expression. Report a compiler bug."

99+

66100

67101joinR :: [Source.Expr] -> [String] -> IParser Source.Expr

68−joinR [e] [] = return e

69−joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

70− return (merge a e (Binop (Var.Raw op) a e))

71−joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

102+joinR exprs ops =

103+ case (exprs, ops) of

104+ ([expr], []) ->

105+ return expr

106+

107+ (a:b:remainingExprs, op:remainingOps) ->

108+ do e <- joinR (b:remainingExprs) remainingOps

109+ return (A.merge a e (Binop (Var.Raw op) a e))

110+

111+ (_, _) ->

112+ failure "Ill-formed binary expression. Report a compiler bug."

113+

72114

73115getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc

74116getAssoc table n eops

75117 | all (==L) assocs = return L

76− | all (==R) assocs = return R

77− | all (==N) assocs = case assocs of [_] -> return N

78− _ -> failure (msg "precedence")

118+ | all (==R) assocs = return R

119+ | all (==N) assocs =

120+ case assocs of

121+ [_] -> return N

122+ _ -> failure (msg "precedence")

79123 | otherwise = failure (msg "associativity")

80− where levelOps = filter (hasLevel table n) eops

81− assocs = map (opAssoc table . fst) levelOps

82− msg problem =

83− concat [ "Conflicting " ++ problem ++ " for binary operators ("

84− , List.intercalate ", " (map fst eops), "). "

85− , "Consider adding parentheses to disambiguate." ]

124+ where

125+ levelOps = filter (hasLevel table n) eops

126+ assocs = map (opAssoc table . fst) levelOps

127+ msg problem =

128+ concat

129+ [ "Conflicting " ++ problem ++ " for binary operators ("

130+ , List.intercalate ", " (map fst eops), "). "

131+ , "Consider adding parentheses to disambiguate."

132+ ]

src/Parse/Declaration.hs+11−7

@@ -12,21 +12,23 @@ import qualified Parse.Type as Type

1212

1313declaration :: IParser D.SourceDecl

1414declaration =

15− typeDecl <|> infixDecl <|> port <|> definition

15+ addLocation (typeDecl <|> infixDecl <|> port <|> definition)

1616

1717

1818-- TYPE ANNOTATIONS and DEFINITIONS

1919

20−definition :: IParser D.SourceDecl

20+definition :: IParser D.SourceDecl'

2121definition =

22− D.Definition <$> (Expr.typeAnnotation <|> Expr.definition)

22+ D.Definition

23+ <$> (Expr.typeAnnotation <|> Expr.definition)

24+ <?> "a value definition"

2325

2426

2527-- TYPE ALIAS and UNION TYPES

2628

27−typeDecl :: IParser D.SourceDecl

29+typeDecl :: IParser D.SourceDecl'

2830typeDecl =

29− do try (reserved "type") <?> "type declaration"

31+ do try (reserved "type") <?> "a type declaration"

3032 forcedWS

3133 isAlias <- optionMaybe (string "alias" >> forcedWS)

3234

@@ -46,8 +48,9 @@ typeDecl =

4648

4749-- INFIX

4850

49−infixDecl :: IParser D.SourceDecl

51+infixDecl :: IParser D.SourceDecl'

5052infixDecl =

53+ expecting "an infix declaration" $

5154 do assoc <-

5255 choice

5356 [ try (reserved "infixl") >> return D.L

@@ -62,8 +65,9 @@ infixDecl =

6265

6366-- PORT

6467

65−port :: IParser D.SourceDecl

68+port :: IParser D.SourceDecl'

6669port =

70+ expecting "a port declaration" $

6771 do try (reserved "port")

6872 whitespace

6973 name <- lowVar

src/Parse/Expression.hs+165−93

@@ -12,42 +12,63 @@ import qualified Parse.Literal as Literal

1212import qualified Parse.Pattern as Pattern

1313import qualified Parse.Type as Type

1414

15−import qualified AST.Annotation as Annotation

1615import qualified AST.Expression.General as E

1716import qualified AST.Expression.Source as Source

1817import qualified AST.Literal as L

1918import qualified AST.Pattern as P

2019import qualified AST.Variable as Var

20+import qualified Reporting.Annotation as A

2121

2222

2323-------- Basic Terms --------

2424

2525varTerm :: IParser Source.Expr'

2626varTerm =

27− toVar <$> var <?> "variable"

27+ toVar <$> var

2828

2929

3030toVar :: String -> Source.Expr'

3131toVar v =

3232 case v of

33− "True" -> E.Literal (L.Boolean True)

34− "False" -> E.Literal (L.Boolean False)

35− _ -> E.rawVar v

33+ "True" ->

34+ E.Literal (L.Boolean True)

35+

36+ "False" ->

37+ E.Literal (L.Boolean False)

38+

39+ _ ->

40+ E.rawVar v

3641

3742

3843accessor :: IParser Source.Expr'

3944accessor =

4045 do (start, lbl, end) <- located (try (string "." >> rLabel))

41− let loc e = Annotation.at start end e

42− return (E.Lambda (P.Var "_") (loc $ E.Access (loc $ E.rawVar "_") lbl))

46+

47+ let ann value =

48+ A.at start end value

49+

50+ return $

51+ E.Lambda

52+ (ann (P.Var "_"))

53+ (ann (E.Access (ann (E.rawVar "_")) lbl))

4354

4455

4556negative :: IParser Source.Expr'

4657negative =

4758 do (start, nTerm, end) <-

48− located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

49− let loc e = Annotation.at start end e

50− return (E.Binop (Var.Raw "-") (loc $ E.Literal (L.IntNum 0)) nTerm)

59+ located $ try $

60+ do char '-'

61+ notFollowedBy (char '.' <|> char '-')

62+ term

63+

64+ let ann e =

65+ A.at start end e

66+

67+ return $

68+ E.Binop

69+ (Var.Raw "-")

70+ (ann (E.Literal (L.IntNum 0)))

71+ nTerm

5172

5273

5374-------- Complex Terms --------

@@ -56,46 +77,69 @@ listTerm :: IParser Source.Expr'

5677listTerm =

5778 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)

5879 where

59− range = do

60− lo <- expr

61− padded (string "..")

62− E.Range lo <$> expr

80+ range =

81+ do lo <- expr

82+ padded (string "..")

83+ E.Range lo <$> expr

6384

64− shader' = do

65− pos <- getPosition

66− let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

67− (rawSrc, tipe) <- Help.shader

68− return $ E.GLShader uid (filter (/='\r') rawSrc) tipe

85+ shader' =

86+ do pos <- getPosition

87+ let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

88+ (rawSrc, tipe) <- Help.shader

89+ return $ E.GLShader uid (filter (/='\r') rawSrc) tipe

6990

7091

7192parensTerm :: IParser Source.Expr

7293parensTerm =

73− try (parens opFn) <|> parens (tupleFn <|> parened)

94+ choice

95+ [ try (parens opFn)

96+ , parens (tupleFn <|> parened)

97+ ]

7498 where

75− opFn = do

76− (start, op, end) <- located anyOp

77− let loc = Annotation.at start end

78− return . loc . E.Lambda (P.Var "x") . loc . E.Lambda (P.Var "y") . loc $

79− E.Binop (Var.Raw op) (loc (E.rawVar "x")) (loc (E.rawVar "y"))

80−

81− tupleFn = do

82− let comma = char ',' <?> "comma ','"

83− (start, commas, end) <- located (comma >> many (whitespace >> comma))

84− let vars = map (('v':) . show) [ 0 .. length commas + 1 ]

85− loc = Annotation.at start end

86− return $ foldr (\x e -> loc $ E.Lambda x e)

87− (loc . E.tuple $ map (loc . E.rawVar) vars) (map P.Var vars)

88−

89− parened = do

90− (start, es, end) <- located (commaSep expr)

91− return $ case es of

92− [e] -> e

93− _ -> Annotation.at start end (E.tuple es)

99+ lambda start end x body =

100+ A.at start end (E.Lambda (A.at start end (P.Var x)) body)

101+

102+ var start end x =

103+ A.at start end (E.rawVar x)

104+

105+ opFn =

106+ do (start, op, end) <- located anyOp

107+ return $

108+ lambda start end "x" $

109+ lambda start end "y" $

110+ A.at start end $

111+ E.Binop (Var.Raw op) (var start end "x") (var start end "y")

112+

113+ tupleFn =

114+ do (start, commas, end) <-

115+ located (comma >> many (whitespace >> comma))

116+

117+ let vars = map (('v':) . show) [ 0 .. length commas + 1 ]

118+

119+ return $

120+ foldr

121+ (lambda start end)

122+ (A.at start end (E.tuple (map (var start end) vars)))

123+ vars

124+

125+ parened =

126+ do (start, expressions, end) <- located (commaSep expr)

127+ return $

128+ case expressions of

129+ [expression] ->

130+ expression

131+ _ ->

132+ A.at start end (E.tuple expressions)

133+

94134

95135recordTerm :: IParser Source.Expr

96136recordTerm =

97− brackets $ choice [ misc, addLocation record ]

137+ addLocation $

138+ brackets (choice [ misc, record ])

98139 where

140+ record =

141+ E.Record <$> commaSep field

142+

99143 field =

100144 do label <- rLabel

101145 patterns <- spacePrefix Pattern.term

@@ -103,52 +147,73 @@ recordTerm =

103147 body <- expr

104148 return (label, makeFunction patterns body)

105149

106− record =

107− E.Record <$> commaSep field

108−

109− change =

110− do lbl <- rLabel

111− padded (string "<-")

112− (,) lbl <$> expr

113−

114− remove r =

115− addLocation (string "-" >> whitespace >> E.Remove r <$> rLabel)

150+ misc =

151+ do nextParser <- try miscStarter

152+ whitespace

153+ nextParser

116154

117− insert r =

118− addLocation $

119− do string "|" >> whitespace

120− E.Insert r <$> rLabel <*> (padded equals >> expr)

155+ miscStarter =

156+ do start <- getMyPosition

157+ record <- addLocation (E.rawVar <$> rLabel)

158+ whitespace

159+ choice

160+ [ string "-" >> return (afterMinus start record)

161+ , string "|" >> return (afterBar record)

162+ ]

121163

122− modify r =

123− addLocation (string "|" >> whitespace >> E.Modify r <$> commaSep1 change)

164+ afterMinus start record =

165+ do field <- rLabel

166+ end <- getMyPosition

167+ let subRecord' = E.Remove record field

168+ maybe <- optionMaybe (try (whitespace >> string "|"))

169+ case maybe of

170+ Nothing ->

171+ return subRecord'

172+ Just _ ->

173+ do whitespace

174+ field <- rLabel

175+ padded equals

176+ E.Insert (A.at start end subRecord') field <$> expr

177+

178+ afterBar record =

179+ do field <- rLabel

180+ whitespace

181+ choice

182+ [ do equals

183+ whitespace

184+ E.Insert record field <$> expr

185+ , do leftArrow

186+ whitespace

187+ value <- expr

188+ updates <- spaceyPrefixBy comma update

189+ return (E.Modify record ((field,value) : updates))

190+ ]

124191

125− misc =

126− try $ do

127− record <- addLocation (E.rawVar <$> rLabel)

128− opt <- padded (optionMaybe (remove record))

129− case opt of

130− Just e -> try (insert e) <|> return e

131− Nothing -> try (insert record) <|> try (modify record)

192+ update =

193+ do lbl <- rLabel

194+ padded leftArrow

195+ (,) lbl <$> expr

132196

133197

134198term :: IParser Source.Expr

135199term =

136200 addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])

137201 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

138− <?> "basic term (4, x, 'c', etc.)"

202+ <?> "an expression"

139203

140204

141205-------- Applications --------

142206

143207appExpr :: IParser Source.Expr

144208appExpr =

209+ expecting "an expression" $

145210 do t <- term

146211 ts <- constrainedSpacePrefix term $ \str ->

147212 if null str then notFollowedBy (char '-') else return ()

148213 return $

149214 case ts of

150215 [] -> t

151− _ -> List.foldl' (\f x -> Annotation.merge f x $ E.App f x) t ts

216+ _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts

152217

153218

154219-------- Normal Expressions --------

@@ -165,8 +230,10 @@ binaryExpr :: IParser Source.Expr

165230binaryExpr =

166231 Binop.binops appExpr lastExpr anyOp

167232 where

168− lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

169− <|> lambdaExpr

233+ lastExpr =

234+ addLocation (choice [ ifExpr, letExpr, caseExpr ])

235+ <|> lambdaExpr

236+ <?> "an expression"

170237

171238

172239ifExpr :: IParser Source.Expr'

@@ -185,24 +252,26 @@ ifExpr =

185252 elseBranch <- expr

186253 return $ E.MultiIf

187254 [ (bool, thenBranch)

188− , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)

255+ , (A.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)

189256 ]

190257

191258 multiIf =

192259 E.MultiIf <$> spaceSep1 iff

193260 where

194261 iff =

195− do string "|" ; whitespace

196− b <- expr ; padded arrow

262+ do string "|"

263+ whitespace

264+ b <- expr

265+ padded rightArrow

197266 (,) b <$> expr

198267

199268

200269lambdaExpr :: IParser Source.Expr

201270lambdaExpr =

202− do char '\\' <|> char '\x03BB' <?> "anonymous function"

271+ do char '\\' <|> char '\x03BB' <?> "an anonymous function"

203272 whitespace

204273 args <- spaceSep1 Pattern.term

205− padded arrow

274+ padded rightArrow

206275 body <- expr

207276 return (makeFunction args body)

208277

@@ -217,7 +286,7 @@ caseExpr =

217286 where

218287 case_ =

219288 do p <- Pattern.expr

220− padded arrow

289+ padded rightArrow

221290 (,) p <$> expr

222291

223292 with =

@@ -246,7 +315,7 @@ letExpr =

246315

247316typeAnnotation :: IParser Source.Def

248317typeAnnotation =

249− Source.TypeAnnotation <$> try start <*> Type.expr

318+ addLocation (Source.TypeAnnotation <$> try start <*> Type.expr)

250319 where

251320 start =

252321 do v <- lowVar <|> parens symOp

@@ -258,6 +327,7 @@ typeAnnotation =

258327

259328definition :: IParser Source.Def

260329definition =

330+ addLocation $

261331 withPos $

262332 do (name:args) <- defStart

263333 padded equals

@@ -266,29 +336,31 @@ definition =

266336

267337

268338makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr

269−makeFunction args body@(Annotation.A ann _) =

270− foldr (\arg body' -> Annotation.A ann $ E.Lambda arg body') body args

339+makeFunction args body@(A.A ann _) =

340+ foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args

271341

272342

273343defStart :: IParser [P.RawPattern]

274344defStart =

275345 choice

276− [ do p1 <- try Pattern.term

277− infics p1 <|> func p1

278− , func =<< (P.Var <$> parens symOp)

346+ [ do pattern <- try Pattern.term

347+ infics pattern <|> func pattern

348+ , do opPattern <- addLocation (P.Var <$> parens symOp)

349+ func opPattern

279350 ]

280351 <?> "the definition of a variable (x = ...)"

281− where

282− func pattern =

283− case pattern of

284− P.Var _ -> (pattern:) <$> spacePrefix Pattern.term

285− _ -> do try (lookAhead (whitespace >> string "="))

286− return [pattern]

287−

288− infics p1 =

289− do o:p <- try (whitespace >> anyOp)

290− p2 <- (whitespace >> Pattern.term)

291− return $

292− if o == '`'

293− then [ P.Var $ takeWhile (/='`') p, p1, p2 ]

294− else [ P.Var (o:p), p1, p2 ]

352+ where

353+ func pattern =

354+ case pattern of

355+ A.A _ (P.Var _) ->

356+ (pattern:) <$> spacePrefix Pattern.term

357+

358+ _ ->

359+ return [pattern]

360+

361+ infics p1 =

362+ do (start, o:p, end) <- try (whitespace >> located anyOp)

363+ p2 <- (whitespace >> Pattern.term)

364+ let opName =

365+ if o == '`' then takeWhile (/='`') p else o:p

366+ return [ A.at start end (P.Var opName), p1, p2 ]

src/Parse/Helpers.hs+89−59

@@ -8,19 +8,20 @@ import Data.Char (isUpper)

88import qualified Data.Map as Map

99import qualified Language.GLSL.Parser as GLP

1010import qualified Language.GLSL.Syntax as GLS

11−import Text.Parsec hiding (newline,spaces,State)

11+import Text.Parsec hiding (newline, spaces, State)

1212import Text.Parsec.Indent (indented, runIndent)

1313import qualified Text.Parsec.Token as T

1414

15−import qualified AST.Annotation as Annotation

1615import qualified AST.Declaration as Decl

1716import qualified AST.Expression.General as E

1817import qualified AST.Expression.Source as Source

1918import qualified AST.Helpers as Help

2019import qualified AST.Literal as L

21−import qualified AST.PrettyPrint as P

2220import qualified AST.Variable as Variable

2321import Elm.Utils ((|>))

22+import qualified Reporting.Annotation as A

23+import qualified Reporting.Error.Syntax as Syntax

24+import qualified Reporting.Region as R

2425

2526

2627reserveds :: [String]

@@ -37,9 +38,13 @@ reserveds =

3738 ]

3839

3940

41+-- ERROR HELP

42+

4043expecting = flip (<?>)

4144

4245

46+-- SETUP

47+

4348type OpTable = Map.Map String (Int, Decl.Assoc)

4449type SourceM = State SourcePos

4550type IParser a = ParsecT String OpTable SourceM a

@@ -59,17 +64,17 @@ iParseWithTable sourceName table aParser input =

5964

6065var :: IParser String

6166var =

62− makeVar (letter <|> char '_' <?> "variable")

67+ makeVar (letter <|> char '_') <?> "a variable"

6368

6469

6570lowVar :: IParser String

6671lowVar =

67− makeVar (lower <?> "lower case variable")

72+ makeVar lower <?> "a lower case variable"

6873

6974

7075capVar :: IParser String

7176capVar =

72− makeVar (upper <?> "upper case variable")

77+ makeVar upper <?> "an upper case variable"

7378

7479

7580qualifiedVar :: IParser String

@@ -84,15 +89,15 @@ rLabel = lowVar

8489

8590innerVarChar :: IParser Char

8691innerVarChar =

87− alphaNum <|> char '_' <|> char '\'' <?> ""

92+ alphaNum <|> char '_' <|> char '\'' <?> "more letters in this variable"

8893

8994

9095makeVar :: IParser Char -> IParser String

91−makeVar p =

92− do v <- (:) <$> p <*> many innerVarChar

93− if v `elem` reserveds

94− then fail $ "unexpected keyword '" ++ v ++ "', variables cannot be keywords"

95− else return v

96+makeVar firstChar =

97+ do variable <- (:) <$> firstChar <*> many innerVarChar

98+ if variable `elem` reserveds

99+ then fail (Syntax.keyword variable)

100+ else return variable

96101

97102

98103reserved :: String -> IParser String

@@ -109,7 +114,7 @@ anyOp :: IParser String

109114anyOp =

110115 betwixt '`' '`' qualifiedVar

111116 <|> symOp

112− <?> "infix operator"

117+ <?> "an infix operator like (+)"

113118

114119

115120symOp :: IParser String

@@ -124,13 +129,23 @@ symOp =

124129-- COMMON SYMBOLS

125130

126131equals :: IParser String

127−equals = string "="

132+equals =

133+ string "=" <?> "="

134+

135+

136+rightArrow :: IParser String

137+rightArrow =

138+ string "->" <|> string "\8594" <?> "->"

139+

140+

141+leftArrow :: IParser String

142+leftArrow =

143+ string "<-" <?> "<- for a record update"

128144

129−arrow :: IParser String

130−arrow = string "->" <|> string "\8594" <?> "arrow (->)"

131145

132146hasType :: IParser String

133−hasType = string ":" <?> "':' (a type annotation)'"

147+hasType =

148+ string ":" <?> "the \"has type\" symbol ':'"

134149

135150

136151commitIf check p =

@@ -143,14 +158,24 @@ commitIf check p =

143158-- SEPARATORS

144159

145160spaceySepBy1 :: IParser b -> IParser a -> IParser [a]

146−spaceySepBy1 sep p =

147− do a <- p

148− (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))

161+spaceySepBy1 sep parser =

162+ do value <- parser

163+ (value:) <$> spaceyPrefixBy sep parser

164+

165+

166+spaceyPrefixBy :: IParser sep -> IParser a -> IParser [a]

167+spaceyPrefixBy sep parser =

168+ many (commitIf (whitespace >> sep) (padded sep >> parser))

169+

170+

171+comma :: IParser Char

172+comma =

173+ char ',' <?> "a comma ','"

149174

150175

151176commaSep1 :: IParser a -> IParser [a]

152177commaSep1 =

153− spaceySepBy1 (char ',' <?> "comma ','")

178+ spaceySepBy1 comma

154179

155180

156181commaSep :: IParser a -> IParser [a]

@@ -160,17 +185,17 @@ commaSep =

160185

161186semiSep1 :: IParser a -> IParser [a]

162187semiSep1 =

163− spaceySepBy1 (char ';' <?> "semicolon ';'")

188+ spaceySepBy1 (char ';' <?> "a semicolon ';'")

164189

165190

166191pipeSep1 :: IParser a -> IParser [a]

167192pipeSep1 =

168− spaceySepBy1 (char '|' <?> "type divider '|'")

193+ spaceySepBy1 (char '|' <?> "a vertical bar '|'")

169194

170195

171196consSep1 :: IParser a -> IParser [a]

172197consSep1 =

173− spaceySepBy1 (string "::" <?> "cons operator '::'")

198+ spaceySepBy1 (string "::" <?> "a cons operator '::'")

174199

175200

176201dotSep1 :: IParser a -> IParser [a]

@@ -187,15 +212,15 @@ spacePrefix p =

187212 constrainedSpacePrefix p (\_ -> return ())

188213

189214

190−constrainedSpacePrefix p constraint =

215+constrainedSpacePrefix parser constraint =

191216 many $ choice

192− [ try (spacing >> lookAhead (oneOf "[({")) >> p

193− , try (spacing >> p)

217+ [ try (spacing >> lookAhead (oneOf "[({")) >> parser

218+ , try (spacing >> parser)

194219 ]

195220 where

196221 spacing = do

197222 n <- whitespace

198− constraint n

223+ constraint n <?> Syntax.whitespace

199224 indented

200225

201226

@@ -210,14 +235,14 @@ followedBy a b =

210235betwixt a b c =

211236 do char a

212237 out <- c

213− char b <?> "closing '" ++ [b] ++ "'"

238+ char b <?> "a closing '" ++ [b] ++ "'"

214239 return out

215240

216241

217242surround a z name p = do

218243 char a

219244 v <- padded p

220− char z <?> unwords ["closing", name, show z]

245+ char z <?> unwords ["a closing", name, show z]

221246 return v

222247

223248

@@ -238,27 +263,32 @@ brackets =

238263

239264-- HELPERS FOR EXPRESSIONS

240265

241−addLocation :: (P.Pretty a) => IParser a -> IParser (Annotation.Located a)

266+getMyPosition :: IParser R.Position

267+getMyPosition =

268+ R.fromSourcePos <$> getPosition

269+

270+

271+addLocation :: IParser a -> IParser (A.Located a)

242272addLocation expr =

243273 do (start, e, end) <- located expr

244− return (Annotation.at start end e)

274+ return (A.at start end e)

245275

246276

247−located :: IParser a -> IParser (SourcePos, a, SourcePos)

248−located p =

249− do start <- getPosition

250− e <- p

251− end <- getPosition

252− return (start, e, end)

277+located :: IParser a -> IParser (R.Position, a, R.Position)

278+located parser =

279+ do start <- getMyPosition

280+ value <- parser

281+ end <- getMyPosition

282+ return (start, value, end)

253283

254284

255285accessible :: IParser Source.Expr -> IParser Source.Expr

256286accessible exprParser =

257− do start <- getPosition

287+ do start <- getMyPosition

258288

259− annotatedRootExpr@(Annotation.A _ rootExpr) <- exprParser

289+ annotatedRootExpr@(A.A _ rootExpr) <- exprParser

260290

261− access <- optionMaybe (try dot <?> "field access (e.g. List.map)")

291+ access <- optionMaybe (try dot <?> "a field access like .name")

262292

263293 case access of

264294 Nothing ->

@@ -266,9 +296,9 @@ accessible exprParser =

266296

267297 Just _ ->

268298 accessible $

269− do v <- var <?> "field access (e.g. List.map)"

270− end <- getPosition

271− return . Annotation.at start end $

299+ do v <- var

300+ end <- getMyPosition

301+ return . A.at start end $

272302 case rootExpr of

273303 E.Var (Variable.Raw name@(c:_))

274304 | isUpper c ->

@@ -279,7 +309,8 @@ accessible exprParser =

279309

280310dot :: IParser ()

281311dot =

282− char '.' >> notFollowedBy (char '.')

312+ do char '.'

313+ notFollowedBy (char '.')

283314

284315

285316-- WHITESPACE

@@ -294,7 +325,7 @@ padded p =

294325

295326spaces :: IParser String

296327spaces =

297− let space = string " " <|> multiComment <?> "whitespace"

328+ let space = string " " <|> multiComment <?> Syntax.whitespace

298329 in

299330 concat <$> many1 space

300331

@@ -323,14 +354,14 @@ whitespace =

323354

324355freshLine :: IParser [[String]]

325356freshLine =

326− try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""

357+ try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> Syntax.freshLine

327358 where

328359 space_nl = try $ spaces >> many1 newline

329360

330361

331362newline :: IParser String

332363newline =

333− simpleNewline <|> lineComment <?> "a newline"

364+ simpleNewline <|> lineComment <?> Syntax.newline

334365

335366

336367simpleNewline :: IParser String

@@ -354,7 +385,7 @@ closeComment :: IParser String

354385closeComment =

355386 anyUntil $

356387 choice $

357− [ try (string "-}") <?> "close comment"

388+ [ try (string "-}") <?> "the end of a comment -}"

358389 , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]

359390 ]

360391

@@ -427,12 +458,10 @@ withSource p =

427458

428459anyUntilPos :: SourcePos -> IParser String

429460anyUntilPos pos =

430− go

431− where

432− go = do currentPos <- getPosition

433− case currentPos == pos of

434− True -> return []

435− False -> (:) <$> anyChar <*> go

461+ do currentPos <- getPosition

462+ if currentPos == pos

463+ then return []

464+ else (:) <$> anyChar <*> anyUntilPos pos

436465

437466

438467-- BASIC LANGUAGE LITERALS

@@ -505,9 +534,10 @@ glSource src =

505534

506535

507536str :: IParser String

508−str = expecting "String" $ do

509− s <- choice [ multiStr, singleStr ]

510− processAs T.stringLiteral . sandwich '\"' $ concat s

537+str =

538+ expecting "a string" $

539+ do s <- choice [ multiStr, singleStr ]

540+ processAs T.stringLiteral . sandwich '\"' $ concat s

511541 where

512542 rawString quote insides =

513543 quote >> manyTill insides quote

@@ -547,7 +577,7 @@ escaped delim =

547577

548578chr :: IParser Char

549579chr =

550− betwixt '\'' '\'' character <?> "character"

580+ betwixt '\'' '\'' character <?> "a character"

551581 where

552582 nonQuote = satisfy (/='\'')

553583

src/Parse/Literal.hs+4−4

@@ -9,19 +9,19 @@ import qualified AST.Literal as L

99

1010literal :: IParser L.Literal

1111literal =

12− num <|> (L.Str <$> str) <|> (L.Chr <$> chr) <?> "literal"

12+ num <|> (L.Str <$> str) <|> (L.Chr <$> chr)

1313

1414

1515num :: IParser L.Literal

1616num =

17− toLiteral <$> (rawNumber <?> "number")

17+ toLiteral <$> (rawNumber <?> "a number")

1818

1919

2020toLiteral :: String -> L.Literal

2121toLiteral n

22− | 'x' `elem` n = L.IntNum (read n)

22+ | 'x' `elem` n = L.IntNum (read n)

2323 | any (`elem` ".eE") n = L.FloatNum (read n)

24− | otherwise = L.IntNum (read n)

24+ | otherwise = L.IntNum (read n)

2525

2626

2727rawNumber :: IParser String

src/Parse/Module.hs+24−19

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

1−module Parse.Module (header, headerAndImports, getModuleName) where

1+module Parse.Module (moduleDecl, header, getModuleName) where

22

33import Control.Applicative ((<$>), (<*>))

44import Text.Parsec hiding (newline, spaces)

@@ -6,6 +6,7 @@ import Text.Parsec hiding (newline, spaces)

66import Parse.Helpers

77import qualified AST.Module as Module

88import qualified AST.Variable as Var

9+import Reporting.Annotation as A

910

1011

1112getModuleName :: String -> Maybe String

@@ -16,38 +17,41 @@ getModuleName source =

1617 where

1718 getModuleName =

1819 do optional freshLine

19− (names, _) <- header

20+ (names, _) <- moduleDecl

2021 return (Module.nameToString names)

2122

2223

23−headerAndImports :: IParser Module.HeaderAndImports

24−headerAndImports =

24+header :: IParser (Module.Header [Module.UserImport])

25+header =

2526 do optional freshLine

2627 (names, exports) <-

27− option (["Main"], Var.openListing) (header `followedBy` freshLine)

28+ option (["Main"], Var.openListing) (moduleDecl `followedBy` freshLine)

2829 imports' <- imports

29− return $ Module.HeaderAndImports names exports imports'

30+ return (Module.Header names exports imports')

3031

3132

32−header :: IParser ([String], Var.Listing Var.Value)

33−header =

33+moduleDecl :: IParser ([String], Var.Listing (A.Located Var.Value))

34+moduleDecl =

35+ expecting "a module declaration" $

3436 do try (reserved "module")

3537 whitespace

36− names <- dotSep1 capVar <?> "name of module"

38+ names <- dotSep1 capVar <?> "the name of this module"

39+ whitespace

40+ exports <- option Var.openListing (listing (addLocation value))

3741 whitespace

38− exports <- option Var.openListing (listing value)

39− whitespace <?> "reserved word 'where'"

4042 reserved "where"

4143 return (names, exports)

4244

4345

44−imports :: IParser [(Module.Name, Module.ImportMethod)]

46+imports :: IParser [Module.UserImport]

4547imports =

4648 many (import' `followedBy` freshLine)

4749

4850

49−import' :: IParser (Module.Name, Module.ImportMethod)

51+import' :: IParser Module.UserImport

5052import' =

53+ expecting "an import" $

54+ addLocation $

5155 do try (reserved "import")

5256 whitespace

5357 names <- dotSep1 capVar

@@ -56,14 +60,14 @@ import' =

5660 method :: String -> IParser Module.ImportMethod

5761 method defaultAlias =

5862 Module.ImportMethod

59− <$> option (Just defaultAlias) (Just <$> as')

63+ <$> option (Just defaultAlias) (Just <$> as' defaultAlias)

6064 <*> option Var.closedListing exposing

6165

62− as' :: IParser String

63− as' =

66+ as' :: String -> IParser String

67+ as' moduleName =

6468 do try (whitespace >> reserved "as")

6569 whitespace

66− capVar <?> "alias for module"

70+ capVar <?> ("an alias for module '" ++ moduleName ++ "'")

6771

6872 exposing :: IParser (Var.Listing Var.Value)

6973 exposing =

@@ -74,13 +78,14 @@ import' =

7478

7579listing :: IParser a -> IParser (Var.Listing a)

7680listing item =

81+ expecting "a listing of values to expose, like (..)" $

7782 do try (whitespace >> char '(')

7883 whitespace

7984 listing <-

8085 choice

8186 [ const Var.openListing <$> string ".."

8287 , Var.Listing <$> commaSep1 item <*> return False

83− ] <?> "listing of values (x,y,z)"

88+ ]

8489 whitespace

8590 char ')'

8691 return listing

@@ -88,7 +93,7 @@ listing item =

8893

8994value :: IParser Var.Value

9095value =

91− val <|> tipe

96+ val <|> tipe <?> "a value to expose"

9297 where

9398 val =

9499 Var.Value <$> (lowVar <|> parens symOp)

src/Parse/Parse.hs+113−54

@@ -1,79 +1,138 @@

1−module Parse.Parse (program) where

1+{-# OPTIONS_GHC -Wall #-}

2+module Parse.Parse (program, parse) where

23

3−import Control.Applicative ((<$>))

4−import qualified Data.List as List

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

55import qualified Data.Map as Map

6−import Text.Parsec hiding (newline, spaces)

7−import qualified Text.PrettyPrint as P

6+import qualified Data.Traversable as T

7+import Text.Parsec (char, eof, letter, many, optional, putState, (<|>))

8+import qualified Text.Parsec.Error as Parsec

89

910import qualified AST.Declaration as D

1011import qualified AST.Module as M

12+import qualified Elm.Compiler.Imports as Imports

1113import Parse.Helpers

12−import Parse.Declaration (infixDecl)

1314import qualified Parse.Module as Module

1415import qualified Parse.Declaration as Decl

15−import Transform.Declaration (combineAnnotations)

16+import qualified Reporting.Region as R

17+import qualified Reporting.Error.Syntax as Error

18+import qualified Reporting.Result as Result

19+import qualified Validate

1620

1721

22+program

23+ :: Bool

24+ -> OpTable

25+ -> String

26+ -> Result.Result wrn Error.Error M.ValidModule

27+program needsDefaults table src =

28+ do (M.Module names filePath exports imports sourceDecls) <-

29+ parseWithTable table src programParser

30+

31+ validDecls <- Validate.declarations sourceDecls

32+

33+ let ammendedImports =

34+ (if needsDefaults then Imports.defaults else [], imports)

35+

36+ return (M.Module names filePath exports ammendedImports validDecls)

37+

38+

39+-- HEADERS AND DECLARATIONS

40+

41+programParser :: IParser M.SourceModule

42+programParser =

43+ do (M.Header names exports imports) <- Module.header

44+ decls <- declarations

45+ optional freshLine

46+ optional spaces

47+ eof

48+ return $ M.Module names "" exports imports decls

49+

50+

51+declarations :: IParser [D.SourceDecl]

52+declarations =

53+ (:) <$> Decl.declaration

54+ <*> many freshDef

55+

56+

57+freshDef :: IParser D.SourceDecl

1858freshDef =

1959 commitIf (freshLine >> (letter <|> char '_')) $

20− do freshLine

21− Decl.declaration <?> "another datatype or variable definition"

60+ do _ <- freshLine

61+ Decl.declaration

2262

2363

24−decls =

25− do d <- Decl.declaration <?> "at least one datatype or variable definition"

26− (d:) <$> many freshDef

64+-- RUN PARSERS

2765

66+parse :: String -> IParser a -> Result.Result wrn Error.Error a

67+parse source parser =

68+ case iParse parser source of

69+ Right result ->

70+ return result

2871

29−program :: OpTable -> String -> Either [P.Doc] M.ValidModule

30−program table src =

31− do (M.Module names filePath exs ims sourceDecls) <-

32− setupParserWithTable table programParser src

72+ Left err ->

73+ let pos = R.fromSourcePos (Parsec.errorPos err)

74+ msgs = Parsec.errorMessages err

75+ in

76+ Result.throw (R.Region pos pos) (Error.Parse msgs)

3377

34− decls <-

35− either (\err -> Left [P.text err]) Right (combineAnnotations sourceDecls)

3678

37− return $ M.Module names filePath exs ims decls

79+parseWithTable

80+ :: OpTable

81+ -> String

82+ -> IParser a

83+ -> Result.Result wrn Error.Error a

84+parseWithTable table source parser =

85+ do infixInfoList <- parse source parseFixities

3886

87+ infixTable <- makeInfixTable table infixInfoList

3988

40−programParser :: IParser M.SourceModule

41−programParser =

42− do (M.HeaderAndImports names exports imports) <- Module.headerAndImports

43− declarations <- decls

44− optional freshLine ; optional spaces ; eof

45− return $ M.Module names "" exports imports declarations

46−

47−

48−setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a

49−setupParserWithTable table p source =

50− do localTable <- setupParser parseFixities source

51− case Map.intersection table localTable of

52− overlap | not (Map.null overlap) -> Left [ msg overlap ]

53− | otherwise ->

54− flip setupParser source $

55− do putState (Map.union table localTable)

56− p

57− where

58− msg overlap =

59− P.vcat

60− [ P.text "Parse error:"

61− , P.text $

62− "Overlapping definitions for infix operators: "

63− ++ List.intercalate " " (Map.keys overlap)

64− ]

89+ parse source $

90+ do putState infixTable

91+ parser

6592

6693

67−parseFixities =

68− do decls <- onFreshLines (:) [] infixDecl

69− return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]

7094

95+-- INFIX INFO

96+

97+makeInfixTable

98+ :: Map.Map String (Int, D.Assoc)

99+ -> [(String, InfixInfo)]

100+ -> Result.Result wrn Error.Error (Map.Map String (Int, D.Assoc))

101+makeInfixTable table newInfo =

102+ let add (op, info) dict =

103+ Map.insertWith (++) op [info] dict

104+

105+ infoTable =

106+ foldr add Map.empty newInfo

107+

108+ check op infoList =

109+ case infoList of

110+ [] ->

111+ error "problem parsing infix declarations, this should never happen"

112+

113+ [InfixInfo region info] ->

114+ if Map.member op table

115+ then Result.throw region (Error.InfixDuplicate op)

116+ else return info

117+

118+ InfixInfo region _ : _ ->

119+ Result.throw region (Error.InfixDuplicate op)

120+ in

121+ Map.union table <$> T.sequenceA (Map.mapWithKey check infoTable)

122+

123+

124+parseFixities :: IParser [(String, InfixInfo)]

125+parseFixities =

126+ onFreshLines (:) [] infics

127+ where

128+ infics =

129+ do start <- getMyPosition

130+ (D.Fixity assoc level op) <- Decl.infixDecl

131+ end <- getMyPosition

132+ return (op, InfixInfo (R.Region start end) (level, assoc))

71133

72−setupParser :: IParser a -> String -> Either [P.Doc] a

73−setupParser p source =

74− case iParse p source of

75− Right result ->

76− Right result

77134

78− Left err ->

79− Left [ P.text $ "Parse error at " ++ show err ]

135+data InfixInfo = InfixInfo

136+ { _region :: R.Region

137+ , _info :: (Int, D.Assoc)

138+ }

src/Parse/Pattern.hs+81−37

@@ -5,64 +5,108 @@ import Data.Char (isUpper)

55import qualified Data.List as List

66import Text.Parsec ((<|>), (<?>), char, choice, optionMaybe, try)

77

8−import Parse.Helpers

9−import qualified Parse.Literal as Literal

108import qualified AST.Literal as L

119import qualified AST.Pattern as P

1210import qualified AST.Variable as Var

11+import Parse.Helpers

12+import qualified Parse.Literal as Literal

13+import qualified Reporting.Annotation as A

14+import qualified Reporting.Region as R

15+

1316

1417basic :: IParser P.RawPattern

15−basic = choice

16− [ char '_' >> return P.Anything

17− , stringToPattern <$> var

18− , P.Literal <$> Literal.literal

19− ]

18+basic =

19+ addLocation $

20+ choice

21+ [ char '_' >> return P.Anything

22+ , stringToPattern <$> var

23+ , P.Literal <$> Literal.literal

24+ ]

2025 where

21− stringToPattern v =

22− case v of

23− "True" -> P.Literal (L.Boolean True)

24− "False" -> P.Literal (L.Boolean False)

25− c:_ | isUpper c -> P.Data (Var.Raw v) []

26− _ -> P.Var v

26+ stringToPattern str =

27+ case str of

28+ "True" ->

29+ P.Literal (L.Boolean True)

30+

31+ "False" ->

32+ P.Literal (L.Boolean False)

33+

34+ c:_ | isUpper c ->

35+ P.Data (Var.Raw str) []

36+

37+ _ ->

38+ P.Var str

39+

40+

41+asPattern :: IParser P.RawPattern -> IParser P.RawPattern

42+asPattern patternParser =

43+ do pattern <- patternParser

2744

45+ let (A.A (R.Region start _) _) = pattern

2846

29−asPattern :: P.RawPattern -> IParser P.RawPattern

30−asPattern pattern =

31− do var <- optionMaybe (try (whitespace >> reserved "as") >> whitespace >> lowVar)

32− case var of

33− Just v ->

34− return (P.Alias v pattern)

47+ maybeAlias <- optionMaybe asAlias

48+

49+ case maybeAlias of

50+ Just alias ->

51+ do end <- getMyPosition

52+ return (A.at start end (P.Alias alias pattern))

3553

3654 Nothing ->

37− return pattern

55+ return pattern

56+ where

57+ asAlias =

58+ do try (whitespace >> reserved "as")

59+ whitespace

60+ lowVar

3861

3962

4063record :: IParser P.RawPattern

41−record = P.Record <$> brackets (commaSep1 lowVar)

64+record =

65+ addLocation

66+ (P.Record <$> brackets (commaSep1 lowVar))

67+

4268

4369tuple :: IParser P.RawPattern

44−tuple = do

45− ps <- parens (commaSep expr)

46− return $ case ps of

47− [p] -> p

48− _ -> P.tuple ps

70+tuple =

71+ do (start, patterns, end) <-

72+ located (parens (commaSep expr))

73+

74+ case patterns of

75+ [pattern] ->

76+ return pattern

77+

78+ _ ->

79+ return (A.at start end (P.tuple patterns))

80+

4981

5082list :: IParser P.RawPattern

51−list = P.list <$> braces (commaSep expr)

83+list =

84+ braces $

85+ do (_, patterns, end) <- located (commaSep expr)

86+ return (P.list end patterns)

87+

5288

5389term :: IParser P.RawPattern

5490term =

55− (choice [ record, tuple, list, basic ]) <?> "pattern"

91+ choice [ record, tuple, list, basic ]

92+ <?> "a pattern"

93+

5694

5795patternConstructor :: IParser P.RawPattern

58−patternConstructor = do

59− v <- List.intercalate "." <$> dotSep1 capVar

60− case v of

61− "True" -> return $ P.Literal (L.Boolean True)

62− "False" -> return $ P.Literal (L.Boolean False)

63− _ -> P.Data (Var.Raw v) <$> spacePrefix term

96+patternConstructor =

97+ addLocation $

98+ do v <- List.intercalate "." <$> dotSep1 capVar

99+ case v of

100+ "True" -> return $ P.Literal (L.Boolean True)

101+ "False" -> return $ P.Literal (L.Boolean False)

102+ _ -> P.Data (Var.Raw v) <$> spacePrefix term

103+

64104

65105expr :: IParser P.RawPattern

66−expr = do

67− patterns <- consSep1 (patternConstructor <|> term)

68− asPattern (foldr1 P.cons patterns) <?> "pattern"

106+expr =

107+ asPattern subPattern <?> "a pattern"

108+ where

109+ subPattern =

110+ do patterns <- consSep1 (patternConstructor <|> term)

111+ end <- getMyPosition

112+ return (P.consMany end patterns)

src/Parse/Type.hs+48−33

@@ -5,26 +5,30 @@ import Control.Applicative ((<$>),(<*>),(<*))

55import Data.List (intercalate)

66import Text.Parsec ((<|>), (<?>), char, many, optionMaybe, string, try)

77

8−import qualified AST.Type as T

8+import qualified AST.Type as Type

99import qualified AST.Variable as Var

1010import Parse.Helpers

11+import qualified Reporting.Annotation as A

12+import qualified Reporting.Region as R

1113

1214

13−tvar :: IParser T.RawType

15+tvar :: IParser Type.Raw

1416tvar =

15− T.Var <$> lowVar <?> "type variable"

17+ addLocation

18+ (Type.RVar <$> lowVar <?> "a type variable")

1619

1720

18−tuple :: IParser T.RawType

21+tuple :: IParser Type.Raw

1922tuple =

20− do ts <- parens (commaSep expr)

21− case ts of

23+ do (start, types, end) <- located (parens (commaSep expr))

24+ case types of

2225 [t] -> return t

23− _ -> return (T.tupleOf ts)

26+ _ -> return (Type.tuple (R.Region start end) types)

2427

2528

26−record :: IParser T.RawType

29+record :: IParser Type.Raw

2730record =

31+ addLocation $

2832 do char '{'

2933 whitespace

3034 rcrd <- extended <|> normal

@@ -32,18 +36,19 @@ record =

3236 char '}'

3337 return rcrd

3438 where

35− normal = flip T.Record Nothing <$> commaSep field

39+ normal = flip Type.RRecord Nothing <$> commaSep field

3640

3741 -- extended record types require at least one field

38− extended = do

39− ext <- try (lowVar <* (whitespace >> string "|"))

40− whitespace

41− flip T.Record (Just (T.Var ext)) <$> commaSep1 field

42+ extended =

43+ do ext <- try (addLocation lowVar <* (whitespace >> string "|"))

44+ whitespace

45+ fields <- commaSep1 field

46+ return (Type.RRecord fields (Just (A.map Type.RVar ext)))

4247

43− field = do

44− lbl <- rLabel

45− whitespace >> hasType >> whitespace

46− (,) lbl <$> expr

48+ field =

49+ do lbl <- rLabel

50+ whitespace >> hasType >> whitespace

51+ (,) lbl <$> expr

4752

4853

4954capTypeVar :: IParser String

@@ -51,41 +56,51 @@ capTypeVar =

5156 intercalate "." <$> dotSep1 capVar

5257

5358

54−constructor0 :: IParser T.RawType

59+constructor0 :: IParser Type.Raw

5560constructor0 =

61+ addLocation $

5662 do name <- capTypeVar

57− return (T.Type (Var.Raw name))

63+ return (Type.RType (Var.Raw name))

5864

5965

60−term :: IParser T.RawType

66+term :: IParser Type.Raw

6167term =

6268 tuple <|> record <|> tvar <|> constructor0

6369

6470

65−app :: IParser T.RawType

71+app :: IParser Type.Raw

6672app =

67− do f <- constructor0 <|> try tupleCtor <?> "type constructor"

73+ do start <- getMyPosition

74+ f <- constructor0 <|> try tupleCtor <?> "a type constructor"

6875 args <- spacePrefix term

76+ end <- getMyPosition

6977 case args of

7078 [] -> return f

71− _ -> return (T.App f args)

79+ _ -> return (A.A (R.Region start end) (Type.RApp f args))

7280 where

73− tupleCtor = do

74− n <- length <$> parens (many (char ','))

75− let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)

76− return (T.Type (Var.Raw ctor))

81+ tupleCtor =

82+ addLocation $

83+ do n <- length <$> parens (many (char ','))

84+ let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)

85+ return (Type.RType (Var.Raw ctor))

7786

7887

79−expr :: IParser T.RawType

88+expr :: IParser Type.Raw

8089expr =

81− do t1 <- app <|> term

82− arr <- optionMaybe $ try (whitespace >> arrow)

90+ do start <- getMyPosition

91+ t1 <- app <|> term

92+ arr <- optionMaybe $ try (whitespace >> rightArrow)

8393 case arr of

84− Just _ -> T.Lambda t1 <$> (whitespace >> expr)

85− Nothing -> return t1

94+ Nothing ->

95+ return t1

96+ Just _ ->

97+ do whitespace

98+ t2 <- expr

99+ end <- getMyPosition

100+ return (A.A (R.Region start end) (Type.RLambda t1 t2))

86101

87102

88−constructor :: IParser (String, [T.RawType])

103+constructor :: IParser (String, [Type.Raw])

89104constructor =

90105 (,) <$> (capTypeVar <?> "another type constructor")

91106 <*> spacePrefix term

src/Reporting/Annotation.hsnew file+52

@@ -0,0 +1,52 @@

1+module Reporting.Annotation where

2+

3+import Prelude hiding (map)

4+import qualified Reporting.PrettyPrint as P

5+import qualified Reporting.Region as R

6+

7+

8+-- ANNOTATION

9+

10+data Annotated annotation a

11+ = A annotation a

12+ deriving (Show)

13+

14+

15+type Located a =

16+ Annotated R.Region a

17+

18+

19+-- CREATE

20+

21+at :: R.Position -> R.Position -> a -> Located a

22+at start end value =

23+ A (R.Region start end) value

24+

25+

26+merge :: Located a -> Located b -> value -> Located value

27+merge (A region1 _) (A region2 _) value =

28+ A (R.merge region1 region2) value

29+

30+

31+sameAs :: Annotated info a -> b -> Annotated info b

32+sameAs (A annotation _) value =

33+ A annotation value

34+

35+

36+-- MANIPULATE

37+

38+map :: (a -> b) -> Annotated info a -> Annotated info b

39+map f (A annotation value) =

40+ A annotation (f value)

41+

42+

43+drop :: Annotated info a -> a

44+drop (A _ value) =

45+ value

46+

47+

48+-- PRETTY PRINT

49+

50+instance (P.Pretty a) => P.Pretty (Annotated info a) where

51+ pretty parens (A _ value) =

52+ P.pretty parens value

src/Reporting/Error.hsnew file+35

@@ -0,0 +1,35 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Reporting.Error where

3+

4+import qualified Reporting.Annotation as A

5+import qualified Reporting.Error.Canonicalize as Canonicalize

6+import qualified Reporting.Error.Syntax as Syntax

7+import qualified Reporting.Error.Type as Type

8+import qualified Reporting.Report as Report

9+

10+

11+-- ALL POSSIBLE ERRORS

12+

13+data Error

14+ = Syntax Syntax.Error

15+ | Canonicalize Canonicalize.Error

16+ | Type Type.Error

17+

18+

19+-- TO STRING

20+

21+toString :: String -> String -> A.Located Error -> String

22+toString location source (A.A region err) =

23+ let

24+ report =

25+ case err of

26+ Syntax syntaxError ->

27+ Syntax.toReport syntaxError

28+

29+ Canonicalize canonicalizeError ->

30+ Canonicalize.toReport canonicalizeError

31+

32+ Type typeError ->

33+ Type.toReport typeError

34+ in

35+ Report.toString location region report source

src/Reporting/Error/Canonicalize.hsnew file+259

@@ -0,0 +1,259 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Reporting.Error.Canonicalize where

4+

5+import Data.Function (on)

6+import qualified Data.List as List

7+import qualified Text.EditDistance as Dist

8+import qualified Text.PrettyPrint as P

9+

10+import qualified AST.Module as Module

11+import qualified AST.Type as Type

12+import qualified AST.Variable as Var

13+import Elm.Utils ((|>))

14+import qualified Reporting.PrettyPrint as P

15+import qualified Reporting.Region as Region

16+import qualified Reporting.Report as Report

17+

18+

19+data Error

20+ = Var VarError

21+ | Pattern PatternError

22+ | Alias AliasError

23+ | Import Module.Name ImportError

24+ | Export String [String]

25+ | Port PortError

26+

27+

28+-- VARIABLES

29+

30+data VarError = VarError

31+ { varKind :: String

32+ , varName :: String

33+ , varProblem :: VarProblem

34+ , varSuggestions :: [String]

35+ }

36+

37+

38+data VarProblem

39+ = Ambiguous

40+ | UnknownQualifier String

41+ | QualifiedUnknown String

42+ | ExposedUnknown

43+

44+

45+variable :: String -> String -> VarProblem -> [String] -> Error

46+variable kind name problem suggestions =

47+ Var (VarError kind name problem suggestions)

48+

49+

50+-- PATTERN

51+

52+data PatternError

53+ = PatternArgMismatch Var.Canonical Int Int

54+

55+

56+argMismatch :: Var.Canonical -> Int -> Int -> Error

57+argMismatch name expected actual =

58+ Pattern (PatternArgMismatch name expected actual)

59+

60+

61+-- IMPORTS

62+

63+data ImportError

64+ = ModuleNotFound [Module.Name]

65+ | ValueNotFound String [String]

66+

67+

68+moduleNotFound :: Module.Name -> [Module.Name] -> Error

69+moduleNotFound name possibilities =

70+ Import name (ModuleNotFound possibilities)

71+

72+

73+valueNotFound :: Module.Name -> String -> [String] -> Error

74+valueNotFound name value possibilities =

75+ Import name (ValueNotFound value possibilities)

76+

77+

78+-- ALIASES

79+

80+data AliasError

81+ = ArgMismatch Var.Canonical Int Int

82+ | SelfRecursive String [String] Type.Raw

83+ | MutuallyRecursive [(Region.Region, String, [String], Type.Raw)]

84+

85+

86+alias :: Var.Canonical -> Int -> Int -> Error

87+alias name expected actual =

88+ Alias (ArgMismatch name expected actual)

89+

90+

91+-- PORTS

92+

93+data PortError = PortError

94+ { portName :: String

95+ , portIsInbound :: Bool

96+ , portRootType :: Type.Canonical

97+ , portLocalType :: Type.Canonical

98+ , portMessage :: Maybe String

99+ }

100+

101+

102+port

103+ :: String

104+ -> Bool

105+ -> Type.Canonical

106+ -> Type.Canonical

107+ -> Maybe String

108+ -> Error

109+port name isInbound rootType localType maybeMessage =

110+ Port (PortError name isInbound rootType localType maybeMessage)

111+

112+

113+-- NEARBY NAMES

114+

115+nearbyNames :: (a -> String) -> a -> [a] -> [a]

116+nearbyNames format name names =

117+ let editDistance =

118+ if length (format name) < 3 then 1 else 2

119+ in

120+ names

121+ |> map (\x -> (distance (format name) (format x), x))

122+ |> List.sortBy (compare `on` fst)

123+ |> filter ( (<= editDistance) . abs . fst )

124+ |> map snd

125+

126+

127+distance :: String -> String -> Int

128+distance x y =

129+ Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y

130+

131+

132+-- TO REPORT

133+

134+namingError :: String -> String -> Report.Report

135+namingError pre post =

136+ Report.simple "NAMING ERROR" pre post

137+

138+

139+toReport :: Error -> Report.Report

140+toReport err =

141+ case err of

142+ Var (VarError kind name problem suggestions) ->

143+ let var = kind ++ " '" ++ name ++ "'"

144+ in

145+ case problem of

146+ Ambiguous ->

147+ namingError

148+ ("This usage of " ++ var ++ " is ambiguous.")

149+ (maybeYouWant suggestions)

150+

151+ UnknownQualifier qualifier ->

152+ namingError

153+ ("Cannot find " ++ var ++ ", qualifier '" ++ qualifier ++ "' is not in scope.")

154+ (maybeYouWant suggestions)

155+

156+ QualifiedUnknown qualifier ->

157+ namingError

158+ ("Cannot find " ++ var ++ ", module '" ++ qualifier ++ "' does not expose that value.")

159+ (maybeYouWant suggestions)

160+

161+ ExposedUnknown ->

162+ namingError

163+ ("Cannot find " ++ var)

164+ (maybeYouWant suggestions)

165+

166+ Pattern patternError ->

167+ case patternError of

168+ PatternArgMismatch var expected actual ->

169+ argMismatchReport "Pattern" var expected actual

170+

171+ Alias aliasError ->

172+ case aliasError of

173+ ArgMismatch var expected actual ->

174+ argMismatchReport "Type" var expected actual

175+

176+ SelfRecursive name tvars tipe ->

177+ Report.simple "ALIAS PROBLEM" "This type alias is recursive, forming an infinite type!" $

178+ "Type aliases are just names for more fundamental types, so I go through\n"

179+ ++ "and expand them all to know the real underlying type. The problem is that\n"

180+ ++ "when I expand a recursive type alias, it keeps getting bigger and bigger.\n"

181+ ++ "Dealiasing results in an infinitely large type! Try this instead:\n\n"

182+ ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="

183+ ++ P.render (P.nest 8 (P.hang (P.text name) 2 (P.pretty True tipe)))

184+ ++ "\n\nThis creates a brand new type that cannot be expanded. It is similar types\n"

185+ ++ "like List which are recursive, but do not get expanded into infinite types."

186+

187+ MutuallyRecursive aliases ->

188+ Report.simple "ALIAS PROBLEM" "This type alias is part of a mutually recursive set of type aliases." $

189+ "The following type aliases all depend on each other in some way:\n"

190+ ++ concatMap showName aliases ++ "\n\n"

191+ ++ "The problem is that when you try to expand any of these type aliases, they\n"

192+ ++ "expand infinitely! To fix, first try to centralize them into one alias."

193+ where

194+ showName (Region.Region start _, name, _, _) =

195+ "\n " ++ name ++ replicate (65 - length name) ' '

196+ ++ "line " ++ show (Region.line start)

197+

198+ Import name importError ->

199+ let moduleName = Module.nameToString name

200+ in

201+ case importError of

202+ ModuleNotFound suggestions ->

203+ namingError

204+ ("Could not find a module named '" ++ moduleName ++ "'")

205+ (maybeYouWant (map Module.nameToString suggestions))

206+

207+ ValueNotFound value suggestions ->

208+ namingError

209+ ("Module '" ++ moduleName ++ "' does not expose '" ++ value ++ "'")

210+ (maybeYouWant suggestions)

211+

212+ Export name suggestions ->

213+ namingError

214+ ("Could not export '" ++ name ++ "' which is not defined in this module.")

215+ (maybeYouWant suggestions)

216+

217+ Port (PortError name isInbound _rootType localType maybeMessage) ->

218+ let

219+ boundPort =

220+ if isInbound then "inbound port" else "outbound port"

221+

222+ preHint =

223+ "Trying to send " ++ maybe "an unsupported type" id maybeMessage

224+ ++ " through " ++ boundPort ++ " '" ++ name ++ "'"

225+

226+ postHint =

227+ "The specific unsupported type is:\n\n"

228+ ++ P.render (P.nest 4 (P.pretty False localType)) ++ "\n\n"

229+ ++ "The types of values that can flow through " ++ boundPort ++ "s include:\n"

230+ ++ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples,\n"

231+ ++ "Json.Values, and concrete records."

232+ in

233+ Report.simple "PORT ERROR" preHint postHint

234+

235+

236+argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report

237+argMismatchReport kind var expected actual =

238+ let

239+ preHint =

240+ kind ++ " " ++ Var.toString var ++ " has too "

241+ ++ (if actual < expected then "few" else "many")

242+ ++ "arguments."

243+

244+ postHint =

245+ "Expecting " ++ show expected ++ ", but got " ++ show actual ++ "."

246+ in

247+ Report.simple "ARGUMENT" preHint postHint

248+

249+

250+maybeYouWant :: [String] -> String

251+maybeYouWant suggestions =

252+ case suggestions of

253+ [] ->

254+ ""

255+

256+ _:_ ->

257+ "Maybe you want one of the following?\n"

258+ ++ concatMap ("\n "++) suggestions

259+

src/Reporting/Error/Syntax.hsnew file+220

@@ -0,0 +1,220 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Error.Syntax where

3+

4+import qualified Data.List as List

5+import qualified Data.Set as Set

6+import qualified Text.Parsec.Error as Parsec

7+import qualified Text.PrettyPrint as P

8+import Text.PrettyPrint ((<+>))

9+

10+import qualified AST.Helpers as Help

11+import qualified AST.Type as Type

12+import Elm.Utils ((|>))

13+import qualified Reporting.PrettyPrint as P

14+import qualified Reporting.Report as Report

15+

16+

17+data Error

18+ = Parse [Parsec.Message]

19+ | InfixDuplicate String

20+ | TypeWithoutDefinition String

21+ | PortWithoutAnnotation String

22+ | DuplicateValueDeclaration String

23+ | DuplicateTypeDeclaration String

24+ | DuplicateDefinition String

25+ | UnboundTypeVarsInAlias String [String] String [String] Type.Raw

26+ | UnboundTypeVarsInUnion String [String] String [String] [(String, [Type.Raw])]

27+

28+

29+-- TO REPORT

30+

31+toReport :: Error -> Report.Report

32+toReport err =

33+ case err of

34+ Parse messages ->

35+ parseErrorReport messages

36+

37+ InfixDuplicate opName ->

38+ Report.simple

39+ "INFIX OVERLAP"

40+ ("The infix declarations for " ++ operator ++ " must be removed.")

41+ ("The precedence and associativity can only be set in one place, and\n"

42+ ++ "this information has already been set somewhere else."

43+ )

44+ where

45+ operator =

46+ if Help.isOp opName

47+ then "(" ++ opName ++ ")"

48+ else "`" ++ opName ++ "`"

49+

50+ TypeWithoutDefinition valueName ->

51+ Report.simple

52+ "MISSING DEFINITION"

53+ ("There is a type annotation for '" ++ valueName ++ "' but there"

54+ ++ "is no corresponding definition!"

55+ )

56+ ("Directly below the type annotation, put a definition like:\n\n"

57+ ++ " " ++ valueName ++ " = 42"

58+ )

59+

60+ PortWithoutAnnotation portName ->

61+ Report.simple

62+ "PORT ERROR"

63+ ("Port '" ++ portName ++ "' does not have a type annotation!")

64+ ("Directly above the port definition, I need something like this:\n\n"

65+ ++ " port " ++ portName ++ " : Signal Int"

66+ )

67+

68+ DuplicateValueDeclaration name ->

69+ Report.simple

70+ "DUPLICATE DEFINITION"

71+ ("Naming multiple top-level values '" ++ name ++ "' makes things\n"

72+ ++ "ambiguous. When you say '" ++ name ++ "' which one do you want?!"

73+ )

74+ ("Find all the top-level values named '" ++ name ++ "' and\n"

75+ ++ "do some renaming. Make sure the names are distinct!"

76+ )

77+

78+ DuplicateTypeDeclaration name ->

79+ Report.simple

80+ "DUPLICATE DEFINITION"

81+ ("Naming multiple types '" ++ name ++ "' makes things ambiguous\n"

82+ ++ "When you say '" ++ name ++ "' which one do you want?!"

83+ )

84+ ("Find all the types named '" ++ name ++ "' and\n"

85+ ++ "do some renaming. Make sure the names are distinct!"

86+ )

87+

88+ DuplicateDefinition name ->

89+ Report.simple

90+ "DUPLICATE DEFINITION"

91+ ("Naming multiple values '" ++ name ++ "' in a single let-expression makes\n"

92+ ++ "things ambiguous. When you say '" ++ name ++ "' which one do you want?!"

93+ )

94+ ("Find all the values named '" ++ name ++ "' in this let-expression and\n"

95+ ++ "do some renaming. Make sure the names are distinct!"

96+ )

97+

98+ UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->

99+ unboundTypeVars typeName tvar tvars $ P.render $

100+ P.hang

101+ (P.text "type alias" <+> P.text typeName <+> P.hsep vars <+> P.equals)

102+ 4

103+ (P.pretty False tipe)

104+ where

105+ vars = map P.text (givenVars ++ tvar : tvars)

106+

107+

108+ UnboundTypeVarsInUnion typeName givenVars tvar tvars ctors ->

109+ unboundTypeVars typeName tvar tvars $ P.render $

110+ P.vcat

111+ [ P.text "type" <+> P.text typeName <+> P.hsep vars

112+ , map toDoc ctors

113+ |> zipWith (<+>) (P.text "=" : repeat (P.text "|"))

114+ |> P.vcat

115+ |> P.nest 4

116+ ]

117+ where

118+ vars = map P.text (givenVars ++ tvar : tvars)

119+ toDoc (ctor, args) =

120+ P.text ctor <+> P.hsep (map (P.pretty True) args)

121+

122+

123+unboundTypeVars :: String -> String -> [String] -> String -> Report.Report

124+unboundTypeVars typeName tvar tvars revisedDeclaration =

125+ Report.simple

126+ "UNBOUND TYPE VARS"

127+ ( "Not all type variables in '" ++ typeName ++ "' are listed, making sneaky\n"

128+ ++ "type errors possible. Unbound type variables include: "

129+ ++ List.intercalate ", " (tvar:tvars)

130+ )

131+ ( "You probably want this definition instead:\n"

132+ ++ concatMap ("\n "++) (lines revisedDeclaration) ++ "\n\n"

133+ ++ "Here's why. Imagine one '" ++ typeName ++ "' where '" ++ tvar ++ "' is an Int and\n"

134+ ++ "another where it is a Bool. When we explicitly list the type variables, type\n"

135+ ++ "checker can see that they are actually different types."

136+ )

137+

138+

139+-- TAGGING PARSE ERRORS

140+

141+newline :: String

142+newline = "NEWLINE"

143+

144+freshLine :: String

145+freshLine = "FRESH_LINE"

146+

147+whitespace :: String

148+whitespace = "WHITESPACE"

149+

150+keyword :: String -> String

151+keyword kwd =

152+ "KEYWORD=" ++ kwd

153+

154+unkeyword :: String -> Maybe String

155+unkeyword message =

156+ if List.isPrefixOf "KEYWORD=" message

157+ then Just (drop (length "KEYWORD=") message)

158+ else Nothing

159+

160+

161+-- REPORTING PARSE ERRORS

162+

163+parseErrorReport :: [Parsec.Message] -> Report.Report

164+parseErrorReport messages =

165+ let

166+ addMsg message hint =

167+ case message of

168+ Parsec.SysUnExpect _msg ->

169+ hint

170+

171+ Parsec.UnExpect _msg ->

172+ hint

173+

174+ Parsec.Expect msg ->

175+ let

176+ msg' =

177+ if msg `elem` [whitespace, newline, freshLine]

178+ then "whitespace"

179+ else msg

180+ in

181+ hint { _expected = Set.insert msg' (_expected hint) }

182+

183+ Parsec.Message msg ->

184+ hint { _messages = msg : _messages hint }

185+

186+ (ParseHint msgs expects) =

187+ foldr addMsg emptyHint messages

188+

189+ preHint =

190+ case msgs of

191+ [msg] ->

192+ case unkeyword msg of

193+ Just kwd ->

194+ "It looks like the keyword '" ++ kwd ++ "' is being used as a variable.\n"

195+ ++ "Try renaming it to something else."

196+ Nothing ->

197+ msg

198+

199+ _ -> "I ran into something unexpected when parsing your code!"

200+

201+ postHint =

202+ if Set.null expects

203+ then ""

204+ else

205+ "I am looking for one of the following things:\n"

206+ ++ concatMap ("\n "++) (Set.toList expects)

207+ in

208+ Report.simple "SYNTAX PROBLEM" preHint postHint

209+

210+

211+data ParseHint = ParseHint

212+ { _messages :: [String]

213+ , _expected :: Set.Set String

214+ }

215+ deriving (Show)

216+

217+

218+emptyHint :: ParseHint

219+emptyHint =

220+ ParseHint [] Set.empty

src/Reporting/Error/Type.hsnew file+137

@@ -0,0 +1,137 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Error.Type where

3+

4+import qualified Text.PrettyPrint as P

5+

6+import qualified AST.Type as Type

7+import qualified Reporting.PrettyPrint as P

8+import qualified Reporting.Region as Region

9+import qualified Reporting.Report as Report

10+

11+

12+data Error

13+ = Mismatch Mismatch

14+ | InfiniteType String Type.Canonical

15+ | BadMain Type.Canonical

16+

17+

18+data Mismatch = MismatchInfo

19+ { _hint :: Hint

20+ , _leftType :: Type.Canonical

21+ , _rightType :: Type.Canonical

22+ , _note :: Note

23+ }

24+

25+

26+data Hint

27+ = None

28+ | CaseBranch Int Region.Region

29+ | Case

30+ | IfBranches

31+ | MultiIfBranch Int Region.Region

32+ | If

33+ | List

34+ | ListElement Int Region.Region

35+

36+

37+data Note

38+ = PreNote String

39+ | NoNote

40+ | PostNote String

41+

42+

43+-- TO REPORT

44+

45+toReport :: Error -> Report.Report

46+toReport err =

47+ case err of

48+ Mismatch (MismatchInfo hint leftType rightType note) ->

49+ let

50+ (subRegion, preHint) = hintToString hint

51+

52+ postHint =

53+ "To be more specific, as I infer all the types, I am seeing a conflict between\n"

54+ ++ "this type:\n\n"

55+ ++ P.render (P.nest 4 (P.pretty False leftType))

56+ ++ "\n\nand this type:\n\n"

57+ ++ P.render (P.nest 4 (P.pretty False rightType))

58+ in

59+ case note of

60+ PreNote msg ->

61+ Report.Report "TYPE MISMATCH" subRegion (preHint ++ "\n\n" ++ msg) postHint

62+

63+ NoNote ->

64+ Report.Report "TYPE MISMATCH" subRegion preHint postHint

65+

66+ PostNote msg ->

67+ Report.Report "TYPE MISMATCH" subRegion preHint (postHint ++ "\n\n" ++ msg)

68+

69+ InfiniteType var tipe ->

70+ Report.simple "INFINITE TYPE" "This expression is leading me to infer an infinite type." $

71+ "Maybe you are trying to do some tricky recursion? Try breaking the expression\n"

72+ ++ "into smaller pieces. Give each piece a name and try to write down its type.\n\n"

73+ ++ "Type inference got stuck when type '" ++ var ++ "' needed equal to:\n\n"

74+ ++ P.render (P.nest 4 (P.pretty False tipe))

75+ ++ "\n\nNotice that type variable '" ++ var ++ "' appears there too, so if we\n"

76+ ++ "expanded this type, it would just keep getting bigger and bigger."

77+

78+ BadMain tipe ->

79+ Report.simple "BAD MAIN TYPE" "The 'main' value has an unsupported type." $

80+ "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\n"

81+ ++ "on screen, but you gave me:\n\n"

82+ ++ P.render (P.nest 4 (P.pretty False tipe))

83+

84+

85+hintToString :: Hint -> (Maybe Region.Region, String)

86+hintToString hint =

87+ case hint of

88+ None ->

89+ ( Nothing

90+ , "This expression is triggering a type mismatch."

91+ )

92+

93+ CaseBranch branchNumber region ->

94+ ( Just region

95+ , "The branches of this case-expression return different types of values.\n\n"

96+ ++ "I noticed the mismatch in branch #" ++ show branchNumber ++ ", but go through and make sure every\n"

97+ ++ "branch returns the same type of value."

98+ )

99+

100+ Case ->

101+ ( Nothing

102+ , "All the branches of this case-expression are consistent, but the overall\n"

103+ ++ "type does not match how it is used elsewhere."

104+ )

105+

106+ IfBranches ->

107+ ( Nothing

108+ , "The branches of this if-expression return different types of values.\n"

109+ ++ "All branches must have the same return type!"

110+ )

111+

112+ MultiIfBranch branchNumber region ->

113+ ( Just region

114+ , "The branches of this if-expression return different types of values.\n\n"

115+ ++ "I noticed the mismatch in branch #" ++ show branchNumber ++ ", but go through and make sure every\n"

116+ ++ "branch returns the same type of value."

117+ )

118+

119+ If ->

120+ ( Nothing

121+ , "All the branches of this if-expression are consistent, but the overall\n"

122+ ++ "type does not match how it is used elsewhere."

123+ )

124+

125+ ListElement elementNumber region ->

126+ ( Just region

127+ , "Not all elements of this list are the same type of value.\n\n"

128+ ++ "I noticed the mismatch in element #" ++ show elementNumber ++ ", but go through and make sure every\n"

129+ ++ "element is the same type of value."

130+ )

131+

132+ List ->

133+ ( Nothing

134+ , "All the elements in this list are the same type, but the overall\n"

135+ ++ "type does not match how it is used elsewhere."

136+ )

137+

src/Reporting/PrettyPrint.hsnew file+34

@@ -0,0 +1,34 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+module Reporting.PrettyPrint where

3+

4+import Text.PrettyPrint as P

5+import qualified AST.Helpers as Help

6+

7+

8+class Pretty a where

9+ pretty :: Bool -> a -> Doc

10+

11+

12+instance Pretty String where

13+ pretty _ str =

14+ P.text str

15+

16+

17+commaCat :: [Doc] -> Doc

18+commaCat docs =

19+ cat (punctuate comma docs)

20+

21+

22+commaSep :: [Doc] -> Doc

23+commaSep docs =

24+ sep (punctuate comma docs)

25+

26+

27+parensIf :: Bool -> Doc -> Doc

28+parensIf bool doc =

29+ if bool then parens doc else doc

30+

31+

32+variable :: String -> Doc

33+variable x =

34+ if Help.isOp x then parens (text x) else text x

src/Reporting/Region.hsnew file+64

@@ -0,0 +1,64 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Reporting.Region where

3+

4+import Data.Aeson ((.=))

5+import qualified Data.Aeson as Json

6+import qualified Text.Parsec.Pos as Parsec

7+

8+

9+data Region = Region

10+ { start :: Position

11+ , end :: Position

12+ }

13+ deriving (Show)

14+

15+

16+data Position = Position

17+ { line :: Int

18+ , column :: Int

19+ }

20+ deriving (Show)

21+

22+

23+fromSourcePos :: Parsec.SourcePos -> Position

24+fromSourcePos sourcePos =

25+ Position

26+ (Parsec.sourceLine sourcePos)

27+ (Parsec.sourceColumn sourcePos)

28+

29+

30+merge :: Region -> Region -> Region

31+merge (Region start _) (Region _ end) =

32+ Region start end

33+

34+

35+-- TO STRING

36+

37+toString :: Region -> String

38+toString (Region start end) =

39+ case line start == line end of

40+ False ->

41+ "between lines " ++ show (line start)

42+ ++ " and " ++ show (line end)

43+

44+ True ->

45+ "on line " ++ show (line end) ++ ", column "

46+ ++ show (column start) ++ " to " ++ show (column end)

47+

48+

49+-- JSON

50+

51+instance Json.ToJSON Region where

52+ toJSON (Region start end) =

53+ Json.object

54+ [ "start" .= start

55+ , "end" .= end

56+ ]

57+

58+

59+instance Json.ToJSON Position where

60+ toJSON (Position line column) =

61+ Json.object

62+ [ "line" .= line

63+ , "column" .= column

64+ ]

src/Reporting/Report.hsnew file+133

@@ -0,0 +1,133 @@

1+module Reporting.Report

2+ ( Report(Report)

3+ , simple

4+ , toString

5+ ) where

6+

7+import Elm.Utils ((|>))

8+import qualified Reporting.Region as R

9+

10+

11+data Report = Report

12+ { title :: String

13+ , highlight :: Maybe R.Region

14+ , preHint :: String

15+ , postHint :: String

16+ }

17+

18+

19+simple :: String -> String -> String -> Report

20+simple title pre post =

21+ Report title Nothing pre post

22+

23+

24+toString :: String -> R.Region -> Report -> String -> String

25+toString location region report source =

26+ concat

27+ [ messageBar (title report) location

28+ , preHint report ++ "\n\n"

29+ , grabRegion (highlight report) region source ++ "\n"

30+ , postHint report ++ "\n\n\n"

31+ ]

32+

33+

34+-- REPORT HEADER

35+

36+messageBar :: String -> String -> String

37+messageBar tag location =

38+ let usedSpace = 4 + length tag + 1 + length location

39+ in

40+ "-- " ++ tag ++ " "

41+ ++ replicate (max 1 (80 - usedSpace)) '-'

42+ ++ " " ++ location ++ "\n\n"

43+

44+

45+-- REGIONS

46+

47+grabRegion :: Maybe R.Region -> R.Region -> String -> String

48+grabRegion maybeSubRegion (R.Region start end) source =

49+ let

50+ (R.Position startLine startColumn) = start

51+ (R.Position endLine endColumn) = end

52+

53+ relevantLines =

54+ lines source

55+ |> drop (startLine - 1)

56+ |> take (endLine - startLine + 1)

57+ in

58+ case relevantLines of

59+ [] ->

60+ ""

61+

62+ [sourceLine] ->

63+ singleLineRegion startLine sourceLine $

64+ case maybeSubRegion of

65+ Nothing ->

66+ (0, startColumn, endColumn, length sourceLine)

67+

68+ Just (R.Region s e) ->

69+ (startColumn, R.column s, R.column e, endColumn)

70+

71+ firstLine : rest ->

72+ let

73+ filteredFirstLine =

74+ replicate (startColumn - 1) ' '

75+ ++ drop (startColumn - 1) firstLine

76+

77+ filteredLastLine =

78+ take (endColumn) (last rest)

79+

80+ focusedRelevantLines =

81+ filteredFirstLine : init rest ++ [filteredLastLine]

82+

83+ lineNumbersWidth =

84+ length (show (endLine + 1))

85+

86+ numberedLines =

87+ zipWith

88+ (addLineNumber maybeSubRegion lineNumbersWidth)

89+ [startLine - 1 .. endLine + 1]

90+ ("" : focusedRelevantLines ++ [""])

91+ in

92+ unlines numberedLines

93+

94+

95+addLineNumber :: Maybe R.Region -> Int -> Int -> String -> String

96+addLineNumber maybeSubRegion width n line =

97+ let

98+ number =

99+ if n < 0 then " " else show n

100+

101+ spacer (R.Region start end) =

102+ if R.line start <= n && n <= R.line end

103+ then ">"

104+ else " "

105+ in

106+ replicate (width - length number) ' ' ++ number

107+ ++ "|" ++ maybe " " spacer maybeSubRegion

108+ ++ line

109+

110+

111+singleLineRegion :: Int -> String -> (Int, Int, Int, Int) -> String

112+singleLineRegion lineNum sourceLine (start, innerStart, innerEnd, end) =

113+ let

114+ w = length (show (lineNum + 1))

115+

116+ number =

117+ addLineNumber Nothing w

118+

119+ underline =

120+ replicate (innerStart - 1) ' '

121+ ++ replicate (max 1 (innerEnd - innerStart)) '^'

122+

123+ trimmedSourceLine =

124+ sourceLine

125+ |> drop (start - 1)

126+ |> take (end - start + 1)

127+ |> (++) (replicate (start - 1) ' ')

128+ in

129+ unlines

130+ [ number (lineNum-1) ""

131+ , number lineNum trimmedSourceLine

132+ , number (lineNum+1) underline

133+ ]

src/Reporting/Result.hsnew file+113

@@ -0,0 +1,113 @@

1+module Reporting.Result where

2+

3+import qualified Control.Applicative as A

4+import qualified Control.Monad as M

5+import Control.Monad.Except (Except, runExcept)

6+

7+import qualified Reporting.Annotation as A

8+import qualified Reporting.Region as R

9+

10+

11+-- TASK

12+

13+data Result warning error result =

14+ Result [A.Located warning] (RawResult [A.Located error] result)

15+

16+data RawResult e a

17+ = Ok a

18+ | Err e

19+

20+

21+-- HELPERS

22+

23+ok :: a -> Result w e a

24+ok value =

25+ Result [] (Ok value)

26+

27+

28+throw :: R.Region -> e -> Result w e a

29+throw region err =

30+ Result [] (Err [A.A region err])

31+

32+

33+throwMany :: [A.Located e] -> Result w e a

34+throwMany errors =

35+ Result [] (Err errors)

36+

37+

38+from :: (e -> e') -> Except [A.Located e] a -> Result w e' a

39+from f except =

40+ case runExcept except of

41+ Right answer ->

42+ ok answer

43+

44+ Left errors ->

45+ throwMany (map (A.map f) errors)

46+

47+

48+mapError :: (e -> e') -> Result w e a -> Result w e' a

49+mapError f (Result warnings rawResult) =

50+ Result warnings $

51+ case rawResult of

52+ Ok v ->

53+ Ok v

54+

55+ Err msgs ->

56+ Err (map (A.map f) msgs)

57+

58+

59+warn :: R.Region -> w -> Result w e ()

60+warn region warning =

61+ Result [A.A region warning] (Ok ())

62+

63+

64+addWarnings :: [A.Located w] -> Result w e a -> Result w e a

65+addWarnings newWarnings (Result warnings rawResult) =

66+ Result (newWarnings ++ warnings) rawResult

67+

68+

69+-- EXTRA FANCY HELPERS

70+

71+instance M.Functor (Result w e) where

72+ fmap func (Result warnings rawResult) =

73+ case rawResult of

74+ Ok a ->

75+ Result warnings (Ok (func a))

76+

77+ Err msgs ->

78+ Result warnings (Err msgs)

79+

80+

81+instance A.Applicative (Result w e) where

82+ pure value =

83+ ok value

84+

85+ (<*>) (Result warnings resultFunc) (Result warnings' resultVal) =

86+ Result (warnings ++ warnings') $

87+ case (resultFunc, resultVal) of

88+ (Ok func, Ok val) ->

89+ Ok (func val)

90+

91+ (Err msgs, Err msgs') ->

92+ Err (msgs ++ msgs')

93+

94+ (Err msgs, _) ->

95+ Err msgs

96+

97+ (_, Err msgs) ->

98+ Err msgs

99+

100+

101+instance M.Monad (Result w e) where

102+ return value =

103+ ok value

104+

105+ (>>=) (Result warnings rawResult) callback =

106+ case rawResult of

107+ Err msg ->

108+ Result warnings (Err msg)

109+

110+ Ok value ->

111+ let (Result warnings' rawResult') = callback value

112+ in

113+ Result (warnings ++ warnings') rawResult'

src/Reporting/Warning.hsnew file+9

@@ -0,0 +1,9 @@

1+module Reporting.Warning where

2+

3+import qualified AST.Module as Module

4+import qualified AST.Type as Type

5+

6+

7+data Warning

8+ = UnusedImport Module.Name

9+ | MissingTypeAnnotation String Type.Canonical

src/Transform/Canonicalize.hsdeleted−349

@@ -1,349 +0,0 @@

1−module Transform.Canonicalize (module') where

2−

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

4−import Control.Monad.Error (runErrorT, throwError)

5−import Control.Monad.State (runState)

6−import qualified Data.List as List

7−import qualified Data.Map as Map

8−import qualified Data.Set as Set

9−import qualified Data.Traversable as T

10−

11−import AST.Expression.General (Expr'(..), dummyLet)

12−import qualified AST.Expression.General as E

13−import qualified AST.Expression.Valid as Valid

14−import qualified AST.Expression.Canonical as Canonical

15−

16−import AST.Module (CanonicalBody(..))

17−import qualified AST.Module as Module

18−import qualified AST.Type as Type

19−import qualified AST.Variable as Var

20−import qualified AST.Annotation as A

21−import qualified AST.Declaration as D

22−import AST.PrettyPrint (pretty, commaSep)

23−import qualified AST.Pattern as P

24−import Text.PrettyPrint as P

25−

26−import qualified Transform.Canonicalize.Environment as Env

27−import qualified Transform.Canonicalize.Setup as Setup

28−import qualified Transform.Canonicalize.Type as Canonicalize

29−import qualified Transform.Canonicalize.Variable as Canonicalize

30−import qualified Transform.Canonicalize.Port as Port

31−import qualified Transform.SortDefinitions as Transform

32−import qualified Transform.Declaration as Transform

33−

34−

35−module'

36− :: Module.Interfaces

37− -> Module.ValidModule

38− -> Either [Doc] Module.CanonicalModule

39−module' interfaces modul =

40− filterImports <$> modul'

41− where

42− (modul', usedModules) =

43− runState (runErrorT (moduleHelp interfaces modul)) Set.empty

44−

45− filterImports m =

46− let used (name,_) = Set.member name usedModules

47− in

48− m { Module.imports = filter used (Module.imports m) }

49−

50−

51−moduleHelp

52− :: Module.Interfaces

53− -> Module.ValidModule

54− -> Env.Canonicalizer [Doc] Module.CanonicalModule

55−moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =

56− do env <- Setup.environment interfaces modul

57− canonicalDecls <- mapM (declaration env) decls

58− exports' <- resolveExports locals exports

59− return $ modul

60− { Module.exports = exports'

61− , Module.body = body canonicalDecls

62− }

63− where

64− locals :: [Var.Value]

65− locals = concatMap declToValue decls

66−

67− body :: [D.CanonicalDecl] -> Module.CanonicalBody

68− body decls =

69− Module.CanonicalBody

70− { program =

71− let expr = Transform.toExpr (Module.names modul) decls

72− in Transform.sortDefs (dummyLet expr)

73− , types = Map.empty

74− , datatypes =

75− Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]

76− , fixities =

77− [ (assoc,level,op) | D.Fixity assoc level op <- decls ]

78− , aliases =

79− Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]

80− , ports =

81− [ E.portName impl | D.Port (D.CanonicalPort impl) <- decls ]

82− }

83−

84−

85−resolveExports

86− :: [Var.Value]

87− -> Var.Listing Var.Value

88− -> Env.Canonicalizer [Doc] [Var.Value]

89−resolveExports fullList (Var.Listing partialList open) =

90− if open

91− then return fullList

92− else do

93− valueExports <- getValueExports

94− aliasExports <- concat `fmap` mapM getAliasExport aliases

95− adtExports <- mapM getAdtExport adts

96− return $ valueExports ++ aliasExports ++ adtExports

97− where

98− (allValues, allAliases, allAdts) = splitValues fullList

99−

100− (values, aliases, adts) = splitValues partialList

101−

102− getValueExports =

103− case Set.toList (Set.difference values' allValues') of

104− [] -> return (map Var.Value values)

105− xs -> notFound xs

106− where

107− allValues' = Set.fromList allValues

108− values' = Set.fromList values

109−

110− getAliasExport alias

111− | alias `elem` allAliases =

112− let recordConstructor =

113− if alias `elem` allValues then [Var.Value alias] else []

114− in

115− return $ Var.Alias alias : recordConstructor

116−

117− | otherwise =

118− case List.find (\(name, _ctors) -> name == alias) allAdts of

119− Nothing -> notFound [alias]

120− Just (name, _ctor) ->

121− return [Var.Union name (Var.Listing [] False)]

122−

123− getAdtExport (name, Var.Listing ctors open) =

124− case lookup name allAdts of

125− Nothing -> notFound [name]

126− Just (Var.Listing allCtors _)

127− | open -> return $ Var.Union name (Var.Listing allCtors False)

128− | otherwise ->

129− case filter (`notElem` allCtors) ctors of

130− [] -> return $ Var.Union name (Var.Listing ctors False)

131− unfoundCtors -> notFound unfoundCtors

132−

133− notFound xs =

134− throwError [ P.text "Export Error: trying to export non-existent values:" <+>

135− commaSep (map pretty xs)

136− ]

137−

138−

139−{-| Split a list of values into categories so we can work with them

140−independently.

141−-}

142−splitValues :: [Var.Value] -> ([String], [String], [(String, Var.Listing String)])

143−splitValues mixedValues =

144− case mixedValues of

145− [] -> ([], [], [])

146− x:xs ->

147− let (values, aliases, adts) = splitValues xs in

148− case x of

149− Var.Value name ->

150− (name : values, aliases, adts)

151−

152− Var.Alias name ->

153− (values, name : aliases, adts)

154−

155− Var.Union name listing ->

156− (values, aliases, (name, listing) : adts)

157−

158−

159−

160−declToValue :: D.ValidDecl -> [Var.Value]

161−declToValue decl =

162− case decl of

163− D.Definition (Valid.Definition pattern _ _) ->

164− map Var.Value (P.boundVarList pattern)

165−

166− D.Datatype name _tvs ctors ->

167− [ Var.Union name (Var.Listing (map fst ctors) False) ]

168−

169− D.TypeAlias name _ tipe ->

170− case tipe of

171− Type.Record _ _ ->

172− [ Var.Alias name, Var.Value name ]

173− _ -> [ Var.Alias name ]

174−

175− _ -> []

176−

177−

178−declaration

179− :: Env.Environment

180− -> D.ValidDecl

181− -> Env.Canonicalizer [Doc] D.CanonicalDecl

182−declaration env decl =

183− let canonicalize kind context pattern env v =

184− let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon

185− throw err = P.vcat [ ctx, P.text err ]

186− in

187− Env.onError throw (kind env v)

188− in

189− case decl of

190− D.Definition (Valid.Definition p e t) ->

191− do p' <- canonicalize pattern "definition" p env p

192− e' <- expression env e

193− t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t

194− return $ D.Definition (Canonical.Definition p' e' t')

195−

196− D.Datatype name tvars ctors ->

197− D.Datatype name tvars <$> mapM canonicalize' ctors

198− where

199− canonicalize' (ctor,args) =

200− (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args

201−

202− D.TypeAlias name tvars expanded ->

203− do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded

204− return (D.TypeAlias name tvars expanded')

205−

206− D.Port validPort ->

207− do Env.uses ["Native","Port"]

208− Env.uses ["Native","Json"]

209− case validPort of

210− D.In name tipe ->

211− do tipe' <- canonicalize Canonicalize.tipe "port" name env tipe

212− port' <- Port.check name Nothing tipe'

213− return (D.Port port')

214−

215−

216− D.Out name expr tipe ->

217− do expr' <- expression env expr

218− tipe' <- canonicalize Canonicalize.tipe "port" name env tipe

219− port' <- Port.check name (Just expr') tipe'

220− return (D.Port port')

221−

222− D.Fixity assoc prec op ->

223− return $ D.Fixity assoc prec op

224−

225−

226−expression

227− :: Env.Environment

228− -> Valid.Expr

229− -> Env.Canonicalizer [Doc] Canonical.Expr

230−expression env (A.A ann validExpr) =

231− let go = expression env

232− tipe' environ = format . Canonicalize.tipe environ

233− throw err =

234− P.vcat

235− [ P.text "Error" <+> pretty ann <> P.colon

236− , P.text err

237− ]

238− format = Env.onError throw

239− in

240− A.A ann <$>

241− case validExpr of

242− Literal lit ->

243− return (Literal lit)

244−

245− Range lowExpr highExpr ->

246− Range <$> go lowExpr <*> go highExpr

247−

248− Access record field ->

249− Access <$> go record <*> return field

250−

251− Remove record field ->

252− flip Remove field <$> go record

253−

254− Insert record field expr ->

255− flip Insert field <$> go record <*> go expr

256−

257− Modify record fields ->

258− Modify

259− <$> go record

260− <*> mapM (\(field,expr) -> (,) field <$> go expr) fields

261−

262− Record fields ->

263− Record

264− <$> mapM (\(field,expr) -> (,) field <$> go expr) fields

265−

266− Binop (Var.Raw op) leftExpr rightExpr ->

267− do op' <- format (Canonicalize.variable env op)

268− Binop op' <$> go leftExpr <*> go rightExpr

269−

270− Lambda arg body ->

271− let env' = Env.addPattern arg env

272− in

273− Lambda <$> format (pattern env' arg) <*> expression env' body

274−

275− App func arg ->

276− App <$> go func <*> go arg

277−

278− MultiIf branches ->

279− MultiIf <$> mapM go' branches

280− where

281− go' (condition, branch) =

282− (,) <$> go condition <*> go branch

283−

284− Let defs body ->

285− Let <$> mapM rename' defs <*> expression env' body

286− where

287− env' =

288− foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs

289−

290− rename' (Valid.Definition p body mtipe) =

291− Canonical.Definition

292− <$> format (pattern env' p)

293− <*> expression env' body

294− <*> T.traverse (tipe' env') mtipe

295−

296− Var (Var.Raw x) ->

297− Var <$> format (Canonicalize.variable env x)

298−

299− Data name exprs ->

300− Data name <$> mapM go exprs

301−

302− ExplicitList exprs ->

303− ExplicitList <$> mapM go exprs

304−

305− Case expr cases ->

306− Case <$> go expr <*> mapM branch cases

307− where

308− branch (p,b) =

309− (,) <$> format (pattern env p)

310− <*> expression (Env.addPattern p env) b

311−

312− Port impl ->

313− let portType pt =

314− case pt of

315− Type.Normal t ->

316− Type.Normal <$> tipe' env t

317−

318− Type.Signal root arg ->

319− Type.Signal <$> tipe' env root <*> tipe' env arg

320− in

321− Port <$>

322− case impl of

323− E.In name tipe ->

324− E.In name <$> portType tipe

325−

326− E.Out name expr tipe ->

327− E.Out name <$> go expr <*> portType tipe

328−

329− E.Task name expr tipe ->

330− E.Task name <$> go expr <*> portType tipe

331−

332− GLShader uid src tipe ->

333− return (GLShader uid src tipe)

334−

335−

336−pattern

337− :: Env.Environment

338− -> P.RawPattern

339− -> Env.Canonicalizer String P.CanonicalPattern

340−pattern env ptrn =

341− case ptrn of

342− P.Var x -> return $ P.Var x

343− P.Literal lit -> return $ P.Literal lit

344− P.Record fs -> return $ P.Record fs

345− P.Anything -> return P.Anything

346− P.Alias x p -> P.Alias x <$> pattern env p

347− P.Data (Var.Raw name) ps ->

348− P.Data <$> Canonicalize.pvar env name

349− <*> mapM (pattern env) ps

src/Transform/Canonicalize/Environment.hsdeleted−110

@@ -1,110 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Canonicalize.Environment where

3−

4−import Control.Arrow (second)

5−import qualified Control.Monad.Error as Error

6−import qualified Control.Monad.State as State

7−import qualified Data.Map as Map

8−import qualified Data.Set as Set

9−

10−import AST.Expression.General (saveEnvName)

11−import qualified AST.Module as Module

12−import qualified AST.Pattern as P

13−import qualified AST.Type as Type

14−import qualified AST.Variable as Var

15−

16−import Text.PrettyPrint (Doc)

17−

18−

19−-- ENVIRONMENT

20−

21−data Environment = Env

22− { _home :: Module.Name

23− , _values :: Dict Var.Canonical

24− , _adts :: Dict Var.Canonical

25− , _aliases :: Dict (Var.Canonical, [String], Type.CanonicalType)

26− , _patterns :: Dict Var.Canonical

27− }

28−

29−

30−builtIns :: Module.Name -> Environment

31−builtIns home =

32− Env { _home = home

33− , _values = builtIn (tuples ++ [saveEnvName])

34− , _adts = builtIn (tuples ++ ["List","Int","Float","Char","Bool","String"])

35− , _aliases = dict []

36− , _patterns = builtIn (tuples ++ ["::","[]"])

37− }

38− where

39− builtIn xs =

40− dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs

41−

42− tuples =

43− map (\n -> "_Tuple" ++ show n) [0 .. 9 :: Int]

44−

45−

46−addPattern :: P.Pattern var -> Environment -> Environment

47−addPattern ptrn env =

48− env { _values = foldr put (_values env) (P.boundVarList ptrn) }

49− where

50− put x =

51− Map.insert x (Set.singleton (Var.local x))

52−

53−

54−merge :: Environment -> Environment -> Environment

55−merge (Env n1 v1 t1 a1 p1) (Env n2 v2 t2 a2 p2)

56− | n1 /= n2 = error "trying to merge incompatable environments"

57− | otherwise =

58− Env { _home = n1

59− , _values = Map.unionWith Set.union v1 v2

60− , _adts = Map.unionWith Set.union t1 t2

61− , _aliases = Map.unionWith Set.union a1 a2

62− , _patterns = Map.unionWith Set.union p1 p2

63− }

64−

65−

66−-- RAW NAMES to CANONICAL NAMES

67−

68−type Dict a =

69− Map.Map String (Set.Set a)

70−

71−

72−dict :: [(String,a)] -> Dict a

73−dict pairs =

74− Map.fromList (map (second Set.singleton) pairs)

75−

76−

77−insert :: (Ord a) => String -> a -> Dict a -> Dict a

78−insert key value =

79− Map.insertWith Set.union key (Set.singleton value)

80−

81−

82−-- CANONICALIZATION MANAGER

83−

84−type Canonicalizer err a =

85− Error.ErrorT err (State.State (Set.Set Module.Name)) a

86−

87−

88−uses :: (Error.Error e) => Module.Name -> Canonicalizer e ()

89−uses home =

90− Error.lift (State.modify (Set.insert home))

91−

92−

93−using :: Var.Canonical -> Canonicalizer String Var.Canonical

94−using var@(Var.Canonical home _) =

95− do case home of

96− Var.BuiltIn -> return ()

97− Var.Module path -> uses path

98− Var.Local -> return ()

99− return var

100−

101−

102−onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a

103−onError handler canonicalizer =

104− do usedModules <- Error.lift State.get

105− let (result, usedModules') =

106− State.runState (Error.runErrorT canonicalizer) usedModules

107− Error.lift (State.put usedModules')

108− case result of

109− Left err -> Error.throwError [handler err]

110− Right x -> return x

src/Transform/Canonicalize/Port.hsdeleted−156

@@ -1,156 +0,0 @@

1−module Transform.Canonicalize.Port (check) where

2−

3−import Control.Applicative ((<$>))

4−import Control.Monad.Error (throwError)

5−import Text.PrettyPrint as P

6−

7−import qualified AST.Declaration as D

8−import qualified AST.Expression.General as E

9−import qualified AST.Expression.Canonical as Canonical

10−import qualified AST.PrettyPrint as PP

11−import qualified AST.Type as T

12−import qualified AST.Variable as Var

13−import qualified Transform.Canonicalize.Environment as Env

14−

15−

16−throw :: [Doc] -> Env.Canonicalizer [P.Doc] a

17−throw err =

18− throwError [ P.vcat err ]

19−

20−

21−-- CHECK FOR PORT

22−

23−check

24− :: String

25− -> Maybe Canonical.Expr

26− -> T.CanonicalType

27− -> Env.Canonicalizer [P.Doc] D.CanonicalPort

28−check name maybeExpr rootType =

29− do impl <- checkHelp name maybeExpr rootType rootType

30− return (D.CanonicalPort impl)

31−

32−

33−checkHelp

34− :: String

35− -> Maybe Canonical.Expr

36− -> T.CanonicalType

37− -> T.CanonicalType

38− -> Env.Canonicalizer [P.Doc] (E.PortImpl Canonical.Expr Var.Canonical)

39−checkHelp name maybeExpr rootType tipe =

40− case (maybeExpr, tipe) of

41− (_, T.Aliased _ args t) ->

42− checkHelp name maybeExpr rootType (T.dealias args t)

43−

44− (Just expr, T.App (T.Type task) [ _x, _a ])

45− | Var.isTask task ->

46− return (E.Task name expr (T.Normal tipe))

47−

48−

49− (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])

50− | Var.isSignal signal && Var.isTask task ->

51− return (E.Task name expr (T.Signal tipe arg))

52−

53−

54− (_, T.App (T.Type signal) [arg])

55− | Var.isSignal signal ->

56− case maybeExpr of

57− Nothing ->

58− do validForeignType name In arg arg

59− return (E.In name (T.Signal rootType arg))

60−

61− Just expr ->

62− do validForeignType name Out arg arg

63− return (E.Out name expr (T.Signal rootType arg))

64−

65− _ ->

66− case maybeExpr of

67− Nothing ->

68− do validForeignType name In rootType tipe

69− return (E.In name (T.Normal rootType))

70−

71− Just expr ->

72− do validForeignType name Out rootType tipe

73− return (E.Out name expr (T.Normal rootType))

74−

75−

76−-- CHECK INBOUND AND OUTBOUND TYPES

77−

78−data Direction = In | Out

79−

80−

81−validForeignType

82− :: String

83− -> Direction

84− -> T.CanonicalType

85− -> T.CanonicalType

86− -> Env.Canonicalizer [P.Doc] ()

87−validForeignType name portKind rootType tipe =

88− let valid localType =

89− validForeignType name portKind rootType localType

90−

91− err hint =

92− throw (foreignError name portKind rootType tipe hint)

93− in

94− case tipe of

95− T.Aliased _ args t ->

96− valid (T.dealias args t)

97−

98− T.Type v ->

99− case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of

100− True -> return ()

101− False -> err "It contains an unsupported type"

102−

103− T.App t [] ->

104− valid t

105−

106− T.App (T.Type v) [t]

107− | Var.isMaybe v -> valid t

108− | Var.isArray v -> valid t

109− | Var.isList v -> valid t

110−

111− T.App (T.Type v) ts

112− | Var.isTuple v -> mapM_ valid ts

113−

114− T.App _ _ ->

115− err "It contains an unsupported type"

116−

117− T.Var _ ->

118− err "It contains a free type variable"

119−

120− T.Lambda _ _ ->

121− err "It contains functions"

122−

123− T.Record _ (Just _) ->

124− err "It contains extended records with free type variables"

125−

126− T.Record fields Nothing ->

127− mapM_ (\(k,v) -> (,) k <$> valid v) fields

128−

129−

130−foreignError

131− :: String

132− -> Direction

133− -> T.CanonicalType

134− -> T.CanonicalType

135− -> String

136− -> [P.Doc]

137−foreignError name portKind rootType localType problemMessage =

138− [ P.text ("Port Error:")

139− , P.nest 4 $

140− P.vcat

141− [ txt [ "The ", port, " named '", name, "' has an invalid type.\n" ]

142− , P.nest 4 (PP.pretty rootType) <> P.text "\n"

143− , txt [ problemMessage, ":\n" ]

144− , P.nest 4 (PP.pretty localType) <> P.text "\n"

145− , txt [ "The kinds of values that can flow through ", port, "s include:" ]

146− , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays," ]

147− , txt [ " Tuples, JavaScript.Values, and concrete records." ]

148− ]

149− ]

150− where

151− port =

152− case portKind of

153− In -> "inbound port"

154− Out -> "outbound port"

155−

156− txt = P.text . concat

src/Transform/Canonicalize/Setup.hsdeleted−340

@@ -1,340 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Canonicalize.Setup

3− ( environment

4− , typeAliasErrorSegue

5− , typeAliasErrorExplanation

6− ) where

7−

8−import Control.Arrow (first)

9−import Control.Monad (foldM)

10−import Control.Monad.Error (throwError)

11−import qualified Data.Graph as Graph

12−import qualified Data.List as List

13−import qualified Data.Map as Map

14−

15−import qualified AST.Expression.Valid as Valid

16−

17−import AST.Module (Interface(iAdts, iTypes, iAliases))

18−import qualified AST.Module as Module

19−import qualified AST.Type as Type

20−import qualified AST.Variable as Var

21−import qualified AST.Declaration as D

22−import AST.PrettyPrint (pretty, eightyCharLines)

23−import qualified AST.Pattern as P

24−import Text.PrettyPrint as P

25−

26−import Transform.Canonicalize.Environment

27− ( Canonicalizer, Environment(Env, _home, _values, _adts, _aliases, _patterns) )

28−import qualified Transform.Canonicalize.Environment as Env

29−import qualified Transform.Canonicalize.Type as Canonicalize

30−import qualified Transform.Interface as Interface

31−

32−

33−environment

34− :: Module.Interfaces

35− -> Module.ValidModule

36− -> Canonicalizer [Doc] Environment

37−environment interfaces modul@(Module.Module _ _ _ imports decls) =

38− do () <- allImportsAvailable

39− let moduleName =

40− Module.names modul

41−

42− nonLocalEnv <-

43− foldM (addImports moduleName interfaces) (Env.builtIns moduleName) imports

44−

45− let (aliases, env) =

46− List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls

47−

48− addTypeAliases moduleName aliases env

49−

50− where

51− allImportsAvailable :: Canonicalizer [Doc] ()

52− allImportsAvailable =

53− case filter (not . found) modules of

54− [] -> return ()

55− missings -> throwError [ P.text (missingModuleError missings) ]

56− where

57− modules =

58− map fst imports

59−

60− found m =

61− Map.member m interfaces || Module.nameIsNative m

62−

63− missingModuleError missings =

64− concat

65− [ "The following imports were not found:\n "

66− , List.intercalate ", " (map Module.nameToString missings)

67− ]

68−

69−

70−addImports

71− :: Module.Name

72− -> Module.Interfaces

73− -> Environment

74− -> (Module.Name, Module.ImportMethod)

75− -> Canonicalizer [Doc] Environment

76−addImports moduleName interfaces environ (name, method)

77− | Module.nameIsNative name =

78− return environ

79−

80− | otherwise =

81− let (Module.ImportMethod maybeAlias listing) = method

82−

83− (Var.Listing exposedVars open) = listing

84−

85− qualifier =

86− maybe (Module.nameToString name) id maybeAlias

87−

88− env =

89− updateEnviron (qualifier ++ ".") environ

90− in

91− if open

92− then return (updateEnviron "" env)

93− else foldM (addValue name interface) env exposedVars

94− where

95− interface =

96− Interface.filterExports ((Map.!) interfaces name)

97−

98− updateEnviron prefix env =

99− let dict' pairs = Env.dict (map (first (prefix++)) pairs)

100− in

101− Env.merge env $

102− Env

103− { _home = moduleName

104− , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors

105− , _adts = dict' $ map pair (Map.keys (iAdts interface))

106− , _aliases = dict' $ map alias (Map.toList (iAliases interface))

107− , _patterns = dict' $ ctors

108− }

109−

110− canonical :: String -> Var.Canonical

111− canonical =

112− Var.Canonical (Var.Module name)

113−

114− pair :: String -> (String, Var.Canonical)

115− pair key =

116− (key, canonical key)

117−

118− alias (x,(tvars,tipe)) =

119− (x, (canonical x, tvars, tipe))

120−

121− ctors =

122− concatMap

123− (map (pair . fst) . snd . snd)

124− (Map.toList (iAdts interface))

125−

126−

127−addValue

128− :: Module.Name

129− -> Module.Interface

130− -> Environment

131− -> Var.Value

132− -> Canonicalizer [Doc] Environment

133−addValue moduleName interface env value =

134− let name = Module.nameToString moduleName

135− insert' x = Env.insert x (Var.Canonical (Var.Module moduleName) x)

136− msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++

137− "'.\n It is not exported by module " ++ name ++ "."

138− notFound x = throwError [ P.text (msg x) ]

139− in

140− case value of

141− Var.Value x

142− | Map.notMember x (iTypes interface) ->

143− notFound x

144−

145− | otherwise ->

146− return $ env { _values = insert' x (_values env) }

147−

148− Var.Alias x ->

149− case Map.lookup x (iAliases interface) of

150− Just (tvars, t) ->

151− return $ env

152− { _aliases = Env.insert x v (_aliases env)

153− , _values = updatedValues

154− }

155− where

156− v = (Var.Canonical (Var.Module moduleName) x, tvars, t)

157− updatedValues =

158− if Map.member x (iTypes interface)

159− then insert' x (_values env)

160− else _values env

161−

162− Nothing ->

163− case Map.lookup x (iAdts interface) of

164− Nothing -> notFound x

165− Just (_,_) ->

166− return $ env { _adts = insert' x (_adts env) }

167−

168− Var.Union x (Var.Listing xs open) ->

169− case Map.lookup x (iAdts interface) of

170− Nothing -> notFound x

171− Just (_tvars, ctors) ->

172− do ctors' <- filterNames (map fst ctors)

173− return $ env

174− { _adts = insert' x (_adts env)

175− , _values = foldr insert' (_values env) ctors'

176− , _patterns = foldr insert' (_patterns env) ctors'

177− }

178− where

179− filterNames names

180− | open = return names

181− | otherwise =

182− case filter (`notElem` names) xs of

183− [] -> return names

184− c:_ -> notFound c

185−

186−

187−type Node = ((String, [String], Type.RawType), String, [String])

188−

189−

190−node :: String -> [String] -> Type.RawType -> Node

191−node name tvars alias =

192− ((name, tvars, alias), name, edges alias)

193− where

194− edges tipe =

195− case tipe of

196− Type.Lambda t1 t2 ->

197− edges t1 ++ edges t2

198−

199− Type.Var _ ->

200− []

201−

202− Type.Type (Var.Raw x) ->

203− [x]

204−

205− Type.App t ts ->

206− edges t ++ concatMap edges ts

207−

208− Type.Record fs ext ->

209− maybe [] edges ext ++ concatMap (edges . snd) fs

210−

211− Type.Aliased _ args aliasType ->

212− case aliasType of

213− Type.Holey t ->

214− edges t ++ concatMap (edges . snd) args

215− Type.Filled t ->

216− edges t

217−

218−

219−addTypeAliases

220− :: Module.Name

221− -> [Node]

222− -> Environment

223− -> Canonicalizer [Doc] Environment

224−addTypeAliases moduleName nodes environ =

225− foldM (addTypeAlias moduleName) environ (Graph.stronglyConnComp nodes)

226−

227−

228−addTypeAlias

229− :: Module.Name

230− -> Environment

231− -> Graph.SCC (String, [String], Type.RawType)

232− -> Canonicalizer [Doc] Environment

233−addTypeAlias moduleName env scc =

234− case Graph.flattenSCC scc of

235− [(name, tvars, alias)] ->

236− do alias' <- Env.onError throw (Canonicalize.tipe env alias)

237− let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')

238− return $ env { _aliases = Env.insert name value (_aliases env) }

239− where

240− throw err =

241− let msg = "Problem with type alias '" ++ name ++ "':"

242− in P.vcat [ P.text msg, P.text err ]

243−

244− aliases ->

245− throwError

246− [ P.vcat

247− [ P.text (eightyCharLines 0 mutuallyRecursiveMessage)

248− , indented (map typeAlias aliases)

249− , P.text (eightyCharLines 0 typeAliasErrorSegue)

250− , indented (map datatype aliases)

251− , P.text (eightyCharLines 0 typeAliasErrorExplanation)

252− ]

253− ]

254−

255−

256−typeAlias :: (String, [String], Type.Type var) -> D.Declaration' pk def var expr

257−typeAlias (n,ts,t) =

258− D.TypeAlias n ts t

259−

260−

261−datatype :: (String, [String], Type.Type var) -> D.Declaration' pk def var expr

262−datatype (n,ts,t) =

263− D.Datatype n ts [(n,[t])]

264−

265−

266−indented :: [D.ValidDecl] -> Doc

267−indented decls =

268− P.vcat (map prty decls) <> P.text "\n"

269− where

270− prty decl = P.text "\n " <> pretty decl

271−

272−

273−mutuallyRecursiveMessage :: String

274−mutuallyRecursiveMessage =

275− "The following type aliases are mutually recursive, forming an \

276− \infinite type. When you expand them, they just keep getting bigger:"

277−

278−

279−typeAliasErrorSegue :: String

280−typeAliasErrorSegue =

281− "Try this instead:"

282−

283−

284−typeAliasErrorExplanation :: String

285−typeAliasErrorExplanation =

286− "It looks very similar, but the 'type' keyword creates a brand new type, \

287− \not just an alias for an existing one. This lets us avoid infinitely \

288− \expanding it during type inference."

289−

290−

291−-- When canonicalizing, all _values should be Local, but all _adts and _patterns

292−-- should be fully namespaced. With _adts, they may appear in types that can

293−-- escape the module.

294−addDecl

295− :: Module.Name

296− -> ([Node], Environment)

297− -> D.ValidDecl

298− -> ([Node], Environment)

299−addDecl moduleName info@(nodes,env) decl =

300− let namespacedVar = Var.Canonical (Var.Module moduleName)

301− addLocal x e = Env.insert x (Var.local x) e

302− addNamespaced x e = Env.insert x (namespacedVar x) e

303− in

304− case decl of

305− D.Definition (Valid.Definition pattern _ _) ->

306− (,) nodes $ env

307− { _values =

308− foldr addLocal (_values env) (P.boundVarList pattern)

309− }

310−

311− D.Datatype name _ ctors ->

312− (,) nodes $ env

313− { _values =

314− addCtors addLocal (_values env)

315− , _adts =

316− addNamespaced name (_adts env)

317− , _patterns =

318− addCtors addNamespaced (_patterns env)

319− }

320− where

321− addCtors how e = foldr how e (map fst ctors)

322−

323− D.TypeAlias name tvars alias ->

324− (,) (node name tvars alias : nodes) $ env

325− { _values =

326− case alias of

327− Type.Record _ _ ->

328− addLocal name (_values env)

329− _ ->

330− _values env

331− }

332−

333− D.Port port ->

334− (,) nodes $ env

335− { _values =

336− addLocal (D.validPortName port) (_values env)

337− }

338−

339− D.Fixity _ _ _ ->

340− info

src/Transform/Canonicalize/Type.hsdeleted−84

@@ -1,84 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Canonicalize.Type (tipe) where

3−

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

5−import Control.Monad.Error

6−import Data.Traversable (traverse)

7−

8−import qualified AST.Type as T

9−import qualified AST.Variable as Var

10−

11−import Transform.Canonicalize.Environment

12−import qualified Transform.Canonicalize.Variable as Canonicalize

13−

14−

15−tipe

16− :: Environment

17− -> T.RawType

18− -> Canonicalizer String T.CanonicalType

19−tipe env typ =

20− let go = tipe env

21− goSnd (name,t) =

22− (,) name <$> go t

23− in

24− case typ of

25− T.Var x ->

26− return (T.Var x)

27−

28− T.Type _ ->

29− canonicalizeApp env typ []

30−

31− T.App t ts ->

32− canonicalizeApp env t ts

33−

34− T.Lambda a b ->

35− T.Lambda <$> go a <*> go b

36−

37− T.Record fields ext ->

38− T.Record <$> mapM goSnd fields <*> traverse go ext

39−

40− T.Aliased _ _ _ ->

41− error "a RawType should never have an alias in it"

42−

43−

44−canonicalizeApp

45− :: Environment

46− -> T.RawType

47− -> [T.RawType]

48− -> Canonicalizer String T.CanonicalType

49−canonicalizeApp env f args =

50− case f of

51− T.Type (Var.Raw rawName) ->

52− do answer <- Canonicalize.tvar env rawName

53− case answer of

54− Right alias ->

55− canonicalizeAlias env alias args

56−

57− Left name ->

58− case args of

59− [] -> return (T.Type name)

60− _ ->

61− T.App (T.Type name) <$> mapM (tipe env) args

62−

63− _ ->

64− T.App <$> tipe env f <*> mapM (tipe env) args

65−

66−

67−canonicalizeAlias

68− :: Environment

69− -> (Var.Canonical, [String], T.CanonicalType)

70− -> [T.RawType]

71− -> Canonicalizer String T.CanonicalType

72−canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =

73− do when (tipesLen /= tvarsLen) (throwError msg)

74− tipes' <- mapM (tipe env) tipes

75− return $ T.Aliased name (zip tvars tipes') (T.Holey dealiasedTipe)

76− where

77− tipesLen = length tipes

78− tvarsLen = length tvars

79−

80− msg :: String

81− msg =

82− "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++

83− " type argument" ++ (if tvarsLen == 1 then "" else "s") ++

84− " but was given " ++ show tipesLen

src/Transform/Canonicalize/Variable.hsdeleted−242

@@ -1,242 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Canonicalize.Variable where

3−

4−import Control.Monad.Error

5−import qualified Data.Either as Either

6−import Data.Function (on)

7−import qualified Data.List as List

8−import qualified Data.Map as Map

9−import qualified Data.Set as Set

10−import qualified Text.EditDistance as Dist

11−

12−import qualified AST.Helpers as Help

13−import qualified AST.Module as Module

14−import qualified AST.Type as Type

15−import qualified AST.Variable as Var

16−import Transform.Canonicalize.Environment as Env

17−import Elm.Utils ((|>))

18−

19−

20−variable :: Environment -> String -> Canonicalizer String Var.Canonical

21−variable env var =

22− case splitName var of

23− Right (name, varName)

24− | Module.nameIsNative name ->

25− Env.using (Var.Canonical (Var.Module name) varName)

26−

27− _ ->

28− case Set.toList `fmap` Map.lookup var (_values env) of

29− Just [v] -> Env.using v

30− Just vs -> preferLocals env "variable" vs var

31− Nothing -> notFound "variable" (Map.keys (_values env)) var

32−

33−

34−tvar

35− :: Environment

36− -> String

37− -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType))

38−tvar env var =

39− case adts ++ aliases of

40− [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var

41− [v] -> found extract v

42− vs -> preferLocals' env extract "type" vs var

43− where

44− adts =

45− map Left (maybe [] Set.toList (Map.lookup var (_adts env)))

46−

47− aliases =

48− map Right (maybe [] Set.toList (Map.lookup var (_aliases env)))

49−

50− extract value =

51− case value of

52− Left v -> v

53− Right (v,_,_) -> v

54−

55−

56−pvar :: Environment -> String -> Canonicalizer String Var.Canonical

57−pvar env var =

58− case Set.toList `fmap` Map.lookup var (_patterns env) of

59− Just [v] -> Env.using v

60− Just vs -> preferLocals env "pattern" vs var

61− Nothing -> notFound "pattern" (Map.keys (_patterns env)) var

62−

63−

64−-- FOUND

65−

66−found :: (a -> Var.Canonical) -> a -> Canonicalizer String a

67−found extract v =

68− do _ <- Env.using (extract v)

69− return v

70−

71−

72−preferLocals

73− :: Environment

74− -> String

75− -> [Var.Canonical]

76− -> String

77− -> Canonicalizer String Var.Canonical

78−preferLocals env =

79− preferLocals' env id

80−

81−

82−preferLocals'

83− :: Environment

84− -> (a -> Var.Canonical)

85− -> String

86− -> [a]

87− -> String

88− -> Canonicalizer String a

89−preferLocals' env extract kind possibilities var =

90− case filter (isLocal . extract) possibilities of

91− [] -> ambiguous possibilities

92− [v] -> found extract v

93− locals -> ambiguous locals

94− where

95− isLocal :: Var.Canonical -> Bool

96− isLocal (Var.Canonical home _) =

97− case home of

98− Var.Local -> True

99− Var.BuiltIn -> False

100− Var.Module name ->

101− name == Env._home env

102−

103− ambiguous possibleVars =

104− throwError msg

105− where

106− vars = map (Var.toString . extract) possibleVars

107− msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++

108− " Disambiguate between: " ++ List.intercalate ", " vars

109−

110−

111−-- NOT FOUND HELPERS

112−

113−splitName :: String -> Either String ([String], String)

114−splitName var =

115− case Help.splitDots var of

116− [x] -> Left x

117− xs -> Right (init xs, last xs)

118−

119−

120−getName :: Either String ([String], String) -> String

121−getName name =

122− case name of

123− Left x -> x

124− Right (_, x) -> x

125−

126−

127−nameToString :: ([String], String) -> String

128−nameToString (modul, name) =

129− Module.nameToString (modul ++ [name])

130−

131−

132−isOp :: Either String ([String], String) -> Bool

133−isOp name =

134− Help.isOp (getName name)

135−

136−

137−distance :: String -> String -> Int

138−distance x y =

139− Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y

140−

141−

142−nearbyNames :: (a -> String) -> a -> [a] -> [a]

143−nearbyNames format name names =

144− let editDistance =

145− if length (format name) < 3 then 1 else 2

146− in

147− names

148− |> map (\x -> (distance (format name) (format x), x))

149− |> List.sortBy (compare `on` fst)

150− |> filter ( (<= editDistance) . abs . fst )

151− |> map snd

152−

153−

154−-- NOT FOUND

155−

156−notFound :: String -> [String] -> String -> Canonicalizer String a

157−notFound kind possibilities var =

158− let possibleNames =

159− map splitName possibilities

160−

161− name =

162− splitName var

163−

164− closeNames =

165− possibleNames

166− |> filter (\n -> isOp name == isOp n)

167− |> nearbyNames getName name

168−

169− (exposed, qualified) =

170− Either.partitionEithers closeNames

171−

172− message =

173− case name of

174− Left _ ->

175− closeExposedMessage exposed ++ closeQualifiedMessage qualified

176−

177− Right (modul, _) ->

178− qualifiedMessage modul (Either.rights possibleNames) qualified

179−

180− in

181− throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ message

182−

183−

184−

185−closeExposedMessage :: [String] -> String

186−closeExposedMessage exposed =

187− if null exposed

188− then ""

189− else

190− "\n\nClose matches include:" ++ concatMap ("\n " ++) exposed

191−

192−

193−closeQualifiedMessage :: [([String], String)] -> String

194−closeQualifiedMessage qualified =

195− if null qualified

196− then ""

197− else

198− "\n\nMaybe you forgot to say which module it came from?\n"

199− ++ "Close qualified names include:"

200− ++ concatMap (("\n " ++) . nameToString) qualified

201− ++ usingImportsMessage

202−

203−

204−qualifiedMessage :: [String] -> [([String], String)] -> [([String], String)] -> String

205−qualifiedMessage modul allQualified qualified =

206− let availableModules =

207− Set.fromList (map fst allQualified)

208− in

209− case Set.member modul availableModules of

210− True ->

211− let inSameModule =

212− filter ((==) modul . fst) qualified

213− in

214− if null inSameModule

215− then ""

216− else

217− "\n\nClose matches include:"

218− ++ concatMap (("\n " ++) . nameToString) inSameModule

219−

220− False ->

221− let closeModules =

222− Set.toList availableModules

223− |> map Module.nameToString

224− |> nearbyNames id (Module.nameToString modul)

225− in

226− case closeModules of

227− [] ->

228− "\n\nLooks like the prefix '" ++ Module.nameToString modul

229− ++ "' is not in scope. Is it spelled correctly?"

230− ++ "\nIs it imported correctly?"

231− ++ usingImportsMessage

232−

233− _ ->

234− "\n\nClose matches to '" ++ Module.nameToString modul ++ "' include:"

235− ++ concatMap ("\n " ++) closeModules

236−

237−

238−usingImportsMessage :: String

239−usingImportsMessage =

240− "\n\nYou can read about how imports work at the following address:"

241− ++ "\n<http://elm-lang.org/learn/Syntax.elm#modules>"

242−

src/Transform/Check.hsdeleted−216

@@ -1,216 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Check (mistakes) where

3−

4−import qualified Data.List as List

5−import qualified Data.Maybe as Maybe

6−import qualified Data.Set as Set

7−

8−import qualified AST.Expression.Valid as Valid

9−import qualified AST.Declaration as D

10−import qualified AST.Pattern as Pattern

11−import qualified AST.Type as T

12−import qualified AST.Variable as Var

13−import qualified Transform.Expression as Expr

14−import qualified Transform.Canonicalize.Setup as Setup

15−

16−import AST.PrettyPrint

17−import Elm.Utils ((|>))

18−import Text.PrettyPrint as P

19−

20−

21−mistakes :: [D.ValidDecl] -> [Doc]

22−mistakes decls =

23− concat

24− [ infiniteTypeAliases decls

25− , illFormedTypeDecls decls

26− , map P.text (duplicateTypeDeclarations decls)

27− , map P.text (duplicateValues decls)

28− ]

29−

30−

31−-- DUPLICATES

32−

33−dups :: Ord a => [a] -> [a]

34−dups names =

35− List.sort names

36− |> List.group

37− |> filter ((>1) . length)

38− |> map head

39−

40−

41−duplicateValues :: [D.ValidDecl] -> [String]

42−duplicateValues decls =

43− map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

44− case mapM exprDups defExprs of

45− Left name -> [msg name]

46− Right _ -> []

47−

48− where

49− msg x =

50− "Name Collision: There can only be one definition of '" ++ x ++ "'."

51−

52− (defPatterns, defExprs) =

53− unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]

54−

55− portNames =

56− [ D.validPortName port | D.Port port <- decls ]

57−

58− exprDups :: Valid.Expr -> Either String Valid.Expr

59− exprDups expr =

60− Expr.crawlLet defsDups expr

61−

62− defsDups :: [Valid.Def] -> Either String [Valid.Def]

63− defsDups defs =

64− let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in

65− case dups $ concatMap varsIn defs of

66− [] -> Right defs

67− name:_ -> Left name

68−

69−

70−duplicateTypeDeclarations :: [D.ValidDecl] -> [String]

71−duplicateTypeDeclarations decls =

72− map dupTypeError (dups (typeNames ++ aliasNames))

73− ++ map dupCtorError (dups (ctorNames ++ aliasNames))

74− where

75− typeNames =

76− [ name | D.Datatype name _ _ <- decls ]

77−

78− aliasNames =

79− [ name | D.TypeAlias name _ _ <- decls ]

80−

81− ctorNames =

82− concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]

83−

84−

85−dupTypeError :: String -> String

86−dupTypeError name =

87− "Name Collision: There can only be one type named '" ++ name ++ "'"

88−

89−

90−dupCtorError :: String -> String

91−dupCtorError name =

92− "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"

93− ++ " Constructors are created for record type aliases and for union types, so\n"

94− ++ " something should be renamed or moved to a different module."

95−

96−

97−-- FREE TYPE VARIABLES IN TYPE DECLARATIONS

98−

99−illFormedTypeDecls :: [D.ValidDecl] -> [Doc]

100−illFormedTypeDecls decls =

101− map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

102− where

103− aliases =

104− [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]

105−

106− adts =

107− [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]

108−

109− freeVars tipe =

110− case tipe of

111− T.Lambda t1 t2 ->

112− Set.union (freeVars t1) (freeVars t2)

113−

114− T.Var x ->

115− Set.singleton x

116−

117− T.Type _ ->

118− Set.empty

119−

120− T.App t ts ->

121− Set.unions (map freeVars (t:ts))

122−

123− T.Record fields ext ->

124− let ext' = maybe Set.empty freeVars ext

125− in

126− Set.unions (ext' : map (freeVars . snd) fields)

127−

128− T.Aliased _ args t ->

129− freeVars (T.dealias args t)

130−

131− undeclared tvars tipes =

132− Set.difference used declared

133− where

134− used = Set.unions (map freeVars tipes)

135− declared = Set.fromList tvars

136−

137− isIllFormed (decl, tvars, tipes) =

138− let unbound = undeclared tvars tipes in

139− if Set.null unbound

140− then Nothing

141− else Just (decl, Set.toList unbound)

142−

143− report (decl, tvars) =

144− P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"

145− , P.text "\n"

146− , nest 4 (pretty decl) ]

147− where

148− listing =

149− case tvars of

150− [tvar] -> " " ++ quote tvar ++ " is"

151− _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"

152−

153− addCommas xs

154− | length xs < 3 = concat xs

155− | otherwise = List.intercalate "," xs

156−

157− addAnd xs

158− | length xs < 2 = xs

159− | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs

160−

161− quote tvar = "'" ++ tvar ++ "'"

162−

163−

164−-- INFINITE TYPE ALIASES

165−

166−infiniteTypeAliases :: [D.ValidDecl] -> [Doc]

167−infiniteTypeAliases decls =

168− [ report name tvars tipe

169− | D.TypeAlias name tvars tipe <- decls

170− , infiniteType name tipe

171− ]

172− where

173− infiniteType :: String -> T.Type Var.Raw -> Bool

174− infiniteType name tipe =

175− let infinite = infiniteType name in

176− case tipe of

177− T.Lambda a b ->

178− infinite a || infinite b

179−

180− T.Var _ ->

181− False

182−

183− T.Type (Var.Raw name') ->

184− name == name'

185−

186− T.App t ts ->

187− any infinite (t:ts)

188−

189− T.Record fields _ ->

190− any (infinite . snd) fields

191−

192− T.Aliased _ args aliasType ->

193− case aliasType of

194− T.Holey t ->

195− infinite t || any (infinite . snd) args

196−

197− T.Filled t ->

198− infinite t

199−

200− indented :: D.ValidDecl -> Doc

201− indented decl =

202− P.text "\n " <> pretty decl <> P.text "\n"

203−

204− report name args tipe =

205− P.vcat

206− [ P.text $ eightyCharLines 0 msg1

207− , indented $ D.TypeAlias name args tipe

208− , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue

209− , indented $ D.Datatype name args [(name,[tipe])]

210− , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n"

211− ]

212− where

213− msg1 =

214− "Type alias '" ++ name ++ "' is an infinite type. " ++

215− "Notice that it appears in its own definition, so when \

216− \you expand it, it just keeps getting bigger:"

src/Transform/Declaration.hsdeleted−158

@@ -1,158 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Declaration (combineAnnotations, toExpr) where

3−

4−import Control.Applicative ((<$>))

5−

6−import qualified AST.Annotation as A

7−import qualified AST.Declaration as D

8−import qualified AST.Expression.General as E

9−import qualified AST.Expression.Source as Source

10−import qualified AST.Expression.Valid as Valid

11−import qualified AST.Expression.Canonical as Canonical

12−import qualified AST.Module as Module

13−import qualified AST.Pattern as P

14−import qualified AST.Type as T

15−import qualified AST.Variable as Var

16−

17−import qualified Transform.Expression as Expr

18−import qualified Transform.Definition as Def

19−

20−

21−combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]

22−combineAnnotations =

23− go

24− where

25− errorMessage kind name =

26− "Syntax Error: The type annotation for " ++ kind ++ " '" ++

27− name ++ "' must be directly above its definition."

28−

29− exprCombineAnnotations =

30− Expr.crawlLet Def.combineAnnotations

31−

32− go decls =

33− case decls of

34− -- simple cases, pass them through with no changes

35− [] ->

36− return []

37−

38− D.Datatype name tvars ctors : rest ->

39− (:) (D.Datatype name tvars ctors) <$> go rest

40−

41− D.TypeAlias name tvars alias : rest ->

42− (:) (D.TypeAlias name tvars alias) <$> go rest

43−

44− D.Fixity assoc prec op : rest ->

45− (:) (D.Fixity assoc prec op) <$> go rest

46−

47− -- combine definitions

48− D.Definition def : defRest ->

49− case def of

50− Source.Definition pat expr ->

51− do expr' <- exprCombineAnnotations expr

52− let def' = Valid.Definition pat expr' Nothing

53− (:) (D.Definition def') <$> go defRest

54−

55− Source.TypeAnnotation name tipe ->

56− case defRest of

57− D.Definition (Source.Definition pat@(P.Var name') expr) : rest

58− | name == name' ->

59− do expr' <- exprCombineAnnotations expr

60− let def' = Valid.Definition pat expr' (Just tipe)

61− (:) (D.Definition def') <$> go rest

62−

63− _ -> Left (errorMessage "value" name)

64−

65− D.Port port : rest ->

66− case port of

67− D.PortAnnotation name tipe ->

68− case rest of

69− D.Port (D.PortDefinition name' expr) : restRest

70− | name == name' ->

71− do expr' <- exprCombineAnnotations expr

72− let port' = D.Out name expr' tipe

73− (:) (D.Port port') <$> go restRest

74−

75− _ ->

76− (:) (D.Port (D.In name tipe)) <$> go rest

77−

78− D.PortDefinition name _ ->

79− Left (errorMessage "port" name)

80−

81−

82−toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]

83−toExpr moduleName =

84− concatMap (toDefs moduleName)

85−

86−

87−toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]

88−toDefs moduleName decl =

89− let typeVar = Var.Canonical (Var.Module moduleName) in

90− case decl of

91− D.Definition def ->

92− [def]

93−

94− D.Datatype name tvars constructors ->

95− concatMap toDefs' constructors

96− where

97− toDefs' (ctor, tipes) =

98− let vars = take (length tipes) arguments

99− tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)

100− body = A.none . E.Data ctor $ map (A.none . E.localVar) vars

101− in

102− [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

103−

104− D.TypeAlias name tvars tipe@(T.Record fields ext) ->

105− [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]

106− where

107− result =

108− T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)

109−

110− args =

111− map snd fields ++ maybe [] (:[]) ext

112−

113− var = A.none . E.localVar

114− vars = take (length args) arguments

115−

116− efields = zip (map fst fields) (map var vars)

117− record =

118− case ext of

119− Nothing -> A.none $ E.Record efields

120− Just _ ->

121− foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields

122−

123− -- Type aliases must be added to an extended equality dictionary,

124− -- but they do not require any basic constraints.

125− D.TypeAlias _ _ _ ->

126− []

127−

128− D.Port (D.CanonicalPort impl) ->

129− let body = A.none (E.Port impl)

130− in

131− case impl of

132− E.In name tipe ->

133− [ definition name body (T.portType tipe) ]

134−

135− E.Out name _expr tipe ->

136− [ definition name body (T.portType tipe) ]

137−

138− E.Task name _expr tipe ->

139− [ definition name body (T.portType tipe) ]

140−

141− -- no constraints are needed for fixity declarations

142− D.Fixity _ _ _ ->

143− []

144−

145−

146−arguments :: [String]

147−arguments =

148− map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

149−

150−

151−buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr

152−buildFunction body@(A.A s _) vars =

153− foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)

154−

155−

156−definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def

157−definition name expr tipe =

158− Canonical.Definition (P.Var name) expr (Just tipe)

src/Transform/Definition.hsdeleted−40

@@ -1,40 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Definition where

3−

4−import Control.Applicative ((<$>))

5−import qualified AST.Pattern as P

6−import qualified AST.Expression.Source as Source

7−import qualified AST.Expression.Valid as Valid

8−import qualified Transform.Expression as Expr

9−

10−combineAnnotations :: [Source.Def] -> Either String [Valid.Def]

11−combineAnnotations =

12− go

13− where

14− errorMessage x =

15− "Syntax Error: The type annotation for '" ++ x ++

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

17−

18− exprCombineAnnotations =

19− Expr.crawlLet combineAnnotations

20−

21− go defs =

22− case defs of

23− Source.TypeAnnotation name tipe : rest ->

24− case rest of

25− Source.Definition pat@(P.Var name') expr : rest'

26− | name == name' ->

27− do expr' <- exprCombineAnnotations expr

28− let def = Valid.Definition pat expr' (Just tipe)

29− (:) def <$> go rest'

30−

31− _ ->

32− Left (errorMessage name)

33−

34− Source.Definition pat expr : rest ->

35− do expr' <- exprCombineAnnotations expr

36− let def = Valid.Definition pat expr' Nothing

37− (:) def <$> go rest

38−

39− [] ->

40− return []

src/Transform/Expression.hsdeleted−84

@@ -1,84 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Expression (crawlLet) where

3−

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

5−import AST.Annotation ( Annotated(A) )

6−import AST.Expression.General

7−

8−

9−crawlLet

10− :: ([def] -> Either a [def'])

11− -> Expr ann def var

12− -> Either a (Expr ann def' var)

13−crawlLet defsTransform annotatedExpression =

14− go annotatedExpression

15− where

16− go (A srcSpan expression) =

17− A srcSpan <$>

18− case expression of

19− Var x ->

20− return (Var x)

21−

22− Lambda pattern body ->

23− Lambda pattern <$> go body

24−

25− Binop op leftExpr rightExpr ->

26− Binop op <$> go leftExpr <*> go rightExpr

27−

28− Case e cases ->

29− Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases

30−

31− Data name es ->

32− Data name <$> mapM go es

33−

34− Literal lit ->

35− return (Literal lit)

36−

37− Range lowExpr highExpr ->

38− Range <$> go lowExpr <*> go highExpr

39−

40− ExplicitList expressions ->

41− ExplicitList <$> mapM go expressions

42−

43− App funcExpr argExpr ->

44− App <$> go funcExpr <*> go argExpr

45−

46− MultiIf branches ->

47− MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches

48−

49− Access record field ->

50− Access <$> go record <*> return field

51−

52− Remove record field ->

53− Remove <$> go record <*> return field

54−

55− Insert record field expr ->

56− Insert <$> go record <*> return field <*> go expr

57−

58− Modify record fields ->

59− Modify

60− <$> go record

61− <*> mapM (\(field,expr) -> (,) field <$> go expr) fields

62−

63− Record fields ->

64− Record <$> mapM (\(field,expr) -> (,) field <$> go expr) fields

65−

66− Let defs body ->

67− Let <$> defsTransform defs <*> go body

68−

69− GLShader uid src gltipe ->

70− return $ GLShader uid src gltipe

71−

72− Port impl ->

73− Port <$>

74− case impl of

75− In name tipe ->

76− return (In name tipe)

77−

78− Out name expr tipe ->

79− do expr' <- go expr

80− return (Out name expr' tipe)

81−

82− Task name expr tipe ->

83− do expr' <- go expr

84− return (Task name expr' tipe)

src/Transform/Interface.hsdeleted−60

@@ -1,60 +0,0 @@

1−module Transform.Interface (filterExports) where

2−

3−import qualified Data.Map as Map

4−import qualified Data.Maybe as Maybe

5−import qualified AST.Module as Module

6−import qualified AST.Variable as Var

7−

8−

9−filterExports :: Module.Interface -> Module.Interface

10−filterExports interface =

11− interface

12− { Module.iTypes =

13− Map.fromList $

14− Maybe.mapMaybe

15− (get (Module.iTypes interface))

16− (Var.getValues exports ++ ctors)

17−

18− , Module.iAliases =

19− Map.fromList $

20− Maybe.mapMaybe

21− (get (Module.iAliases interface))

22− (Var.getAliases exports)

23−

24− , Module.iAdts =

25− Map.fromList

26− (Maybe.mapMaybe (trimUnions interface) unions)

27− }

28− where

29− exports :: [Var.Value]

30− exports =

31− Module.iExports interface

32−

33− unions :: [(String, Var.Listing String)]

34− unions =

35− Var.getUnions exports

36−

37− ctors :: [String]

38− ctors =

39− concatMap (\(_, Var.Listing ctorList _) -> ctorList) unions

40−

41−

42−get :: Map.Map String a -> String -> Maybe (String, a)

43−get dict key =

44− case Map.lookup key dict of

45− Nothing -> Nothing

46− Just value -> Just (key, value)

47−

48−

49−trimUnions

50− :: Module.Interface

51− -> (String, Var.Listing String)

52− -> Maybe (String, Module.AdtInfo String)

53−trimUnions interface (name, Var.Listing exportedCtors _) =

54− case Map.lookup name (Module.iAdts interface) of

55− Nothing -> Nothing

56− Just (tvars, ctors) ->

57− let isExported (ctor, _) =

58− ctor `elem` exportedCtors

59− in

60− Just (name, (tvars, filter isExported ctors))

src/Type/Constrain/Expression.hs+298−148

@@ -3,212 +3,362 @@ module Type.Constrain.Expression where

33

44import Control.Applicative ((<$>))

55import qualified Control.Monad as Monad

6−import Control.Monad.Error

76import qualified Data.List as List

87import qualified Data.Map as Map

9−import Prelude hiding (and)

10−import qualified Text.PrettyPrint as PP

118

12−import qualified AST.Literal as Lit

13−import AST.Annotation as Ann

14−import AST.Expression.General

9+import qualified AST.Expression.General as E

1510import qualified AST.Expression.Canonical as Canonical

11+import qualified AST.Literal as Lit

1612import qualified AST.Pattern as P

1713import qualified AST.Type as ST

1814import qualified AST.Variable as V

19−import Type.Type hiding (Descriptor(..))

20−import qualified Type.Fragment as Fragment

21−import qualified Type.Environment as Env

15+import qualified Reporting.Annotation as A

16+import qualified Reporting.Error.Type as Error

17+import qualified Reporting.Region as R

2218import qualified Type.Constrain.Literal as Literal

2319import qualified Type.Constrain.Pattern as Pattern

20+import qualified Type.Environment as Env

21+import qualified Type.Fragment as Fragment

22+import Type.Type hiding (Descriptor(..))

2423

2524

2625constrain

2726 :: Env.Environment

2827 -> Canonical.Expr

2928 -> Type

30− -> ErrorT [PP.Doc] IO TypeConstraint

31−constrain env (A region expression) tipe =

29+ -> IO TypeConstraint

30+constrain env (A.A region expression) tipe =

3231 let list t = Env.get env Env.types "List" <| t

33− and = A region . CAnd

34− true = A region CTrue

35− t1 === t2 = A region (CEqual t1 t2)

36− x <? t = A region (CInstance x t)

37− clet schemes c = A region (CLet schemes c)

32+ (===) = CEqual Error.None region

33+ (<?) = CInstance region

3834 in

3935 case expression of

40− Literal lit ->

41− liftIO $ Literal.constrain env region lit tipe

36+ E.Literal lit ->

37+ Literal.constrain env region lit tipe

4238

43− GLShader _uid _src gltipe ->

39+ E.GLShader _uid _src gltipe ->

4440 exists $ \attr ->

4541 exists $ \unif ->

4642 let

47− shaderTipe a u v = Env.get env Env.types "WebGL.Shader" <| a <| u <| v

48− glTipe = Env.get env Env.types . Lit.glTipeName

49− makeRec accessor baseRec =

50− let decls = accessor gltipe

51− in if Map.size decls == 0

52− then baseRec

53− else record (Map.map (\t -> [glTipe t]) decls) baseRec

54− attribute = makeRec Lit.attribute attr

55− uniform = makeRec Lit.uniform unif

56− varying = makeRec Lit.varying (termN EmptyRecord1)

43+ shaderTipe a u v =

44+ Env.get env Env.types "WebGL.Shader" <| a <| u <| v

45+

46+ glTipe =

47+ Env.get env Env.types . Lit.glTipeName

48+

49+ makeRec accessor baseRec =

50+ let decls = accessor gltipe

51+ in

52+ if Map.size decls == 0

53+ then baseRec

54+ else record (Map.map (\t -> [glTipe t]) decls) baseRec

55+

56+ attribute = makeRec Lit.attribute attr

57+ uniform = makeRec Lit.uniform unif

58+ varying = makeRec Lit.varying (termN EmptyRecord1)

5759 in

58− return . A region $ CEqual tipe (shaderTipe attribute uniform varying)

60+ return (tipe === shaderTipe attribute uniform varying)

5961

60− Var var

61− | name == saveEnvName -> return (A region CSaveEnv)

62− | otherwise -> return (name <? tipe)

63− where

64− name = V.toString var

62+ E.Var var ->

63+ let name = V.toString var

64+ in

65+ return (if name == E.saveEnvName then CSaveEnv else name <? tipe)

6566

66− Range lo hi ->

67+ E.Range lowExpr highExpr ->

6768 existsNumber $ \n ->

68− do clo <- constrain env lo n

69− chi <- constrain env hi n

70− return $ and [clo, chi, list n === tipe]

71−

72− ExplicitList exprs ->

73− exists $ \x ->

74− do constraints <- mapM (\e -> constrain env e x) exprs

75− return . and $ list x === tipe : constraints

76−

77− Binop op e1 e2 ->

78− exists $ \t1 ->

79− exists $ \t2 ->

80− do c1 <- constrain env e1 t1

81− c2 <- constrain env e2 t2

82− return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]

83−

84− Lambda p e ->

85− exists $ \t1 ->

86− exists $ \t2 ->

87− do fragment <- try region $ Pattern.constrain env p t1

88− c2 <- constrain env e t2

89− let c = ex (Fragment.vars fragment)

90− (clet [monoscheme (Fragment.typeEnv fragment)]

91− (Fragment.typeConstraint fragment /\ c2)

92− )

93− return $ c /\ tipe === (t1 ==> t2)

94−

95− App e1 e2 ->

96− exists $ \t ->

97− do c1 <- constrain env e1 (t ==> tipe)

98− c2 <- constrain env e2 t

99− return $ c1 /\ c2

100−

101− MultiIf branches ->

102− and <$> mapM constrain' branches

103− where

104− bool = Env.get env Env.types "Bool"

105−

106− constrain' (cond, expr) =

107− do cb <- constrain env cond bool

108− ce <- constrain env expr tipe

109− return (cb /\ ce)

110−

111− Case expr branches ->

112− exists $ \t ->

113− do ce <- constrain env expr t

114− and . (:) ce <$> mapM (branch t) branches

115− where

116− branch t (pattern, branchExpr) =

117− do fragment <- try region $ Pattern.constrain env pattern t

118− clet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe

119−

120− Data name exprs ->

121− do vars <- forM exprs $ \_ -> liftIO (variable Flexible)

69+ do lowCon <- constrain env lowExpr n

70+ highCon <- constrain env highExpr n

71+ return $ CAnd [lowCon, highCon, list n === tipe]

72+

73+ E.ExplicitList exprs ->

74+ constrainList env region exprs tipe

75+

76+ E.Binop op leftExpr rightExpr ->

77+ exists $ \leftType ->

78+ exists $ \rightType ->

79+ do leftCon <- constrain env leftExpr leftType

80+ rightCon <- constrain env rightExpr rightType

81+ return $ CAnd

82+ [ leftCon

83+ , rightCon

84+ , V.toString op <? (leftType ==> rightType ==> tipe)

85+ ]

86+

87+ E.Lambda pattern body ->

88+ exists $ \argType ->

89+ exists $ \resType ->

90+ do fragment <- Pattern.constrain env pattern argType

91+ bodyCon <- constrain env body resType

92+ let con =

93+ ex (Fragment.vars fragment)

94+ (CLet [monoscheme (Fragment.typeEnv fragment)]

95+ (Fragment.typeConstraint fragment /\ bodyCon)

96+ )

97+ return $ con /\ tipe === (argType ==> resType)

98+

99+ E.App func arg ->

100+ do argVar <- variable Flexible

101+ resultVar <- variable Flexible

102+ argCon <- constrain env arg (varN argVar)

103+ funcCon <- constrain env func (varN argVar ==> varN resultVar)

104+ let appCon = tipe === varN resultVar

105+ return $

106+ ex [argVar,resultVar] (CAnd [ argCon, funcCon, appCon ])

107+

108+ E.MultiIf branches ->

109+ constrainIf env region branches tipe

110+

111+ E.Case expr branches ->

112+ constrainCase env region expr branches tipe

113+

114+ E.Data name exprs ->

115+ do vars <- Monad.forM exprs $ \_ -> variable Flexible

122116 let pairs = zip exprs (map varN vars)

123− (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

117+ (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

124118 return $ ex vars (cs /\ name <? ctipe)

125119 where

126120 step (t,c) (e,x) =

127121 do c' <- constrain env e x

128122 return (x ==> t, c /\ c')

129123

130− Access expr label ->

124+ E.Access expr label ->

131125 exists $ \t ->

132126 constrain env expr (record (Map.singleton label [tipe]) t)

133127

134− Remove expr label ->

128+ E.Remove expr label ->

135129 exists $ \t ->

136130 constrain env expr (record (Map.singleton label [t]) tipe)

137131

138− Insert expr label value ->

139− exists $ \tVal ->

140− exists $ \tRec ->

141− do cVal <- constrain env value tVal

142− cRec <- constrain env expr tRec

143− let c = tipe === record (Map.singleton label [tVal]) tRec

144− return (and [cVal, cRec, c])

132+ E.Insert expr label value ->

133+ exists $ \valueType ->

134+ exists $ \recordType ->

135+ do valueCon <- constrain env value valueType

136+ recordCon <- constrain env expr recordType

137+ let newRecordType =

138+ record (Map.singleton label [valueType]) recordType

139+ return (CAnd [valueCon, recordCon, tipe === newRecordType])

145140

146− Modify expr fields ->

141+ E.Modify expr fields ->

147142 exists $ \t ->

148− do oldVars <- forM fields $ \_ -> liftIO (variable Flexible)

143+ do oldVars <- Monad.forM fields $ \_ -> variable Flexible

149144 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

150145 cOld <- ex oldVars <$> constrain env expr (record oldFields t)

151146

152− newVars <- forM fields $ \_ -> liftIO (variable Flexible)

147+ newVars <- Monad.forM fields $ \_ -> variable Flexible

153148 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

154149 let cNew = tipe === record newFields t

155150

156− cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)

151+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)

157152

158− return $ cOld /\ ex newVars (and (cNew : cs))

153+ return $ cOld /\ ex newVars (CAnd (cNew : cs))

159154

160− Record fields ->

161− do vars <- forM fields $ \_ -> liftIO (variable Flexible)

162− cs <- zipWithM (constrain env) (map snd fields) (map varN vars)

155+ E.Record fields ->

156+ do vars <- Monad.forM fields (\_ -> variable Flexible)

157+ fieldCons <-

158+ Monad.zipWithM

159+ (constrain env)

160+ (map snd fields)

161+ (map varN vars)

163162 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

164163 let recordType = record fields' (termN EmptyRecord1)

165− return . ex vars . and $ tipe === recordType : cs

164+ return (ex vars (CAnd (fieldCons ++ [tipe === recordType])))

166165

167− Let defs body ->

168− do c <- constrain env body tipe

166+ E.Let defs body ->

167+ do bodyCon <- constrain env body tipe

169168

170169 (Info schemes rqs fqs headers c2 c1) <-

171170 Monad.foldM

172171 (constrainDef env)

173− (Info [] [] [] Map.empty true true)

172+ (Info [] [] [] Map.empty CTrue CTrue)

174173 (concatMap expandPattern defs)

175174

176− let letScheme = [ Scheme rqs fqs (clet [monoscheme headers] c2) headers ]

175+ let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]

177176

178− return $ clet schemes (clet letScheme (c1 /\ c))

177+ return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))

179178

180− Port impl ->

179+ E.Port impl ->

181180 case impl of

182− In _ _ ->

183− return true

181+ E.In _ _ ->

182+ return CTrue

184183

185− Out _ expr _ ->

184+ E.Out _ expr _ ->

186185 constrain env expr tipe

187186

188− Task _ expr _ ->

187+ E.Task _ expr _ ->

189188 constrain env expr tipe

190189

191190

191+-- CONSTRAIN LISTS

192+

193+constrainList

194+ :: Env.Environment

195+ -> R.Region

196+ -> [Canonical.Expr]

197+ -> Type

198+ -> IO TypeConstraint

199+constrainList env region exprs tipe =

200+ do (exprInfo, exprCons) <-

201+ unzip <$> mapM elementConstraint exprs

202+

203+ let pairwiseCons = pairwiseConstraints 2 exprInfo

204+

205+ return $

206+ ex (map fst exprInfo)

207+ (CAnd (exprCons ++ pairwiseCons))

208+ where

209+ list t =

210+ Env.get env Env.types "List" <| t

211+

212+ elementConstraint expr@(A.A region' _) =

213+ do var <- variable Flexible

214+ con <- constrain env expr (varN var)

215+ return ( (var, region'), con )

216+

217+ pairwiseConstraints n exprInfo =

218+ case exprInfo of

219+ [] ->

220+ []

221+

222+ (var,_) : [] ->

223+ [ CEqual Error.List region tipe (list (varN var)) ]

224+

225+ (var,_) : (var',region') : rest ->

226+ let

227+ hint = Error.ListElement n region'

228+ con = CEqual hint region (varN var) (varN var')

229+ in

230+ con : pairwiseConstraints (n+1) ((var', region') : rest)

231+

232+

233+-- CONSTRAIN IF EXPRESSIONS

234+

235+constrainIf

236+ :: Env.Environment

237+ -> R.Region

238+ -> [(Canonical.Expr, Canonical.Expr)]

239+ -> Type

240+ -> IO TypeConstraint

241+constrainIf env region branches tipe =

242+ do (branchInfo, branchExprCons) <-

243+ unzip <$> mapM constrainBranch branches

244+

245+ return $

246+ ex (map fst branchInfo)

247+ (CAnd (branchExprCons ++ branchCons branchInfo))

248+ where

249+ bool = Env.get env Env.types "Bool"

250+

251+ constrainBranch (cond, expr@(A.A branchRegion _)) =

252+ do branchVar <- variable Flexible

253+ condCon <- constrain env cond bool

254+ exprCon <- constrain env expr (varN branchVar)

255+ return

256+ ( (branchVar, branchRegion)

257+ , condCon /\ exprCon

258+ )

259+

260+ branchCons branchInfo =

261+ case branchInfo of

262+ [(thenVar, _), (elseVar, _)] ->

263+ [ CEqual Error.IfBranches region (varN thenVar) (varN elseVar)

264+ , CEqual Error.If region tipe (varN thenVar)

265+ ]

266+

267+ _ ->

268+ buildBranchCons 2 branchInfo

269+

270+ buildBranchCons n branchInfo =

271+ case branchInfo of

272+ [] ->

273+ []

274+

275+ (var,_) : [] ->

276+ [ CEqual Error.If region tipe (varN var) ]

277+

278+ (var,_) : (var',region') : rest ->

279+ let

280+ hint = Error.MultiIfBranch n region'

281+ con = CEqual hint region (varN var) (varN var')

282+ in

283+ con : buildBranchCons (n+1) ((var', region') : rest)

284+

285+

286+-- CONSTRAIN CASE EXPRESSIONS

287+

288+constrainCase

289+ :: Env.Environment

290+ -> R.Region

291+ -> Canonical.Expr

292+ -> [(P.CanonicalPattern, Canonical.Expr)]

293+ -> Type

294+ -> IO TypeConstraint

295+constrainCase env region expr branches tipe =

296+ do exprVar <- variable Flexible

297+

298+ exprCon <- constrain env expr (varN exprVar)

299+

300+ (branchInfo, branchExprCons) <-

301+ unzip <$> mapM (branch (varN exprVar)) branches

302+

303+ return $

304+ ex (exprVar : map fst branchInfo)

305+ (CAnd (exprCon : branchExprCons ++ branchCons 2 branchInfo))

306+ where

307+ branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

308+ do branchVar <- variable Flexible

309+ fragment <- Pattern.constrain env pattern patternType

310+ branchCon <- constrain env branchExpr (varN branchVar)

311+ return

312+ ( (branchVar, branchRegion)

313+ , CLet [Fragment.toScheme fragment] branchCon

314+ )

315+

316+ branchCons n branchInfo =

317+ case branchInfo of

318+ [] ->

319+ []

320+

321+ (var,_) : [] ->

322+ [ CEqual Error.Case region tipe (varN var) ]

323+

324+ (var,_) : (var',region') : rest ->

325+ let

326+ hint = Error.CaseBranch n region'

327+ con = CEqual hint region (varN var) (varN var')

328+ in

329+ con : branchCons (n+1) ((var', region') : rest)

330+

331+

332+-- EXPAND PATTERNS

333+

192334expandPattern :: Canonical.Def -> [Canonical.Def]

193−expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =

194− case pattern of

195− P.Var _ ->

196− [def]

197− _ ->

198− Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars

199− where

200− vars = P.boundVarList pattern

201− x = "$" ++ concat vars

202− mkVar = A r . localVar

203− toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

204−

205−

206−try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

207−try region computation =

208− do result <- liftIO $ runErrorT computation

209− case result of

210− Left err -> throwError [err region]

211− Right value -> return value

335+expandPattern def@(Canonical.Definition lpattern expr maybeType) =

336+ let (A.A patternRegion pattern) = lpattern

337+ in

338+ case pattern of

339+ P.Var _ ->

340+ [def]

341+

342+ _ ->

343+ mainDef : map toDef vars

344+ where

345+ vars = P.boundVarList lpattern

346+

347+ combinedName = "$" ++ concat vars

348+

349+ pvar name =

350+ A.A patternRegion (P.Var name)

351+

352+ localVar name =

353+ A.A patternRegion (E.localVar name)

354+

355+ mainDef = Canonical.Definition (pvar combinedName) expr maybeType

356+

357+ toDef name =

358+ let extract =

359+ E.Case (localVar combinedName) [(lpattern, localVar name)]

360+ in

361+ Canonical.Definition (pvar name) (A.A patternRegion extract) Nothing

212362

213363

214364-- CONSTRAIN DEFINITIONS

@@ -223,8 +373,8 @@ data Info = Info

223373 }

224374

225375

226−constrainDef :: Env.Environment -> Info -> Canonical.Def -> ErrorT [PP.Doc] IO Info

227−constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

376+constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info

377+constrainDef env info (Canonical.Definition (A.A _ pattern) expr maybeTipe) =

228378 let qs = [] -- should come from the def, but I'm not sure what would live there...

229379 in

230380 case (pattern, maybeTipe) of

@@ -243,13 +393,13 @@ constrainAnnotatedDef

243393 -> [String]

244394 -> String

245395 -> Canonical.Expr

246− -> ST.CanonicalType

247− -> ErrorT [PP.Doc] IO Info

396+ -> ST.Canonical

397+ -> IO Info

248398constrainAnnotatedDef env info qs name expr tipe =

249399 do -- Some mistake may be happening here. Currently, qs is always [].

250− rigidVars <- forM qs (\_ -> liftIO $ variable Rigid)

400+ rigidVars <- Monad.forM qs (\_ -> variable Rigid)

251401

252− flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)

402+ flexiVars <- Monad.forM qs (\_ -> variable Flexible)

253403

254404 let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

255405

@@ -261,7 +411,7 @@ constrainAnnotatedDef env info qs name expr tipe =

261411 Scheme

262412 { rigidQuantifiers = []

263413 , flexibleQuantifiers = flexiVars ++ vars

264− , constraint = Ann.noneNoDocs CTrue

414+ , constraint = CTrue

265415 , header = Map.singleton name typ

266416 }

267417

@@ -279,12 +429,12 @@ constrainUnannotatedDef

279429 -> [String]

280430 -> String

281431 -> Canonical.Expr

282− -> ErrorT [PP.Doc] IO Info

432+ -> IO Info

283433constrainUnannotatedDef env info qs name expr =

284434 do -- Some mistake may be happening here. Currently, qs is always [].

285− rigidVars <- forM qs (\_ -> liftIO $ variable Rigid)

435+ rigidVars <- Monad.forM qs (\_ -> variable Rigid)

286436

287− v <- liftIO $ variable Flexible

437+ v <- variable Flexible

288438

289439 let tipe = varN v

290440

src/Type/Constrain/Literal.hs+24−16

@@ -1,21 +1,29 @@

11module Type.Constrain.Literal where

22

3−import AST.Annotation

4−import AST.Literal

5−import Type.Type

6−import Type.Environment as Env

3+import qualified AST.Literal as L

4+import qualified Reporting.Error.Type as Error

5+import qualified Reporting.Region as R

6+import qualified Type.Type as T

7+import qualified Type.Environment as Env

78

8−constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint

9+

10+constrain

11+ :: Env.Environment

12+ -> R.Region

13+ -> L.Literal

14+ -> T.Type

15+ -> IO T.TypeConstraint

916constrain env region literal tipe =

10− do tipe' <- litType

11− return . A region $ CEqual tipe tipe'

12− where

13− prim name = return (Env.get env Env.types name)

17+ do tipe' <- litType

18+ return (T.CEqual Error.None region tipe tipe')

19+ where

20+ prim name =

21+ return (Env.get env Env.types name)

1422

15− litType =

16− case literal of

17− IntNum _ -> varN `fmap` variable (Is Number)

18− FloatNum _ -> prim "Float"

19− Chr _ -> prim "Char"

20− Str _ -> prim "String"

21− Boolean _ -> prim "Bool"

23+ litType =

24+ case literal of

25+ L.IntNum _ -> T.varN `fmap` T.variable (T.Is T.Number)

26+ L.FloatNum _ -> prim "Float"

27+ L.Chr _ -> prim "Char"

28+ L.Str _ -> prim "String"

29+ L.Boolean _ -> prim "Bool"

src/Type/Constrain/Pattern.hs+52−62

@@ -4,78 +4,68 @@ module Type.Constrain.Pattern where

44import Control.Arrow (second)

55import Control.Applicative ((<$>))

66import qualified Control.Monad as Monad

7−import Control.Monad.Error

87import qualified Data.Map as Map

9−import qualified Text.PrettyPrint as PP

108

11−import qualified AST.Annotation as A

129import qualified AST.Pattern as P

1310import qualified AST.Variable as V

14−import AST.PrettyPrint (pretty)

15−import Type.Type

16−import Type.Fragment

17−import Type.Environment as Env

11+import qualified Reporting.Annotation as A

12+import qualified Reporting.Error.Type as Error

1813import qualified Type.Constrain.Literal as Literal

14+import qualified Type.Environment as Env

15+import Type.Fragment

16+import Type.Type

1917

2018

21−constrain :: Environment -> P.CanonicalPattern -> Type

22− -> ErrorT (A.Region -> PP.Doc) IO Fragment

23−constrain env pattern tipe =

24− let region = A.None (pretty pattern)

25− t1 === t2 = A.A region (CEqual t1 t2)

26− in

27− case pattern of

28− P.Anything -> return emptyFragment

29−

30− P.Literal lit -> do

31− c <- liftIO $ Literal.constrain env region lit tipe

32− return $ emptyFragment { typeConstraint = c }

19+constrain

20+ :: Env.Environment

21+ -> P.CanonicalPattern

22+ -> Type

23+ -> IO Fragment

24+constrain env (A.A region pattern) tipe =

25+ let (===) = CEqual Error.None region

26+ in

27+ case pattern of

28+ P.Anything ->

29+ return emptyFragment

3330

34− P.Var name -> do

35− v <- liftIO $ variable Flexible

36− return $ Fragment {

37− typeEnv = Map.singleton name (varN v),

38− vars = [v],

39− typeConstraint = varN v === tipe

40− }

31+ P.Literal lit ->

32+ do c <- Literal.constrain env region lit tipe

33+ return $ emptyFragment { typeConstraint = c }

4134

42− P.Alias name p -> do

43− v <- liftIO $ variable Flexible

44− fragment <- constrain env p tipe

45− return $ fragment

46− { typeEnv = Map.insert name (varN v) (typeEnv fragment)

47− , vars = v : vars fragment

48− , typeConstraint = varN v === tipe /\ typeConstraint fragment

49− }

35+ P.Var name ->

36+ do v <- variable Flexible

37+ return $ Fragment

38+ { typeEnv = Map.singleton name (varN v)

39+ , vars = [v]

40+ , typeConstraint = varN v === tipe

41+ }

5042

51− P.Data name patterns -> do

52− (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)

53− let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind

54− , " argument", if kind == 1 then "" else "s"

55− , " but was given ", show (length patterns), "." ]

56− err span = PP.vcat [ PP.text $ "Type error " ++ show span

57− , PP.text msg ]

58− case length patterns == kind of

59− False -> throwError err

60− True -> do

61− fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)

62− return $ fragment {

63− typeConstraint = typeConstraint fragment /\ tipe === result,

64− vars = cvars ++ vars fragment

43+ P.Alias name p ->

44+ do v <- variable Flexible

45+ fragment <- constrain env p tipe

46+ return $ fragment

47+ { typeEnv = Map.insert name (varN v) (typeEnv fragment)

48+ , vars = v : vars fragment

49+ , typeConstraint = varN v === tipe /\ typeConstraint fragment

6550 }

6651

67− P.Record fields -> do

68− pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields

69− let tenv = Map.fromList (map (second varN) pairs)

70− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

71− return $ Fragment {

72− typeEnv = tenv,

73− vars = map snd pairs,

74− typeConstraint = c

75− }

52+ P.Data name patterns ->

53+ do (_kind, cvars, args, result) <-

54+ Env.freshDataScheme env (V.toString name)

55+

56+ fragList <- Monad.zipWithM (constrain env) patterns args

57+ let fragment = joinFragments fragList

58+ return $ fragment

59+ { typeConstraint = typeConstraint fragment /\ tipe === result

60+ , vars = cvars ++ vars fragment

61+ }

7662

77−instance Error (A.Region -> PP.Doc) where

78− noMsg _ = PP.empty

79− strMsg str span =

80− PP.vcat [ PP.text $ "Type error " ++ show span

81− , PP.text str ]

63+ P.Record fields ->

64+ do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields

65+ let tenv = Map.fromList (map (second varN) pairs)

66+ c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

67+ return $ Fragment

68+ { typeEnv = tenv

69+ , vars = map snd pairs

70+ , typeConstraint = c

71+ }

src/Type/Environment.hs+15−23

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

11module Type.Environment where

22

33import Control.Applicative ((<$>), (<*>))

4−import Control.Exception (try, SomeException)

5−import Control.Monad

6−import Control.Monad.Error (ErrorT, throwError, liftIO)

4+import Control.Monad (forM)

75import qualified Control.Monad.State as State

86import qualified Data.Traversable as Traverse

97import qualified Data.Map as Map

108import qualified Data.Set as Set

119import Data.List (isPrefixOf)

12−import qualified Text.PrettyPrint as PP

1310

1411import qualified AST.Type as T

1512import qualified AST.Variable as V

16−import AST.Module (CanonicalAdt, AdtInfo)

13+import qualified AST.Module as Module

1714import Type.Type

1815

1916

@@ -28,7 +25,7 @@ data Environment = Environment

2825 }

2926

3027

31−initialEnvironment :: [CanonicalAdt] -> IO Environment

28+initialEnvironment :: [Module.CanonicalAdt] -> IO Environment

3229initialEnvironment datatypes =

3330 do types <- makeTypes datatypes

3431 let env =

@@ -40,13 +37,13 @@ initialEnvironment datatypes =

4037 return $ env { constructor = makeConstructors env datatypes }

4138

4239

43−makeTypes :: [CanonicalAdt] -> IO TypeDict

40+makeTypes :: [Module.CanonicalAdt] -> IO TypeDict

4441makeTypes datatypes =

4542 do adts <- mapM makeImported datatypes

4643 bs <- mapM makeBuiltin builtins

4744 return (Map.fromList (adts ++ bs))

4845 where

49− makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)

46+ makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)

5047 makeImported (var, _) =

5148 do tvar <- namedVar Constant var

5249 return (V.toString var, varN tvar)

@@ -70,7 +67,7 @@ makeTypes datatypes =

7067

7168makeConstructors

7269 :: Environment

73− -> [CanonicalAdt]

70+ -> [Module.CanonicalAdt]

7471 -> Map.Map String (IO (Int, [Variable], [Type], Type))

7572makeConstructors env datatypes =

7673 Map.fromList builtins

@@ -98,18 +95,18 @@ makeConstructors env datatypes =

9895

9996ctorToType

10097 :: Environment

101− -> (V.Canonical, AdtInfo V.Canonical)

98+ -> (V.Canonical, Module.AdtInfo V.Canonical)

10299 -> [(String, IO (Int, [Variable], [Type], Type))]

103100ctorToType env (name, (tvars, ctors)) =

104101 zip (map (V.toString . fst) ctors) (map inst ctors)

105102 where

106− inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)

103+ inst :: (V.Canonical, [T.Canonical]) -> IO (Int, [Variable], [Type], Type)

107104 inst ctor =

108105 do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty

109106 return (length args, Map.elems dict, args, tipe)

110107

111108

112− go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)

109+ go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)

113110 go (_, args) =

114111 do types <- mapM (instantiator env) args

115112 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))

@@ -133,22 +130,17 @@ freshDataScheme env name =

133130

134131instantiateType

135132 :: Environment

136− -> T.CanonicalType

133+ -> T.Canonical

137134 -> VarDict

138− -> ErrorT [PP.Doc] IO ([Variable], Type)

135+ -> IO ([Variable], Type)

139136instantiateType env sourceType dict =

140− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)

141− case result :: Either SomeException (Type, VarDict) of

142− Left someError ->

143− throwError [ PP.text $ show someError ]

144−

145− Right (tipe, dict') ->

146− return (Map.elems dict', tipe)

137+ do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict

138+ return (Map.elems dict', tipe)

147139

148140

149141instantiator

150142 :: Environment

151− -> T.CanonicalType

143+ -> T.Canonical

152144 -> State.StateT VarDict IO Type

153145instantiator env sourceType =

154146 instantiatorHelp env Set.empty sourceType

@@ -157,7 +149,7 @@ instantiator env sourceType =

157149instantiatorHelp

158150 :: Environment

159151 -> Set.Set String

160− -> T.CanonicalType

152+ -> T.Canonical

161153 -> State.StateT VarDict IO Type

162154instantiatorHelp env aliasVars sourceType =

163155 let go = instantiatorHelp env aliasVars

src/Type/ExtraChecks.hsdeleted−160

@@ -1,160 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−

3−{-| This module contains checks to be run *after* type inference has completed

4−successfully. At that point we still need to do occurs checks and ensure that

5−`main` has an acceptable type.

6−-}

7−module Type.ExtraChecks (effectTypes, occurs) where

8−

9−import Prelude hiding (maybe)

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

11−import Control.Monad.Error

12−import Control.Monad.State

13−import qualified Data.Map as Map

14−import qualified Data.Traversable as Traverse

15−import qualified Data.UnionFind.IO as UF

16−import Text.PrettyPrint as P

17−

18−import qualified AST.Annotation as A

19−import qualified AST.PrettyPrint as PP

20−import qualified AST.Type as ST

21−import qualified AST.Variable as Var

22−import qualified Type.Hint as Hint

23−import qualified Type.Type as TT

24−import qualified Type.State as TS

25−

26−

27−-- EFFECT TYPE CHECKS

28−

29−effectTypes :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)

30−effectTypes environment =

31− do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment

32− mainCheck environment'

33− return environment'

34−

35−

36−-- MAIN TYPE

37−

38−mainCheck

39− :: (Monad m)

40− => Map.Map String ST.CanonicalType

41− -> ErrorT [P.Doc] m ()

42−mainCheck env =

43− case Map.lookup "main" env of

44− Nothing ->

45− return ()

46−

47− Just typeOfMain ->

48− let tipe = ST.deepDealias typeOfMain

49− in

50− if tipe `elem` validMainTypes

51− then return ()

52− else throwError [ badMainMessage typeOfMain ]

53−

54−

55−validMainTypes :: [ST.CanonicalType]

56−validMainTypes =

57− [ element

58− , html

59− , signal element

60− , signal html

61− ]

62− where

63− fromModule :: [String] -> String -> ST.CanonicalType

64− fromModule home name =

65− ST.Type (Var.fromModule home name)

66−

67− html =

68− fromModule ["VirtualDom"] "Node"

69−

70− signal tipe =

71− ST.App (fromModule ["Signal"] "Signal") [ tipe ]

72−

73− element =

74− let builtin name =

75− ST.Type (Var.builtin name)

76−

77− maybe tipe =

78− ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]

79− in

80− ST.Record

81− [ ("element", fromModule ["Graphics","Element"] "ElementPrim")

82− , ("props",

83− ST.Record

84− [ ("click" , builtin "_Tuple0")

85− , ("color" , maybe (fromModule ["Color"] "Color"))

86− , ("height" , builtin "Int")

87− , ("hover" , builtin "_Tuple0")

88− , ("href" , builtin "String")

89− , ("id" , builtin "Int")

90− , ("opacity", builtin "Float")

91− , ("tag" , builtin "String")

92− , ("width" , builtin "Int")

93− ]

94− Nothing

95− )

96− ]

97− Nothing

98−

99−

100−badMainMessage :: ST.CanonicalType -> P.Doc

101−badMainMessage typeOfMain =

102− P.vcat

103− [ P.text "Type Error: 'main' must have one of the following types:"

104− , P.text " "

105− , P.text " Element, Html, Signal Element, Signal Html"

106− , P.text " "

107− , P.text "Instead 'main' has type:\n"

108− , P.nest 4 (PP.pretty typeOfMain)

109− , P.text " "

110− ]

111−

112−

113−-- INFINITE TYPES

114−

115−occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

116−occurs (name, variable) =

117− do vars <- liftIO $ infiniteVars [] variable

118− case vars of

119− [] ->

120− return ()

121−

122− var : _ ->

123− do desc <- liftIO $ UF.descriptor var

124− case TT.structure desc of

125− Nothing ->

126− TS.addHint (P.text msg)

127−

128− Just _ ->

129− do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

130− var' <- liftIO $ UF.fresh desc

131− hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'

132− TS.addHint hint

133− where

134− msg = "Infinite types are not allowed"

135−

136− infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

137− infiniteVars seen var =

138− let go = infiniteVars (var:seen) in

139− if var `elem` seen

140− then return [var]

141− else do

142− desc <- UF.descriptor var

143− case TT.structure desc of

144− Nothing -> return []

145− Just struct ->

146− case struct of

147− TT.App1 a b ->

148− (++) <$> go a <*> go b

149−

150− TT.Fun1 a b ->

151− (++) <$> go a <*> go b

152−

153− TT.Var1 a ->

154− go a

155−

156− TT.EmptyRecord1 ->

157− return []

158−

159− TT.Record1 fields ext ->

160− concat <$> mapM go (ext : concat (Map.elems fields))

src/Type/Fragment.hs+11−11

@@ -5,32 +5,32 @@ import qualified Data.List as List

55import qualified Data.Map as Map

66

77import Type.Type

8−import AST.Annotation (noneNoDocs)

8+

99

1010data Fragment = Fragment

11− { typeEnv :: Map.Map String Type

12− , vars :: [Variable]

11+ { typeEnv :: Map.Map String Type

12+ , vars :: [Variable]

1313 , typeConstraint :: TypeConstraint

1414 }

1515

1616

1717emptyFragment :: Fragment

1818emptyFragment =

19− Fragment Map.empty [] (noneNoDocs CTrue)

19+ Fragment Map.empty [] CTrue

2020

2121

2222joinFragment :: Fragment -> Fragment -> Fragment

2323joinFragment f1 f2 =

2424 Fragment

25− { typeEnv =

26− Map.union (typeEnv f1) (typeEnv f2)

25+ { typeEnv =

26+ Map.union (typeEnv f1) (typeEnv f2)

2727

28− , vars =

29− vars f1 ++ vars f2

28+ , vars =

29+ vars f1 ++ vars f2

3030

31− , typeConstraint =

32− typeConstraint f1 /\ typeConstraint f2

33− }

31+ , typeConstraint =

32+ typeConstraint f1 /\ typeConstraint f2

33+ }

3434

3535

3636joinFragments :: [Fragment] -> Fragment

src/Type/Hint.hsdeleted−35

@@ -1,35 +0,0 @@

1−module Type.Hint where

2−

3−import Control.Applicative ( (<$>) )

4−import qualified Data.UnionFind.IO as UF

5−import Text.PrettyPrint as P

6−

7−import qualified AST.Annotation as A

8−import AST.PrettyPrint (pretty)

9−import Type.Type (Descriptor, toSrcType)

10−

11−

12−type Hint = Doc

13−

14−

15−create

16− :: A.Region

17− -> Maybe String

18− -> UF.Point Descriptor

19− -> UF.Point Descriptor

20− -> IO Hint

21−create region hint t1 t2 =

22− do t1' <- pretty <$> toSrcType t1

23− t2' <- pretty <$> toSrcType t2

24− return . foldr ($+$) P.empty $

25− [ P.text "Type mismatch between the following types" <+> pretty region <> P.text ":"

26− , P.text ""

27− , P.nest 8 t1'

28− , P.text ""

29− , P.nest 8 t2'

30− , P.text ""

31− , maybe P.empty (P.nest 4 . P.text) hint

32− , P.text " It is related to the following expression:"

33− , P.text ""

34− , P.nest 8 $ A.getRegionDocs region

35− ]

src/Type/Inference.hs+34−29

@@ -1,18 +1,17 @@

11module Type.Inference where

22

33import Control.Arrow (first, second)

4−import Control.Monad.State (execStateT, forM)

5−import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)

4+import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)

65import qualified Data.Map as Map

7−import Text.PrettyPrint

6+import qualified Data.Traversable as Traverse

87

9−import qualified AST.Annotation as A

108import AST.Module as Module

11−import AST.Type (CanonicalType)

9+import qualified AST.Type as Type

1210import qualified AST.Variable as Var

11+import qualified Reporting.Annotation as A

12+import qualified Reporting.Error.Type as Error

1313import qualified Type.Constrain.Expression as TcExpr

1414import qualified Type.Environment as Env

15−import qualified Type.ExtraChecks as Check

1615import qualified Type.Solve as Solve

1716import qualified Type.State as TS

1817import qualified Type.Type as T

@@ -22,50 +21,56 @@ import System.IO.Unsafe

2221 -- I don't think that'd be worthwhile though.

2322

2423

25−infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)

24+infer

25+ :: Interfaces

26+ -> CanonicalModule

27+ -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)

2628infer interfaces modul =

27− unsafePerformIO $ runErrorT $

28− do (header, constraint) <- genConstraints interfaces modul

29−

30− state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState

29+ either throwError return $ unsafePerformIO $ runExceptT $

30+ do (header, constraint) <-

31+ liftIO (genConstraints interfaces modul)

3132

32− () <- case TS.sHint state of

33− hints@(_:_) -> throwError hints

34− [] -> return ()

33+ state <- Solve.solve constraint

3534

3635 let header' = Map.delete "::" header

37− types = Map.difference (TS.sSavedEnv state) header'

36+ let types = Map.difference (TS.sSavedEnv state) header'

3837

39− Check.effectTypes types

38+ liftIO (Traverse.traverse T.toSrcType types)

4039

4140

4241genConstraints

4342 :: Interfaces

4443 -> CanonicalModule

45− -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)

44+ -> IO (Env.TypeDict, T.TypeConstraint)

4645genConstraints interfaces modul =

47− do env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)

46+ do env <-

47+ Env.initialEnvironment (canonicalizeAdts interfaces modul)

4848

49− ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do

50− (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name

51− return (name, (vars, foldr (T.==>) result args))

49+ ctors <-

50+ forM (Map.keys (Env.constructor env)) $ \name ->

51+ do (_, vars, args, result) <- Env.freshDataScheme env name

52+ return (name, (vars, foldr (T.==>) result args))

5253

53− importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)

54+ importedVars <-

55+ mapM (canonicalizeValues env) (Map.toList interfaces)

5456

5557 let allTypes = concat (ctors : importedVars)

56− vars = concatMap (fst . snd) allTypes

57− header = Map.map snd (Map.fromList allTypes)

58− environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]

58+ let vars = concatMap (fst . snd) allTypes

59+ let header = Map.map snd (Map.fromList allTypes)

60+ let environ = T.CLet [ T.Scheme vars [] T.CTrue header ]

61+

62+ fvar <- T.variable T.Flexible

63+

64+ constraint <-

65+ TcExpr.constrain env (program (body modul)) (T.varN fvar)

5966

60− fvar <- liftIO $ T.variable T.Flexible

61− c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)

62− return (header, environ c)

67+ return (header, environ constraint)

6368

6469

6570canonicalizeValues

6671 :: Env.Environment

6772 -> (Module.Name, Interface)

68− -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]

73+ -> IO [(String, ([T.Variable], T.Type))]

6974canonicalizeValues env (moduleName, iface) =

7075 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->

7176 do tipe' <- Env.instantiateType env tipe Map.empty

src/Type/Solve.hs+158−92

@@ -1,29 +1,32 @@

11module Type.Solve (solve) where

22

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

34import Control.Monad

4−import Control.Monad.State

5+import Control.Monad.State (StateT, execStateT, liftIO)

6+import Control.Monad.Except (ExceptT, throwError)

57import qualified Data.List as List

68import qualified Data.Map as Map

79import qualified Data.Traversable as Traversable

810import qualified Data.UnionFind.IO as UF

11+

12+import qualified Reporting.Annotation as A

13+import qualified Reporting.Error.Type as Error

14+import qualified Type.State as TS

915import Type.Type

1016import Type.Unify

11−import qualified Type.ExtraChecks as Check

12−import qualified Type.Hint as Hint

13−import qualified Type.State as TS

14−import qualified AST.Annotation as A

1517

1618

17−-- | Every variable has rank less than or equal to the maxRank of the pool.

18−-- This sorts variables into the young and old pools accordingly.

19+{-| Every variable has rank less than or equal to the maxRank of the pool.

20+This sorts variables into the young and old pools accordingly.

21+-}

1922generalize :: TS.Pool -> StateT TS.SolverState IO ()

2023generalize youngPool =

21− do youngMark <- TS.uniqueMark

24+ do youngMark <- TS.uniqueMark

2225 let youngRank = TS.maxRank youngPool

23− insert dict var = do

24− descriptor <- liftIO $ UF.descriptor var

25− liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

26− return $ Map.insertWith (++) (rank descriptor) [var] dict

26+ let insert dict var =

27+ do descriptor <- liftIO $ UF.descriptor var

28+ liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

29+ return $ Map.insertWith (++) (rank descriptor) [var] dict

2730

2831 -- Sort the youngPool variables by rank.

2932 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

@@ -37,9 +40,9 @@ generalize youngPool =

3740

3841 -- For variables that have rank lowerer than youngRank, register them in

3942 -- the old pool if they are not redundant.

40− let registerIfNotRedundant var = do

41− isRedundant <- liftIO $ UF.redundant var

42− if isRedundant then return var else TS.register var

43+ let registerIfNotRedundant var =

44+ do isRedundant <- liftIO $ UF.redundant var

45+ if isRedundant then return var else TS.register var

4346

4447 let rankDict' = Map.delete youngRank rankDict

4548 Traversable.traverse (mapM registerIfNotRedundant) rankDict'

@@ -58,7 +61,7 @@ generalize youngPool =

5861 False -> do

5962 let flex' = case flex desc of { Flexible -> Rigid ; other -> other }

6063 liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })

61−

64+

6265 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

6366

6467

@@ -85,73 +88,96 @@ adjustRank youngMark visitedMark groupRank var =

8588 | otherwise ->

8689 return (rank descriptor)

8790 where

88− adjust = adjustRank youngMark visitedMark groupRank

91+ adjust =

92+ adjustRank youngMark visitedMark groupRank

8993

9094 adjustTerm term =

9195 case term of

92− App1 a b -> max `liftM` adjust a `ap` adjust b

93− Fun1 a b -> max `liftM` adjust a `ap` adjust b

94− Var1 x -> adjust x

95− EmptyRecord1 -> return outermostRank

96+ App1 a b ->

97+ max `liftM` adjust a `ap` adjust b

98+

99+ Fun1 a b ->

100+ max `liftM` adjust a `ap` adjust b

101+

102+ Var1 x ->

103+ adjust x

104+

105+ EmptyRecord1 ->

106+ return outermostRank

107+

96108 Record1 fields extension ->

97− do ranks <- mapM adjust (concat (Map.elems fields))

98− rnk <- adjust extension

99− return . maximum $ rnk : ranks

109+ do ranks <- mapM adjust (concat (Map.elems fields))

110+ rnk <- adjust extension

111+ return . maximum $ rnk : ranks

112+

113+

114+-- SOLVER

100115

116+solve :: TypeConstraint -> ExceptT [A.Located Error.Error] IO TS.SolverState

117+solve constraint =

118+ do state <-

119+ liftIO (execStateT (actuallySolve constraint) TS.initialState)

120+ case TS.sError state of

121+ [] ->

122+ return state

123+ errors ->

124+ throwError errors

101125

102−solve :: TypeConstraint -> StateT TS.SolverState IO ()

103−solve (A.A region constraint) =

126+

127+actuallySolve :: TypeConstraint -> StateT TS.SolverState IO ()

128+actuallySolve constraint =

104129 case constraint of

105130 CTrue ->

106− return ()

131+ return ()

107132

108133 CSaveEnv ->

109− TS.saveLocalEnv

134+ TS.saveLocalEnv

110135

111− CEqual term1 term2 ->

112− do t1 <- TS.flatten term1

113− t2 <- TS.flatten term2

114− unify region t1 t2

136+ CEqual hint region term1 term2 ->

137+ do t1 <- TS.flatten term1

138+ t2 <- TS.flatten term2

139+ unify hint region t1 t2

115140

116141 CAnd cs ->

117− mapM_ solve cs

142+ mapM_ actuallySolve cs

118143

119− CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) ->

120− do oldEnv <- TS.getEnv

121− mapM TS.introduce fqs

122− solve constraint'

123− TS.modifyEnv (\_ -> oldEnv)

144+ CLet [Scheme [] fqs constraint' _] CTrue ->

145+ do oldEnv <- TS.getEnv

146+ mapM TS.introduce fqs

147+ actuallySolve constraint'

148+ TS.modifyEnv (\_ -> oldEnv)

124149

125150 CLet schemes constraint' ->

126− do oldEnv <- TS.getEnv

127− headers <- Map.unions `fmap` mapM (solveScheme region) schemes

128− TS.modifyEnv $ \env -> Map.union headers env

129− solve constraint'

130− mapM Check.occurs $ Map.toList headers

131− TS.modifyEnv (\_ -> oldEnv)

132−

133− CInstance name term ->

134− do env <- TS.getEnv

135− freshCopy <-

136− case Map.lookup name env of

137− Just tipe -> TS.makeInstance tipe

138− Nothing

139− | List.isPrefixOf "Native." name -> liftIO (variable Flexible)

140− | otherwise ->

141− error ("Could not find '" ++ name ++ "' when solving type constraints.")

142−

143− t <- TS.flatten term

144− unify region freshCopy t

145−

146−

147−solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

148−solveScheme region scheme =

149− case scheme of

150− Scheme [] [] constraint header ->

151− do solve constraint

151+ do oldEnv <- TS.getEnv

152+ headers <- Map.unions `fmap` mapM solveScheme schemes

153+ TS.modifyEnv $ \env -> Map.union headers env

154+ actuallySolve constraint'

155+ mapM occurs $ Map.toList headers

156+ TS.modifyEnv (\_ -> oldEnv)

157+

158+ CInstance region name term ->

159+ do env <- TS.getEnv

160+ freshCopy <-

161+ case Map.lookup name env of

162+ Just tipe ->

163+ TS.makeInstance tipe

164+ Nothing ->

165+ if List.isPrefixOf "Native." name

166+ then liftIO (variable Flexible)

167+ else error ("Could not find '" ++ name ++ "' when solving type constraints.")

168+

169+ t <- TS.flatten term

170+ unify Error.None region freshCopy t

171+

172+

173+solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

174+solveScheme scheme =

175+ case scheme of

176+ Scheme [] [] constraint header ->

177+ do actuallySolve constraint

152178 Traversable.traverse TS.flatten header

153179

154− Scheme rigidQuantifiers flexibleQuantifiers constraint header ->

180+ Scheme rigidQuantifiers flexibleQuantifiers constraint header ->

155181 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

156182 oldPool <- TS.getPool

157183

@@ -160,54 +186,94 @@ solveScheme region scheme =

160186 TS.switchToPool freshPool

161187 mapM TS.introduce quantifiers

162188 header' <- Traversable.traverse TS.flatten header

163− solve constraint

189+ actuallySolve constraint

164190

165− allDistinct region rigidQuantifiers

191+ allDistinct rigidQuantifiers

166192 youngPool <- TS.getPool

167193 TS.switchToPool oldPool

168194 generalize youngPool

169− mapM (isGeneric region) rigidQuantifiers

195+ mapM isGeneric rigidQuantifiers

170196 return header'

171197

172198

173−addHint

174− :: A.Region

175− -> Maybe String

176− -> UF.Point Descriptor

177− -> UF.Point Descriptor

178− -> StateT TS.SolverState IO ()

179−addHint region hint t1 t2 =

180− do msg <- liftIO (Hint.create region hint t1 t2)

181− TS.addHint msg

182−

199+-- ADDITIONAL CHECKS

183200

184201-- Checks that all of the given variables belong to distinct equivalence classes.

185202-- Also checks that their structure is Nothing, so they represent a variable, not

186203-- a more complex term.

187−allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()

188−allDistinct region vars =

204+allDistinct :: [Variable] -> StateT TS.SolverState IO ()

205+allDistinct vars =

189206 do seen <- TS.uniqueMark

190207 forM_ vars $ \var ->

191208 do desc <- liftIO $ UF.descriptor var

192209 case structure desc of

193210 Just _ ->

194− let msg = "Cannot generalize something that is not a type variable."

195− in

196− addHint region (Just msg) var var

211+ crash "Cannot generalize something that is not a type variable."

197212

198213 Nothing ->

199− do when (mark desc == seen) $

200− do let msg = "Duplicate variable during generalization."

201− addHint region (Just msg) var var

202− liftIO $ UF.setDescriptor var (desc { mark = seen })

214+ if mark desc == seen

215+ then crash "Duplicate variable during generalization."

216+ else liftIO (UF.setDescriptor var (desc { mark = seen }))

203217

204218

205219-- Check that a variable has rank == noRank, meaning that it can be generalized.

206−isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()

207−isGeneric region var =

220+isGeneric :: Variable -> StateT TS.SolverState IO ()

221+isGeneric var =

208222 do desc <- liftIO $ UF.descriptor var

209223 if rank desc == noRank

210224 then return ()

211− else

212− let msg = "Unable to generalize a type variable. It is not unranked."

213− in addHint region (Just msg) var var

225+ else crash "Unable to generalize a type variable. It is not unranked."

226+

227+

228+crash :: String -> a

229+crash msg =

230+ error $

231+ "It looks like something went wrong with the type inference algorithm.\n"

232+ ++ msg ++ "\n"

233+ ++ "Please create a minimal example that triggers this problem and report it to\n"

234+ ++ "<https://github.com/elm-lang/elm-compiler/issues>"

235+

236+

237+occurs :: (String, Variable) -> StateT TS.SolverState IO ()

238+occurs (_name, variable) =

239+ do vars <- liftIO $ infiniteVars [] variable

240+ case vars of

241+ [] ->

242+ return ()

243+

244+ var : _ ->

245+ do desc <- liftIO $ UF.descriptor var

246+ let region = error "TODO:occurs"

247+ case structure desc of

248+ Nothing ->

249+ TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))

250+

251+ Just _ ->

252+ TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))

253+ where

254+ infiniteVars :: [Variable] -> Variable -> IO [Variable]

255+ infiniteVars seen var =

256+ let go = infiniteVars (var:seen)

257+ in

258+ if var `elem` seen

259+ then return [var]

260+ else do

261+ desc <- UF.descriptor var

262+ case structure desc of

263+ Nothing -> return []

264+ Just struct ->

265+ case struct of

266+ App1 a b ->

267+ (++) <$> go a <*> go b

268+

269+ Fun1 a b ->

270+ (++) <$> go a <*> go b

271+

272+ Var1 a ->

273+ go a

274+

275+ EmptyRecord1 ->

276+ return []

277+

278+ Record1 fields ext ->

279+ concat <$> mapM go (ext : concat (Map.elems fields))

src/Type/State.hs+8−6

@@ -8,7 +8,9 @@ import qualified Data.Map as Map

88import qualified Data.Traversable as Traversable

99import qualified Data.UnionFind.IO as UF

1010

11−import qualified Type.Hint as Hint

11+import qualified Reporting.Annotation as A

12+import qualified Reporting.Error.Type as Error

13+import qualified Reporting.Region as R

1214import Type.Type

1315

1416

@@ -40,7 +42,7 @@ data SolverState = SS

4042 , sSavedEnv :: Env

4143 , sPool :: Pool

4244 , sMark :: Int

43− , sHint :: [Hint.Hint]

45+ , sError :: [A.Located Error.Error]

4446 }

4547

4648

@@ -51,7 +53,7 @@ initialState =

5153 , sSavedEnv = Map.empty

5254 , sPool = emptyPool

5355 , sMark = noMark + 1 -- The mark must never be equal to noMark!

54− , sHint = []

56+ , sError = []

5557 }

5658

5759

@@ -65,9 +67,9 @@ modifyPool f =

6567 modify $ \state -> state { sPool = f (sPool state) }

6668

6769

68−addHint :: Hint.Hint -> StateT SolverState IO ()

69−addHint hint =

70− modify $ \state -> state { sHint = hint : sHint state }

70+addError :: R.Region -> Error.Error -> StateT SolverState IO ()

71+addError region err =

72+ modify $ \state -> state { sError = A.A region err : sError state }

7173

7274

7375switchToPool :: (MonadState SolverState m) => Pool -> m ()

src/Type/Type.hs+84−63

@@ -3,7 +3,6 @@ module Type.Type where

33import Control.Applicative ((<$>),(<*>))

44import Control.Monad.State (StateT)

55import qualified Control.Monad.State as State

6−import Control.Monad.Error (ErrorT, Error, liftIO)

76import qualified Data.Char as Char

87import qualified Data.Map as Map

98import qualified Data.Set as Set

@@ -12,10 +11,10 @@ import qualified Data.UnionFind.IO as UF

1211import Text.PrettyPrint as P

1312import System.IO.Unsafe

1413

15−import AST.Annotation

16−import qualified AST.PrettyPrint as PP

1714import qualified AST.Type as T

1815import qualified AST.Variable as Var

16+import qualified Reporting.Error.Type as Error

17+import qualified Reporting.Region as R

1918import Type.PrettyPrint

2019

2120

@@ -103,16 +102,13 @@ data SuperType

103102

104103-- CONSTRAINTS

105104

106−type Constraint a b =

107− Located (BasicConstraint a b)

108−

109−data BasicConstraint a b

105+data Constraint a b

110106 = CTrue

111107 | CSaveEnv

112− | CEqual a a

108+ | CEqual Error.Hint R.Region a a

113109 | CAnd [Constraint a b]

114110 | CLet [Scheme a b] (Constraint a b)

115− | CInstance SchemeName a

111+ | CInstance R.Region SchemeName a

116112

117113type SchemeName = String

118114

@@ -170,40 +166,40 @@ variable flex = UF.fresh $ Descriptor

170166

171167monoscheme :: Map.Map String a -> Scheme a b

172168monoscheme headers =

173− Scheme [] [] (noneNoDocs CTrue) headers

169+ Scheme [] [] CTrue headers

174170

175171

176172infixl 8 /\

177173

178174(/\) :: Constraint a b -> Constraint a b -> Constraint a b

179−(/\) a@(A _ c1) b@(A _ c2) =

175+(/\) c1 c2 =

180176 case (c1, c2) of

181− (CTrue, _) -> b

182− (_, CTrue) -> a

183− _ -> mergeOldDocs a b (CAnd [a,b])

177+ (CTrue, _) -> c2

178+ (_, CTrue) -> c1

179+ _ -> CAnd [c1,c2]

184180

185181

186182-- ex qs constraint == exists qs. constraint

187183ex :: [Variable] -> TypeConstraint -> TypeConstraint

188−ex fqs constraint@(A ann _) =

189− A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)

184+ex fqs constraint =

185+ CLet [Scheme [] fqs constraint Map.empty] CTrue

190186

191187

192188-- fl qs constraint == forall qs. constraint

193189fl :: [Variable] -> TypeConstraint -> TypeConstraint

194−fl rqs constraint@(A ann _) =

195− A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)

190+fl rqs constraint =

191+ CLet [Scheme rqs [] constraint Map.empty] CTrue

196192

197193

198−exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

194+exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

199195exists f =

200− do v <- liftIO $ variable Flexible

196+ do v <- variable Flexible

201197 ex [v] <$> f (varN v)

202198

203199

204−existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

200+existsNumber :: (Type -> IO TypeConstraint) -> IO TypeConstraint

205201existsNumber f =

206− do v <- liftIO $ variable (Is Number)

202+ do v <- variable (Is Number)

207203 ex [v] <$> f (varN v)

208204

209205

@@ -214,11 +210,6 @@ instance PrettyType a => PrettyType (UF.Point a) where

214210 unsafePerformIO $ fmap (pretty when) (UF.descriptor point)

215211

216212

217−instance PrettyType t => PrettyType (Annotated a t) where

218− pretty when (A _ e) =

219− pretty when e

220−

221−

222213instance PrettyType a => PrettyType (Term1 a) where

223214 pretty when term =

224215 let prty = pretty Never in

@@ -280,14 +271,20 @@ instance PrettyType a => PrettyType (TermN a) where

280271 case maybeAlias of

281272 Nothing -> doc

282273 Just (name, args) ->

283− P.hang (PP.pretty name) 2 (P.sep (map (pretty App . snd) args))

274+ P.hang

275+ (P.text (Var.toString name))

276+ 2

277+ (P.sep (map (pretty App . snd) args))

284278

285279

286280instance PrettyType Descriptor where

287281 pretty when desc =

288282 case (alias desc, structure desc, name desc) of

289283 (Just (name, args), _, _) ->

290− P.hang (PP.pretty name) 4 (P.sep (map (pretty App . snd) args))

284+ P.hang

285+ (P.text (Var.toString name))

286+ 4

287+ (P.sep (map (pretty App . snd) args))

291288

292289 (_, Just term, _) ->

293290 pretty when term

@@ -301,72 +298,96 @@ instance PrettyType Descriptor where

301298 _ -> P.text "?"

302299

303300

304−instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where

301+instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where

305302 pretty _ constraint =

306303 let prty = pretty Never in

307304 case constraint of

308− CTrue -> P.text "True"

309− CSaveEnv -> P.text "SaveTheEnvironment!!!"

310− CEqual a b -> prty a <+> P.text "=" <+> prty b

311− CAnd [] -> P.text "True"

305+ CTrue ->

306+ P.text "True"

307+

308+ CSaveEnv ->

309+ P.text "SaveTheEnvironment!!!"

310+

311+ CEqual _ _ a b ->

312+ prty a <+> P.text "=" <+> prty b

313+

314+ CAnd [] ->

315+ P.text "True"

312316

313317 CAnd cs ->

314− P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)

318+ P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)

315319

316− CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->

320+ CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->

317321 P.sep [ binder, pretty Never c ]

318322 where

319− mergeExists vs (A _ c) =

323+ mergeExists vs c =

320324 case c of

321− CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'

325+ CLet [Scheme [] fqs' c' _] CTrue -> mergeExists (vs ++ fqs') c'

322326 _ -> (vs, c)

323327

324328 (fqs', c) = mergeExists fqs constraint

325329

326− binder = if null fqs' then P.empty else

327− P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."

330+ binder =

331+ if null fqs'

332+ then P.empty

333+ else

334+ P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."

328335

329336 CLet schemes constraint ->

330− P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)

331− , P.text "in", pretty Never constraint ]

337+ P.fsep

338+ [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)

339+ , P.text "in", pretty Never constraint

340+ ]

332341

333− CInstance name tipe ->

334− P.text name <+> P.text "<" <+> prty tipe

342+ CInstance _region name tipe ->

343+ P.text name <+> P.text "<" <+> prty tipe

335344

336345

337346instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

338− pretty _ (Scheme rqs fqs (A _ constraint) headers) =

347+ pretty _ (Scheme rqs fqs constraint headers) =

339348 P.sep [ forall, cs, headers' ]

340349 where

341350 prty = pretty Never

342351

343− forall = if null rqs && null fqs then P.empty else

344− P.text "\x2200" <+> frees <+> rigids

352+ forall =

353+ if null rqs && null fqs

354+ then P.empty

355+ else P.text "\x2200" <+> frees <+> rigids

356+

357+ frees = P.hsep (map prty fqs)

358+

359+ rigids =

360+ if null rqs

361+ then P.empty

362+ else P.braces . P.hsep $ map prty rqs

363+

364+ cs =

365+ case constraint of

366+ CTrue -> P.empty

367+ CAnd [] -> P.empty

368+ _ -> P.brackets (pretty Never constraint)

345369

346− frees = P.hsep $ map prty fqs

347− rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs

370+ headers' =

371+ if Map.size headers > 0 then dict else P.empty

348372

349− cs = case constraint of

350− CTrue -> P.empty

351− CAnd [] -> P.empty

352− _ -> P.brackets (pretty Never constraint)

373+ dict =

374+ P.parens . commaSep . map prettyPair $ Map.toList headers

353375

354− headers' = if Map.size headers > 0 then dict else P.empty

355− dict = P.parens . commaSep . map prettyPair $ Map.toList headers

356− prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t

376+ prettyPair (n,t) =

377+ P.text n <+> P.text ":" <+> pretty Never t

357378

358379

359380-- CONVERT TO SOURCE TYPES

360381

361382-- TODO: Attach resulting type to the descriptor so that you

362383-- never have to do extra work, particularly nice for aliased types

363−toSrcType :: Variable -> IO T.CanonicalType

384+toSrcType :: Variable -> IO T.Canonical

364385toSrcType variable =

365386 do addNames variable

366387 variableToSrcType variable variable

367388

368389

369−variableToSrcType :: Variable -> Variable -> IO T.CanonicalType

390+variableToSrcType :: Variable -> Variable -> IO T.Canonical

370391variableToSrcType rootVariable variable =

371392 do desc <- UF.descriptor variable

372393 srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)

@@ -383,7 +404,7 @@ variableToSrcType rootVariable variable =

383404 do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args

384405 return (T.Aliased name args' (T.Filled srcType))

385406 where

386− backupSrcType :: Descriptor -> IO T.CanonicalType

407+ backupSrcType :: Descriptor -> IO T.Canonical

387408 backupSrcType desc =

388409 case name desc of

389410 Just v@(Var.Canonical _ x@(c:_))

@@ -401,7 +422,7 @@ variableToSrcType rootVariable variable =

401422 ]

402423

403424

404−termToSrcType :: Variable -> Term1 Variable -> IO T.CanonicalType

425+termToSrcType :: Variable -> Term1 Variable -> IO T.Canonical

405426termToSrcType rootVariable term =

406427 let go = variableToSrcType rootVariable in

407428 case term of

@@ -433,7 +454,7 @@ termToSrcType rootVariable term =

433454 T.Var _ -> T.Record fields (Just ext')

434455 _ -> error "Used toSrcType on a type that is not well-formed"

435456 where

436− dealias :: T.CanonicalType -> T.CanonicalType

457+ dealias :: T.Canonical -> T.Canonical

437458 dealias tipe =

438459 case tipe of

439460 T.Aliased _ args tipe' ->

@@ -473,7 +494,7 @@ data NameState = NameState

473494

474495varAddNames :: Variable -> StateT NameState IO ()

475496varAddNames var =

476− do desc <- liftIO (UF.descriptor var)

497+ do desc <- State.liftIO (UF.descriptor var)

477498 case alias desc of

478499 Nothing ->

479500 return ()

@@ -490,7 +511,7 @@ varAddNames var =

490511 Just _ -> return ()

491512 Nothing ->

492513 do name' <- createName desc

493− liftIO $ UF.modifyDescriptor var $ \desc ->

514+ State.liftIO $ UF.modifyDescriptor var $ \desc ->

494515 desc { name = Just (Var.local name') }

495516

496517

src/Type/Unify.hs+94−90

@@ -1,60 +1,74 @@

11module Type.Unify (unify) where

22

33import Control.Applicative ((<|>))

4−import Control.Monad.Error (ErrorT, throwError, runErrorT)

4+import Control.Monad.Except (ExceptT, throwError, runExceptT)

55import Control.Monad.State as State

66import qualified Data.List as List

77import qualified Data.Map as Map

8−import qualified Data.Maybe as Maybe

98import qualified Data.UnionFind.IO as UF

109import Text.PrettyPrint (render)

1110

12−import qualified AST.Annotation as A

11+import qualified AST.Type as AstType

1312import qualified AST.Variable as Var

13+import qualified Reporting.Region as R

14+import qualified Reporting.Error.Type as Error

1415import qualified Type.State as TS

15−import Type.Type

16+import Type.Type as Type

1617import Type.PrettyPrint

17−import qualified Type.Hint as Hint

1818import Elm.Utils ((|>))

1919

2020

21−unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

22−unify region variable1 variable2 =

23− do result <- runErrorT (unifyHelp region variable1 variable2)

24− either TS.addHint return result

21+unify

22+ :: Error.Hint

23+ -> R.Region

24+ -> Variable

25+ -> Variable

26+ -> StateT TS.SolverState IO ()

27+unify hint region variable1 variable2 =

28+ do result <- runExceptT (unifyHelp variable1 variable2)

29+ case result of

30+ Right state ->

31+ return state

32+

33+ Left (RawMismatch (leftType, rightType, note)) ->

34+ TS.addError region $ Error.Mismatch $

35+ Error.MismatchInfo hint leftType rightType note

2536

2637

2738-- ACTUALLY UNIFY STUFF

2839

29−type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)

40+type Unify =

41+ ExceptT RawMismatch (StateT TS.SolverState IO)

42+

43+

44+newtype RawMismatch =

45+ RawMismatch (AstType.Canonical, AstType.Canonical, Error.Note)

3046

3147

3248typeError

33− :: A.Region

34− -> Maybe String

35− -> UF.Point Descriptor

49+ :: UF.Point Descriptor

3650 -> UF.Point Descriptor

51+ -> Error.Note

3752 -> Unify a

38−typeError region hint t1 t2 =

39− do msg <- liftIO (Hint.create region hint t1 t2)

40− throwError msg

53+typeError leftType rightType note =

54+ do leftSrcType <- liftIO (toSrcType leftType)

55+ rightSrcType <- liftIO (toSrcType rightType)

56+ throwError (RawMismatch (leftSrcType, rightSrcType, note))

4157

4258

43−unifyHelp :: A.Region -> Variable -> Variable -> Unify ()

44−unifyHelp region variable1 variable2 = do

45− equivalent <- liftIO $ UF.equivalent variable1 variable2

46− if equivalent

47− then return ()

48− else actuallyUnify region variable1 variable2

59+unifyHelp :: Variable -> Variable -> Unify ()

60+unifyHelp variable1 variable2 =

61+ do equivalent <- liftIO $ UF.equivalent variable1 variable2

62+ if equivalent

63+ then return ()

64+ else actuallyUnify variable1 variable2

4965

5066

51−actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()

52−actuallyUnify region variable1 variable2 = do

67+actuallyUnify :: Variable -> Variable -> Unify ()

68+actuallyUnify variable1 variable2 = do

5369 desc1 <- liftIO $ UF.descriptor variable1

5470 desc2 <- liftIO $ UF.descriptor variable2

55− let unifyHelp' = unifyHelp region

56−

57− (name', flex', rank', alias') = combinedDescriptors desc1 desc2

71+ let (name', flex', rank', alias') = combinedDescriptors desc1 desc2

5872

5973 merge1 :: Unify ()

6074 merge1 =

@@ -100,30 +114,23 @@ actuallyUnify region variable1 variable2 = do

100114

101115 flexAndUnify v =

102116 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

103− unifyHelp' variable1 variable2

117+ unifyHelp variable1 variable2

104118

105119 unifyNumber svar (Var.Canonical home name) =

106120 case home of

107121 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar

108122 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar

109123 _ ->

110− let hint = "Looks like something besides an Int or Float is being used as a number."

111− in

112− typeError region (Just hint) variable1 variable2

113−

114− comparableError maybe =

115− typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

116− where

117− msg =

118− "Looks like you want something comparable, but the only valid comparable\n\

119− \types are Int, Float, Char, String, lists, or tuples."

120−

121− appendableError maybe =

122− typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

123− where

124− msg =

125− "Looks like you want something appendable, but the only Strings, Lists,\n\

126− \and Text can be appended with the (++) operator."

124+ typeError variable1 variable2 Error.NoNote

125+

126+ comparableError maybeHint =

127+ typeError variable1 variable2 $ Error.PostNote $

128+ "Note: comparable types include Int, Float, Char, String, lists, and tuples."

129+ ++ maybe "" ("\n"++) maybeHint

130+

131+ appendableError =

132+ typeError variable1 variable2 $ Error.PostNote $

133+ "Note: appendable types include only Strings, Lists, and Text."

127134

128135 unifyComparable v (Var.Canonical home name) =

129136 case home of

@@ -139,29 +146,30 @@ actuallyUnify region variable1 variable2 = do

139146

140147 List v ->

141148 do flexAndUnify varSuper

142− unifyHelp' v =<< liftIO (variable $ Is Comparable)

149+ unifyHelp v =<< liftIO (variable $ Is Comparable)

143150

144151 Tuple vs

145152 | length vs > 6 ->

146− comparableError $ Just "Cannot compare a tuple with more than 6 elements."

153+ comparableError $ Just $

154+ "Furthermore, it cannot be a tuple with more than 6 elements."

147155 | otherwise ->

148156 do flexAndUnify varSuper

149157 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

150− zipWithM_ unifyHelp' vs cmpVars

158+ zipWithM_ unifyHelp vs cmpVars

151159

152160 unifyAppendable varSuper varFlex =

153161 do struct <- liftIO $ collectApps varFlex

154162 case struct of

155163 List _ -> flexAndUnify varSuper

156− _ -> appendableError Nothing

164+ _ -> appendableError

157165

158166 rigidError var =

159− typeError region (Just hint) variable1 variable2

160− where

161− hint =

162− "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++

163− "The problem probably relates to the type variable being shared between a\n\

164− \top-level type annotation and a related let-bound type annotation."

167+ let v = render (pretty Never var)

168+ in

169+ typeError variable1 variable2 $ Error.PreNote $

170+ "Could not unify rigid type variable '" ++ v ++ "'. The problem probably\n"

171+ ++ "relates to the type variable being shared between two type annotations.\n"

172+ ++ "Try commenting out some type annotations and see what happens."

165173

166174 superUnify =

167175 case (flex desc1, flex desc2, name desc1, name desc2) of

@@ -187,7 +195,7 @@ actuallyUnify region variable1 variable2 = do

187195

188196 (Rigid, _, _, _) -> rigidError variable1

189197 (_, Rigid, _, _) -> rigidError variable2

190− _ -> typeError region Nothing variable1 variable2

198+ _ -> typeError variable1 variable2 Error.NoNote

191199

192200 case (structure desc1, structure desc2) of

193201 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->

@@ -200,10 +208,10 @@ actuallyUnify region variable1 variable2 = do

200208 merge1

201209

202210 (Just (Var1 v), _) ->

203− unifyHelp' v variable2

211+ unifyHelp v variable2

204212

205213 (_, Just (Var1 v)) ->

206− unifyHelp' variable1 v

214+ unifyHelp variable1 v

207215

208216 (Nothing, _) ->

209217 superUnify

@@ -215,38 +223,37 @@ actuallyUnify region variable1 variable2 = do

215223 case (type1,type2) of

216224 (App1 term1 term2, App1 term1' term2') ->

217225 do merge

218− unifyHelp' term1 term1'

219− unifyHelp' term2 term2'

226+ unifyHelp term1 term1'

227+ unifyHelp term2 term2'

220228 (Fun1 term1 term2, Fun1 term1' term2') ->

221229 do merge

222− unifyHelp' term1 term1'

223− unifyHelp' term2 term2'

230+ unifyHelp term1 term1'

231+ unifyHelp term2 term2'

224232

225233 (EmptyRecord1, EmptyRecord1) ->

226234 return ()

227235

228− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2

229− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' variable1 ext

236+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2

237+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext

230238

231239 (Record1 _ _, Record1 _ _) ->

232− recordUnify region fresh variable1 variable2

240+ recordUnify fresh variable1 variable2

233241

234− _ -> typeError region Nothing variable1 variable2

242+ _ -> typeError variable1 variable2 Error.NoNote

235243

236244

237245-- RECORD UNIFICATION

238246

239247recordUnify

240− :: A.Region

241− -> (Maybe (Term1 Variable) -> Unify Variable)

248+ :: (Maybe (Term1 Variable) -> Unify Variable)

242249 -> Variable

243250 -> Variable

244251 -> Unify ()

245−recordUnify region fresh variable1 variable2 =

252+recordUnify fresh variable1 variable2 =

246253 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)

247254 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)

248255

249− unifyOverlappingFields region fields1 fields2

256+ unifyOverlappingFields fields1 fields2

250257

251258 let freshRecord fields ext =

252259 fresh (Just (Record1 fields ext))

@@ -255,59 +262,57 @@ recordUnify region fresh variable1 variable2 =

255262 let uniqueFields2 = diffFields fields2 fields1

256263

257264 let addFieldMismatchError missingFields =

258− let msg = fieldMismatchError missingFields

259− in

260− typeError region (Just msg) variable1 variable2

265+ typeError variable1 variable2 $ Error.PreNote $

266+ fieldMismatchError missingFields

261267

262268 case (ext1, ext2) of

263269 (Empty _, Empty _) ->

264270 case Map.null uniqueFields1 && Map.null uniqueFields2 of

265271 True -> return ()

266− False -> typeError region Nothing variable1 variable2

272+ False -> typeError variable1 variable2 Error.NoNote

267273

268274 (Empty var1, Extension var2) ->

269275 case (Map.null uniqueFields1, Map.null uniqueFields2) of

270276 (_, False) -> addFieldMismatchError uniqueFields2

271− (True, True) -> unifyHelp region var1 var2

277+ (True, True) -> unifyHelp var1 var2

272278 (False, True) ->

273279 do subRecord <- freshRecord uniqueFields1 var1

274− unifyHelp region subRecord var2

280+ unifyHelp subRecord var2

275281

276282 (Extension var1, Empty var2) ->

277283 case (Map.null uniqueFields1, Map.null uniqueFields2) of

278284 (False, _) -> addFieldMismatchError uniqueFields1

279− (True, True) -> unifyHelp region var1 var2

285+ (True, True) -> unifyHelp var1 var2

280286 (True, False) ->

281287 do subRecord <- freshRecord uniqueFields2 var2

282− unifyHelp region var1 subRecord

288+ unifyHelp var1 subRecord

283289

284290 (Extension var1, Extension var2) ->

285291 case (Map.null uniqueFields1, Map.null uniqueFields2) of

286292 (True, True) ->

287− unifyHelp region var1 var2

293+ unifyHelp var1 var2

288294

289295 (True, False) ->

290296 do subRecord <- freshRecord uniqueFields2 var2

291− unifyHelp region var1 subRecord

297+ unifyHelp var1 subRecord

292298

293299 (False, True) ->

294300 do subRecord <- freshRecord uniqueFields1 var1

295− unifyHelp region subRecord var2

301+ unifyHelp subRecord var2

296302

297303 (False, False) ->

298304 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing

299305 record2' <- freshRecord uniqueFields2 =<< fresh Nothing

300− unifyHelp region record1' var2

301− unifyHelp region var1 record2'

306+ unifyHelp record1' var2

307+ unifyHelp var1 record2'

302308

303309

304310unifyOverlappingFields

305− :: A.Region

306− -> Map.Map String [Variable]

311+ :: Map.Map String [Variable]

307312 -> Map.Map String [Variable]

308313 -> Unify ()

309−unifyOverlappingFields region fields1 fields2 =

310− Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2

314+unifyOverlappingFields fields1 fields2 =

315+ Map.intersectionWith (zipWith unifyHelp) fields1 fields2

311316 |> Map.elems

312317 |> concat

313318 |> sequence_

@@ -351,10 +356,9 @@ fieldMismatchError missingFields =

351356 case Map.keys missingFields of

352357 [] -> ""

353358 [key] ->

354− "Looks like a record is missing the field '" ++ key ++ "'.\n " ++

355− "Maybe there is a misspelling in a record access or record update?"

359+ "Looks like a record is missing the field '" ++ key ++ "'"

356360 keys ->

357− "Looks like one record is missing fields "

361+ "Looks like a record is missing fields "

358362 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys

359363

360364

src/Validate.hsnew file+410

@@ -0,0 +1,410 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Validate (declarations) where

3+

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

5+import qualified Data.Map as Map

6+import qualified Data.Set as Set

7+import qualified Data.Foldable as F

8+import qualified Data.Traversable as T

9+

10+import AST.Expression.General

11+import qualified AST.Expression.Source as Source

12+import qualified AST.Expression.Valid as Valid

13+import qualified AST.Declaration as D

14+import qualified AST.Pattern as Pattern

15+import qualified AST.Type as Type

16+import Elm.Utils ((|>))

17+import qualified Reporting.Annotation as A

18+import qualified Reporting.Error.Syntax as Error

19+import qualified Reporting.Region as R

20+import qualified Reporting.Result as Result

21+

22+

23+-- VALIDATE DECLARATIONS

24+

25+declarations

26+ :: [D.SourceDecl]

27+ -> Result.Result wrn Error.Error [D.ValidDecl]

28+declarations sourceDecls =

29+ do validDecls <- validateDecls sourceDecls

30+ (\_ _ -> validDecls)

31+ <$> declDuplicates validDecls

32+ <*> T.traverse checkDecl validDecls

33+

34+

35+validateDecls

36+ :: [D.SourceDecl]

37+ -> Result.Result wrn Error.Error [D.ValidDecl]

38+validateDecls sourceDecls =

39+ case sourceDecls of

40+ [] ->

41+ return []

42+

43+ decl : decls ->

44+ validateDeclsHelp decl decls

45+

46+

47+validateDeclsHelp

48+ :: D.SourceDecl

49+ -> [D.SourceDecl]

50+ -> Result.Result wrn Error.Error [D.ValidDecl]

51+validateDeclsHelp (A.A region decl) decls =

52+ let addRest validDecl =

53+ (:) (A.A region validDecl) <$> validateDecls decls

54+ in

55+ case decl of

56+ D.Datatype name tvars ctors ->

57+ addRest (D.Datatype name tvars ctors)

58+

59+ D.TypeAlias name tvars alias ->

60+ addRest (D.TypeAlias name tvars alias)

61+

62+ D.Fixity assoc prec op ->

63+ addRest (D.Fixity assoc prec op)

64+

65+ D.Definition def ->

66+ defHelp def decls

67+

68+ D.Port port ->

69+ portHelp region port decls

70+

71+

72+-- VALIDATE DEFINITIONS IN DECLARATIONS

73+

74+defHelp

75+ :: Source.Def

76+ -> [D.SourceDecl]

77+ -> Result.Result wrn Error.Error [D.ValidDecl]

78+defHelp (A.A region def) decls =

79+ let addRest def' rest =

80+ (:) (A.A region (D.Definition def')) <$> validateDecls rest

81+ in

82+ case def of

83+ Source.Definition pat expr ->

84+ do expr' <- Validate.expression expr

85+ let def' = Valid.Definition pat expr' Nothing

86+ addRest def' decls

87+

88+ Source.TypeAnnotation name tipe ->

89+ case decls of

90+ A.A _ (D.Definition (A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr))) : rest

91+ | name == name' ->

92+ do expr' <- Validate.expression expr

93+ let def' = Valid.Definition pat expr' (Just tipe)

94+ addRest def' rest

95+

96+ _ ->

97+ Result.throw region (Error.TypeWithoutDefinition name)

98+

99+

100+-- VALIDATE PORTS IN DECLARATIONS

101+

102+portHelp

103+ :: R.Region

104+ -> D.SourcePort

105+ -> [D.SourceDecl]

106+ -> Result.Result wrn Error.Error [D.ValidDecl]

107+portHelp region port decls =

108+ let addRest port' rest =

109+ (:) (A.A region (D.Port port')) <$> validateDecls rest

110+ in

111+ case port of

112+ D.PortDefinition name _ ->

113+ Result.throw region (Error.PortWithoutAnnotation name)

114+

115+ D.PortAnnotation name tipe ->

116+ case decls of

117+ A.A _ (D.Port (D.PortDefinition name' expr)) : rest

118+ | name == name' ->

119+ do expr' <- Validate.expression expr

120+ let port' = D.Out name expr' tipe

121+ addRest port' rest

122+

123+ _ ->

124+ addRest (D.In name tipe) decls

125+

126+

127+-- VALIDATE DEFINITIONS

128+

129+definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]

130+definitions sourceDefs =

131+ do validDefs <- definitionsHelp sourceDefs

132+ let patterns = map (\(Valid.Definition p _ _) -> p) validDefs

133+ defDuplicates patterns

134+ return validDefs

135+

136+

137+definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]

138+definitionsHelp sourceDefs =

139+ case sourceDefs of

140+ [] ->

141+ return []

142+

143+ A.A _ (Source.Definition pat expr) : rest ->

144+ do expr' <- expression expr

145+ let def = Valid.Definition pat expr' Nothing

146+ (:) def <$> definitionsHelp rest

147+

148+ A.A region (Source.TypeAnnotation name tipe) : rest ->

149+ case rest of

150+ A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'

151+ | name == name' ->

152+ do expr' <- expression expr

153+ let def = Valid.Definition pat expr' (Just tipe)

154+ (:) def <$> definitionsHelp rest'

155+

156+ _ ->

157+ Result.throw region (Error.TypeWithoutDefinition name)

158+

159+

160+-- VALIDATE EXPRESSIONS

161+

162+expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr

163+expression (A.A ann sourceExpression) =

164+ A.A ann <$>

165+ case sourceExpression of

166+ Var x ->

167+ return (Var x)

168+

169+ Lambda pattern body ->

170+ Lambda pattern <$> expression body

171+

172+ Binop op leftExpr rightExpr ->

173+ Binop op

174+ <$> expression leftExpr

175+ <*> expression rightExpr

176+

177+ Case e branches ->

178+ Case

179+ <$> expression e

180+ <*> T.traverse second branches

181+

182+ Data name args ->

183+ Data name <$> T.traverse expression args

184+

185+ Literal lit ->

186+ return (Literal lit)

187+

188+ Range lowExpr highExpr ->

189+ Range

190+ <$> expression lowExpr

191+ <*> expression highExpr

192+

193+ ExplicitList expressions ->

194+ ExplicitList

195+ <$> T.traverse expression expressions

196+

197+ App funcExpr argExpr ->

198+ App

199+ <$> expression funcExpr

200+ <*> expression argExpr

201+

202+ MultiIf branches ->

203+ MultiIf <$> T.traverse both branches

204+

205+ Access record field ->

206+ Access

207+ <$> expression record

208+ <*> return field

209+

210+ Remove record field ->

211+ Remove

212+ <$> expression record

213+ <*> return field

214+

215+ Insert record field expr ->

216+ Insert

217+ <$> expression record

218+ <*> return field

219+ <*> expression expr

220+

221+ Modify record fields ->

222+ Modify

223+ <$> expression record

224+ <*> T.traverse second fields

225+

226+ Record fields ->

227+ Record

228+ <$> T.traverse second fields

229+

230+ Let defs body ->

231+ Let

232+ <$> definitions defs

233+ <*> expression body

234+

235+ GLShader uid src gltipe ->

236+ return (GLShader uid src gltipe)

237+

238+ Port impl ->

239+ Port <$>

240+ case impl of

241+ In name tipe ->

242+ return (In name tipe)

243+

244+ Out name expr tipe ->

245+ do expr' <- expression expr

246+ return (Out name expr' tipe)

247+

248+ Task name expr tipe ->

249+ do expr' <- expression expr

250+ return (Task name expr' tipe)

251+

252+

253+second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

254+second (value, expr) =

255+ (,) value <$> expression expr

256+

257+

258+both

259+ :: (Source.Expr, Source.Expr)

260+ -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)

261+both (expr1, expr2) =

262+ (,) <$> expression expr1 <*> expression expr2

263+

264+

265+-- DETECT DUPLICATES

266+

267+detectDuplicates

268+ :: (String -> Error.Error)

269+ -> [A.Located String]

270+ -> Result.Result wrn Error.Error ()

271+detectDuplicates tag names =

272+ let add (A.A region name) dict =

273+ Map.insertWith (++) name [region] dict

274+

275+ makeGroups pairs =

276+ Map.toList (foldr add Map.empty pairs)

277+

278+ check (name, regions) =

279+ case regions of

280+ _ : region : _ ->

281+ Result.throw region (tag name)

282+

283+ _ ->

284+ return ()

285+ in

286+ F.traverse_ check (makeGroups names)

287+

288+

289+defDuplicates

290+ :: [Pattern.RawPattern]

291+ -> Result.Result wrn Error.Error ()

292+defDuplicates patterns =

293+ concatMap Pattern.boundVars patterns

294+ |> detectDuplicates Error.DuplicateDefinition

295+

296+

297+declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()

298+declDuplicates decls =

299+ let (valueLists, typeLists) = unzip (map extractValues decls)

300+ in

301+ (\_ _ -> ())

302+ <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)

303+ <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)

304+

305+

306+extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])

307+extractValues (A.A region decl) =

308+ case decl of

309+ D.Definition (Valid.Definition pattern _ _) ->

310+ ( Pattern.boundVars pattern

311+ , []

312+ )

313+

314+ D.Datatype name _ ctors ->

315+ ( map (A.A region . fst) ctors

316+ , [A.A region name]

317+ )

318+

319+ D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->

320+ ( [A.A region name]

321+ , [A.A region name]

322+ )

323+

324+ D.TypeAlias name _ _ ->

325+ ( []

326+ , [A.A region name]

327+ )

328+

329+ D.Port port ->

330+ ( [A.A region (D.validPortName port)]

331+ , []

332+ )

333+

334+ D.Fixity _ _ _ ->

335+ ( []

336+ , []

337+ )

338+

339+

340+-- UNBOUND TYPE VARIABLES

341+

342+checkDecl :: D.ValidDecl -> Result.Result wrn Error.Error ()

343+checkDecl (A.A region decl) =

344+ case decl of

345+ D.Definition _ ->

346+ return ()

347+

348+ D.Datatype name boundVars ctors ->

349+ let frees = concatMap freeVars (concatMap snd ctors)

350+ in

351+ case findUnbound boundVars frees of

352+ [] ->

353+ return ()

354+

355+ unbound ->

356+ let

357+ (v:vs) = Set.toList (Set.fromList unbound)

358+ in

359+ Result.throw region

360+ (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)

361+

362+ D.TypeAlias name boundVars tipe ->

363+ case findUnbound boundVars (freeVars tipe) of

364+ [] ->

365+ return ()

366+

367+ unbound ->

368+ let

369+ (v:vs) = Set.toList (Set.fromList unbound)

370+ in

371+ Result.throw region

372+ (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)

373+

374+ D.Port _ ->

375+ return ()

376+

377+ D.Fixity _ _ _ ->

378+ return ()

379+

380+

381+findUnbound :: [String] -> [A.Located String] -> [String]

382+findUnbound boundVars frees =

383+ let bounds = Set.fromList boundVars

384+

385+ isUnbound x =

386+ Set.notMember x bounds

387+ in

388+ filter isUnbound (map A.drop frees)

389+

390+

391+

392+freeVars :: Type.Raw -> [A.Located String]

393+freeVars (A.A region tipe) =

394+ case tipe of

395+ Type.RLambda t1 t2 ->

396+ freeVars t1 ++ freeVars t2

397+

398+ Type.RVar x ->

399+ [A.A region x]

400+

401+ Type.RType _ ->

402+ []

403+

404+ Type.RApp t ts ->

405+ concatMap freeVars (t:ts)

406+

407+ Type.RRecord fields ext ->

408+ maybe [] freeVars ext

409+ ++ concatMap (freeVars . snd) fields

410+