git.iko.soy/elk
on master help sign in
Merge branch 'warnings'
7be0e81Evan Czaplicki
elm-compiler.cabal+29−26
compare with master
unifiedsplit
@@ -46,41 +46,37 @@ Library
46 Elm.Utils
46 Elm.Utils
47
47
48 other-modules:
48 other-modules:
49− AST.Annotation,
50 AST.Declaration,
49 AST.Declaration,
50+ AST.Expression.Canonical,
51 AST.Expression.General,
51 AST.Expression.General,
52 AST.Expression.Source,
52 AST.Expression.Source,
53 AST.Expression.Valid,
53 AST.Expression.Valid,
54− AST.Expression.Canonical,
55 AST.Helpers,
54 AST.Helpers,
56 AST.Literal,
55 AST.Literal,
57 AST.Module,
56 AST.Module,
58 AST.Pattern,
57 AST.Pattern,
59− AST.PrettyPrint,
60 AST.Type,
58 AST.Type,
61 AST.Variable,
59 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,
62 Compile,
69 Compile,
70+ Elm.Compiler.Imports,
63 Elm.Compiler.Type.Extract,
71 Elm.Compiler.Type.Extract,
64 Elm.Compiler.Version,
72 Elm.Compiler.Version,
73+ Generate.Cases,
65 Generate.JavaScript,
74 Generate.JavaScript,
66 Generate.JavaScript.Helpers,
75 Generate.JavaScript.Helpers,
67 Generate.JavaScript.Port,
76 Generate.JavaScript.Port,
68 Generate.JavaScript.Variable,
77 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,
84 Parse.Binop,
80 Parse.Binop,
85 Parse.Declaration,
81 Parse.Declaration,
86 Parse.Expression,
82 Parse.Expression,
@@ -90,19 +86,28 @@ Library
90 Parse.Parse,
86 Parse.Parse,
91 Parse.Pattern,
87 Parse.Pattern,
92 Parse.Type,
88 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,
93 Type.Constrain.Expression,
99 Type.Constrain.Expression,
94 Type.Constrain.Literal,
100 Type.Constrain.Literal,
95 Type.Constrain.Pattern,
101 Type.Constrain.Pattern,
96 Type.Environment,
102 Type.Environment,
97− Type.ExtraChecks,
98 Type.Fragment,
103 Type.Fragment,
99− Type.Hint,
100 Type.Inference,
104 Type.Inference,
101 Type.PrettyPrint,
105 Type.PrettyPrint,
102 Type.Solve,
106 Type.Solve,
103 Type.State,
107 Type.State,
104 Type.Type,
108 Type.Type,
105 Type.Unify,
109 Type.Unify,
110+ Validate,
106 Paths_elm_compiler
111 Paths_elm_compiler
107
112
108 Build-depends:
113 Build-depends:
@@ -121,7 +126,7 @@ Library
121 indents >= 0.3 && < 0.4,
126 indents >= 0.3 && < 0.4,
122 language-ecmascript >= 0.15 && < 0.18,
127 language-ecmascript >= 0.15 && < 0.18,
123 language-glsl >= 0.0.2 && < 0.2,
128 language-glsl >= 0.0.2 && < 0.2,
124− mtl >= 2 && < 3,
129+ mtl >= 2.2 && < 3,
125 parsec >= 3.1.1 && < 3.5,
130 parsec >= 3.1.1 && < 3.5,
126 pretty >= 1.0 && < 2.0,
131 pretty >= 1.0 && < 2.0,
127 process,
132 process,
@@ -143,14 +148,12 @@ Executable elm-doc
143
148
144 other-modules:
149 other-modules:
145 Elm.Compiler.Version,
150 Elm.Compiler.Version,
146− AST.Annotation,
147 AST.Declaration,
151 AST.Declaration,
148 AST.Expression.General,
152 AST.Expression.General,
149 AST.Helpers,
153 AST.Helpers,
150 AST.Literal,
154 AST.Literal,
151 AST.Module,
155 AST.Module,
152 AST.Pattern,
156 AST.Pattern,
153− AST.PrettyPrint,
154 AST.Type,
157 AST.Type,
155 AST.Variable,
158 AST.Variable,
156 Parse.Binop,
159 Parse.Binop,
@@ -174,7 +177,7 @@ Executable elm-doc
174 filepath >= 1 && < 2.0,
177 filepath >= 1 && < 2.0,
175 indents >= 0.3 && < 0.4,
178 indents >= 0.3 && < 0.4,
176 language-glsl >= 0.0.2 && < 0.2,
179 language-glsl >= 0.0.2 && < 0.2,
177− mtl >= 2 && < 3,
180+ mtl >= 2.2 && < 3,
178 parsec >= 3.1.1 && < 3.5,
181 parsec >= 3.1.1 && < 3.5,
179 pretty >= 1.0 && < 2.0,
182 pretty >= 1.0 && < 2.0,
180 process,
183 process,
@@ -208,7 +211,7 @@ Executable elm
208 filepath >= 1 && < 2.0,
211 filepath >= 1 && < 2.0,
209 indents >= 0.3 && < 0.4,
212 indents >= 0.3 && < 0.4,
210 language-glsl >= 0.0.2 && < 0.2,
213 language-glsl >= 0.0.2 && < 0.2,
211− mtl >= 2 && < 3,
214+ mtl >= 2.2 && < 3,
212 parsec >= 3.1.1 && < 3.5,
215 parsec >= 3.1.1 && < 3.5,
213 pretty >= 1.0 && < 2.0,
216 pretty >= 1.0 && < 2.0,
214 process,
217 process,
@@ -258,7 +261,7 @@ Test-Suite compiler-tests
258 indents >= 0.3 && < 0.4,
261 indents >= 0.3 && < 0.4,
259 language-ecmascript >= 0.15 && < 0.18,
262 language-ecmascript >= 0.15 && < 0.18,
260 language-glsl >= 0.0.2 && < 0.2,
263 language-glsl >= 0.0.2 && < 0.2,
261− mtl >= 2 && < 3,
264+ mtl >= 2.2 && < 3,
262 parsec >= 3.1.1 && < 3.5,
265 parsec >= 3.1.1 && < 3.5,
263 pretty >= 1.0 && < 2.0,
266 pretty >= 1.0 && < 2.0,
264 process,
267 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 @@
2module AST.Declaration where
2module AST.Declaration where
3
3
4import Data.Binary
4import Data.Binary
5+
5import qualified AST.Expression.General as General
6import qualified AST.Expression.General as General
6import qualified AST.Expression.Source as Source
7import qualified AST.Expression.Source as Source
7import qualified AST.Expression.Valid as Valid
8import qualified AST.Expression.Valid as Valid
8import qualified AST.Expression.Canonical as Canonical
9import qualified AST.Expression.Canonical as Canonical
9−import qualified AST.Type as T
10+import qualified AST.Type as Type
10−import qualified AST.Variable as Var
11+import qualified Reporting.Annotation as A
11−import AST.PrettyPrint
12−import Text.PrettyPrint as P
13
12
14
13
15-- DECLARATIONS
14-- DECLARATIONS
16
15
17−data Declaration' port def var expr
16+data Declaration' port def tipe expr
18 = Definition def
17 = Definition def
19− | Datatype String [String] [(String, [T.Type var])]
18+ | Datatype String [String] [(String, [tipe])]
20− | TypeAlias String [String] (T.Type var)
19+ | TypeAlias String [String] tipe
21 | Port port
20 | Port port
22 | Fixity Assoc Int String
21 | Fixity Assoc Int String
23
22
24
23
24+-- INFIX STUFF
25+
25data Assoc = L | N | R
26data Assoc = L | N | R
26 deriving (Eq)
27 deriving (Eq)
27
28
28
29
30+assocToString :: Assoc -> String
31+assocToString assoc =
32+ case assoc of
33+ L -> "left"
34+ N -> "non"
35+ R -> "right"
36+
37+
29-- DECLARATION PHASES
38-- DECLARATION PHASES
30
39
40+type SourceDecl' =
41+ Declaration' SourcePort Source.Def Type.Raw Source.Expr
42+
43+
31type SourceDecl =
44type SourceDecl =
32− Declaration' SourcePort Source.Def Var.Raw Source.Expr
45+ A.Located SourceDecl'
33
46
34
47
35type ValidDecl =
48type ValidDecl =
36− Declaration' ValidPort Valid.Def Var.Raw Valid.Expr
49+ A.Located (Declaration' ValidPort Valid.Def Type.Raw Valid.Expr)
37
50
38
51
39type CanonicalDecl =
52type CanonicalDecl =
40− Declaration' CanonicalPort Canonical.Def Var.Canonical Canonical.Expr
53+ A.Located (Declaration' CanonicalPort Canonical.Def Type.Canonical Canonical.Expr)
41
54
42
55
43-- PORTS
56-- PORTS
44
57
45data SourcePort
58data SourcePort
46− = PortAnnotation String T.RawType
59+ = PortAnnotation String Type.Raw
47 | PortDefinition String Source.Expr
60 | PortDefinition String Source.Expr
48
61
49
62
50data ValidPort
63data ValidPort
51− = In String T.RawType
64+ = In String Type.Raw
52− | Out String Valid.Expr T.RawType
65+ | Out String Valid.Expr Type.Raw
53
66
54
67
55newtype CanonicalPort
68newtype CanonicalPort
56− = CanonicalPort (General.PortImpl Canonical.Expr Var.Canonical)
69+ = CanonicalPort (General.PortImpl Canonical.Expr Type.Canonical)
57
70
58
71
59validPortName :: ValidPort -> String
72validPortName :: ValidPort -> String
@@ -80,105 +93,3 @@ instance Binary Assoc where
80 L -> 0
93 L -> 0
81 N -> 1
94 N -> 1
82 R -> 2
95 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 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−
3module AST.Expression.Canonical where
2module AST.Expression.Canonical where
4
3
5−import AST.PrettyPrint
6import Text.PrettyPrint as P
4import Text.PrettyPrint as P
5+
7import qualified AST.Expression.General as General
6import qualified AST.Expression.General as General
8−import AST.Type (CanonicalType)
9−import qualified AST.Annotation as Annotation
10import qualified AST.Pattern as Pattern
7import qualified AST.Pattern as Pattern
8+import qualified AST.Type as Type
11import qualified AST.Variable as Var
9import qualified AST.Variable as Var
10+import qualified Reporting.PrettyPrint as P
11+import qualified Reporting.Region as R
12
12
13
13
14{-| Canonicalized expressions. All variables are fully resolved to the module
14{-| Canonicalized expressions. All variables are fully resolved to the module
15they came from.
15they came from.
16-}
16-}
17type Expr =
17type Expr =
18− General.Expr Annotation.Region Def Var.Canonical
18+ General.Expr R.Region Def Var.Canonical Type.Canonical
19
19
20
20
21type Expr' =
21type Expr' =
22− General.Expr' Annotation.Region Def Var.Canonical
22+ General.Expr' R.Region Def Var.Canonical Type.Canonical
23
23
24
24
25+data Def
25−data Def = Definition Pattern.CanonicalPattern Expr (Maybe CanonicalType)
26+ = Definition Pattern.CanonicalPattern Expr (Maybe Type.Canonical)
26 deriving (Show)
27 deriving (Show)
27
28
28
29
29−instance Pretty Def where
30+instance P.Pretty Def where
30− pretty (Definition pattern expr maybeTipe) =
31+ pretty _ (Definition pattern expr maybeTipe) =
31 P.vcat [ annotation, definition ]
32 P.vcat [ annotation, definition ]
32 where
33 where
33 definition =
34 definition =
34− pretty pattern <+> P.equals <+> pretty expr
35+ P.pretty True pattern <+> P.equals <+> P.pretty False expr
35
36
36 annotation =
37 annotation =
37 case maybeTipe of
38 case maybeTipe of
@@ -39,4 +40,4 @@ instance Pretty Def where
39 P.empty
40 P.empty
40
41
41 Just tipe ->
42 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.
8-}
8-}
9module AST.Expression.General where
9module AST.Expression.General where
10
10
11−import AST.PrettyPrint
12import Text.PrettyPrint as P
11import Text.PrettyPrint as P
13
12
14−import qualified AST.Annotation as Annotation
15import qualified AST.Helpers as Help
13import qualified AST.Helpers as Help
16import qualified AST.Literal as Literal
14import qualified AST.Literal as Literal
17import qualified AST.Pattern as Pattern
15import qualified AST.Pattern as Pattern
18import qualified AST.Type as Type
16import qualified AST.Type as Type
19import qualified AST.Variable as Var
17import qualified AST.Variable as Var
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.PrettyPrint as P
20
20
21
21
22---- GENERAL AST ----
22---- GENERAL AST ----
@@ -36,43 +36,43 @@ move through the compilation process. The type holes are used to represent:
36 with information about what module a variable came from.
36 with information about what module a variable came from.
37
37
38-}
38-}
39−type Expr annotation definition variable =
39+type Expr annotation definition variable tipe =
40− Annotation.Annotated annotation (Expr' annotation definition variable)
40+ A.Annotated annotation (Expr' annotation definition variable tipe)
41
41
42
42
43−data Expr' ann def var
43+data Expr' ann def var typ
44 = Literal Literal.Literal
44 = Literal Literal.Literal
45 | Var var
45 | Var var
46− | Range (Expr ann def var) (Expr ann def var)
46+ | Range (Expr ann def var typ) (Expr ann def var typ)
47− | ExplicitList [Expr ann def var]
47+ | ExplicitList [Expr ann def var typ]
48− | Binop var (Expr ann def var) (Expr ann def var)
48+ | Binop var (Expr ann def var typ) (Expr ann def var typ)
49− | Lambda (Pattern.Pattern var) (Expr ann def var)
49+ | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)
50− | App (Expr ann def var) (Expr ann def var)
50+ | App (Expr ann def var typ) (Expr ann def var typ)
51− | MultiIf [(Expr ann def var,Expr ann def var)]
51+ | MultiIf [(Expr ann def var typ,Expr ann def var typ)]
52− | Let [def] (Expr ann def var)
52+ | Let [def] (Expr ann def var typ)
53− | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)]
53+ | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]
54− | Data String [Expr ann def var]
54+ | Data String [Expr ann def var typ]
55− | Access (Expr ann def var) String
55+ | Access (Expr ann def var typ) String
56− | Remove (Expr ann def var) String
56+ | Remove (Expr ann def var typ) String
57− | Insert (Expr ann def var) String (Expr ann def var)
57+ | Insert (Expr ann def var typ) String (Expr ann def var typ)
58− | Modify (Expr ann def var) [(String, Expr ann def var)]
58+ | Modify (Expr ann def var typ) [(String, Expr ann def var typ)]
59− | Record [(String, Expr ann def var)]
59+ | Record [(String, Expr ann def var typ)]
60 -- for type checking and code gen only
60 -- for type checking and code gen only
61− | Port (PortImpl (Expr ann def var) var)
61+ | Port (PortImpl (Expr ann def var typ) typ)
62 | GLShader String String Literal.GLShaderTipe
62 | GLShader String String Literal.GLShaderTipe
63 deriving (Show)
63 deriving (Show)
64
64
65
65
66-- PORTS
66-- PORTS
67
67
68−data PortImpl expr var
68+data PortImpl expr tipe
69− = In String (Type.PortType var)
69+ = In String (Type.Port tipe)
70− | Out String expr (Type.PortType var)
70+ | Out String expr (Type.Port tipe)
71− | Task String expr (Type.PortType var)
71+ | Task String expr (Type.Port tipe)
72 deriving (Show)
72 deriving (Show)
73
73
74
74
75−portName :: PortImpl expr var -> String
75+portName :: PortImpl expr tipe -> String
76portName impl =
76portName impl =
77 case impl of
77 case impl of
78 In name _ -> name
78 In name _ -> name
@@ -82,17 +82,17 @@ portName impl =
82
82
83---- UTILITIES ----
83---- UTILITIES ----
84
84
85−rawVar :: String -> Expr' ann def Var.Raw
85+rawVar :: String -> Expr' ann def Var.Raw typ
86rawVar x =
86rawVar x =
87 Var (Var.Raw x)
87 Var (Var.Raw x)
88
88
89
89
90−localVar :: String -> Expr' ann def Var.Canonical
90+localVar :: String -> Expr' ann def Var.Canonical typ
91localVar x =
91localVar x =
92 Var (Var.Canonical Var.Local x)
92 Var (Var.Canonical Var.Local x)
93
93
94
94
95−tuple :: [Expr ann def var] -> Expr' ann def var
95+tuple :: [Expr ann def var typ] -> Expr' ann def var typ
96tuple expressions =
96tuple expressions =
97 Data ("_Tuple" ++ show (length expressions)) expressions
97 Data ("_Tuple" ++ show (length expressions)) expressions
98
98
@@ -102,102 +102,151 @@ saveEnvName =
102 "_save_the_environment!!!"
102 "_save_the_environment!!!"
103
103
104
104
105−dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical
105+dummyLet :: (P.Pretty def) => [def] -> Expr ann def Var.Canonical typ
106dummyLet defs =
106dummyLet 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)
108
111
109
112
113+-- PRETTY PRINTING
114+
110−instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where
115+instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where
111− pretty expression =
116+ pretty needsParens expression =
112 case expression of
117 case expression of
113 Literal literal ->
118 Literal literal ->
114− pretty literal
119+ P.pretty needsParens literal
115
120
116 Var x ->
121 Var x ->
117− pretty x
122+ P.pretty needsParens x
118
123
119 Range lowExpr highExpr ->
124 Range lowExpr highExpr ->
125+ P.brackets $
126+ P.pretty False lowExpr
127+ <> P.text ".."
120− P.brackets (pretty lowExpr <> P.text ".." <> pretty highExpr)
128+ <> P.pretty False highExpr
121
129
122 ExplicitList elements ->
130 ExplicitList elements ->
123− P.brackets (commaCat (map pretty elements))
131+ P.brackets (P.commaCat (map (P.pretty False) elements))
124
132
125− Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) expr
133+ Binop op (A.A _ (Literal (Literal.IntNum 0))) expr
126 | Var.toString op == "-" ->
134 | Var.toString op == "-" ->
127− P.text "-" <> prettyParens expr
135+ P.text "-" <> P.pretty True expr
128
136
129 Binop op leftExpr rightExpr ->
137 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)
131 where
143 where
132 op' = Var.toString op
144 op' = Var.toString op
133 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
145 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
134
146
135 Lambda pattern expr ->
147 Lambda pattern expr ->
148+ P.parensIf needsParens $
136− P.text "\\" <> args <+> P.text "->" <+> pretty body
149+ P.text "\\" <> args <+> P.text "->" <+> P.pretty False body
137 where
150 where
151+ (patterns, body) =
138− (patterns, body) = collectLambdas expr
152+ collectLambdas expr
153+
154+ args =
139− args = P.sep (map Pattern.prettyParens (pattern : patterns))
155+ P.sep (map (P.pretty True) (pattern : patterns))
140
156
141 App expr arg ->
157 App expr arg ->
158+ P.parensIf needsParens $
142− P.hang func 2 (P.sep args)
159+ P.hang func 2 (P.sep args)
143 where
160 where
144 func:args =
161 func:args =
145− map prettyParens (collectApps expr ++ [arg])
162+ map (P.pretty True) (collectApps expr ++ [arg])
146
163
147 MultiIf branches ->
164 MultiIf branches ->
165+ P.parensIf needsParens $
148− P.text "if" $$ nest 3 (vcat $ map iff branches)
166+ P.text "if" $$ nest 3 (vcat $ map iff branches)
149 where
167 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)
151
174
152 Let defs body ->
175 Let defs body ->
176+ P.parensIf needsParens $
153− P.sep
177+ P.sep
178+ [ P.hang
179+ (P.text "let")
180+ 4
154− [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
181+ (P.vcat (map (P.pretty False) defs))
155− , P.text "in" <+> pretty body
182+ , P.text "in" <+> P.pretty False body
156− ]
183+ ]
157
184
158 Case expr branches ->
185 Case expr branches ->
186+ P.parensIf needsParens $
159− P.hang pexpr 2 (P.vcat (map pretty' branches))
187+ P.hang pexpr 2 (P.vcat (map pretty' branches))
160 where
188 where
189+ pexpr =
161− pexpr = P.sep [ P.text "case" <+> pretty expr, P.text "of" ]
190+ P.text "case" <+> P.pretty False expr <+> P.text "of"
191+
162 pretty' (pattern, branch) =
192 pretty' (pattern, branch) =
163− pretty pattern <+> P.text "->" <+> pretty branch
193+ P.pretty False pattern
194+ <+> P.text "->"
195+ <+> P.pretty False branch
164
196
165 Data "::" [hd,tl] ->
197 Data "::" [hd,tl] ->
198+ P.parensIf needsParens $
166− pretty hd <+> P.text "::" <+> pretty tl
199+ P.pretty True hd <+> P.text "::" <+> P.pretty True tl
167
200
168 Data "[]" [] ->
201 Data "[]" [] ->
169 P.text "[]"
202 P.text "[]"
170
203
171− Data name exprs
204+ Data name exprs ->
172− | Help.isTuple name ->
205+ if Help.isTuple name
206+ then
173− P.parens (commaCat (map pretty exprs))
207+ P.parens (P.commaCat (map (P.pretty False) exprs))
174− | otherwise ->
208+ else
175− P.hang (P.text name) 2 (P.sep (map prettyParens exprs))
209+ P.parensIf (needsParens && not (null exprs)) $
210+ P.hang
211+ (P.text name)
212+ 2
213+ (P.sep (map (P.pretty True) exprs))
176
214
177 Access record field ->
215 Access record field ->
178− prettyParens record <> P.text "." <> variable field
216+ P.pretty True record <> P.text "." <> P.text field
179
217
180 Remove record field ->
218 Remove record field ->
181− P.braces (pretty record <+> P.text "-" <+> variable field)
219+ P.braces (P.pretty False record <+> P.text "-" <+> P.text field)
182
220
183− Insert (Annotation.A _ (Remove record y)) x v ->
221+ Insert (A.A _ (Remove record oldField)) newField expr ->
184 P.braces $
222 P.braces $
185 P.hsep
223 P.hsep
186− [ pretty record, P.text "-", variable y, P.text "|"
224+ [ P.pretty False record
225+ , P.text "-"
226+ , P.text oldField
227+ , P.text "|"
228+ , P.text newField
187− , variable x, P.equals, pretty v
229+ , P.equals
230+ , P.pretty False expr
188 ]
231 ]
189
232
190 Insert record field expr ->
233 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
192
240
193 Modify record fields ->
241 Modify record fields ->
194 P.braces $
242 P.braces $
195 P.hang
243 P.hang
196− (pretty record <+> P.text "|")
244+ (P.pretty False record <+> P.text "|")
197 4
245 4
198− (commaSep $ map field fields)
246+ (P.commaSep $ map prettyField fields)
199 where
247 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
201
250
202 Record fields ->
251 Record fields ->
203 P.sep
252 P.sep
@@ -206,48 +255,34 @@ instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var
206 ]
255 ]
207 where
256 where
208 field (name, expr) =
257 field (name, expr) =
209− variable name <+> P.equals <+> pretty expr
258+ P.text name <+> P.equals <+> P.pretty False expr
210
259
211 GLShader _ _ _ ->
260 GLShader _ _ _ ->
212 P.text "[glsl| ... |]"
261 P.text "[glsl| ... |]"
213
262
214 Port portImpl ->
263 Port portImpl ->
215− pretty portImpl
264+ P.pretty needsParens portImpl
216
265
217
266
218−instance (Pretty expr, Pretty var) => Pretty (PortImpl expr var) where
267+instance P.Pretty (PortImpl expr tipe) where
219− pretty impl =
268+ pretty _ impl =
220 P.text ("<port:" ++ portName impl ++ ">")
269 P.text ("<port:" ++ portName impl ++ ">")
221
270
222
271
223−collectApps :: Expr ann def var -> [Expr ann def var]
272+collectApps :: Expr ann def var typ -> [Expr ann def var typ]
224−collectApps annExpr@(Annotation.A _ expr) =
273+collectApps annExpr@(A.A _ expr) =
225 case expr of
274 case expr of
226 App a b -> collectApps a ++ [b]
275 App a b -> collectApps a ++ [b]
227 _ -> [annExpr]
276 _ -> [annExpr]
228
277
229
278
279+collectLambdas
280+ :: Expr ann def var typ
230−collectLambdas :: Expr ann def var -> ([Pattern.Pattern var], Expr ann def var)
281+ -> ([Pattern.Pattern ann var], Expr ann def var typ)
231−collectLambdas lexpr@(Annotation.A _ expr) =
282+collectLambdas lexpr@(A.A _ expr) =
232 case expr of
283 case expr of
233 Lambda pattern body ->
284 Lambda pattern body ->
234 let (ps, body') = collectLambdas body
285 let (ps, body') = collectLambdas body
235 in (pattern : ps, body')
286 in (pattern : ps, body')
236
287
237 _ -> ([], lexpr)
288 _ -> ([], 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 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−
3module AST.Expression.Source where
2module AST.Expression.Source where
4
3
5−import AST.PrettyPrint
6−import Text.PrettyPrint as P
7import qualified AST.Expression.General as General
4import 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
11import qualified AST.Pattern as Pattern
5import 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
12
10
13
11
14{-| Expressions created by the parser. These use a split representation of type
12{-| 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
16they are parsed.
14they are parsed.
17-}
15-}
18type Expr =
16type Expr =
19− General.Expr Annotation.Region Def Var.Raw
17+ General.Expr R.Region Def Var.Raw Type.Raw
20
18
21
19
22type Expr' =
20type Expr' =
23− General.Expr' Annotation.Region Def Var.Raw
21+ General.Expr' R.Region Def Var.Raw Type.Raw
24−
25
22
26−data Def
27− = Definition Pattern.RawPattern Expr
28− | TypeAnnotation String RawType
29− deriving (Show)
30
23
24+type Def =
25+ A.Located Def'
31
26
32−instance Pretty Def where
33− pretty def =
34− case def of
35− TypeAnnotation name tipe ->
36− variable name <+> P.colon <+> pretty tipe
37
27
38− Definition pattern expr ->
28+data Def'
39− pretty pattern <+> P.equals <+> pretty expr
29+ = Definition Pattern.RawPattern Expr
30+ | TypeAnnotation String Type.Raw
31+ deriving (Show)
src/AST/Expression/Valid.hs+7−25
@@ -1,14 +1,11 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−
3module AST.Expression.Valid where
2module AST.Expression.Valid where
4
3
5−import AST.PrettyPrint
6−import Text.PrettyPrint as P
7import qualified AST.Expression.General as General
4import 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
11import qualified AST.Pattern as Pattern
5import 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
12
9
13
10
14{-| "Normal" expressions. When the compiler checks that type annotations and
11{-| "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
16them into a Def that is easier to work with in later phases of compilation.
13them into a Def that is easier to work with in later phases of compilation.
17-}
14-}
18type Expr =
15type Expr =
19− General.Expr Annotation.Region Def Var.Raw
16+ General.Expr R.Region Def Var.Raw Type.Raw
20
17
21
18
22type Expr' =
19type Expr' =
23− General.Expr' Annotation.Region Def Var.Raw
20+ General.Expr' R.Region Def Var.Raw Type.Raw
24
21
25
22
23+data Def
26−data Def = Definition Pattern.RawPattern Expr (Maybe RawType)
24+ = Definition Pattern.RawPattern Expr (Maybe Type.Raw)
27 deriving (Show)
25 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 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module AST.Literal where
2module AST.Literal where
3
3
4−import AST.PrettyPrint
5−import Data.Map (Map)
4+import qualified Data.Map as Map
6−import qualified Text.PrettyPrint as PP
5+import qualified Text.PrettyPrint as P
6+
7+import qualified Reporting.PrettyPrint as P
8+
7
9
8data Literal
10data Literal
9 = IntNum Int
11 = IntNum Int
@@ -14,14 +16,14 @@ data Literal
14 deriving (Eq, Ord, Show)
16 deriving (Eq, Ord, Show)
15
17
16
18
17−instance Pretty Literal where
19+instance P.Pretty Literal where
18− pretty literal =
20+ pretty _ literal =
19 case literal of
21 case literal of
20− IntNum n -> PP.int n
22+ IntNum n -> P.int n
21− FloatNum n -> PP.double n
23+ FloatNum n -> P.double n
22− Chr c -> PP.text . show $ c
24+ Chr c -> P.text . show $ c
23− Str s -> PP.text . show $ s
25+ Str s -> P.text . show $ s
24− Boolean bool -> PP.text (show bool)
26+ Boolean bool -> P.text (show bool)
25
27
26
28
27data GLTipe
29data GLTipe
@@ -48,8 +50,8 @@ glTipeName glTipe =
48
50
49
51
50data GLShaderTipe = GLShaderTipe
52data GLShaderTipe = GLShaderTipe
51− { attribute :: Map String GLTipe
53+ { attribute :: Map.Map String GLTipe
52− , uniform :: Map String GLTipe
54+ , uniform :: Map.Map String GLTipe
53− , varying :: Map String GLTipe
55+ , varying :: Map.Map String GLTipe
54 }
56 }
55 deriving (Show)
57 deriving (Show)
src/AST/Module.hs+38−70
@@ -4,55 +4,62 @@ module AST.Module
4 , AdtInfo, CanonicalAdt
4 , AdtInfo, CanonicalAdt
5 , SourceModule, ValidModule, CanonicalModule
5 , SourceModule, ValidModule, CanonicalModule
6 , Module(..), CanonicalBody(..)
6 , Module(..), CanonicalBody(..)
7− , HeaderAndImports(..)
7+ , Header(..)
8 , Name, nameToString, nameIsNative
8 , Name, nameToString, nameIsNative
9 , Interface(..), toInterface
9 , Interface(..), toInterface
10− , ImportMethod(..)
10+ , UserImport, DefaultImport, ImportMethod(..)
11 ) where
11 ) where
12
12
13+import Control.Applicative ((<$>),(<*>))
13import Data.Binary
14import Data.Binary
14import qualified Data.List as List
15import qualified Data.List as List
15import qualified Data.Map as Map
16import qualified Data.Map as Map
16−import Control.Applicative ((<$>),(<*>))
17
17
18−import qualified AST.Expression.Canonical as Canonical
19import qualified AST.Declaration as Decl
18import qualified AST.Declaration as Decl
19+import qualified AST.Expression.Canonical as Canonical
20import qualified AST.Type as Type
20import qualified AST.Type as Type
21import qualified AST.Variable as Var
21import qualified AST.Variable as Var
22−import AST.PrettyPrint
23import qualified Elm.Compiler.Version as Compiler
22import qualified Elm.Compiler.Version as Compiler
24−import Text.PrettyPrint as P
23+import qualified Reporting.Annotation as A
25
24
26
25
27-- HELPFUL TYPE ALIASES
26-- HELPFUL TYPE ALIASES
28
27
29type Interfaces = Map.Map Name Interface
28type Interfaces = Map.Map Name Interface
30
29
31−type Types = Map.Map String Type.CanonicalType
30+type Types = Map.Map String Type.Canonical
32−type Aliases = Map.Map String ([String], Type.CanonicalType)
31+type Aliases = Map.Map String ([String], Type.Canonical)
33type ADTs = Map.Map String (AdtInfo String)
32type ADTs = Map.Map String (AdtInfo String)
34
33
35−type AdtInfo v = ( [String], [(v, [Type.CanonicalType])] )
34+type AdtInfo v = ( [String], [(v, [Type.Canonical])] )
36type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)
35type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)
37
36
38
37
39-- MODULES
38-- MODULES
40
39
41type SourceModule =
40type SourceModule =
41+ Module
42+ [UserImport]
42− Module (Var.Listing Var.Value) [Decl.SourceDecl]
43+ (Var.Listing (A.Located Var.Value))
44+ [Decl.SourceDecl]
45+
43
46
44type ValidModule =
47type ValidModule =
48+ Module
49+ ([DefaultImport], [UserImport])
45− Module (Var.Listing Var.Value) [Decl.ValidDecl]
50+ (Var.Listing (A.Located Var.Value))
51+ [Decl.ValidDecl]
52+
46
53
47type CanonicalModule =
54type CanonicalModule =
48− Module [Var.Value] CanonicalBody
55+ Module [Name] [Var.Value] CanonicalBody
49
56
50
57
51−data Module exports body = Module
58+data Module imports exports body = Module
52 { names :: Name
59 { names :: Name
53 , path :: FilePath
60 , path :: FilePath
54 , exports :: exports
61 , exports :: exports
55− , imports :: [(Name, ImportMethod)]
62+ , imports :: imports
56 , body :: body
63 , body :: body
57 }
64 }
58
65
@@ -69,10 +76,10 @@ data CanonicalBody = CanonicalBody
69-- HEADERS
76-- HEADERS
70
77
71{-| Basic info needed to identify modules and determine dependencies. -}
78{-| Basic info needed to identify modules and determine dependencies. -}
72−data HeaderAndImports = HeaderAndImports
79+data Header imports = Header
73 { _names :: Name
80 { _names :: Name
74− , _exports :: Var.Listing Var.Value
81+ , _exports :: Var.Listing (A.Located Var.Value)
75− , _imports :: [(Name, ImportMethod)]
82+ , _imports :: imports
76 }
83 }
77
84
78
85
@@ -91,6 +98,19 @@ nameIsNative name =
91 _ -> False
98 _ -> False
92
99
93
100
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+
94
114
95-- INTERFACES
115-- INTERFACES
96
116
@@ -99,7 +119,7 @@ data Interface = Interface
99 { iVersion :: String
119 { iVersion :: String
100 , iExports :: [Var.Value]
120 , iExports :: [Var.Value]
101 , iTypes :: Types
121 , iTypes :: Types
102− , iImports :: [(Name, ImportMethod)]
122+ , iImports :: [Name]
103 , iAdts :: ADTs
123 , iAdts :: ADTs
104 , iAliases :: Aliases
124 , iAliases :: Aliases
105 , iFixities :: [(Decl.Assoc, Int, String)]
125 , iFixities :: [(Decl.Assoc, Int, String)]
@@ -131,55 +151,3 @@ instance Binary Interface where
131 put (iAliases modul)
151 put (iAliases modul)
132 put (iFixities modul)
152 put (iFixities modul)
133 put (iPorts modul)
153 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 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module AST.Pattern where
2module AST.Pattern where
3
3
4−import qualified AST.Helpers as Help
5−import AST.PrettyPrint
6−import Text.PrettyPrint as PP
7import qualified Data.Set as Set
4import qualified Data.Set as Set
5+import Text.PrettyPrint as P
8
6
7+import qualified AST.Helpers as Help
8+import qualified AST.Literal as L
9import qualified AST.Variable as Var
9import 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+
11
14
15+type Pattern ann var =
16+ A.Annotated ann (Pattern' ann var)
12
17
18+
13−data Pattern var
19+data Pattern' ann var
14− = Data var [Pattern var]
20+ = Data var [Pattern ann var]
15 | Record [String]
21 | Record [String]
16− | Alias String (Pattern var)
22+ | Alias String (Pattern ann var)
17 | Var String
23 | Var String
18 | Anything
24 | Anything
19− | Literal Literal.Literal
25+ | Literal L.Literal
20− deriving (Eq, Ord, Show)
26+ deriving (Show)
21
27
22
28
23type RawPattern =
29type RawPattern =
24− Pattern Var.Raw
30+ Pattern R.Region Var.Raw
25
31
26
32
27−type CanonicalPattern =
33+type RawPattern' =
28− Pattern Var.Canonical
34+ Pattern' R.Region Var.Raw
29
35
30
36
31−cons :: RawPattern -> RawPattern -> RawPattern
37+type CanonicalPattern =
32−cons h t =
38+ Pattern R.Region Var.Canonical
33− Data (Var.Raw "::") [h,t]
34
39
35
40
36−nil :: RawPattern
41+list :: R.Position -> [RawPattern] -> RawPattern
37−nil =
42+list end patterns =
43+ case patterns of
44+ [] ->
38− Data (Var.Raw "[]") []
45+ A.at end end (Data (Var.Raw "[]") [])
39
46
47+ pattern@(A.A (R.Region start _) _) : rest ->
48+ A.at start end (Data (Var.Raw "::") [pattern, list end rest])
40
49
41−list :: [RawPattern] -> RawPattern
42−list patterns =
43− foldr cons nil patterns
44
50
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
45
57
58+
46−tuple :: [RawPattern] -> RawPattern
59+tuple :: [RawPattern] -> RawPattern'
47tuple patterns =
60tuple patterns =
48 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns
61 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns
49
62
50
63
51−boundVarList :: Pattern var -> [String]
64+-- FIND VARIABLES
52−boundVarList pattern =
53− Set.toList (boundVars pattern)
54−
55
65
56−boundVars :: Pattern var -> Set.Set String
66+boundVars :: Pattern ann var -> [A.Annotated ann String]
57−boundVars pattern =
67+boundVars (A.A ann pattern) =
58 case pattern of
68 case pattern of
59− Var x -> Set.singleton x
69+ Var x ->
60− Alias x p -> Set.insert x (boundVars p)
70+ [A.A ann x]
61− Data _ ps -> Set.unions (map boundVars ps)
71+
72+ Alias name realPattern ->
73+ A.A ann name : boundVars realPattern
74+
75+ Data _ patterns ->
76+ concatMap boundVars patterns
77+
62− Record fields -> Set.fromList fields
78+ Record fields ->
79+ map (A.A ann) fields
80+
63− Anything -> Set.empty
81+ Anything ->
82+ []
83+
64− Literal _ -> Set.empty
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+
65
102
103+-- PRETTY PRINTING
66
104
67−instance Var.ToString var => Pretty (Pattern var) where
105+instance Var.ToString var => P.Pretty (Pattern' ann var) where
68− pretty pattern =
106+ pretty needsParens pattern =
69 case pattern of
107 case pattern of
70− Var x ->
108+ Var name ->
71− variable x
109+ P.text name
72
110
73 Literal literal ->
111 Literal literal ->
74− pretty literal
112+ P.pretty needsParens literal
75
113
76 Record fields ->
114 Record fields ->
77− PP.braces (commaCat (map variable fields))
115+ P.braces (P.commaCat (map P.text fields))
78
116
79− Alias x p ->
117+ Alias x ptrn ->
80− prettyParens p <+> PP.text "as" <+> variable x
118+ P.parensIf needsParens $
119+ P.pretty True ptrn <+> P.text "as" <+> P.text x
81
120
82 Anything ->
121 Anything ->
83− PP.text "_"
122+ P.text "_"
84−
123+
124+ Data name [A.A _ hd, A.A _ tl]
85− Data name [hd,tl] | Var.toString name == "::" ->
125+ | Var.toString name == "::" ->
86− parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
126+ P.parensIf isCons (P.pretty False hd)
127+ <+> P.text "::"
128+ <+> P.pretty False tl
87− where
129+ where
88− isCons =
130+ isCons =
89− case hd of
131+ case hd of
90− Data ctor _ -> Var.toString ctor == "::"
132+ Data ctor _ -> Var.toString ctor == "::"
91− _ -> False
133+ _ -> False
92−
134+
93− Data name ps ->
135+ Data name patterns ->
94− let name' = Var.toString name
136+ let name' = Var.toString name
95− in
137+ in
96 if Help.isTuple name'
138 if Help.isTuple name'
139+ then
97− then PP.parens (commaCat (map pretty ps))
140+ P.parens (P.commaCat (map (P.pretty False) patterns))
141+ else
142+ P.parensIf needsParens $
98− else hsep (PP.text name' : map prettyParens ps)
143+ P.hsep (P.text name' : map (P.pretty True) patterns)
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
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 @@
1module AST.Type
1module AST.Type
2− ( Type(..), AliasType(..)
2+ ( Raw, Raw'(..)
3− , RawType, CanonicalType
3+ , Canonical(..), Aliased(..)
4− , PortType(..), portType
4+ , Port(..), portType
5− , fieldMap, recordOf, listOf, tupleOf
6 , deepDealias, dealias
5 , deepDealias, dealias
7 , collectLambdas
6 , collectLambdas
8− , prettyParens
7+ , fieldMap
8+ , tuple
9 ) where
9 ) where
10
10
11import Control.Applicative ((<$>), (<*>))
11import Control.Applicative ((<$>), (<*>))
12import Control.Arrow (second)
12import Control.Arrow (second)
13import Data.Binary
13import Data.Binary
14import qualified Data.Map as Map
14import qualified Data.Map as Map
15+import qualified Data.Maybe as Maybe
16+import Text.PrettyPrint as P
15
17
16import qualified AST.Variable as Var
18import qualified AST.Variable as Var
17−import AST.PrettyPrint
18import qualified AST.Helpers as Help
19import qualified AST.Helpers as Help
20+import qualified Reporting.Annotation as A
19−import Text.PrettyPrint as P
21+import qualified Reporting.PrettyPrint as P
22+import qualified Reporting.Region as R
20
23
21
24
22-- DEFINITION
25-- DEFINITION
23
26
24−data Type var
27+type Raw =
25− = Lambda (Type var) (Type var)
28+ A.Located Raw'
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)
32
29
33
30
34−data AliasType var
31+data Raw'
35− = Holey (Type var)
32+ = RLambda Raw Raw
36− | Filled (Type var)
33+ | RVar String
34+ | RType Var.Raw
35+ | RApp Raw [Raw]
36+ | RRecord [(String, Raw)] (Maybe Raw)
37− deriving (Eq, Ord, Show)
37+ deriving (Show)
38
38
39
39
40−type RawType =
40+data Canonical
41+ = Lambda Canonical Canonical
42+ | Var String
41− Type Var.Raw
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)
42
48
43
49
44−type CanonicalType =
50+data Aliased t
45− Type Var.Canonical
51+ = Holey t
52+ | Filled t
53+ deriving (Eq, Ord, Show)
46
54
47
55
48−data PortType var
56+data Port t
49− = Normal (Type var)
57+ = Normal t
50− | Signal { root :: Type var, arg :: Type var }
58+ | Signal { root :: t, arg :: t }
51 deriving (Show)
59 deriving (Show)
52
60
53
61
54−portType :: PortType var -> Type var
62+portType :: Port tipe -> tipe
55portType portType =
63portType portType =
56 case portType of
64 case portType of
57 Normal tipe -> tipe
65 Normal tipe -> tipe
@@ -65,7 +73,7 @@ fieldMap fields =
65 in
73 in
66 foldl add Map.empty fields
74 foldl add Map.empty fields
67
75
68−
76+{--
69recordOf :: [(String, Type var)] -> Type var
77recordOf :: [(String, Type var)] -> Type var
70recordOf fields =
78recordOf fields =
71 Record fields Nothing
79 Record fields Nothing
@@ -74,18 +82,18 @@ recordOf fields =
74listOf :: RawType -> RawType
82listOf :: RawType -> RawType
75listOf tipe =
83listOf tipe =
76 App (Type (Var.Raw "List")) [tipe]
84 App (Type (Var.Raw "List")) [tipe]
85+--}
77
86
78−
87+tuple :: R.Region -> [Raw] -> Raw
79−tupleOf :: [RawType] -> RawType
88+tuple region types =
80−tupleOf types =
81 let name = Var.Raw ("_Tuple" ++ show (length types))
89 let name = Var.Raw ("_Tuple" ++ show (length types))
82 in
90 in
83− App (Type name) types
91+ A.A region (RApp (A.A region (RType name)) types)
84
92
85
93
86-- DEALIASING
94-- DEALIASING
87
95
88−deepDealias :: Type v -> Type v
96+deepDealias :: Canonical -> Canonical
89deepDealias tipe =
97deepDealias tipe =
90 let go = deepDealias in
98 let go = deepDealias in
91 case tipe of
99 case tipe of
@@ -108,7 +116,7 @@ deepDealias tipe =
108 App (go f) (map go args)
116 App (go f) (map go args)
109
117
110
118
111−dealias :: [(String, Type v)] -> AliasType v -> Type v
119+dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
112dealias args aliasType =
120dealias args aliasType =
113 case aliasType of
121 case aliasType of
114 Holey tipe ->
122 Holey tipe ->
@@ -118,7 +126,7 @@ dealias args aliasType =
118 tipe
126 tipe
119
127
120
128
121−dealiasHelp :: Map.Map String (Type var) -> Type var -> Type var
129+dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
122dealiasHelp typeTable tipe =
130dealiasHelp typeTable tipe =
123 let go = dealiasHelp typeTable in
131 let go = dealiasHelp typeTable in
124 case tipe of
132 case tipe of
@@ -143,120 +151,212 @@ dealiasHelp typeTable tipe =
143
151
144-- PRETTY PRINTING
152-- PRETTY PRINTING
145
153
146−instance (Pretty var, Var.ToString var) => Pretty (PortType var) where
154+instance (P.Pretty t) => P.Pretty (Port t) where
147− pretty portType =
155+ pretty needsParens portType =
148 case portType of
156 case portType of
149 Normal tipe ->
157 Normal tipe ->
150− pretty tipe
158+ P.pretty needsParens tipe
151
159
152 Signal tipe _ ->
160 Signal tipe _ ->
153− pretty tipe
161+ P.pretty needsParens tipe
154
162
155
163
156−instance (Var.ToString var, Pretty var) => Pretty (Type var) where
164+instance P.Pretty Raw' where
157− pretty tipe =
165+ pretty needsParens tipe =
158 case tipe of
166 case tipe of
159− Lambda _ _ ->
167+ RLambda arg body ->
168+ P.parensIf needsParens (prettyLambda getRawLambda arg body)
169+
170+ RVar x ->
160− P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
171+ P.text x
161− where
172+
162− t:ts = map prettyLambda (collectLambdas tipe)
173+ RType var ->
163− prettyLambda t =
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 =
164− case t of
189+ case tipe of
165− Lambda _ _ -> P.parens (pretty t)
190+ Lambda arg body ->
166− _ -> pretty t
191+ P.parensIf needsParens (prettyLambda getCanLambda arg body)
167
192
168 Var x ->
193 Var x ->
169 P.text x
194 P.text x
170
195
171 Type var ->
196 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
173 in
203 in
174− P.text (if v == "_Tuple0" then "()" else v)
204+ prettyApp needsParens isTuple func args
175
205
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 _ _ ->
206+ Record fields ext ->
185− case flattenRecord tipe of
207+ prettyRecord (flattenCanRecord fields ext)
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
208
207 Aliased name args _ ->
209 Aliased name args _ ->
210+ P.parensIf (needsParens && not (null args)) $
211+ P.hang
212+ (P.pretty False name)
213+ 2
208− P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args))
214+ (P.sep (map (P.pretty True . snd) args))
209
215
210
216
211−collectLambdas :: Type var -> [Type var]
217+-- PRETTY HELPERS
212−collectLambdas tipe =
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) =
213 case tipe of
246 case tipe of
214− Lambda arg body ->
247+ RLambda arg body -> Just (arg, body)
215− arg : collectLambdas body
248+ _ -> Nothing
216
249
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 ->
218 [tipe]
265 [tipe]
219
266
220
267
221−prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
268+collectLambdas :: Canonical -> [Canonical]
222−prettyParens tipe =
269+collectLambdas tipe =
223− parensIf (needed tipe) (pretty tipe)
270+ gatherLambda getCanLambda tipe
224− where
225− needed t =
226− case t of
227− Aliased _ [] _ -> False
228
271
229− Aliased _ _ _ -> True
230
272
231− Lambda _ _ -> True
273+-- PRETTY APP
232
274
233− App (Type name) _
275+prettyApp :: (P.Pretty t) => Bool -> (t -> Bool) -> t -> [t] -> P.Doc
234− | Help.isTuple (Var.toString name) ->
276+prettyApp needsParens isTuple func args
235− False
277+ | isTuple func =
278+ P.parens $ P.sep $
279+ P.punctuate P.comma (map (P.pretty False) args)
236
280
237− App t' [] -> needed t'
281+ | null args =
282+ P.pretty needsParens func
238
283
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))
240
290
241− _ -> False
242
291
292+-- PRETTY RECORD
243
293
244−flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
294+prettyRecord :: (P.Pretty t) => ([(String, t)], Maybe String) -> P.Doc
245−flattenRecord tipe =
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 =
246− case tipe of
329+ case ext of
247− Var x ->
330+ Nothing ->
331+ (fields, Nothing)
332+
333+ Just (A.A _ (RVar x)) ->
248− ([], Just x)
334+ (fields, Just x)
249
335
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
250− Record fields Nothing ->
349+ Nothing ->
251 (fields, Nothing)
350 (fields, Nothing)
252
351
352+ Just (Var x) ->
353+ (fields, Just x)
354+
253− Record fields (Just ext) ->
355+ Just (Record fields' ext') ->
254− let (fields',ext') = flattenRecord ext
255− in
256− (fields' ++ fields, ext')
356+ flattenCanRecord (fields' ++ fields) ext'
257
357
258− Aliased _ args tipe' ->
358+ Just (Aliased _ args tipe) ->
259− flattenRecord (dealias args tipe')
359+ flattenCanRecord fields (Just (dealias args tipe))
260
360
261 _ ->
361 _ ->
262 error "Trying to flatten ill-formed record."
362 error "Trying to flatten ill-formed record."
@@ -264,7 +364,7 @@ flattenRecord tipe =
264
364
265-- BINARY
365-- BINARY
266
366
267−instance Binary var => Binary (Type var) where
367+instance Binary Canonical where
268 put tipe =
368 put tipe =
269 case tipe of
369 case tipe of
270 Lambda t1 t2 ->
370 Lambda t1 t2 ->
@@ -297,7 +397,7 @@ instance Binary var => Binary (Type var) where
297 _ -> error "Error reading a valid type from serialized string"
397 _ -> error "Error reading a valid type from serialized string"
298
398
299
399
300−instance Binary var => Binary (AliasType var) where
400+instance Binary t => Binary (Aliased t) where
301 put aliasType =
401 put aliasType =
302 case aliasType of
402 case aliasType of
303 Holey tipe ->
403 Holey tipe ->
src/AST/Variable.hs+68−46
@@ -5,28 +5,29 @@ import Data.Binary
5import qualified Data.List as List
5import qualified Data.List as List
6import qualified Data.Maybe as Maybe
6import qualified Data.Maybe as Maybe
7import Text.PrettyPrint as P
7import Text.PrettyPrint as P
8+
8import qualified AST.Helpers as Help
9import qualified AST.Helpers as Help
9−import AST.PrettyPrint
10+import qualified Reporting.PrettyPrint as P
10
11
11
12
12-- VARIABLES
13-- VARIABLES
13
14
14newtype Raw = Raw String
15newtype Raw = Raw String
15− deriving (Eq,Ord,Show)
16+ deriving (Eq, Ord, Show)
16
17
17
18
18data Home
19data Home
19 = BuiltIn
20 = BuiltIn
20 | Module [String]
21 | Module [String]
21 | Local
22 | Local
22− deriving (Eq,Ord,Show)
23+ deriving (Eq, Ord, Show)
23
24
24
25
25data Canonical = Canonical
26data Canonical = Canonical
26 { home :: !Home
27 { home :: !Home
27 , name :: !String
28 , name :: !String
28 }
29 }
29− deriving (Eq,Ord,Show)
30+ deriving (Eq, Ord, Show)
30
31
31
32
32local :: String -> Canonical
33local :: String -> Canonical
@@ -88,8 +89,10 @@ isTuple v =
88isPrimitive :: Canonical -> Bool
89isPrimitive :: Canonical -> Bool
89isPrimitive v =
90isPrimitive v =
90 case v of
91 case v of
92+ Canonical BuiltIn name ->
91− Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]
93+ name `elem` ["Int","Float","String","Bool"]
94+ _ ->
92− _ -> False
95+ False
93
96
94
97
95isPrim :: String -> Canonical -> Bool
98isPrim :: String -> Canonical -> Bool
@@ -117,10 +120,10 @@ instance ToString Raw where
117
120
118instance ToString Canonical where
121instance ToString Canonical where
119 toString (Canonical home name) =
122 toString (Canonical home name) =
120− case home of
123+ case home of
121− BuiltIn -> name
124+ BuiltIn -> name
122− Module path -> List.intercalate "." (path ++ [name])
125+ Module path -> List.intercalate "." (path ++ [name])
123− Local -> name
126+ Local -> name
124
127
125
128
126-- LISTINGS
129-- LISTINGS
@@ -129,7 +132,8 @@ instance ToString Canonical where
129data Listing a = Listing
132data Listing a = Listing
130 { _explicits :: [a]
133 { _explicits :: [a]
131 , _open :: Bool
134 , _open :: Bool
135+ }
132− } deriving (Eq,Ord,Show)
136+ deriving (Eq, Ord, Show)
133
137
134
138
135openListing :: Listing a
139openListing :: Listing a
@@ -152,7 +156,7 @@ data Value
152 = Value !String
156 = Value !String
153 | Alias !String
157 | Alias !String
154 | Union !String !(Listing String)
158 | Union !String !(Listing String)
155− deriving (Eq,Ord,Show)
159+ deriving (Eq, Ord, Show)
156
160
157
161
158-- CATEGORIZING VALUES
162-- CATEGORIZING VALUES
@@ -198,30 +202,36 @@ getUnion value =
198
202
199-- PRETTY VARIABLES
203-- PRETTY VARIABLES
200
204
201−instance Pretty Raw where
205+instance P.Pretty Raw where
202− pretty (Raw name) =
206+ pretty _ (Raw name) =
203− variable name
207+ if Help.isOp name
208+ then P.parens (P.text name)
209+ else P.text name
204
210
205
211
206−instance Pretty Canonical where
212+instance P.Pretty Canonical where
207− pretty var =
213+ pretty _ var =
208 P.text (toString var)
214 P.text (toString var)
209
215
210
216
211−instance Pretty a => Pretty (Listing a) where
217+instance P.Pretty a => P.Pretty (Listing a) where
212− pretty (Listing explicits open) =
218+ pretty _ (Listing explicits open) =
213− P.parens (commaCat (map pretty explicits ++ dots))
214− where
215− dots = [if open then P.text ".." else P.empty]
219+ let dots = [if open then P.text ".." else P.empty]
220+ in
221+ P.parens (P.commaCat (map (P.pretty False) explicits ++ dots))
216
222
217
223
218−instance Pretty Value where
224+instance P.Pretty Value where
219− pretty portable =
225+ pretty _ portable =
220 case portable of
226 case portable of
221− Value name -> P.text name
227+ Value name ->
228+ P.text name
229+
222− Alias name -> P.text name
230+ Alias name ->
231+ P.text name
232+
223 Union name ctors ->
233 Union name ctors ->
224− P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })
234+ P.text name <> P.pretty False ctors
225
235
226
236
227-- BINARY SERIALIZATION
237-- BINARY SERIALIZATION
@@ -229,31 +239,43 @@ instance Pretty Value where
229instance Binary Canonical where
239instance Binary Canonical where
230 put (Canonical home name) =
240 put (Canonical home name) =
231 case home of
241 case home of
242+ BuiltIn ->
232− BuiltIn -> putWord8 0 >> put name
243+ putWord8 0 >> put name
244+
245+ Module path ->
233− Module path -> putWord8 1 >> put path >> put name
246+ putWord8 1 >> put path >> put name
247+
248+ Local ->
234− Local -> putWord8 2 >> put name
249+ putWord8 2 >> put name
235
250
251+ get =
236− get = do tag <- getWord8
252+ do tag <- getWord8
237− case tag of
253+ case tag of
238− 0 -> Canonical BuiltIn <$> get
254+ 0 -> Canonical BuiltIn <$> get
239− 1 -> Canonical . Module <$> get <*> get
255+ 1 -> Canonical . Module <$> get <*> get
240− 2 -> Canonical Local <$> get
256+ 2 -> Canonical Local <$> get
241− _ -> error "Unexpected tag when deserializing canonical variable"
257+ _ -> error "Unexpected tag when deserializing canonical variable"
242
258
243
259
244instance Binary Value where
260instance Binary Value where
245 put portable =
261 put portable =
246 case portable of
262 case portable of
263+ Value name ->
247− Value name -> putWord8 0 >> put name
264+ putWord8 0 >> put name
265+
266+ Alias name ->
248− Alias name -> putWord8 1 >> put name
267+ putWord8 1 >> put name
268+
269+ Union name ctors ->
249− Union name ctors -> putWord8 2 >> put name >> put ctors
270+ putWord8 2 >> put name >> put ctors
250−
271+
272+ get =
251− get = do tag <- getWord8
273+ do tag <- getWord8
252− case tag of
274+ case tag of
253− 0 -> Value <$> get
275+ 0 -> Value <$> get
254− 1 -> Alias <$> get
276+ 1 -> Alias <$> get
255− 2 -> Union <$> get <*> get
277+ 2 -> Union <$> get <*> get
256− _ -> error "Error reading valid import/export information from serialized string"
278+ _ -> error "Error reading valid import/export information from serialized string"
257
279
258
280
259instance (Binary a) => Binary (Listing a) where
281instance (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 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Transform.SortDefinitions (sortDefs) where
2+module Canonicalize.Sort (definitions) where
3
3
4import Control.Monad.State
4import Control.Monad.State
5import Control.Applicative ((<$>),(<*>))
5import Control.Applicative ((<$>),(<*>))
@@ -8,28 +8,18 @@ import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
8import qualified Data.Maybe as Maybe
9import qualified Data.Set as Set
9import qualified Data.Set as Set
10
10
11−import AST.Annotation
12import AST.Expression.General (Expr'(..), PortImpl(..))
11import AST.Expression.General (Expr'(..), PortImpl(..))
13import qualified AST.Expression.Canonical as Canonical
12import qualified AST.Expression.Canonical as Canonical
14import qualified AST.Pattern as P
13import qualified AST.Pattern as P
15import qualified AST.Variable as V
14import qualified AST.Variable as V
15+import qualified Reporting.Annotation as A
16
16
17
17
18−ctors :: P.CanonicalPattern -> [String]
18+-- STARTING POINT
19−ctors pattern =
19+
20− case pattern of
20+definitions :: Canonical.Expr -> Canonical.Expr
21− P.Var _ -> []
21+definitions expression =
22− P.Alias _ p -> ctors p
22+ evalState (reorder expression) Set.empty
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
33
23
34
24
35free :: String -> State (Set.Set String) ()
25free :: String -> State (Set.Set String) ()
@@ -45,19 +35,11 @@ freeIfLocal (V.Canonical home name) =
45 V.Module _ -> return ()
35 V.Module _ -> return ()
46
36
47
37
48−bound :: Set.Set String -> State (Set.Set String) ()
38+-- REORDER EXPRESSIONS
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−
57
39
58reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
40reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
59−reorder (A ann expression) =
41+reorder (A.A ann expression) =
60− A ann <$>
42+ A.A ann <$>
61 case expression of
43 case expression of
62 -- Be careful adding and restricting freeVars
44 -- Be careful adding and restricting freeVars
63 Var var ->
45 Var var ->
@@ -135,49 +117,71 @@ reorder (A ann expression) =
135 -- allows the programmer to write definitions in whatever
117 -- allows the programmer to write definitions in whatever
136 -- order they please, we can still define things in order
118 -- order they please, we can still define things in order
137 -- and generalize polymorphic functions when appropriate.
119 -- and generalize polymorphic functions when appropriate.
138− sccs <- Graph.stronglyConnComp <$> buildDefDict defs
120+ sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
139 let defss = map Graph.flattenSCC sccs
121 let defss = map Graph.flattenSCC sccs
140
122
141 -- remove let-bound variables from the context
123 -- remove let-bound variables from the context
142 forM_ defs $ \(Canonical.Definition pattern _ _) -> do
124 forM_ defs $ \(Canonical.Definition pattern _ _) -> do
143− bound (P.boundVars pattern)
125+ bound pattern
144 mapM free (ctors pattern)
126 mapM free (ctors pattern)
145
127
146− let A _ let' =
128+ let (A.A _ let') =
147− foldr (\ds bod -> A ann (Let ds bod)) body' defss
129+ foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
148
130
149 return let'
131 return let'
150
132
151
133
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+
152bindingReorder
168bindingReorder
153 :: (P.CanonicalPattern, Canonical.Expr)
169 :: (P.CanonicalPattern, Canonical.Expr)
154 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
170 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
155−bindingReorder (pattern,expr) =
171+bindingReorder (pattern, expr) =
156 do expr' <- reorder expr
172 do expr' <- reorder expr
157− bound (P.boundVars pattern)
173+ bound pattern
158 mapM_ free (ctors pattern)
174 mapM_ free (ctors pattern)
159 return (pattern, expr')
175 return (pattern, expr')
160
176
161
177
162−reorderAndGetDependencies
178+-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
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−
175
179
176-- This also reorders the all of the sub-expressions in the Def list.
180-- This also reorders the all of the sub-expressions in the Def list.
177−buildDefDict
181+buildDefGraph
178 :: [Canonical.Def]
182 :: [Canonical.Def]
179 -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
183 -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
180−buildDefDict defs =
184+buildDefGraph defs =
181 do pdefsDeps <- mapM reorderAndGetDependencies defs
185 do pdefsDeps <- mapM reorderAndGetDependencies defs
182 return $ realDeps (addKey pdefsDeps)
186 return $ realDeps (addKey pdefsDeps)
183 where
187 where
@@ -187,7 +191,7 @@ buildDefDict defs =
187
191
188 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
192 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
189 variableToKey (Canonical.Definition pattern _ _, key, _) =
193 variableToKey (Canonical.Definition pattern _ _, key, _) =
190− [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
194+ [ (var, key) | var <- P.boundVarList pattern ]
191
195
192 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
196 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
193 variableToKeyMap pdefsDeps =
197 variableToKeyMap pdefsDeps =
@@ -200,3 +204,17 @@ buildDefDict defs =
200 varDict = variableToKeyMap pdefsDeps
204 varDict = variableToKeyMap pdefsDeps
201 convert (pdef, key, deps) =
205 convert (pdef, key, deps) =
202 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
206 (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 @@
1module Compile (compile) where
1module Compile (compile) where
2
2
3import qualified Data.Map as Map
3import qualified Data.Map as Map
4−import Text.PrettyPrint (Doc)
5
4
6import qualified AST.Module as Module
5import qualified AST.Module as Module
6+import qualified Canonicalize
7+import Elm.Utils ((|>))
8+import qualified Nitpick.TopLevelTypes as Nitpick
7import qualified Parse.Helpers as Parse
9import qualified Parse.Helpers as Parse
8import qualified Parse.Parse as Parse
10import qualified Parse.Parse as Parse
9−import qualified Transform.AddDefaultImports as DefaultImports
11+import qualified Reporting.Error as Error
12+import qualified Reporting.Result as Result
10−import qualified Transform.Check as Check
13+import qualified Reporting.Warning as Warning
11import qualified Type.Inference as TI
14import qualified Type.Inference as TI
12−import qualified Transform.Canonicalize as Canonical
13−import Elm.Utils ((|>))
14
15
15
16
16compile
17compile
@@ -18,35 +19,34 @@ compile
18 -> String
19 -> String
19 -> Module.Interfaces
20 -> Module.Interfaces
20 -> String
21 -> String
21− -> Either [Doc] Module.CanonicalModule
22+ -> Result.Result Warning.Warning Error.Error Module.CanonicalModule
22
23
23compile user projectName interfaces source =
24compile user projectName interfaces source =
24− do
25+ do
25− -- Parse the source code
26− parsedModule <-
27− Parse.program (getOpTable interfaces) source
28−
29 -- determine if default imports should be added
26 -- determine if default imports should be added
30 -- only elm-lang/core is exempt
27 -- only elm-lang/core is exempt
31 let needsDefaults =
28 let needsDefaults =
32 not (user == "elm-lang" && projectName == "core")
29 not (user == "elm-lang" && projectName == "core")
33
30
34− -- add default imports if necessary
31+ -- Parse the source code
35− let rawModule =
32+ validModule <-
36− DefaultImports.add needsDefaults parsedModule
33+ Result.mapError Error.Syntax $
37−
34+ Parse.program needsDefaults (getOpTable interfaces) source
38− -- validate module (e.g. all variables exist)
39− case Check.mistakes (Module.body rawModule) of
40− [] -> return ()
41− ms -> Left ms
42
35
43 -- Canonicalize all variables, pinning down where they came from.
36 -- Canonicalize all variables, pinning down where they came from.
44− canonicalModule <- Canonical.module' interfaces rawModule
37+ canonicalModule <-
38+ Canonicalize.module' interfaces validModule
45
39
46 -- Run type inference on the program.
40 -- Run type inference on the program.
41+ types <-
42+ Result.from Error.Type $
47− types <- TI.infer interfaces canonicalModule
43+ TI.infer interfaces canonicalModule
44+
45+ -- One last round of checks
46+ Result.mapError Error.Type $
47+ Nitpick.topLevelTypes types (Module.body validModule)
48
48
49− -- Add the real list of tyes
49+ -- Add the real list of types
50 let body = (Module.body canonicalModule) { Module.types = types }
50 let body = (Module.body canonicalModule) { Module.types = types }
51
51
52 return $ canonicalModule { Module.body = body }
52 return $ canonicalModule { Module.body = body }
@@ -57,4 +57,4 @@ getOpTable interfaces =
57 Map.elems interfaces
57 Map.elems interfaces
58 |> concatMap Module.iFixities
58 |> concatMap Module.iFixities
59 |> map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
59 |> map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
60− |> Map.fromList
60+ |> Map.fromList
src/Elm/Compiler.hs+48−28
@@ -1,23 +1,24 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE FlexibleContexts #-}
3module Elm.Compiler
2module Elm.Compiler
4 ( version, rawVersion
3 ( version, rawVersion
5 , parseDependencies, compile
4 , parseDependencies, compile
5+ , Error, errorToString
6+ , Warning
6 ) where
7 ) where
7
8
8−import Control.Monad.Error (MonadError, throwError)
9−import qualified Data.List as List
10import qualified Data.Map as Map
9import qualified Data.Map as Map
11−import qualified Text.PrettyPrint as P
12
10
13−import qualified AST.Module as Module (HeaderAndImports(HeaderAndImports), toInterface)
11+import qualified AST.Module as Module
14import qualified Compile
12import qualified Compile
15import qualified Elm.Compiler.Module as PublicModule
13import qualified Elm.Compiler.Module as PublicModule
16import qualified Elm.Compiler.Version as Version
14import qualified Elm.Compiler.Version as Version
17−import Elm.Utils ((|>))
18import qualified Generate.JavaScript as JS
15import qualified Generate.JavaScript as JS
19−import qualified Parse.Helpers as Help
20import qualified Parse.Module as Parse
16import 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
21
22
22
23
23-- VERSION
24-- VERSION
@@ -35,19 +36,22 @@ rawVersion =
35-- DEPENDENCIES
36-- DEPENDENCIES
36
37
37parseDependencies
38parseDependencies
38− :: (MonadError String m)
39+ :: String
39− => String
40− -> m (PublicModule.Name, [PublicModule.Name])
40+ -> Either [Error] (PublicModule.Name, [PublicModule.Name])
41−parseDependencies src =
41+parseDependencies sourceCode =
42− case Help.iParse Parse.headerAndImports src of
42+ let
43− Left msg ->
43+ (Result.Result _warnings rawResult) =
44− throwError (show msg)
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
45
49
46− Right (Module.HeaderAndImports names _exports imports) ->
50+ Result.Ok (Module.Header names _exports imports) ->
47− return
51+ Right
48− ( PublicModule.Name names
52+ ( PublicModule.Name names
49− , map (PublicModule.Name . fst) imports
53+ , map (PublicModule.Name . fst . A.drop) imports
50− )
54+ )
51
55
52
56
53-- COMPILATION
57-- COMPILATION
@@ -58,17 +62,33 @@ compile
58 -> String
62 -> String
59 -> String
63 -> String
60 -> Map.Map PublicModule.Name PublicModule.Interface
64 -> Map.Map PublicModule.Name PublicModule.Interface
61− -> Either String (PublicModule.Interface, String)
65+ -> ([Warning], Either [Error] (PublicModule.Interface, String))
62compile user packageName source interfaces =
66compile user packageName source interfaces =
63 let unwrappedInterfaces =
67 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
65 in
72 in
66− case Compile.compile user packageName unwrappedInterfaces source of
73+ (,) (map Warning warnings) $
74+ case rawResult of
67− Right modul ->
75+ Result.Ok modul ->
68 Right (Module.toInterface modul, JS.generate modul)
76 Right (Module.toInterface modul, JS.generate modul)
69
77
70− Left docs ->
78+ Result.Err errors ->
71− map P.render docs
79+ Left (map Error errors)
72− |> List.intersperse ""
80+
73− |> unlines
81+
74− |> Left
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
2
2
3import qualified AST.Module as Module
3import qualified AST.Module as Module
4import qualified AST.Variable as Var
4import qualified AST.Variable as Var
5
5
6
6
7−-- DESCRIPTION OF DEFAULT IMPORTS
7+-- DEFAULT IMPORTS
8
8
9(==>) :: a -> b -> (a,b)
9(==>) :: a -> b -> (a,b)
10(==>) = (,)
10(==>) = (,)
11
11
12
12
13−defaultImports :: [(Module.Name, Module.ImportMethod)]
13+defaults :: [Module.DefaultImport]
14−defaultImports =
14+defaults =
15 [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing
15 [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing
16 , ["List"] ==> exposing [Var.Value "::"]
16 , ["List"] ==> exposing [Var.Value "::"]
17 , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]
17 , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]
@@ -23,15 +23,3 @@ defaultImports =
23exposing :: [Var.Value] -> Module.ImportMethod
23exposing :: [Var.Value] -> Module.ImportMethod
24exposing vars =
24exposing vars =
25 Module.ImportMethod Nothing (Var.listing vars)
25 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
18import System.FilePath ((</>))
18import System.FilePath ((</>))
19
19
20import qualified AST.Module as Module
20import qualified AST.Module as Module
21−import qualified Transform.AddDefaultImports as Defaults
21+import qualified Elm.Compiler.Imports as Imports
22import qualified Elm.Compiler.Type as Type
22import qualified Elm.Compiler.Type as Type
23import qualified Elm.Compiler.Type.Extract as Extract
23import qualified Elm.Compiler.Type.Extract as Extract
24
24
@@ -34,7 +34,7 @@ newtype Name = Name [String]
34
34
35defaultImports :: [Name]
35defaultImports :: [Name]
36defaultImports =
36defaultImports =
37− map (Name . fst) Defaults.defaultImports
37+ map (Name . fst) Imports.defaults
38
38
39
39
40-- POKING AROUND INTERFACES
40-- POKING AROUND INTERFACES
src/Elm/Compiler/Type/Extract.hs+1−1
@@ -8,7 +8,7 @@ import qualified Elm.Compiler.Type as T
8
8
9-- INTERNAL TYPE to PUBLIC TYPE
9-- INTERNAL TYPE to PUBLIC TYPE
10
10
11−fromInternalType :: Var.ToString a => Type.Type a -> T.Type
11+fromInternalType :: Type.Canonical -> T.Type
12fromInternalType astType =
12fromInternalType astType =
13 case astType of
13 case astType of
14 Type.Lambda t1 t2 ->
14 Type.Lambda t1 t2 ->
src/Elm/Utils.hs+1−1
@@ -2,7 +2,7 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3module Elm.Utils ((|>), (<|), getAsset, run, unwrappedRun, CommandError(..)) where
3module Elm.Utils ((|>), (<|), getAsset, run, unwrappedRun, CommandError(..)) where
4
4
5−import Control.Monad.Error (MonadError, MonadIO, liftIO, throwError)
5+import Control.Monad.Except (MonadError, MonadIO, liftIO, throwError)
6import System.Directory (doesFileExist)
6import System.Directory (doesFileExist)
7import System.Environment (getEnv)
7import System.Environment (getEnv)
8import System.Exit (ExitCode(ExitSuccess, ExitFailure))
8import System.Exit (ExitCode(ExitSuccess, ExitFailure))
src/Generate/Cases.hs+171−119
@@ -4,29 +4,19 @@ import Control.Applicative ((<$>))
4import Control.Arrow (first)
4import Control.Arrow (first)
5import Control.Monad.State (State)
5import Control.Monad.State (State)
6import qualified Control.Monad.State as State
6import qualified Control.Monad.State as State
7−import Data.List (groupBy,sortBy)
7+import qualified Data.List as List
8import Data.Maybe (fromMaybe)
8import Data.Maybe (fromMaybe)
9
9
10−import qualified AST.Annotation as A
11import qualified AST.Expression.General as Expr
10import qualified AST.Expression.General as Expr
12import qualified AST.Expression.Canonical as Canonical
11import qualified AST.Expression.Canonical as Canonical
13import qualified AST.Literal as Literal
12import qualified AST.Literal as Literal
14import qualified AST.Pattern as P
13import qualified AST.Pattern as P
15import qualified AST.Variable as Var
14import qualified AST.Variable as Var
16−import Transform.Substitute (subst)
15+import qualified Generate.Substitute as S
16+import qualified Reporting.Annotation as A
17
17
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
29
18
19+-- MATCHES
30
20
31data Match
21data Match
32 = Match String [Clause] Match
22 = Match String [Clause] Match
@@ -42,47 +32,51 @@ data Clause =
42 deriving Show
32 deriving Show
43
33
44
34
45−type Case =
35+type Branch =
46 ([P.CanonicalPattern], Canonical.Expr)
36 ([P.CanonicalPattern], Canonical.Expr)
47
37
48
38
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+
49matchSubst :: [(String,String)] -> Match -> Match
54matchSubst :: [(String,String)] -> Match -> Match
50matchSubst pairs match =
55matchSubst pairs match =
51− case match of
56+ case match of
52− Break -> Break
57+ 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)
68
58
59+ Fail -> Fail
69
60
70−isCon :: ([P.Pattern var], expr) -> Bool
61+ Seq ms ->
71−isCon ([] , _) = noMatch "isCon"
62+ Seq (map (matchSubst pairs) ms)
72−isCon (p:_, _) =
63+
73− case p of
64+ Other (A.A a e) ->
74− P.Data _ _ -> True
65+ Other . A.A a $ foldr ($) e $ map (\(x,y) -> S.subst x (Expr.localVar y)) pairs
75− P.Literal _ -> True
76− _ -> False
77
66
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)
78
73
79−isVar :: ([P.Pattern var], expr) -> Bool
80−isVar p = not (isCon p)
81
74
75+-- BUILD MATCHES
82
76
83−match :: [String] -> [Case] -> Match -> State Int Match
77+buildMatch :: [String] -> [Branch] -> Match -> State Int Match
84−match variables cases match =
78+buildMatch variables branches match =
85− case (variables, cases, match) of
79+ case (variables, branches, match) of
86 ([], [], _) ->
80 ([], [], _) ->
87 return match
81 return match
88
82
@@ -93,115 +87,173 @@ match variables cases match =
93 return $ Other expr
87 return $ Other expr
94
88
95 ([], _, _) ->
89 ([], _, _) ->
96− return $ Seq (map (Other . snd) cases ++ [match])
90+ return $ Seq (map (Other . snd) branches ++ [match])
97
91
98 (var:_, _, _)
92 (var:_, _, _)
99− | all isVar cases' -> matchVar variables cases' match
93+ | all isVar branches' -> matchVar variables branches' match
100− | all isCon cases' -> matchCon variables cases' match
94+ | all isCon branches' -> matchCon variables branches' match
101− | otherwise -> matchMix variables cases' match
95+ | otherwise -> matchMix variables branches' match
102 where
96 where
103− cases' = map (dealias var) cases
97+ branches' = map (dealias var) branches
104
98
105
99
106−dealias :: String -> Case -> Case
100+dealias :: String -> Branch -> Branch
107dealias _ ([], _) = noMatch "dealias"
101dealias _ ([], _) = noMatch "dealias"
108−dealias v c@(p:ps, A.A a e) =
102+dealias var branch@(p:ps, A.A ann e) =
109 case p of
103 case p of
104+ A.A _ (P.Alias alias pattern) ->
105+ ( pattern:ps
110− P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)
106+ , A.A ann (S.subst alias (Expr.localVar var) e)
111− _ -> c
107+ )
112
108
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
113
120
121+
122+isVar :: ([P.Pattern ann var], expr) -> Bool
123+isVar p =
124+ not (isCon p)
125+
126+
127+-- VARIABLE MATCHES
128+
114−matchVar :: [String] -> [Case] -> Match -> State Int Match
129+matchVar :: [String] -> [Branch] -> Match -> State Int Match
115matchVar [] _ _ = noMatch "matchVar"
130matchVar [] _ _ = noMatch "matchVar"
116−matchVar (v:vs) cs def =
131+matchVar (var:vars) branches match =
117− match vs (map subVar cs) def
132+ buildMatch vars (map subVar branches) match
118 where
133 where
119 subVar ([], _) = noMatch "matchVar.subVar"
134 subVar ([], _) = noMatch "matchVar.subVar"
120− subVar (p:ps, (A.A a expr)) =
135+ subVar (A.A _ pattern : patterns, (A.A ann expr)) =
136+ ( patterns
121− (ps, A.A a $ subOnePattern p expr)
137+ , A.A ann (subOnePattern pattern expr)
138+ )
122 where
139 where
123 subOnePattern pattern expr =
140 subOnePattern pattern expr =
124 case pattern of
141 case pattern of
125− P.Anything -> expr
142+ P.Anything ->
143+ expr
126
144
127 P.Var x ->
145 P.Var x ->
128− subst x (Expr.localVar v) expr
146+ S.subst x (Expr.localVar var) expr
129
147
130− P.Record fs ->
148+ P.Record fields ->
149+ let access = Expr.Access (A.A ann (Expr.localVar var))
150+ in
131− foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) expr fs
151+ foldr (\x -> S.subst x (access x)) expr fields
132
152
153+ _ ->
133− _ -> noMatch "matchVar.subVar"
154+ noMatch "matchVar.subVar"
134
155
135
156
157+-- CONSTRUCTOR MATCHES
158+
136−matchCon :: [String] -> [Case] -> Match -> State Int Match
159+matchCon :: [String] -> [Branch] -> Match -> State Int Match
137−matchCon variables cases match =
160+matchCon variables branches match =
138 case variables of
161 case variables of
139 [] -> noMatch "matchCon"
162 [] -> noMatch "matchCon"
140
163
141 var : _vars ->
164 var : _vars ->
142 flip (Match var) match <$> mapM toClause caseGroups
165 flip (Match var) match <$> mapM toClause caseGroups
143 where
166 where
144− caseGroups :: [[Case]]
167+ caseGroups :: [[Branch]]
145 caseGroups =
168 caseGroups =
146− groupBy eq (sortBy cmp cases)
169+ List.groupBy branchEq (List.sortBy branchCmp branches)
147−
170+
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
171+ toClause :: [Branch] -> State Int Clause
167− toClause cases =
172+ toClause branches =
168− case head cases of
173+ case head branches of
169− (P.Data name _ : _, _) ->
174+ (A.A _ (P.Data name _) : _, _) ->
170− matchClause (Left name) variables cases Break
175+ matchClause (Left name) variables branches Break
171−
176+
172− (P.Literal lit : _, _) ->
177+ (A.A _ (P.Literal lit) : _, _) ->
173− matchClause (Right lit) variables cases Break
178+ matchClause (Right lit) variables branches Break
174
179
175 _ -> noMatch "matchCon"
180 _ -> noMatch "matchCon"
176
181
177
182
183+matchClause
178−matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match
184+ :: Either Var.Canonical Literal.Literal
185+ -> [String]
186+ -> [Branch]
187+ -> Match
179− -> State Int Clause
188+ -> State Int Clause
180matchClause _ [] _ _ = noMatch "matchClause"
189matchClause _ [] _ _ = noMatch "matchClause"
181−matchClause c (_:vs) cs mtch =
190+matchClause c (_:vs) branches match =
182− do vs' <- getVars
191+ do vs' <- getVars
183− Clause c vs' <$> match (vs' ++ vs) (map flatten cs) mtch
192+ Clause c vs' <$> buildMatch (vs' ++ vs) (map flatten branches) match
184− where
193+ where
185− flatten ([], _) = noMatch "matchClause.flatten"
194+ flatten ([], _) = noMatch "matchClause.flatten"
186− flatten (p:ps, e) =
195+ flatten (A.A _ pattern : patterns, expr) =
187− case p of
196+ case pattern of
188− P.Data _ ps' -> (ps' ++ ps, e)
197+ P.Data _ argPatterns ->
198+ (argPatterns ++ patterns, expr)
199+
189− P.Literal _ -> (ps, e)
200+ P.Literal _ ->
201+ (patterns, expr)
202+
203+ _ ->
190− _ -> noMatch "matchClause.flatten"
204+ noMatch "matchClause.flatten"
191−
205+
192− getVars :: State Int [String]
206+ getVars :: State Int [String]
193− getVars =
207+ getVars =
194− case head cs of
208+ case head branches of
209+ (A.A _ (P.Data _ argPatterns) : _, _) ->
195− (P.Data _ ps : _, _) -> State.forM ps (const newVar)
210+ State.forM argPatterns (const newVar)
211+
196− (P.Literal _ : _, _) -> return []
212+ (A.A _ (P.Literal _) : _, _) ->
213+ return []
214+
215+ _ ->
197− _ -> noMatch "matchClause.getVars"
216+ noMatch "matchClause.getVars"
198−
217+
199−
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+
200−matchMix :: [String] -> [Case] -> Match -> State Int Match
251+matchMix :: [String] -> [Branch] -> Match -> State Int Match
201−matchMix vs cs def =
252+matchMix vs branches def =
202− State.foldM (flip $ match vs) def (reverse css)
253+ State.foldM (flip $ buildMatch vs) def (reverse branchGroups)
203 where
254 where
255+ branchGroups =
204− css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
256+ List.groupBy (\p1 p2 -> isCon p1 == isCon p2) branches
205
257
206
258
207noMatch :: String -> a
259noMatch :: String -> a
src/Generate/JavaScript.hs+81−56
@@ -9,12 +9,6 @@ import qualified Data.Set as Set
9import Language.ECMAScript3.PrettyPrint
9import Language.ECMAScript3.PrettyPrint
10import Language.ECMAScript3.Syntax
10import Language.ECMAScript3.Syntax
11
11
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
18import AST.Module
12import AST.Module
19import AST.Expression.General
13import AST.Expression.General
20import qualified AST.Expression.Canonical as Canonical
14import qualified AST.Expression.Canonical as Canonical
@@ -23,6 +17,13 @@ import AST.Literal
23import qualified AST.Module as Module
17import qualified AST.Module as Module
24import qualified AST.Pattern as P
18import qualified AST.Pattern as P
25import qualified AST.Variable as Var
19import 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
26
27
27
28
28internalImports :: Module.Name -> [VarDecl ()]
29internalImports :: Module.Name -> [VarDecl ()]
@@ -59,7 +60,7 @@ literal lit =
59
60
60
61
61expression :: Canonical.Expr -> State Int (Expression ())
62expression :: Canonical.Expr -> State Int (Expression ())
62−expression (A region expr) =
63+expression (A.A region expr) =
63 case expr of
64 case expr of
64 Var var ->
65 Var var ->
65 return $ Var.canonical var
66 return $ Var.canonical var
@@ -117,7 +118,7 @@ expression (A region expr) =
117 Binop op e1 e2 ->
118 Binop op e1 e2 ->
118 binop region op e1 e2
119 binop region op e1 e2
119
120
120− Lambda p e@(A ann _) ->
121+ Lambda pattern rawBody@(A.A ann _) ->
121 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
122 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
122 body' <- expression body
123 body' <- expression body
123 return $
124 return $
@@ -127,17 +128,20 @@ expression (A region expr) =
127 where
128 where
128 depattern (args, body) pattern =
129 depattern (args, body) pattern =
129 case pattern of
130 case pattern of
130− P.Var x ->
131+ A.A _ (P.Var x) ->
131 return (args ++ [ Var.varName x ], body)
132 return (args ++ [ Var.varName x ], body)
133+
132 _ ->
134 _ ->
133 do arg <- Case.newVar
135 do arg <- Case.newVar
136+ return
134− return ( args ++ [arg]
137+ ( args ++ [arg]
135− , A ann (Case (A ann (localVar arg)) [(pattern, body)])
138+ , A.A ann (Case (A.A ann (localVar arg)) [(pattern, body)])
136− )
139+ )
137
140
138− (patterns, innerBody) = collect [p] e
141+ (patterns, innerBody) =
142+ collect [pattern] rawBody
139
143
140− collect patterns lexpr@(A _ expr) =
144+ collect patterns lexpr@(A.A _ expr) =
141 case expr of
145 case expr of
142 Lambda p e -> collect (p:patterns) e
146 Lambda p e -> collect (p:patterns) e
143 _ -> (patterns, lexpr)
147 _ -> (patterns, lexpr)
@@ -155,7 +159,7 @@ expression (A region expr) =
155 (func, args) = getArgs e1 [e2]
159 (func, args) = getArgs e1 [e2]
156 getArgs func args =
160 getArgs func args =
157 case func of
161 case func of
158− (A _ (App f arg)) -> getArgs f (arg : args)
162+ (A.A _ (App f arg)) -> getArgs f (arg : args)
159 _ -> (func, args)
163 _ -> (func, args)
160
164
161 Let defs e ->
165 Let defs e ->
@@ -168,9 +172,9 @@ expression (A region expr) =
168 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
172 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
169 return $
173 return $
170 case last branches of
174 case last branches of
171− (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
175+ (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
172 safeIfs branches'
176 safeIfs branches'
173− (A _ (Literal (Boolean True)), _) ->
177+ (A.A _ (Literal (Boolean True)), _) ->
174 safeIfs branches'
178 safeIfs branches'
175 _ ->
179 _ ->
176 ifs branches' (throw "badIf" region)
180 ifs branches' (throw "badIf" region)
@@ -183,7 +187,7 @@ expression (A region expr) =
183 do (tempVar,initialMatch) <- Case.toMatch cases
187 do (tempVar,initialMatch) <- Case.toMatch cases
184 (revisedMatch, stmt) <-
188 (revisedMatch, stmt) <-
185 case e of
189 case e of
186− A _ (Var (Var.Canonical Var.Local x)) ->
190+ A.A _ (Var (Var.Canonical Var.Local x)) ->
187 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
191 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
188 _ ->
192 _ ->
189 do e' <- expression e
193 do e' <- expression e
@@ -221,9 +225,10 @@ expression (A region expr) =
221
225
222
226
223definition :: Canonical.Def -> State Int [Statement ()]
227definition :: Canonical.Def -> State Int [Statement ()]
224−definition (Canonical.Definition pattern expr@(A region _) _) =
228+definition (Canonical.Definition annPattern expr@(A.A region _) _) =
225 do expr' <- expression expr
229 do expr' <- expression expr
226 let assign x = varDecl x expr'
230 let assign x = varDecl x expr'
231+ let (A.A patternRegion pattern) = annPattern
227 case pattern of
232 case pattern of
228 P.Var x
233 P.Var x
229 | Help.isOp x ->
234 | Help.isOp x ->
@@ -243,9 +248,12 @@ definition (Canonical.Definition pattern expr@(A region _) _) =
243 vars = getVars patterns
248 vars = getVars patterns
244 getVars patterns =
249 getVars patterns =
245 case patterns of
250 case patterns of
251+ A.A _ (P.Var x) : rest ->
246− P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
252+ (Var.varName x :) `fmap` getVars rest
253+ [] ->
247− [] -> Just []
254+ Just []
255+ _ ->
248− _ -> Nothing
256+ Nothing
249
257
250 decl x n = varDecl x (obj ["$","_" ++ show n])
258 decl x n = varDecl x (obj ["$","_" ++ show n])
251 setup vars
259 setup vars
@@ -260,15 +268,16 @@ definition (Canonical.Definition pattern expr@(A region _) _) =
260 do defs' <- concat <$> mapM toDef vars
268 do defs' <- concat <$> mapM toDef vars
261 return (VarDeclStmt () [assign "_"] : defs')
269 return (VarDeclStmt () [assign "_"] : defs')
262 where
270 where
263− vars = P.boundVarList pattern
271+ vars = P.boundVarList annPattern
264− mkVar = A region . localVar
272+ mkVar = A.A region . localVar
265 toDef y =
273 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)
267 in
276 in
268− definition $ Canonical.Definition (P.Var y) expr Nothing
277+ definition (Canonical.Definition pat expr Nothing)
269
278
270
279
271−match :: Region -> Case.Match -> State Int [Statement ()]
280+match :: R.Region -> Case.Match -> State Int [Statement ()]
272match region mtch =
281match region mtch =
273 case mtch of
282 case mtch of
274 Case.Match name clauses mtch' ->
283 Case.Match name clauses mtch' ->
@@ -309,7 +318,7 @@ match region mtch =
309 _ -> dropEnd (acc ++ [m]) ms
318 _ -> dropEnd (acc ++ [m]) ms
310
319
311
320
312−clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
321+clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
313clause region variable (Case.Clause value vars mtch) =
322clause region variable (Case.Clause value vars mtch) =
314 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
323 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
315 where
324 where
@@ -329,7 +338,7 @@ clause region variable (Case.Clause value vars mtch) =
329
338
330
339
331flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
340flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
332−flattenLets defs lexpr@(A _ expr) =
341+flattenLets defs lexpr@(A.A _ expr) =
333 case expr of
342 case expr of
334 Let ds body -> flattenLets (defs ++ ds) body
343 Let ds body -> flattenLets (defs ++ ds) body
335 _ -> (defs, lexpr)
344 _ -> (defs, lexpr)
@@ -359,13 +368,17 @@ generate modul =
359 ]
368 ]
360
369
361 localVars :: [VarDecl ()]
370 localVars :: [VarDecl ()]
371+ localVars =
362− localVars = varDecl "_op" (ObjectLit () []) :
372+ varDecl "_op" (ObjectLit () [])
363− internalImports (Module.names modul) ++
373+ : internalImports (Module.names modul)
364− explicitImports
374+ ++ explicitImports
365 where
375 where
366 explicitImports :: [VarDecl ()]
376 explicitImports :: [VarDecl ()]
367 explicitImports =
377 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
369
382
370 jsImport :: Module.Name -> VarDecl ()
383 jsImport :: Module.Name -> VarDecl ()
371 jsImport name =
384 jsImport name =
@@ -373,29 +386,41 @@ generate modul =
373 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
386 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
374
387
375 body :: [Statement ()]
388 body :: [Statement ()]
389+ body =
376− body = concat $ evalState defs 0
390+ concat (evalState defs 0)
377 where
391 where
392+ defs =
378− defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
393+ Module.program (Module.body modul)
379−
394+ |> flattenLets []
395+ |> fst
396+ |> mapM definition
397+
380− setup namespace path = map create paths
398+ setup namespace path =
399+ map create paths
381 where
400 where
401+ create name =
382− create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
402+ assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
383− paths = drop 2 . init . List.inits $ namespace : path
403+ paths =
384−
404+ namespace : path
405+ |> List.inits
406+ |> init
407+ |> drop 2
408+
409+ jsExports =
385− jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
410+ assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
386− where
411+ where
387− exs = map entry $ "_op" : concatMap extract (exports modul)
412+ exs = map entry $ "_op" : concatMap extract (exports modul)
388− entry x = (prop x, ref x)
413+ entry x = (prop x, ref x)
389− extract value =
414+ extract value =
390− case value of
415+ case value of
391− Var.Alias _ -> []
416+ Var.Alias _ -> []
392
417
393− Var.Value x
418+ Var.Value x
394− | Help.isOp x -> []
419+ | Help.isOp x -> []
395− | otherwise -> [Var.varName x]
420+ | otherwise -> [Var.varName x]
396
421
397− Var.Union _ (Var.Listing ctors _) ->
422+ Var.Union _ (Var.Listing ctors _) ->
398− map Var.varName ctors
423+ map Var.varName ctors
399
424
400 assign path expr =
425 assign path expr =
401 case path of
426 case path of
@@ -406,7 +431,7 @@ generate modul =
406
431
407
432
408binop
433binop
409− :: Region
434+ :: R.Region
410 -> Var.Canonical
435 -> Var.Canonical
411 -> Canonical.Expr
436 -> Canonical.Expr
412 -> Canonical.Expr
437 -> Canonical.Expr
@@ -427,7 +452,7 @@ binop region func@(Var.Canonical home op) e1 e2 =
427 return $ foldr (<|) e2' es
452 return $ foldr (<|) e2' es
428
453
429 (Var.BuiltIn, "::") ->
454 (Var.BuiltIn, "::") ->
430− expression (A region (Data "::" [e1,e2]))
455+ expression (A.A region (Data "::" [e1,e2]))
431
456
432 (Var.Module ["Basics"], _) ->
457 (Var.Module ["Basics"], _) ->
433 do e1' <- expression e1
458 do e1' <- expression e1
@@ -447,13 +472,13 @@ binop region func@(Var.Canonical home op) e1 e2 =
447 where
472 where
448 collectRightAssoc es e =
473 collectRightAssoc es e =
449 case e of
474 case e of
450− A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
475+ A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
451 collectRightAssoc (es ++ [e1]) e2
476 collectRightAssoc (es ++ [e1]) e2
452 _ -> es ++ [e]
477 _ -> es ++ [e]
453
478
454 collectLeftAssoc es e =
479 collectLeftAssoc es e =
455 case e of
480 case e of
456− A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
481+ A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
457 collectLeftAssoc (e2 : es) e1
482 collectLeftAssoc (e2 : es) e1
458 _ -> e : es
483 _ -> e : es
459
484
src/Generate/JavaScript/Helpers.hs+4−4
@@ -1,9 +1,9 @@
1module Generate.JavaScript.Helpers where
1module Generate.JavaScript.Helpers where
2
2
3−import AST.Annotation (Region)
4−import qualified AST.PrettyPrint as PP
5import Language.ECMAScript3.Syntax
3import Language.ECMAScript3.Syntax
6
4
5+import qualified Reporting.Region as R
6+
7
7
8localRuntime :: String
8localRuntime :: String
9localRuntime =
9localRuntime =
@@ -59,11 +59,11 @@ localModuleName =
59 "$moduleName"
59 "$moduleName"
60
60
61
61
62−throw :: String -> Region -> Expression ()
62+throw :: String -> R.Region -> Expression ()
63throw kind region =
63throw kind region =
64 let args =
64 let args =
65 [ ref localModuleName
65 [ ref localModuleName
66− , string (PP.renderPretty region)
66+ , string (R.toString region)
67 ]
67 ]
68 in
68 in
69 obj ["_U",kind] `call` args
69 obj ["_U",kind] `call` args
src/Generate/JavaScript/Port.hs+34−34
@@ -3,15 +3,15 @@ module Generate.JavaScript.Port (inbound, outbound, task) where
3import qualified Data.List as List
3import qualified Data.List as List
4import Language.ECMAScript3.Syntax
4import Language.ECMAScript3.Syntax
5
5
6−import AST.PrettyPrint (pretty)
7−import AST.Type as T
6+import qualified AST.Type as T
8import qualified AST.Variable as Var
7import qualified AST.Variable as Var
9import Generate.JavaScript.Helpers
8import Generate.JavaScript.Helpers
9+import qualified Reporting.PrettyPrint as P
10
10
11
11
12-- TASK
12-- TASK
13
13
14−task :: String -> Expression () -> T.PortType var -> Expression ()
14+task :: String -> Expression () -> T.Port t -> Expression ()
15task name expr portType =
15task name expr portType =
16 case portType of
16 case portType of
17 T.Normal _ ->
17 T.Normal _ ->
@@ -90,42 +90,42 @@ check x jsType continue =
90
90
91-- INBOUND
91-- INBOUND
92
92
93−inbound :: String -> T.PortType Var.Canonical -> Expression ()
93+inbound :: String -> T.Port T.Canonical -> Expression ()
94inbound name portType =
94inbound name portType =
95 case portType of
95 case portType of
96 T.Normal tipe ->
96 T.Normal tipe ->
97 _Port "inbound" `call`
97 _Port "inbound" `call`
98 [ string name
98 [ string name
99− , string (show (pretty tipe))
99+ , string (show (P.pretty False tipe))
100 , toTypeFunction tipe
100 , toTypeFunction tipe
101 ]
101 ]
102
102
103 T.Signal _root arg ->
103 T.Signal _root arg ->
104 _Port "inboundSignal" `call`
104 _Port "inboundSignal" `call`
105 [ string name
105 [ string name
106− , string (show (pretty arg))
106+ , string (show (P.pretty False arg))
107 , toTypeFunction arg
107 , toTypeFunction arg
108 ]
108 ]
109
109
110
110
111−toTypeFunction :: CanonicalType -> Expression ()
111+toTypeFunction :: T.Canonical -> Expression ()
112toTypeFunction tipe =
112toTypeFunction tipe =
113 ["v"] ==> toType tipe (ref "v")
113 ["v"] ==> toType tipe (ref "v")
114
114
115
115
116−toType :: CanonicalType -> Expression () -> Expression ()
116+toType :: T.Canonical -> Expression () -> Expression ()
117toType tipe x =
117toType tipe x =
118 case tipe of
118 case tipe of
119− Lambda _ _ ->
119+ T.Lambda _ _ ->
120 error "functions should not be allowed through input ports"
120 error "functions should not be allowed through input ports"
121
121
122− Var _ ->
122+ T.Var _ ->
123 error "type variables should not be allowed through input ports"
123 error "type variables should not be allowed through input ports"
124
124
125− Aliased _ args t ->
125+ T.Aliased _ args t ->
126− toType (dealias args t) x
126+ toType (T.dealias args t) x
127
127
128− Type (Var.Canonical Var.BuiltIn name)
128+ T.Type (Var.Canonical Var.BuiltIn name)
129 | name == "Int" -> from JSNumber
129 | name == "Int" -> from JSNumber
130 | name == "Float" -> from JSNumber
130 | name == "Float" -> from JSNumber
131 | name == "Bool" -> from JSBoolean
131 | name == "Bool" -> from JSBoolean
@@ -133,7 +133,7 @@ toType tipe x =
133 where
133 where
134 from checks = check x checks x
134 from checks = check x checks x
135
135
136− Type name
136+ T.Type name
137 | Var.isJson name ->
137 | Var.isJson name ->
138 x
138 x
139
139
@@ -143,9 +143,9 @@ toType tipe x =
143 | otherwise ->
143 | otherwise ->
144 error "bad type got to foreign input conversion"
144 error "bad type got to foreign input conversion"
145
145
146− App f args ->
146+ T.App f args ->
147 case f : args of
147 case f : args of
148− Type name : [t]
148+ T.Type name : [t]
149 | Var.isMaybe name ->
149 | Var.isMaybe name ->
150 CondExpr ()
150 CondExpr ()
151 (equal x (NullLit ()))
151 (equal x (NullLit ()))
@@ -160,16 +160,16 @@ toType tipe x =
160 where
160 where
161 array = DotRef () x (var "map") <| toTypeFunction t
161 array = DotRef () x (var "map") <| toTypeFunction t
162
162
163− Type name : ts
163+ T.Type name : ts
164 | Var.isTuple name ->
164 | Var.isTuple name ->
165 toTuple ts x
165 toTuple ts x
166
166
167 _ -> error "bad ADT got to foreign input conversion"
167 _ -> error "bad ADT got to foreign input conversion"
168
168
169− Record _ (Just _) ->
169+ T.Record _ (Just _) ->
170 error "bad record got to foreign input conversion"
170 error "bad record got to foreign input conversion"
171
171
172− Record fields Nothing ->
172+ T.Record fields Nothing ->
173 check x (JSObject (map fst fields)) object
173 check x (JSObject (map fst fields)) object
174 where
174 where
175 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
175 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
@@ -177,7 +177,7 @@ toType tipe x =
177 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
177 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
178
178
179
179
180−toTuple :: [CanonicalType] -> Expression () -> Expression ()
180+toTuple :: [T.Canonical] -> Expression () -> Expression ()
181toTuple types x =
181toTuple types x =
182 check x JSArray (ObjectLit () fields)
182 check x JSArray (ObjectLit () fields)
183 where
183 where
@@ -195,7 +195,7 @@ toTuple types x =
195
195
196-- OUTBOUND
196-- OUTBOUND
197
197
198−outbound :: String -> Expression () -> T.PortType Var.Canonical -> Expression ()
198+outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()
199outbound name expr portType =
199outbound name expr portType =
200 case portType of
200 case portType of
201 T.Normal tipe ->
201 T.Normal tipe ->
@@ -205,18 +205,18 @@ outbound name expr portType =
205 _Port "outboundSignal" `call` [ string name, fromTypeFunction arg, expr ]
205 _Port "outboundSignal" `call` [ string name, fromTypeFunction arg, expr ]
206
206
207
207
208−fromTypeFunction :: CanonicalType -> Expression ()
208+fromTypeFunction :: T.Canonical -> Expression ()
209fromTypeFunction tipe =
209fromTypeFunction tipe =
210 ["v"] ==> fromType tipe (ref "v")
210 ["v"] ==> fromType tipe (ref "v")
211
211
212
212
213−fromType :: CanonicalType -> Expression () -> Expression ()
213+fromType :: T.Canonical -> Expression () -> Expression ()
214fromType tipe x =
214fromType tipe x =
215 case tipe of
215 case tipe of
216− Aliased _ args t ->
216+ T.Aliased _ args t ->
217− fromType (dealias args t) x
217+ fromType (T.dealias args t) x
218
218
219− Lambda _ _
219+ T.Lambda _ _
220 | numArgs > 1 && numArgs < 10 ->
220 | numArgs > 1 && numArgs < 10 ->
221 func (ref ('A':show numArgs) `call` (x:values))
221 func (ref ('A':show numArgs) `call` (x:values))
222 | otherwise ->
222 | otherwise ->
@@ -232,21 +232,21 @@ fromType tipe x =
232 , ret (fromType (last ts) (ref "_r"))
232 , ret (fromType (last ts) (ref "_r"))
233 ]
233 ]
234
234
235− Var _ ->
235+ T.Var _ ->
236 error "type variables should not be allowed through outputs"
236 error "type variables should not be allowed through outputs"
237
237
238− Type (Var.Canonical Var.BuiltIn name)
238+ T.Type (Var.Canonical Var.BuiltIn name)
239 | name `elem` ["Int","Float","Bool","String"] ->
239 | name `elem` ["Int","Float","Bool","String"] ->
240 x
240 x
241
241
242− Type name
242+ T.Type name
243 | Var.isJson name -> x
243 | Var.isJson name -> x
244 | Var.isTuple name -> ArrayLit () []
244 | Var.isTuple name -> ArrayLit () []
245 | otherwise -> error "bad type got to an output"
245 | otherwise -> error "bad type got to an output"
246
246
247− App f args ->
247+ T.App f args ->
248 case f : args of
248 case f : args of
249− Type name : [t]
249+ T.Type name : [t]
250 | Var.isMaybe name ->
250 | Var.isMaybe name ->
251 CondExpr ()
251 CondExpr ()
252 (equal (DotRef () x (var "ctor")) (string "Nothing"))
252 (equal (DotRef () x (var "ctor")) (string "Nothing"))
@@ -259,17 +259,17 @@ fromType tipe x =
259 | Var.isList name ->
259 | Var.isList name ->
260 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
260 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
261
261
262− Type name : ts
262+ T.Type name : ts
263 | Var.isTuple name ->
263 | Var.isTuple name ->
264 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
264 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
265 in ArrayLit () $ zipWith convert [0..] ts
265 in ArrayLit () $ zipWith convert [0..] ts
266
266
267 _ -> error "bad ADT got to an output"
267 _ -> error "bad ADT got to an output"
268
268
269− Record _ (Just _) ->
269+ T.Record _ (Just _) ->
270 error "bad record got to an output"
270 error "bad record got to an output"
271
271
272− Record fields Nothing ->
272+ T.Record fields Nothing ->
273 ObjectLit () keys
273 ObjectLit () keys
274 where
274 where
275 keys = map convert fields
275 keys = map convert fields
src/Transform/Substitute.hs → src/Generate/Substitute.hsrenamed+23−16
@@ -1,19 +1,19 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Transform.Substitute (subst) where
2+module Generate.Substitute (subst) where
3
3
4import Control.Arrow (second, (***))
4import Control.Arrow (second, (***))
5−import qualified Data.Set as Set
6
5
7−import AST.Annotation
8import AST.Expression.General (Expr'(..), PortImpl(..))
6import AST.Expression.General (Expr'(..), PortImpl(..))
9import qualified AST.Expression.Canonical as Canonical
7import qualified AST.Expression.Canonical as Canonical
10import qualified AST.Pattern as Pattern
8import qualified AST.Pattern as Pattern
11import qualified AST.Variable as V
9import qualified AST.Variable as V
10+import Elm.Utils ((|>))
11+import qualified Reporting.Annotation as A
12
12
13
13
14subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'
14subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'
15subst old new expression =
15subst 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
17 case expression of
17 case expression of
18 Range e1 e2 ->
18 Range e1 e2 ->
19 Range (f e1) (f e2)
19 Range (f e1) (f e2)
@@ -24,9 +24,10 @@ subst old new expression =
24 Binop op e1 e2 ->
24 Binop op e1 e2 ->
25 Binop op (f e1) (f e2)
25 Binop op (f e1) (f e2)
26
26
27− Lambda pattern body
27+ Lambda pattern body ->
28− | Set.member old (Pattern.boundVars pattern) -> expression
28+ if Pattern.member old pattern
29+ then expression
29− | otherwise -> Lambda pattern (f body)
30+ else Lambda pattern (f body)
30
31
31 App e1 e2 ->
32 App e1 e2 ->
32 App (f e1) (f e2)
33 App (f e1) (f e2)
@@ -34,28 +35,34 @@ subst old new expression =
34 MultiIf branches ->
35 MultiIf branches ->
35 MultiIf (map (f *** f) branches)
36 MultiIf (map (f *** f) branches)
36
37
37− Let defs body
38+ Let defs body ->
38− | anyShadow -> expression
39+ if anyShadow
40+ then expression
39− | otherwise -> Let (map substDef defs) (f body)
41+ else Let (map substDef defs) (f body)
40 where
42 where
41 substDef (Canonical.Definition p e t) =
43 substDef (Canonical.Definition p e t) =
42 Canonical.Definition p (f e) t
44 Canonical.Definition p (f e) t
43
45
44 anyShadow =
46 anyShadow =
47+ map (\(Canonical.Definition p _ _) -> p) defs
45− any (Set.member old . Pattern.boundVars)
48+ |> any (Pattern.member old)
46− [ pattern | Canonical.Definition pattern _ _ <- defs ]
47
49
48 Var (V.Canonical home x) ->
50 Var (V.Canonical home x) ->
49 case home of
51 case home of
52+ V.Module _ ->
50− V.Module _ -> expression
53+ expression
54+
55+ V.BuiltIn ->
51− V.BuiltIn -> expression
56+ expression
57+
58+ V.Local ->
52− V.Local -> if x == old then new else expression
59+ if x == old then new else expression
53
60
54 Case e cases ->
61 Case e cases ->
55 Case (f e) (map substCase cases)
62 Case (f e) (map substCase cases)
56 where
63 where
57 substCase (pattern, expr) =
64 substCase (pattern, expr) =
58− if Set.member old (Pattern.boundVars pattern)
65+ if Pattern.member old pattern
59 then (pattern, expr)
66 then (pattern, expr)
60 else (pattern, f expr)
67 else (pattern, f expr)
61
68
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
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6import Text.Parsec ((<|>), choice, getState, try)
6import Text.Parsec ((<|>), choice, getState, try)
7
7
8−import AST.Annotation (merge)
9import AST.Declaration (Assoc(L, N, R))
8import AST.Declaration (Assoc(L, N, R))
10import AST.Expression.General (Expr'(Binop))
9import AST.Expression.General (Expr'(Binop))
11import qualified AST.Expression.Source as Source
10import qualified AST.Expression.Source as Source
12import qualified AST.Variable as Var
11import qualified AST.Variable as Var
13import Parse.Helpers (IParser, OpTable, commitIf, failure, whitespace)
12import Parse.Helpers (IParser, OpTable, commitIf, failure, whitespace)
13+import qualified Reporting.Annotation as A
14+
14
15
15opLevel :: OpTable -> String -> Int
16opLevel :: OpTable -> String -> Int
17+opLevel table op =
16−opLevel table op = fst $ Map.findWithDefault (9,L) op table
18+ fst $ Map.findWithDefault (9,L) op table
19+
17
20
18opAssoc :: OpTable -> String -> Assoc
21opAssoc :: OpTable -> String -> Assoc
22+opAssoc table op =
19−opAssoc table op = snd $ Map.findWithDefault (9,L) op table
23+ snd $ Map.findWithDefault (9,L) op table
24+
20
25
21hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool
26hasLevel :: 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+
23
30
31+binops
24−binops :: IParser Source.Expr
32+ :: IParser Source.Expr
25− -> IParser Source.Expr
33+ -> IParser Source.Expr
26− -> IParser String
34+ -> IParser String
27− -> IParser Source.Expr
35+ -> IParser Source.Expr
28binops term last anyOp =
36binops term last anyOp =
29− do e <- term
37+ do e <- term
30− table <- getState
38+ table <- getState
31− split table 0 e =<< nextOps
39+ split table 0 e =<< nextOps
32− where
40+ where
41+ nextOps =
42+ choice
33− nextOps = choice [ commitIf (whitespace >> anyOp) $ do
43+ [ commitIf (whitespace >> anyOp) $
44+ do whitespace
45+ op <- anyOp
34− whitespace ; op <- anyOp ; whitespace
46+ whitespace
35− expr <- Left <$> try term <|> Right <$> last
47+ expr <- Left <$> try term <|> Right <$> last
36− case expr of
48+ case expr of
37− Left t -> (:) (op,t) <$> nextOps
49+ Left t -> (:) (op,t) <$> nextOps
38− Right e -> return [(op,e)]
50+ Right e -> return [(op,e)]
39− , return [] ]
51+ , return []
40−
52+ ]
53+
54+
55+split
41−split :: OpTable
56+ :: OpTable
42− -> Int
57+ -> Int
43− -> Source.Expr
58+ -> Source.Expr
44− -> [(String, Source.Expr)]
59+ -> [(String, Source.Expr)]
45− -> IParser Source.Expr
60+ -> IParser Source.Expr
46−split _ _ e [] = return e
61+split _ _ e [] = return e
47−split table n e eops = do
62+split table n e eops =
48− assoc <- getAssoc table n eops
63+ do assoc <- getAssoc table n eops
49− es <- sequence (splitLevel table n e eops)
64+ es <- sequence (splitLevel table n e eops)
50− let ops = map fst (filter (hasLevel table n) eops)
65+ let ops = map fst (filter (hasLevel table n) eops)
51− case assoc of R -> joinR es ops
66+ case assoc of
67+ R -> joinR es ops
52− _ -> joinL es ops
68+ _ -> joinL es ops
53−
69+
70+
71+splitLevel
72+ :: OpTable
73+ -> Int
74+ -> Source.Expr
54−splitLevel :: OpTable -> Int -> Source.Expr -> [(String, Source.Expr)]
75+ -> [(String, Source.Expr)]
55− -> [IParser Source.Expr]
76+ -> [IParser Source.Expr]
56splitLevel table n e eops =
77splitLevel table n e eops =
57− case break (hasLevel table n) eops of
78+ case break (hasLevel table n) eops of
58− (lops, (_op,e'):rops) ->
79+ (lops, (_op,e'):rops) ->
59− split table (n+1) e lops : splitLevel table n e' rops
80+ split table (n+1) e lops : splitLevel table n e' rops
81+
82+ (lops, []) ->
60− (lops, []) -> [ split table (n+1) e lops ]
83+ [ split table (n+1) e lops ]
84+
61
85
62joinL :: [Source.Expr] -> [String] -> IParser Source.Expr
86joinL :: [Source.Expr] -> [String] -> IParser Source.Expr
87+joinL exprs ops =
88+ case (exprs, ops) of
89+ ([expr], []) ->
63−joinL [e] [] = return e
90+ return expr
91+
92+ (a:b:remainingExprs, op:remainingOps) ->
64−joinL (a:b:es) (op:ops) = joinL (merge a b (Binop (Var.Raw op) a b) : es) ops
93+ let binop = A.merge a b (Binop (Var.Raw op) a b)
94+ in
95+ joinL (binop : remainingExprs) remainingOps
96+
97+ (_, _) ->
65−joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
98+ failure "Ill-formed binary expression. Report a compiler bug."
99+
66
100
67joinR :: [Source.Expr] -> [String] -> IParser Source.Expr
101joinR :: [Source.Expr] -> [String] -> IParser Source.Expr
102+joinR exprs ops =
103+ case (exprs, ops) of
104+ ([expr], []) ->
68−joinR [e] [] = return e
105+ return expr
69−joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
106+
107+ (a:b:remainingExprs, op:remainingOps) ->
108+ do e <- joinR (b:remainingExprs) remainingOps
70− return (merge a e (Binop (Var.Raw op) a e))
109+ return (A.merge a e (Binop (Var.Raw op) a e))
110+
111+ (_, _) ->
71−joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
112+ failure "Ill-formed binary expression. Report a compiler bug."
113+
72
114
73getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc
115getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc
74getAssoc table n eops
116getAssoc table n eops
75 | all (==L) assocs = return L
117 | all (==L) assocs = return L
76− | all (==R) assocs = return R
118+ | all (==R) assocs = return R
119+ | all (==N) assocs =
77− | all (==N) assocs = case assocs of [_] -> return N
120+ case assocs of
121+ [_] -> return N
78− _ -> failure (msg "precedence")
122+ _ -> failure (msg "precedence")
79 | otherwise = failure (msg "associativity")
123 | otherwise = failure (msg "associativity")
124+ where
80− where levelOps = filter (hasLevel table n) eops
125+ levelOps = filter (hasLevel table n) eops
81− assocs = map (opAssoc table . fst) levelOps
126+ assocs = map (opAssoc table . fst) levelOps
82− msg problem =
127+ msg problem =
128+ concat
83− concat [ "Conflicting " ++ problem ++ " for binary operators ("
129+ [ "Conflicting " ++ problem ++ " for binary operators ("
84− , List.intercalate ", " (map fst eops), "). "
130+ , List.intercalate ", " (map fst eops), "). "
85− , "Consider adding parentheses to disambiguate." ]
131+ , "Consider adding parentheses to disambiguate."
132+ ]
src/Parse/Declaration.hs+11−7
@@ -12,21 +12,23 @@ import qualified Parse.Type as Type
12
12
13declaration :: IParser D.SourceDecl
13declaration :: IParser D.SourceDecl
14declaration =
14declaration =
15− typeDecl <|> infixDecl <|> port <|> definition
15+ addLocation (typeDecl <|> infixDecl <|> port <|> definition)
16
16
17
17
18-- TYPE ANNOTATIONS and DEFINITIONS
18-- TYPE ANNOTATIONS and DEFINITIONS
19
19
20−definition :: IParser D.SourceDecl
20+definition :: IParser D.SourceDecl'
21definition =
21definition =
22+ D.Definition
22− D.Definition <$> (Expr.typeAnnotation <|> Expr.definition)
23+ <$> (Expr.typeAnnotation <|> Expr.definition)
24+ <?> "a value definition"
23
25
24
26
25-- TYPE ALIAS and UNION TYPES
27-- TYPE ALIAS and UNION TYPES
26
28
27−typeDecl :: IParser D.SourceDecl
29+typeDecl :: IParser D.SourceDecl'
28typeDecl =
30typeDecl =
29− do try (reserved "type") <?> "type declaration"
31+ do try (reserved "type") <?> "a type declaration"
30 forcedWS
32 forcedWS
31 isAlias <- optionMaybe (string "alias" >> forcedWS)
33 isAlias <- optionMaybe (string "alias" >> forcedWS)
32
34
@@ -46,8 +48,9 @@ typeDecl =
46
48
47-- INFIX
49-- INFIX
48
50
49−infixDecl :: IParser D.SourceDecl
51+infixDecl :: IParser D.SourceDecl'
50infixDecl =
52infixDecl =
53+ expecting "an infix declaration" $
51 do assoc <-
54 do assoc <-
52 choice
55 choice
53 [ try (reserved "infixl") >> return D.L
56 [ try (reserved "infixl") >> return D.L
@@ -62,8 +65,9 @@ infixDecl =
62
65
63-- PORT
66-- PORT
64
67
65−port :: IParser D.SourceDecl
68+port :: IParser D.SourceDecl'
66port =
69port =
70+ expecting "a port declaration" $
67 do try (reserved "port")
71 do try (reserved "port")
68 whitespace
72 whitespace
69 name <- lowVar
73 name <- lowVar
src/Parse/Expression.hs+165−93
@@ -12,42 +12,63 @@ import qualified Parse.Literal as Literal
12import qualified Parse.Pattern as Pattern
12import qualified Parse.Pattern as Pattern
13import qualified Parse.Type as Type
13import qualified Parse.Type as Type
14
14
15−import qualified AST.Annotation as Annotation
16import qualified AST.Expression.General as E
15import qualified AST.Expression.General as E
17import qualified AST.Expression.Source as Source
16import qualified AST.Expression.Source as Source
18import qualified AST.Literal as L
17import qualified AST.Literal as L
19import qualified AST.Pattern as P
18import qualified AST.Pattern as P
20import qualified AST.Variable as Var
19import qualified AST.Variable as Var
20+import qualified Reporting.Annotation as A
21
21
22
22
23-------- Basic Terms --------
23-------- Basic Terms --------
24
24
25varTerm :: IParser Source.Expr'
25varTerm :: IParser Source.Expr'
26varTerm =
26varTerm =
27− toVar <$> var <?> "variable"
27+ toVar <$> var
28
28
29
29
30toVar :: String -> Source.Expr'
30toVar :: String -> Source.Expr'
31toVar v =
31toVar v =
32 case v of
32 case v of
33+ "True" ->
33− "True" -> E.Literal (L.Boolean True)
34+ E.Literal (L.Boolean True)
35+
36+ "False" ->
34− "False" -> E.Literal (L.Boolean False)
37+ E.Literal (L.Boolean False)
38+
39+ _ ->
35− _ -> E.rawVar v
40+ E.rawVar v
36
41
37
42
38accessor :: IParser Source.Expr'
43accessor :: IParser Source.Expr'
39accessor =
44accessor =
40 do (start, lbl, end) <- located (try (string "." >> rLabel))
45 do (start, lbl, end) <- located (try (string "." >> rLabel))
46+
47+ let ann value =
41− let loc e = Annotation.at start end e
48+ A.at start end value
49+
50+ return $
51+ E.Lambda
52+ (ann (P.Var "_"))
42− return (E.Lambda (P.Var "_") (loc $ E.Access (loc $ E.rawVar "_") lbl))
53+ (ann (E.Access (ann (E.rawVar "_")) lbl))
43
54
44
55
45negative :: IParser Source.Expr'
56negative :: IParser Source.Expr'
46negative =
57negative =
47 do (start, nTerm, end) <-
58 do (start, nTerm, end) <-
59+ located $ try $
60+ do char '-'
48− located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
61+ notFollowedBy (char '.' <|> char '-')
62+ term
63+
64+ let ann e =
49− let loc e = Annotation.at start end e
65+ A.at start end e
66+
67+ return $
68+ E.Binop
69+ (Var.Raw "-")
50− return (E.Binop (Var.Raw "-") (loc $ E.Literal (L.IntNum 0)) nTerm)
70+ (ann (E.Literal (L.IntNum 0)))
71+ nTerm
51
72
52
73
53-------- Complex Terms --------
74-------- Complex Terms --------
@@ -56,46 +77,69 @@ listTerm :: IParser Source.Expr'
56listTerm =
77listTerm =
57 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
78 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
58 where
79 where
59− range = do
80+ range =
60− lo <- expr
81+ do lo <- expr
61− padded (string "..")
82+ padded (string "..")
62− E.Range lo <$> expr
83+ E.Range lo <$> expr
63
84
64− shader' = do
85+ shader' =
65− pos <- getPosition
86+ do pos <- getPosition
66− let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
87+ let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
67− (rawSrc, tipe) <- Help.shader
88+ (rawSrc, tipe) <- Help.shader
68− return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
89+ return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
69
90
70
91
71parensTerm :: IParser Source.Expr
92parensTerm :: IParser Source.Expr
72parensTerm =
93parensTerm =
94+ choice
95+ [ try (parens opFn)
73− try (parens opFn) <|> parens (tupleFn <|> parened)
96+ , parens (tupleFn <|> parened)
97+ ]
74 where
98 where
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+
75− opFn = do
105+ opFn =
76− (start, op, end) <- located anyOp
106+ do (start, op, end) <- located anyOp
77− let loc = Annotation.at start end
107+ return $
78− return . loc . E.Lambda (P.Var "x") . loc . E.Lambda (P.Var "y") . loc $
108+ lambda start end "x" $
109+ lambda start end "y" $
110+ A.at start end $
79− E.Binop (Var.Raw op) (loc (E.rawVar "x")) (loc (E.rawVar "y"))
111+ E.Binop (Var.Raw op) (var start end "x") (var start end "y")
80−
112+
81− tupleFn = do
113+ tupleFn =
82− let comma = char ',' <?> "comma ','"
114+ do (start, commas, end) <-
83− (start, commas, end) <- located (comma >> many (whitespace >> comma))
115+ located (comma >> many (whitespace >> comma))
116+
84− let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
117+ let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
85− loc = Annotation.at start end
118+
86− return $ foldr (\x e -> loc $ E.Lambda x e)
119+ return $
87− (loc . E.tuple $ map (loc . E.rawVar) vars) (map P.Var vars)
120+ foldr
88−
121+ (lambda start end)
122+ (A.at start end (E.tuple (map (var start end) vars)))
123+ vars
124+
89− parened = do
125+ parened =
90− (start, es, end) <- located (commaSep expr)
126+ do (start, expressions, end) <- located (commaSep expr)
91− return $ case es of
127+ return $
92− [e] -> e
128+ case expressions of
129+ [expression] ->
130+ expression
131+ _ ->
93− _ -> Annotation.at start end (E.tuple es)
132+ A.at start end (E.tuple expressions)
133+
94
134
95recordTerm :: IParser Source.Expr
135recordTerm :: IParser Source.Expr
96recordTerm =
136recordTerm =
137+ addLocation $
97− brackets $ choice [ misc, addLocation record ]
138+ brackets (choice [ misc, record ])
98 where
139 where
140+ record =
141+ E.Record <$> commaSep field
142+
99 field =
143 field =
100 do label <- rLabel
144 do label <- rLabel
101 patterns <- spacePrefix Pattern.term
145 patterns <- spacePrefix Pattern.term
@@ -103,52 +147,73 @@ recordTerm =
103 body <- expr
147 body <- expr
104 return (label, makeFunction patterns body)
148 return (label, makeFunction patterns body)
105
149
106− record =
150+ misc =
107− E.Record <$> commaSep field
151+ do nextParser <- try miscStarter
108−
152+ whitespace
109− change =
153+ nextParser
110− do lbl <- rLabel
111− padded (string "<-")
112− (,) lbl <$> expr
113−
114− remove r =
115− addLocation (string "-" >> whitespace >> E.Remove r <$> rLabel)
116
154
117− insert r =
155+ miscStarter =
118− addLocation $
156+ do start <- getMyPosition
119− do string "|" >> whitespace
157+ record <- addLocation (E.rawVar <$> rLabel)
120− E.Insert r <$> rLabel <*> (padded equals >> expr)
158+ whitespace
159+ choice
160+ [ string "-" >> return (afterMinus start record)
161+ , string "|" >> return (afterBar record)
162+ ]
121
163
122− modify r =
164+ afterMinus start record =
123− addLocation (string "|" >> whitespace >> E.Modify r <$> commaSep1 change)
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+ ]
124
191
125− misc =
192+ update =
126− try $ do
193+ do lbl <- rLabel
127− record <- addLocation (E.rawVar <$> rLabel)
194+ padded leftArrow
128− opt <- padded (optionMaybe (remove record))
195+ (,) lbl <$> expr
129− case opt of
130− Just e -> try (insert e) <|> return e
131− Nothing -> try (insert record) <|> try (modify record)
132
196
133
197
134term :: IParser Source.Expr
198term :: IParser Source.Expr
135term =
199term =
136 addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])
200 addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])
137 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
201 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
138− <?> "basic term (4, x, 'c', etc.)"
202+ <?> "an expression"
139
203
140
204
141-------- Applications --------
205-------- Applications --------
142
206
143appExpr :: IParser Source.Expr
207appExpr :: IParser Source.Expr
144appExpr =
208appExpr =
209+ expecting "an expression" $
145 do t <- term
210 do t <- term
146 ts <- constrainedSpacePrefix term $ \str ->
211 ts <- constrainedSpacePrefix term $ \str ->
147 if null str then notFollowedBy (char '-') else return ()
212 if null str then notFollowedBy (char '-') else return ()
148 return $
213 return $
149 case ts of
214 case ts of
150 [] -> t
215 [] -> 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
152
217
153
218
154-------- Normal Expressions --------
219-------- Normal Expressions --------
@@ -165,8 +230,10 @@ binaryExpr :: IParser Source.Expr
165binaryExpr =
230binaryExpr =
166 Binop.binops appExpr lastExpr anyOp
231 Binop.binops appExpr lastExpr anyOp
167 where
232 where
233+ lastExpr =
168− lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
234+ addLocation (choice [ ifExpr, letExpr, caseExpr ])
169− <|> lambdaExpr
235+ <|> lambdaExpr
236+ <?> "an expression"
170
237
171
238
172ifExpr :: IParser Source.Expr'
239ifExpr :: IParser Source.Expr'
@@ -185,24 +252,26 @@ ifExpr =
185 elseBranch <- expr
252 elseBranch <- expr
186 return $ E.MultiIf
253 return $ E.MultiIf
187 [ (bool, thenBranch)
254 [ (bool, thenBranch)
188− , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
255+ , (A.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
189 ]
256 ]
190
257
191 multiIf =
258 multiIf =
192 E.MultiIf <$> spaceSep1 iff
259 E.MultiIf <$> spaceSep1 iff
193 where
260 where
194 iff =
261 iff =
262+ do string "|"
195− do string "|" ; whitespace
263+ whitespace
196− b <- expr ; padded arrow
264+ b <- expr
265+ padded rightArrow
197 (,) b <$> expr
266 (,) b <$> expr
198
267
199
268
200lambdaExpr :: IParser Source.Expr
269lambdaExpr :: IParser Source.Expr
201lambdaExpr =
270lambdaExpr =
202− do char '\\' <|> char '\x03BB' <?> "anonymous function"
271+ do char '\\' <|> char '\x03BB' <?> "an anonymous function"
203 whitespace
272 whitespace
204 args <- spaceSep1 Pattern.term
273 args <- spaceSep1 Pattern.term
205− padded arrow
274+ padded rightArrow
206 body <- expr
275 body <- expr
207 return (makeFunction args body)
276 return (makeFunction args body)
208
277
@@ -217,7 +286,7 @@ caseExpr =
217 where
286 where
218 case_ =
287 case_ =
219 do p <- Pattern.expr
288 do p <- Pattern.expr
220− padded arrow
289+ padded rightArrow
221 (,) p <$> expr
290 (,) p <$> expr
222
291
223 with =
292 with =
@@ -246,7 +315,7 @@ letExpr =
246
315
247typeAnnotation :: IParser Source.Def
316typeAnnotation :: IParser Source.Def
248typeAnnotation =
317typeAnnotation =
249− Source.TypeAnnotation <$> try start <*> Type.expr
318+ addLocation (Source.TypeAnnotation <$> try start <*> Type.expr)
250 where
319 where
251 start =
320 start =
252 do v <- lowVar <|> parens symOp
321 do v <- lowVar <|> parens symOp
@@ -258,6 +327,7 @@ typeAnnotation =
258
327
259definition :: IParser Source.Def
328definition :: IParser Source.Def
260definition =
329definition =
330+ addLocation $
261 withPos $
331 withPos $
262 do (name:args) <- defStart
332 do (name:args) <- defStart
263 padded equals
333 padded equals
@@ -266,29 +336,31 @@ definition =
266
336
267
337
268makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
338makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
269−makeFunction args body@(Annotation.A ann _) =
339+makeFunction args body@(A.A ann _) =
270− foldr (\arg body' -> Annotation.A ann $ E.Lambda arg body') body args
340+ foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args
271
341
272
342
273defStart :: IParser [P.RawPattern]
343defStart :: IParser [P.RawPattern]
274defStart =
344defStart =
275 choice
345 choice
276− [ do p1 <- try Pattern.term
346+ [ do pattern <- try Pattern.term
277− infics p1 <|> func p1
347+ infics pattern <|> func pattern
278− , func =<< (P.Var <$> parens symOp)
348+ , do opPattern <- addLocation (P.Var <$> parens symOp)
349+ func opPattern
279 ]
350 ]
280 <?> "the definition of a variable (x = ...)"
351 <?> "the definition of a variable (x = ...)"
281− where
352+ where
282− func pattern =
353+ func pattern =
283− case pattern of
354+ case pattern of
355+ A.A _ (P.Var _) ->
284− P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
356+ (pattern:) <$> spacePrefix Pattern.term
285− _ -> do try (lookAhead (whitespace >> string "="))
357+
358+ _ ->
286− return [pattern]
359+ return [pattern]
287−
360+
288− infics p1 =
361+ infics p1 =
289− do o:p <- try (whitespace >> anyOp)
362+ do (start, o:p, end) <- try (whitespace >> located anyOp)
290− p2 <- (whitespace >> Pattern.term)
363+ p2 <- (whitespace >> Pattern.term)
291− return $
364+ let opName =
292− if o == '`'
293− then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
365+ if o == '`' then takeWhile (/='`') p else o:p
294− else [ P.Var (o:p), p1, p2 ]
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)
8import qualified Data.Map as Map
8import qualified Data.Map as Map
9import qualified Language.GLSL.Parser as GLP
9import qualified Language.GLSL.Parser as GLP
10import qualified Language.GLSL.Syntax as GLS
10import qualified Language.GLSL.Syntax as GLS
11−import Text.Parsec hiding (newline,spaces,State)
11+import Text.Parsec hiding (newline, spaces, State)
12import Text.Parsec.Indent (indented, runIndent)
12import Text.Parsec.Indent (indented, runIndent)
13import qualified Text.Parsec.Token as T
13import qualified Text.Parsec.Token as T
14
14
15−import qualified AST.Annotation as Annotation
16import qualified AST.Declaration as Decl
15import qualified AST.Declaration as Decl
17import qualified AST.Expression.General as E
16import qualified AST.Expression.General as E
18import qualified AST.Expression.Source as Source
17import qualified AST.Expression.Source as Source
19import qualified AST.Helpers as Help
18import qualified AST.Helpers as Help
20import qualified AST.Literal as L
19import qualified AST.Literal as L
21−import qualified AST.PrettyPrint as P
22import qualified AST.Variable as Variable
20import qualified AST.Variable as Variable
23import Elm.Utils ((|>))
21import Elm.Utils ((|>))
22+import qualified Reporting.Annotation as A
23+import qualified Reporting.Error.Syntax as Syntax
24+import qualified Reporting.Region as R
24
25
25
26
26reserveds :: [String]
27reserveds :: [String]
@@ -37,9 +38,13 @@ reserveds =
37 ]
38 ]
38
39
39
40
41+-- ERROR HELP
42+
40expecting = flip (<?>)
43expecting = flip (<?>)
41
44
42
45
46+-- SETUP
47+
43type OpTable = Map.Map String (Int, Decl.Assoc)
48type OpTable = Map.Map String (Int, Decl.Assoc)
44type SourceM = State SourcePos
49type SourceM = State SourcePos
45type IParser a = ParsecT String OpTable SourceM a
50type IParser a = ParsecT String OpTable SourceM a
@@ -59,17 +64,17 @@ iParseWithTable sourceName table aParser input =
59
64
60var :: IParser String
65var :: IParser String
61var =
66var =
62− makeVar (letter <|> char '_' <?> "variable")
67+ makeVar (letter <|> char '_') <?> "a variable"
63
68
64
69
65lowVar :: IParser String
70lowVar :: IParser String
66lowVar =
71lowVar =
67− makeVar (lower <?> "lower case variable")
72+ makeVar lower <?> "a lower case variable"
68
73
69
74
70capVar :: IParser String
75capVar :: IParser String
71capVar =
76capVar =
72− makeVar (upper <?> "upper case variable")
77+ makeVar upper <?> "an upper case variable"
73
78
74
79
75qualifiedVar :: IParser String
80qualifiedVar :: IParser String
@@ -84,15 +89,15 @@ rLabel = lowVar
84
89
85innerVarChar :: IParser Char
90innerVarChar :: IParser Char
86innerVarChar =
91innerVarChar =
87− alphaNum <|> char '_' <|> char '\'' <?> ""
92+ alphaNum <|> char '_' <|> char '\'' <?> "more letters in this variable"
88
93
89
94
90makeVar :: IParser Char -> IParser String
95makeVar :: IParser Char -> IParser String
91−makeVar p =
96+makeVar firstChar =
92− do v <- (:) <$> p <*> many innerVarChar
97+ do variable <- (:) <$> firstChar <*> many innerVarChar
93− if v `elem` reserveds
98+ if variable `elem` reserveds
94− then fail $ "unexpected keyword '" ++ v ++ "', variables cannot be keywords"
99+ then fail (Syntax.keyword variable)
95− else return v
100+ else return variable
96
101
97
102
98reserved :: String -> IParser String
103reserved :: String -> IParser String
@@ -109,7 +114,7 @@ anyOp :: IParser String
109anyOp =
114anyOp =
110 betwixt '`' '`' qualifiedVar
115 betwixt '`' '`' qualifiedVar
111 <|> symOp
116 <|> symOp
112− <?> "infix operator"
117+ <?> "an infix operator like (+)"
113
118
114
119
115symOp :: IParser String
120symOp :: IParser String
@@ -124,13 +129,23 @@ symOp =
124-- COMMON SYMBOLS
129-- COMMON SYMBOLS
125
130
126equals :: IParser String
131equals :: 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"
128
144
129−arrow :: IParser String
130−arrow = string "->" <|> string "\8594" <?> "arrow (->)"
131
145
132hasType :: IParser String
146hasType :: IParser String
133−hasType = string ":" <?> "':' (a type annotation)'"
147+hasType =
148+ string ":" <?> "the \"has type\" symbol ':'"
134
149
135
150
136commitIf check p =
151commitIf check p =
@@ -143,14 +158,24 @@ commitIf check p =
143-- SEPARATORS
158-- SEPARATORS
144
159
145spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
160spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
146−spaceySepBy1 sep p =
161+spaceySepBy1 sep parser =
147− do a <- p
162+ do value <- parser
163+ (value:) <$> spaceyPrefixBy sep parser
164+
165+
166+spaceyPrefixBy :: IParser sep -> IParser a -> IParser [a]
167+spaceyPrefixBy sep parser =
148− (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))
168+ many (commitIf (whitespace >> sep) (padded sep >> parser))
169+
170+
171+comma :: IParser Char
172+comma =
173+ char ',' <?> "a comma ','"
149
174
150
175
151commaSep1 :: IParser a -> IParser [a]
176commaSep1 :: IParser a -> IParser [a]
152commaSep1 =
177commaSep1 =
153− spaceySepBy1 (char ',' <?> "comma ','")
178+ spaceySepBy1 comma
154
179
155
180
156commaSep :: IParser a -> IParser [a]
181commaSep :: IParser a -> IParser [a]
@@ -160,17 +185,17 @@ commaSep =
160
185
161semiSep1 :: IParser a -> IParser [a]
186semiSep1 :: IParser a -> IParser [a]
162semiSep1 =
187semiSep1 =
163− spaceySepBy1 (char ';' <?> "semicolon ';'")
188+ spaceySepBy1 (char ';' <?> "a semicolon ';'")
164
189
165
190
166pipeSep1 :: IParser a -> IParser [a]
191pipeSep1 :: IParser a -> IParser [a]
167pipeSep1 =
192pipeSep1 =
168− spaceySepBy1 (char '|' <?> "type divider '|'")
193+ spaceySepBy1 (char '|' <?> "a vertical bar '|'")
169
194
170
195
171consSep1 :: IParser a -> IParser [a]
196consSep1 :: IParser a -> IParser [a]
172consSep1 =
197consSep1 =
173− spaceySepBy1 (string "::" <?> "cons operator '::'")
198+ spaceySepBy1 (string "::" <?> "a cons operator '::'")
174
199
175
200
176dotSep1 :: IParser a -> IParser [a]
201dotSep1 :: IParser a -> IParser [a]
@@ -187,15 +212,15 @@ spacePrefix p =
187 constrainedSpacePrefix p (\_ -> return ())
212 constrainedSpacePrefix p (\_ -> return ())
188
213
189
214
190−constrainedSpacePrefix p constraint =
215+constrainedSpacePrefix parser constraint =
191 many $ choice
216 many $ choice
192− [ try (spacing >> lookAhead (oneOf "[({")) >> p
217+ [ try (spacing >> lookAhead (oneOf "[({")) >> parser
193− , try (spacing >> p)
218+ , try (spacing >> parser)
194 ]
219 ]
195 where
220 where
196 spacing = do
221 spacing = do
197 n <- whitespace
222 n <- whitespace
198− constraint n
223+ constraint n <?> Syntax.whitespace
199 indented
224 indented
200
225
201
226
@@ -210,14 +235,14 @@ followedBy a b =
210betwixt a b c =
235betwixt a b c =
211 do char a
236 do char a
212 out <- c
237 out <- c
213− char b <?> "closing '" ++ [b] ++ "'"
238+ char b <?> "a closing '" ++ [b] ++ "'"
214 return out
239 return out
215
240
216
241
217surround a z name p = do
242surround a z name p = do
218 char a
243 char a
219 v <- padded p
244 v <- padded p
220− char z <?> unwords ["closing", name, show z]
245+ char z <?> unwords ["a closing", name, show z]
221 return v
246 return v
222
247
223
248
@@ -238,27 +263,32 @@ brackets =
238
263
239-- HELPERS FOR EXPRESSIONS
264-- HELPERS FOR EXPRESSIONS
240
265
266+getMyPosition :: IParser R.Position
267+getMyPosition =
268+ R.fromSourcePos <$> getPosition
269+
270+
241−addLocation :: (P.Pretty a) => IParser a -> IParser (Annotation.Located a)
271+addLocation :: IParser a -> IParser (A.Located a)
242addLocation expr =
272addLocation expr =
243 do (start, e, end) <- located expr
273 do (start, e, end) <- located expr
244− return (Annotation.at start end e)
274+ return (A.at start end e)
245
275
246
276
247−located :: IParser a -> IParser (SourcePos, a, SourcePos)
277+located :: IParser a -> IParser (R.Position, a, R.Position)
248−located p =
278+located parser =
249− do start <- getPosition
279+ do start <- getMyPosition
250− e <- p
280+ value <- parser
251− end <- getPosition
281+ end <- getMyPosition
252− return (start, e, end)
282+ return (start, value, end)
253
283
254
284
255accessible :: IParser Source.Expr -> IParser Source.Expr
285accessible :: IParser Source.Expr -> IParser Source.Expr
256accessible exprParser =
286accessible exprParser =
257− do start <- getPosition
287+ do start <- getMyPosition
258
288
259− annotatedRootExpr@(Annotation.A _ rootExpr) <- exprParser
289+ annotatedRootExpr@(A.A _ rootExpr) <- exprParser
260
290
261− access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
291+ access <- optionMaybe (try dot <?> "a field access like .name")
262
292
263 case access of
293 case access of
264 Nothing ->
294 Nothing ->
@@ -266,9 +296,9 @@ accessible exprParser =
266
296
267 Just _ ->
297 Just _ ->
268 accessible $
298 accessible $
269− do v <- var <?> "field access (e.g. List.map)"
299+ do v <- var
270− end <- getPosition
300+ end <- getMyPosition
271− return . Annotation.at start end $
301+ return . A.at start end $
272 case rootExpr of
302 case rootExpr of
273 E.Var (Variable.Raw name@(c:_))
303 E.Var (Variable.Raw name@(c:_))
274 | isUpper c ->
304 | isUpper c ->
@@ -279,7 +309,8 @@ accessible exprParser =
279
309
280dot :: IParser ()
310dot :: IParser ()
281dot =
311dot =
312+ do char '.'
282− char '.' >> notFollowedBy (char '.')
313+ notFollowedBy (char '.')
283
314
284
315
285-- WHITESPACE
316-- WHITESPACE
@@ -294,7 +325,7 @@ padded p =
294
325
295spaces :: IParser String
326spaces :: IParser String
296spaces =
327spaces =
297− let space = string " " <|> multiComment <?> "whitespace"
328+ let space = string " " <|> multiComment <?> Syntax.whitespace
298 in
329 in
299 concat <$> many1 space
330 concat <$> many1 space
300
331
@@ -323,14 +354,14 @@ whitespace =
323
354
324freshLine :: IParser [[String]]
355freshLine :: IParser [[String]]
325freshLine =
356freshLine =
326− try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
357+ try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> Syntax.freshLine
327 where
358 where
328 space_nl = try $ spaces >> many1 newline
359 space_nl = try $ spaces >> many1 newline
329
360
330
361
331newline :: IParser String
362newline :: IParser String
332newline =
363newline =
333− simpleNewline <|> lineComment <?> "a newline"
364+ simpleNewline <|> lineComment <?> Syntax.newline
334
365
335
366
336simpleNewline :: IParser String
367simpleNewline :: IParser String
@@ -354,7 +385,7 @@ closeComment :: IParser String
354closeComment =
385closeComment =
355 anyUntil $
386 anyUntil $
356 choice $
387 choice $
357− [ try (string "-}") <?> "close comment"
388+ [ try (string "-}") <?> "the end of a comment -}"
358 , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]
389 , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]
359 ]
390 ]
360
391
@@ -427,12 +458,10 @@ withSource p =
427
458
428anyUntilPos :: SourcePos -> IParser String
459anyUntilPos :: SourcePos -> IParser String
429anyUntilPos pos =
460anyUntilPos pos =
430− go
431− where
432− go = do currentPos <- getPosition
461+ do currentPos <- getPosition
433− case currentPos == pos of
462+ if currentPos == pos
434− True -> return []
463+ then return []
435− False -> (:) <$> anyChar <*> go
464+ else (:) <$> anyChar <*> anyUntilPos pos
436
465
437
466
438-- BASIC LANGUAGE LITERALS
467-- BASIC LANGUAGE LITERALS
@@ -505,9 +534,10 @@ glSource src =
505
534
506
535
507str :: IParser String
536str :: IParser String
537+str =
508−str = expecting "String" $ do
538+ expecting "a string" $
509− s <- choice [ multiStr, singleStr ]
539+ do s <- choice [ multiStr, singleStr ]
510− processAs T.stringLiteral . sandwich '\"' $ concat s
540+ processAs T.stringLiteral . sandwich '\"' $ concat s
511 where
541 where
512 rawString quote insides =
542 rawString quote insides =
513 quote >> manyTill insides quote
543 quote >> manyTill insides quote
@@ -547,7 +577,7 @@ escaped delim =
547
577
548chr :: IParser Char
578chr :: IParser Char
549chr =
579chr =
550− betwixt '\'' '\'' character <?> "character"
580+ betwixt '\'' '\'' character <?> "a character"
551 where
581 where
552 nonQuote = satisfy (/='\'')
582 nonQuote = satisfy (/='\'')
553
583
src/Parse/Literal.hs+4−4
@@ -9,19 +9,19 @@ import qualified AST.Literal as L
9
9
10literal :: IParser L.Literal
10literal :: IParser L.Literal
11literal =
11literal =
12− num <|> (L.Str <$> str) <|> (L.Chr <$> chr) <?> "literal"
12+ num <|> (L.Str <$> str) <|> (L.Chr <$> chr)
13
13
14
14
15num :: IParser L.Literal
15num :: IParser L.Literal
16num =
16num =
17− toLiteral <$> (rawNumber <?> "number")
17+ toLiteral <$> (rawNumber <?> "a number")
18
18
19
19
20toLiteral :: String -> L.Literal
20toLiteral :: String -> L.Literal
21toLiteral n
21toLiteral n
22− | 'x' `elem` n = L.IntNum (read n)
22+ | 'x' `elem` n = L.IntNum (read n)
23 | any (`elem` ".eE") n = L.FloatNum (read n)
23 | any (`elem` ".eE") n = L.FloatNum (read n)
24− | otherwise = L.IntNum (read n)
24+ | otherwise = L.IntNum (read n)
25
25
26
26
27rawNumber :: IParser String
27rawNumber :: 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
2
2
3import Control.Applicative ((<$>), (<*>))
3import Control.Applicative ((<$>), (<*>))
4import Text.Parsec hiding (newline, spaces)
4import Text.Parsec hiding (newline, spaces)
@@ -6,6 +6,7 @@ import Text.Parsec hiding (newline, spaces)
6import Parse.Helpers
6import Parse.Helpers
7import qualified AST.Module as Module
7import qualified AST.Module as Module
8import qualified AST.Variable as Var
8import qualified AST.Variable as Var
9+import Reporting.Annotation as A
9
10
10
11
11getModuleName :: String -> Maybe String
12getModuleName :: String -> Maybe String
@@ -16,38 +17,41 @@ getModuleName source =
16 where
17 where
17 getModuleName =
18 getModuleName =
18 do optional freshLine
19 do optional freshLine
19− (names, _) <- header
20+ (names, _) <- moduleDecl
20 return (Module.nameToString names)
21 return (Module.nameToString names)
21
22
22
23
23−headerAndImports :: IParser Module.HeaderAndImports
24+header :: IParser (Module.Header [Module.UserImport])
24−headerAndImports =
25+header =
25 do optional freshLine
26 do optional freshLine
26 (names, exports) <-
27 (names, exports) <-
27− option (["Main"], Var.openListing) (header `followedBy` freshLine)
28+ option (["Main"], Var.openListing) (moduleDecl `followedBy` freshLine)
28 imports' <- imports
29 imports' <- imports
29− return $ Module.HeaderAndImports names exports imports'
30+ return (Module.Header names exports imports')
30
31
31
32
32−header :: IParser ([String], Var.Listing Var.Value)
33+moduleDecl :: IParser ([String], Var.Listing (A.Located Var.Value))
33−header =
34+moduleDecl =
35+ expecting "a module declaration" $
34 do try (reserved "module")
36 do try (reserved "module")
35 whitespace
37 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))
37 whitespace
41 whitespace
38− exports <- option Var.openListing (listing value)
39− whitespace <?> "reserved word 'where'"
40 reserved "where"
42 reserved "where"
41 return (names, exports)
43 return (names, exports)
42
44
43
45
44−imports :: IParser [(Module.Name, Module.ImportMethod)]
46+imports :: IParser [Module.UserImport]
45imports =
47imports =
46 many (import' `followedBy` freshLine)
48 many (import' `followedBy` freshLine)
47
49
48
50
49−import' :: IParser (Module.Name, Module.ImportMethod)
51+import' :: IParser Module.UserImport
50import' =
52import' =
53+ expecting "an import" $
54+ addLocation $
51 do try (reserved "import")
55 do try (reserved "import")
52 whitespace
56 whitespace
53 names <- dotSep1 capVar
57 names <- dotSep1 capVar
@@ -56,14 +60,14 @@ import' =
56 method :: String -> IParser Module.ImportMethod
60 method :: String -> IParser Module.ImportMethod
57 method defaultAlias =
61 method defaultAlias =
58 Module.ImportMethod
62 Module.ImportMethod
59− <$> option (Just defaultAlias) (Just <$> as')
63+ <$> option (Just defaultAlias) (Just <$> as' defaultAlias)
60 <*> option Var.closedListing exposing
64 <*> option Var.closedListing exposing
61
65
62− as' :: IParser String
66+ as' :: String -> IParser String
63− as' =
67+ as' moduleName =
64 do try (whitespace >> reserved "as")
68 do try (whitespace >> reserved "as")
65 whitespace
69 whitespace
66− capVar <?> "alias for module"
70+ capVar <?> ("an alias for module '" ++ moduleName ++ "'")
67
71
68 exposing :: IParser (Var.Listing Var.Value)
72 exposing :: IParser (Var.Listing Var.Value)
69 exposing =
73 exposing =
@@ -74,13 +78,14 @@ import' =
74
78
75listing :: IParser a -> IParser (Var.Listing a)
79listing :: IParser a -> IParser (Var.Listing a)
76listing item =
80listing item =
81+ expecting "a listing of values to expose, like (..)" $
77 do try (whitespace >> char '(')
82 do try (whitespace >> char '(')
78 whitespace
83 whitespace
79 listing <-
84 listing <-
80 choice
85 choice
81 [ const Var.openListing <$> string ".."
86 [ const Var.openListing <$> string ".."
82 , Var.Listing <$> commaSep1 item <*> return False
87 , Var.Listing <$> commaSep1 item <*> return False
83− ] <?> "listing of values (x,y,z)"
88+ ]
84 whitespace
89 whitespace
85 char ')'
90 char ')'
86 return listing
91 return listing
@@ -88,7 +93,7 @@ listing item =
88
93
89value :: IParser Var.Value
94value :: IParser Var.Value
90value =
95value =
91− val <|> tipe
96+ val <|> tipe <?> "a value to expose"
92 where
97 where
93 val =
98 val =
94 Var.Value <$> (lowVar <|> parens symOp)
99 Var.Value <$> (lowVar <|> parens symOp)
src/Parse/Parse.hs+113−54
@@ -1,79 +1,138 @@
1+{-# OPTIONS_GHC -Wall #-}
1−module Parse.Parse (program) where
2+module Parse.Parse (program, parse) where
2
3
3−import Control.Applicative ((<$>))
4+import Control.Applicative ((<$>), (<*>))
4−import qualified Data.List as List
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6−import Text.Parsec hiding (newline, spaces)
6+import qualified Data.Traversable as T
7+import Text.Parsec (char, eof, letter, many, optional, putState, (<|>))
7−import qualified Text.PrettyPrint as P
8+import qualified Text.Parsec.Error as Parsec
8
9
9import qualified AST.Declaration as D
10import qualified AST.Declaration as D
10import qualified AST.Module as M
11import qualified AST.Module as M
12+import qualified Elm.Compiler.Imports as Imports
11import Parse.Helpers
13import Parse.Helpers
12−import Parse.Declaration (infixDecl)
13import qualified Parse.Module as Module
14import qualified Parse.Module as Module
14import qualified Parse.Declaration as Decl
15import 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
16
20
17
21
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
18freshDef =
58freshDef =
19 commitIf (freshLine >> (letter <|> char '_')) $
59 commitIf (freshLine >> (letter <|> char '_')) $
20− do freshLine
60+ do _ <- freshLine
21− Decl.declaration <?> "another datatype or variable definition"
61+ Decl.declaration
22
62
23
63
24−decls =
64+-- RUN PARSERS
25− do d <- Decl.declaration <?> "at least one datatype or variable definition"
26− (d:) <$> many freshDef
27
65
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
28
71
29−program :: OpTable -> String -> Either [P.Doc] M.ValidModule
72+ Left err ->
30−program table src =
73+ let pos = R.fromSourcePos (Parsec.errorPos err)
31− do (M.Module names filePath exs ims sourceDecls) <-
74+ msgs = Parsec.errorMessages err
32− setupParserWithTable table programParser src
75+ in
76+ Result.throw (R.Region pos pos) (Error.Parse msgs)
33
77
34− decls <-
35− either (\err -> Left [P.text err]) Right (combineAnnotations sourceDecls)
36
78
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
38
86
87+ infixTable <- makeInfixTable table infixInfoList
39
88
40−programParser :: IParser M.SourceModule
89+ parse source $
41−programParser =
90+ do putState infixTable
42− do (M.HeaderAndImports names exports imports) <- Module.headerAndImports
91+ parser
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− ]
65
92
66
93
67−parseFixities =
68− do decls <- onFreshLines (:) [] infixDecl
69− return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
70
94
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))
71
133
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
77
134
78− Left err ->
135+data InfixInfo = InfixInfo
79− Left [ P.text $ "Parse error at " ++ show err ]
136+ { _region :: R.Region
137+ , _info :: (Int, D.Assoc)
138+ }
src/Parse/Pattern.hs+81−37
@@ -5,64 +5,108 @@ import Data.Char (isUpper)
5import qualified Data.List as List
5import qualified Data.List as List
6import Text.Parsec ((<|>), (<?>), char, choice, optionMaybe, try)
6import Text.Parsec ((<|>), (<?>), char, choice, optionMaybe, try)
7
7
8−import Parse.Helpers
9−import qualified Parse.Literal as Literal
10import qualified AST.Literal as L
8import qualified AST.Literal as L
11import qualified AST.Pattern as P
9import qualified AST.Pattern as P
12import qualified AST.Variable as Var
10import 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+
13
16
14basic :: IParser P.RawPattern
17basic :: IParser P.RawPattern
18+basic =
19+ addLocation $
15−basic = choice
20+ choice
16− [ char '_' >> return P.Anything
21+ [ char '_' >> return P.Anything
17− , stringToPattern <$> var
22+ , stringToPattern <$> var
18− , P.Literal <$> Literal.literal
23+ , P.Literal <$> Literal.literal
19− ]
24+ ]
20 where
25 where
21− stringToPattern v =
26+ stringToPattern str =
22− case v of
27+ case str of
28+ "True" ->
23− "True" -> P.Literal (L.Boolean True)
29+ P.Literal (L.Boolean True)
30+
31+ "False" ->
24− "False" -> P.Literal (L.Boolean False)
32+ P.Literal (L.Boolean False)
33+
25− c:_ | isUpper c -> P.Data (Var.Raw v) []
34+ c:_ | isUpper c ->
26− _ -> P.Var v
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
27
44
45+ let (A.A (R.Region start _) _) = pattern
28
46
29−asPattern :: P.RawPattern -> IParser P.RawPattern
47+ maybeAlias <- optionMaybe asAlias
30−asPattern pattern =
48+
31− do var <- optionMaybe (try (whitespace >> reserved "as") >> whitespace >> lowVar)
32− case var of
49+ case maybeAlias of
33− Just v ->
50+ Just alias ->
51+ do end <- getMyPosition
34− return (P.Alias v pattern)
52+ return (A.at start end (P.Alias alias pattern))
35
53
36 Nothing ->
54 Nothing ->
37− return pattern
55+ return pattern
56+ where
57+ asAlias =
58+ do try (whitespace >> reserved "as")
59+ whitespace
60+ lowVar
38
61
39
62
40record :: IParser P.RawPattern
63record :: IParser P.RawPattern
64+record =
65+ addLocation
41−record = P.Record <$> brackets (commaSep1 lowVar)
66+ (P.Record <$> brackets (commaSep1 lowVar))
67+
42
68
43tuple :: IParser P.RawPattern
69tuple :: IParser P.RawPattern
44−tuple = do
70+tuple =
71+ do (start, patterns, end) <-
45− ps <- parens (commaSep expr)
72+ located (parens (commaSep expr))
73+
46− return $ case ps of
74+ case patterns of
47− [p] -> p
75+ [pattern] ->
48− _ -> P.tuple ps
76+ return pattern
77+
78+ _ ->
79+ return (A.at start end (P.tuple patterns))
80+
49
81
50list :: IParser P.RawPattern
82list :: IParser P.RawPattern
83+list =
84+ braces $
51−list = P.list <$> braces (commaSep expr)
85+ do (_, patterns, end) <- located (commaSep expr)
86+ return (P.list end patterns)
87+
52
88
53term :: IParser P.RawPattern
89term :: IParser P.RawPattern
54term =
90term =
55− (choice [ record, tuple, list, basic ]) <?> "pattern"
91+ choice [ record, tuple, list, basic ]
92+ <?> "a pattern"
93+
56
94
57patternConstructor :: IParser P.RawPattern
95patternConstructor :: IParser P.RawPattern
58−patternConstructor = do
96+patternConstructor =
97+ addLocation $
59− v <- List.intercalate "." <$> dotSep1 capVar
98+ do v <- List.intercalate "." <$> dotSep1 capVar
60− case v of
99+ case v of
61− "True" -> return $ P.Literal (L.Boolean True)
100+ "True" -> return $ P.Literal (L.Boolean True)
62− "False" -> return $ P.Literal (L.Boolean False)
101+ "False" -> return $ P.Literal (L.Boolean False)
63− _ -> P.Data (Var.Raw v) <$> spacePrefix term
102+ _ -> P.Data (Var.Raw v) <$> spacePrefix term
103+
64
104
65expr :: IParser P.RawPattern
105expr :: IParser P.RawPattern
66−expr = do
106+expr =
107+ asPattern subPattern <?> "a pattern"
108+ where
109+ subPattern =
67− patterns <- consSep1 (patternConstructor <|> term)
110+ do patterns <- consSep1 (patternConstructor <|> term)
68− asPattern (foldr1 P.cons patterns) <?> "pattern"
111+ end <- getMyPosition
112+ return (P.consMany end patterns)
src/Parse/Type.hs+48−33
@@ -5,26 +5,30 @@ import Control.Applicative ((<$>),(<*>),(<*))
5import Data.List (intercalate)
5import Data.List (intercalate)
6import Text.Parsec ((<|>), (<?>), char, many, optionMaybe, string, try)
6import Text.Parsec ((<|>), (<?>), char, many, optionMaybe, string, try)
7
7
8−import qualified AST.Type as T
8+import qualified AST.Type as Type
9import qualified AST.Variable as Var
9import qualified AST.Variable as Var
10import Parse.Helpers
10import Parse.Helpers
11+import qualified Reporting.Annotation as A
12+import qualified Reporting.Region as R
11
13
12
14
13−tvar :: IParser T.RawType
15+tvar :: IParser Type.Raw
14tvar =
16tvar =
17+ addLocation
15− T.Var <$> lowVar <?> "type variable"
18+ (Type.RVar <$> lowVar <?> "a type variable")
16
19
17
20
18−tuple :: IParser T.RawType
21+tuple :: IParser Type.Raw
19tuple =
22tuple =
20− do ts <- parens (commaSep expr)
23+ do (start, types, end) <- located (parens (commaSep expr))
21− case ts of
24+ case types of
22 [t] -> return t
25 [t] -> return t
23− _ -> return (T.tupleOf ts)
26+ _ -> return (Type.tuple (R.Region start end) types)
24
27
25
28
26−record :: IParser T.RawType
29+record :: IParser Type.Raw
27record =
30record =
31+ addLocation $
28 do char '{'
32 do char '{'
29 whitespace
33 whitespace
30 rcrd <- extended <|> normal
34 rcrd <- extended <|> normal
@@ -32,18 +36,19 @@ record =
32 char '}'
36 char '}'
33 return rcrd
37 return rcrd
34 where
38 where
35− normal = flip T.Record Nothing <$> commaSep field
39+ normal = flip Type.RRecord Nothing <$> commaSep field
36
40
37 -- extended record types require at least one field
41 -- extended record types require at least one field
38− extended = do
42+ extended =
39− ext <- try (lowVar <* (whitespace >> string "|"))
43+ do ext <- try (addLocation lowVar <* (whitespace >> string "|"))
40− whitespace
44+ whitespace
41− flip T.Record (Just (T.Var ext)) <$> commaSep1 field
45+ fields <- commaSep1 field
46+ return (Type.RRecord fields (Just (A.map Type.RVar ext)))
42
47
43− field = do
48+ field =
44− lbl <- rLabel
49+ do lbl <- rLabel
45− whitespace >> hasType >> whitespace
50+ whitespace >> hasType >> whitespace
46− (,) lbl <$> expr
51+ (,) lbl <$> expr
47
52
48
53
49capTypeVar :: IParser String
54capTypeVar :: IParser String
@@ -51,41 +56,51 @@ capTypeVar =
51 intercalate "." <$> dotSep1 capVar
56 intercalate "." <$> dotSep1 capVar
52
57
53
58
54−constructor0 :: IParser T.RawType
59+constructor0 :: IParser Type.Raw
55constructor0 =
60constructor0 =
61+ addLocation $
56 do name <- capTypeVar
62 do name <- capTypeVar
57− return (T.Type (Var.Raw name))
63+ return (Type.RType (Var.Raw name))
58
64
59
65
60−term :: IParser T.RawType
66+term :: IParser Type.Raw
61term =
67term =
62 tuple <|> record <|> tvar <|> constructor0
68 tuple <|> record <|> tvar <|> constructor0
63
69
64
70
65−app :: IParser T.RawType
71+app :: IParser Type.Raw
66app =
72app =
73+ do start <- getMyPosition
67− do f <- constructor0 <|> try tupleCtor <?> "type constructor"
74+ f <- constructor0 <|> try tupleCtor <?> "a type constructor"
68 args <- spacePrefix term
75 args <- spacePrefix term
76+ end <- getMyPosition
69 case args of
77 case args of
70 [] -> return f
78 [] -> return f
71− _ -> return (T.App f args)
79+ _ -> return (A.A (R.Region start end) (Type.RApp f args))
72 where
80 where
73− tupleCtor = do
81+ tupleCtor =
82+ addLocation $
74− n <- length <$> parens (many (char ','))
83+ do n <- length <$> parens (many (char ','))
75− let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)
84+ let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)
76− return (T.Type (Var.Raw ctor))
85+ return (Type.RType (Var.Raw ctor))
77
86
78
87
79−expr :: IParser T.RawType
88+expr :: IParser Type.Raw
80expr =
89expr =
90+ do start <- getMyPosition
81− do t1 <- app <|> term
91+ t1 <- app <|> term
82− arr <- optionMaybe $ try (whitespace >> arrow)
92+ arr <- optionMaybe $ try (whitespace >> rightArrow)
83 case arr of
93 case arr of
94+ Nothing ->
95+ return t1
96+ Just _ ->
84− Just _ -> T.Lambda t1 <$> (whitespace >> expr)
97+ do whitespace
85− Nothing -> return t1
98+ t2 <- expr
99+ end <- getMyPosition
100+ return (A.A (R.Region start end) (Type.RLambda t1 t2))
86
101
87
102
88−constructor :: IParser (String, [T.RawType])
103+constructor :: IParser (String, [Type.Raw])
89constructor =
104constructor =
90 (,) <$> (capTypeVar <?> "another type constructor")
105 (,) <$> (capTypeVar <?> "another type constructor")
91 <*> spacePrefix term
106 <*> 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
3
3
4import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
5import qualified Control.Monad as Monad
5import qualified Control.Monad as Monad
6−import Control.Monad.Error
7import qualified Data.List as List
6import qualified Data.List as List
8import qualified Data.Map as Map
7import qualified Data.Map as Map
9−import Prelude hiding (and)
10−import qualified Text.PrettyPrint as PP
11
8
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
15import qualified AST.Expression.Canonical as Canonical
10import qualified AST.Expression.Canonical as Canonical
11+import qualified AST.Literal as Lit
16import qualified AST.Pattern as P
12import qualified AST.Pattern as P
17import qualified AST.Type as ST
13import qualified AST.Type as ST
18import qualified AST.Variable as V
14import qualified AST.Variable as V
19−import Type.Type hiding (Descriptor(..))
15+import qualified Reporting.Annotation as A
20−import qualified Type.Fragment as Fragment
16+import qualified Reporting.Error.Type as Error
21−import qualified Type.Environment as Env
17+import qualified Reporting.Region as R
22import qualified Type.Constrain.Literal as Literal
18import qualified Type.Constrain.Literal as Literal
23import qualified Type.Constrain.Pattern as Pattern
19import 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(..))
24
23
25
24
26constrain
25constrain
27 :: Env.Environment
26 :: Env.Environment
28 -> Canonical.Expr
27 -> Canonical.Expr
29 -> Type
28 -> Type
30− -> ErrorT [PP.Doc] IO TypeConstraint
29+ -> IO TypeConstraint
31−constrain env (A region expression) tipe =
30+constrain env (A.A region expression) tipe =
32 let list t = Env.get env Env.types "List" <| t
31 let list t = Env.get env Env.types "List" <| t
33− and = A region . CAnd
32+ (===) = CEqual Error.None region
34− true = A region CTrue
35− t1 === t2 = A region (CEqual t1 t2)
36− x <? t = A region (CInstance x t)
33+ (<?) = CInstance region
37− clet schemes c = A region (CLet schemes c)
38 in
34 in
39 case expression of
35 case expression of
40− Literal lit ->
36+ E.Literal lit ->
41− liftIO $ Literal.constrain env region lit tipe
37+ Literal.constrain env region lit tipe
42
38
43− GLShader _uid _src gltipe ->
39+ E.GLShader _uid _src gltipe ->
44 exists $ \attr ->
40 exists $ \attr ->
45 exists $ \unif ->
41 exists $ \unif ->
46 let
42 let
43+ shaderTipe a u v =
47− shaderTipe a u v = Env.get env Env.types "WebGL.Shader" <| a <| u <| v
44+ Env.get env Env.types "WebGL.Shader" <| a <| u <| v
45+
46+ glTipe =
48− glTipe = Env.get env Env.types . Lit.glTipeName
47+ Env.get env Env.types . Lit.glTipeName
48+
49− makeRec accessor baseRec =
49+ makeRec accessor baseRec =
50− let decls = accessor gltipe
50+ let decls = accessor gltipe
51+ in
51− in if Map.size decls == 0
52+ if Map.size decls == 0
52− then baseRec
53+ then baseRec
53− else record (Map.map (\t -> [glTipe t]) decls) baseRec
54+ else record (Map.map (\t -> [glTipe t]) decls) baseRec
55+
54− attribute = makeRec Lit.attribute attr
56+ attribute = makeRec Lit.attribute attr
55− uniform = makeRec Lit.uniform unif
57+ uniform = makeRec Lit.uniform unif
56− varying = makeRec Lit.varying (termN EmptyRecord1)
58+ varying = makeRec Lit.varying (termN EmptyRecord1)
57 in
59 in
58− return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
60+ return (tipe === shaderTipe attribute uniform varying)
59
61
60− Var var
62+ E.Var var ->
63+ let name = V.toString var
64+ in
61− | name == saveEnvName -> return (A region CSaveEnv)
65+ return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
62− | otherwise -> return (name <? tipe)
63− where
64− name = V.toString var
65
66
66− Range lo hi ->
67+ E.Range lowExpr highExpr ->
67 existsNumber $ \n ->
68 existsNumber $ \n ->
68− do clo <- constrain env lo n
69+ do lowCon <- constrain env lowExpr n
69− chi <- constrain env hi n
70+ highCon <- constrain env highExpr n
70− return $ and [clo, chi, list n === tipe]
71+ return $ CAnd [lowCon, highCon, list n === tipe]
71−
72+
72− ExplicitList exprs ->
73+ E.ExplicitList exprs ->
73− exists $ \x ->
74+ constrainList env region exprs tipe
74− do constraints <- mapM (\e -> constrain env e x) exprs
75+
75− return . and $ list x === tipe : constraints
76+ E.Binop op leftExpr rightExpr ->
76−
77− Binop op e1 e2 ->
78− exists $ \t1 ->
77+ exists $ \leftType ->
79− exists $ \t2 ->
78+ exists $ \rightType ->
80− do c1 <- constrain env e1 t1
79+ do leftCon <- constrain env leftExpr leftType
81− c2 <- constrain env e2 t2
80+ rightCon <- constrain env rightExpr rightType
81+ return $ CAnd
82+ [ leftCon
83+ , rightCon
82− return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]
84+ , V.toString op <? (leftType ==> rightType ==> tipe)
83−
85+ ]
86+
84− Lambda p e ->
87+ E.Lambda pattern body ->
85− exists $ \t1 ->
88+ exists $ \argType ->
86− exists $ \t2 ->
89+ exists $ \resType ->
87− do fragment <- try region $ Pattern.constrain env p t1
90+ do fragment <- Pattern.constrain env pattern argType
88− c2 <- constrain env e t2
91+ bodyCon <- constrain env body resType
92+ let con =
89− let c = ex (Fragment.vars fragment)
93+ ex (Fragment.vars fragment)
90− (clet [monoscheme (Fragment.typeEnv fragment)]
94+ (CLet [monoscheme (Fragment.typeEnv fragment)]
91− (Fragment.typeConstraint fragment /\ c2)
95+ (Fragment.typeConstraint fragment /\ bodyCon)
92− )
96+ )
93− return $ c /\ tipe === (t1 ==> t2)
97+ return $ con /\ tipe === (argType ==> resType)
94−
98+
95− App e1 e2 ->
99+ E.App func arg ->
96− exists $ \t ->
100+ do argVar <- variable Flexible
101+ resultVar <- variable Flexible
97− do c1 <- constrain env e1 (t ==> tipe)
102+ argCon <- constrain env arg (varN argVar)
98− c2 <- constrain env e2 t
103+ funcCon <- constrain env func (varN argVar ==> varN resultVar)
104+ let appCon = tipe === varN resultVar
99− return $ c1 /\ c2
105+ return $
100−
106+ ex [argVar,resultVar] (CAnd [ argCon, funcCon, appCon ])
107+
101− MultiIf branches ->
108+ E.MultiIf branches ->
102− and <$> mapM constrain' branches
109+ constrainIf env region branches tipe
103− where
110+
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 ->
111+ E.Case expr branches ->
112− exists $ \t ->
112+ constrainCase env region expr branches tipe
113− do ce <- constrain env expr t
113+
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 ->
114+ E.Data name exprs ->
121− do vars <- forM exprs $ \_ -> liftIO (variable Flexible)
115+ do vars <- Monad.forM exprs $ \_ -> variable Flexible
122 let pairs = zip exprs (map varN vars)
116 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)
124 return $ ex vars (cs /\ name <? ctipe)
118 return $ ex vars (cs /\ name <? ctipe)
125 where
119 where
126 step (t,c) (e,x) =
120 step (t,c) (e,x) =
127 do c' <- constrain env e x
121 do c' <- constrain env e x
128 return (x ==> t, c /\ c')
122 return (x ==> t, c /\ c')
129
123
130− Access expr label ->
124+ E.Access expr label ->
131 exists $ \t ->
125 exists $ \t ->
132 constrain env expr (record (Map.singleton label [tipe]) t)
126 constrain env expr (record (Map.singleton label [tipe]) t)
133
127
134− Remove expr label ->
128+ E.Remove expr label ->
135 exists $ \t ->
129 exists $ \t ->
136 constrain env expr (record (Map.singleton label [t]) tipe)
130 constrain env expr (record (Map.singleton label [t]) tipe)
137
131
138− Insert expr label value ->
132+ E.Insert expr label value ->
139− exists $ \tVal ->
133+ exists $ \valueType ->
140− exists $ \tRec ->
134+ exists $ \recordType ->
141− do cVal <- constrain env value tVal
135+ do valueCon <- constrain env value valueType
142− cRec <- constrain env expr tRec
136+ recordCon <- constrain env expr recordType
137+ let newRecordType =
143− let c = tipe === record (Map.singleton label [tVal]) tRec
138+ record (Map.singleton label [valueType]) recordType
144− return (and [cVal, cRec, c])
139+ return (CAnd [valueCon, recordCon, tipe === newRecordType])
145
140
146− Modify expr fields ->
141+ E.Modify expr fields ->
147 exists $ \t ->
142 exists $ \t ->
148− do oldVars <- forM fields $ \_ -> liftIO (variable Flexible)
143+ do oldVars <- Monad.forM fields $ \_ -> variable Flexible
149 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))
144 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))
150 cOld <- ex oldVars <$> constrain env expr (record oldFields t)
145 cOld <- ex oldVars <$> constrain env expr (record oldFields t)
151
146
152− newVars <- forM fields $ \_ -> liftIO (variable Flexible)
147+ newVars <- Monad.forM fields $ \_ -> variable Flexible
153 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))
148 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))
154 let cNew = tipe === record newFields t
149 let cNew = tipe === record newFields t
155
150
156− cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)
151+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)
157
152
158− return $ cOld /\ ex newVars (and (cNew : cs))
153+ return $ cOld /\ ex newVars (CAnd (cNew : cs))
159
154
160− Record fields ->
155+ E.Record fields ->
161− do vars <- forM fields $ \_ -> liftIO (variable Flexible)
156+ do vars <- Monad.forM fields (\_ -> variable Flexible)
157+ fieldCons <-
158+ Monad.zipWithM
162− cs <- zipWithM (constrain env) (map snd fields) (map varN vars)
159+ (constrain env)
160+ (map snd fields)
161+ (map varN vars)
163 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
162 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
164 let recordType = record fields' (termN EmptyRecord1)
163 let recordType = record fields' (termN EmptyRecord1)
165− return . ex vars . and $ tipe === recordType : cs
164+ return (ex vars (CAnd (fieldCons ++ [tipe === recordType])))
166
165
167− Let defs body ->
166+ E.Let defs body ->
168− do c <- constrain env body tipe
167+ do bodyCon <- constrain env body tipe
169
168
170 (Info schemes rqs fqs headers c2 c1) <-
169 (Info schemes rqs fqs headers c2 c1) <-
171 Monad.foldM
170 Monad.foldM
172 (constrainDef env)
171 (constrainDef env)
173− (Info [] [] [] Map.empty true true)
172+ (Info [] [] [] Map.empty CTrue CTrue)
174 (concatMap expandPattern defs)
173 (concatMap expandPattern defs)
175
174
176− let letScheme = [ Scheme rqs fqs (clet [monoscheme headers] c2) headers ]
175+ let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
177
176
178− return $ clet schemes (clet letScheme (c1 /\ c))
177+ return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
179
178
180− Port impl ->
179+ E.Port impl ->
181 case impl of
180 case impl of
182− In _ _ ->
181+ E.In _ _ ->
183− return true
182+ return CTrue
184
183
185− Out _ expr _ ->
184+ E.Out _ expr _ ->
186 constrain env expr tipe
185 constrain env expr tipe
187
186
188− Task _ expr _ ->
187+ E.Task _ expr _ ->
189 constrain env expr tipe
188 constrain env expr tipe
190
189
191
190
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+
192expandPattern :: Canonical.Def -> [Canonical.Def]
334expandPattern :: Canonical.Def -> [Canonical.Def]
193−expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =
335+expandPattern def@(Canonical.Definition lpattern expr maybeType) =
336+ let (A.A patternRegion pattern) = lpattern
337+ in
194− case pattern of
338+ case pattern of
195− P.Var _ ->
339+ P.Var _ ->
196− [def]
340+ [def]
341+
197− _ ->
342+ _ ->
198− Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars
343+ mainDef : map toDef vars
199− where
344+ where
200− vars = P.boundVarList pattern
345+ vars = P.boundVarList lpattern
346+
201− x = "$" ++ concat vars
347+ combinedName = "$" ++ concat vars
348+
349+ pvar name =
350+ A.A patternRegion (P.Var name)
351+
202− mkVar = A r . localVar
352+ localVar name =
203− toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
353+ A.A patternRegion (E.localVar name)
204−
354+
205−
355+ mainDef = Canonical.Definition (pvar combinedName) expr maybeType
206−try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
356+
207−try region computation =
357+ toDef name =
208− do result <- liftIO $ runErrorT computation
358+ let extract =
209− case result of
359+ E.Case (localVar combinedName) [(lpattern, localVar name)]
210− Left err -> throwError [err region]
360+ in
211− Right value -> return value
361+ Canonical.Definition (pvar name) (A.A patternRegion extract) Nothing
212
362
213
363
214-- CONSTRAIN DEFINITIONS
364-- CONSTRAIN DEFINITIONS
@@ -223,8 +373,8 @@ data Info = Info
223 }
373 }
224
374
225
375
226−constrainDef :: Env.Environment -> Info -> Canonical.Def -> ErrorT [PP.Doc] IO Info
376+constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
227−constrainDef env info (Canonical.Definition pattern expr maybeTipe) =
377+constrainDef env info (Canonical.Definition (A.A _ pattern) expr maybeTipe) =
228 let qs = [] -- should come from the def, but I'm not sure what would live there...
378 let qs = [] -- should come from the def, but I'm not sure what would live there...
229 in
379 in
230 case (pattern, maybeTipe) of
380 case (pattern, maybeTipe) of
@@ -243,13 +393,13 @@ constrainAnnotatedDef
243 -> [String]
393 -> [String]
244 -> String
394 -> String
245 -> Canonical.Expr
395 -> Canonical.Expr
246− -> ST.CanonicalType
396+ -> ST.Canonical
247− -> ErrorT [PP.Doc] IO Info
397+ -> IO Info
248constrainAnnotatedDef env info qs name expr tipe =
398constrainAnnotatedDef env info qs name expr tipe =
249 do -- Some mistake may be happening here. Currently, qs is always [].
399 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)
251
401
252− flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)
402+ flexiVars <- Monad.forM qs (\_ -> variable Flexible)
253
403
254 let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars
404 let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars
255
405
@@ -261,7 +411,7 @@ constrainAnnotatedDef env info qs name expr tipe =
261 Scheme
411 Scheme
262 { rigidQuantifiers = []
412 { rigidQuantifiers = []
263 , flexibleQuantifiers = flexiVars ++ vars
413 , flexibleQuantifiers = flexiVars ++ vars
264− , constraint = Ann.noneNoDocs CTrue
414+ , constraint = CTrue
265 , header = Map.singleton name typ
415 , header = Map.singleton name typ
266 }
416 }
267
417
@@ -279,12 +429,12 @@ constrainUnannotatedDef
279 -> [String]
429 -> [String]
280 -> String
430 -> String
281 -> Canonical.Expr
431 -> Canonical.Expr
282− -> ErrorT [PP.Doc] IO Info
432+ -> IO Info
283constrainUnannotatedDef env info qs name expr =
433constrainUnannotatedDef env info qs name expr =
284 do -- Some mistake may be happening here. Currently, qs is always [].
434 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)
286
436
287− v <- liftIO $ variable Flexible
437+ v <- variable Flexible
288
438
289 let tipe = varN v
439 let tipe = varN v
290
440
src/Type/Constrain/Literal.hs+24−16
@@ -1,21 +1,29 @@
1module Type.Constrain.Literal where
1module Type.Constrain.Literal where
2
2
3−import AST.Annotation
4−import AST.Literal
3+import qualified AST.Literal as L
4+import qualified Reporting.Error.Type as Error
5+import qualified Reporting.Region as R
5−import Type.Type
6+import qualified Type.Type as T
6−import Type.Environment as Env
7+import qualified Type.Environment as Env
7
8
9+
10+constrain
11+ :: Env.Environment
12+ -> R.Region
13+ -> L.Literal
14+ -> T.Type
8−constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
15+ -> IO T.TypeConstraint
9constrain env region literal tipe =
16constrain env region literal tipe =
10− do tipe' <- litType
17+ do tipe' <- litType
11− return . A region $ CEqual tipe tipe'
18+ return (T.CEqual Error.None region tipe tipe')
12− where
19+ where
20+ prim name =
13− prim name = return (Env.get env Env.types name)
21+ return (Env.get env Env.types name)
14
22
15− litType =
23+ litType =
16− case literal of
24+ case literal of
17− IntNum _ -> varN `fmap` variable (Is Number)
25+ L.IntNum _ -> T.varN `fmap` T.variable (T.Is T.Number)
18− FloatNum _ -> prim "Float"
26+ L.FloatNum _ -> prim "Float"
19− Chr _ -> prim "Char"
27+ L.Chr _ -> prim "Char"
20− Str _ -> prim "String"
28+ L.Str _ -> prim "String"
21− Boolean _ -> prim "Bool"
29+ L.Boolean _ -> prim "Bool"
src/Type/Constrain/Pattern.hs+52−62
@@ -4,78 +4,68 @@ module Type.Constrain.Pattern where
4import Control.Arrow (second)
4import Control.Arrow (second)
5import Control.Applicative ((<$>))
5import Control.Applicative ((<$>))
6import qualified Control.Monad as Monad
6import qualified Control.Monad as Monad
7−import Control.Monad.Error
8import qualified Data.Map as Map
7import qualified Data.Map as Map
9−import qualified Text.PrettyPrint as PP
10
8
11−import qualified AST.Annotation as A
12import qualified AST.Pattern as P
9import qualified AST.Pattern as P
13import qualified AST.Variable as V
10import qualified AST.Variable as V
14−import AST.PrettyPrint (pretty)
11+import qualified Reporting.Annotation as A
15−import Type.Type
12+import qualified Reporting.Error.Type as Error
16−import Type.Fragment
17−import Type.Environment as Env
18import qualified Type.Constrain.Literal as Literal
13import qualified Type.Constrain.Literal as Literal
14+import qualified Type.Environment as Env
15+import Type.Fragment
16+import Type.Type
19
17
20
18
19+constrain
20+ :: Env.Environment
21−constrain :: Environment -> P.CanonicalPattern -> Type
21+ -> P.CanonicalPattern
22+ -> Type
22− -> ErrorT (A.Region -> PP.Doc) IO Fragment
23+ -> IO Fragment
23−constrain env pattern tipe =
24+constrain env (A.A region pattern) tipe =
24− let region = A.None (pretty pattern)
25+ let (===) = CEqual Error.None region
25− t1 === t2 = A.A region (CEqual t1 t2)
26− in
26+ in
27− case pattern of
27+ case pattern of
28− P.Anything -> return emptyFragment
28+ P.Anything ->
29−
30− P.Literal lit -> do
31− c <- liftIO $ Literal.constrain env region lit tipe
32− return $ emptyFragment { typeConstraint = c }
29+ return emptyFragment
33
30
34− P.Var name -> do
31+ P.Literal lit ->
35− v <- liftIO $ variable Flexible
32+ do c <- Literal.constrain env region lit tipe
36− return $ Fragment {
37− typeEnv = Map.singleton name (varN v),
38− vars = [v],
39− typeConstraint = varN v === tipe
33+ return $ emptyFragment { typeConstraint = c }
40− }
41
34
42− P.Alias name p -> do
35+ P.Var name ->
43− v <- liftIO $ variable Flexible
36+ do v <- variable Flexible
44− fragment <- constrain env p tipe
45− return $ fragment
37+ return $ Fragment
46− { typeEnv = Map.insert name (varN v) (typeEnv fragment)
38+ { typeEnv = Map.singleton name (varN v)
47− , vars = v : vars fragment
39+ , vars = [v]
48− , typeConstraint = varN v === tipe /\ typeConstraint fragment
40+ , typeConstraint = varN v === tipe
49− }
41+ }
50
42
51− P.Data name patterns -> do
43+ P.Alias name p ->
52− (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)
44+ do v <- variable Flexible
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)
45+ fragment <- constrain env p tipe
62− return $ fragment {
46+ return $ fragment
63− typeConstraint = typeConstraint fragment /\ tipe === result,
47+ { typeEnv = Map.insert name (varN v) (typeEnv fragment)
64− vars = cvars ++ vars fragment
48+ , vars = v : vars fragment
49+ , typeConstraint = varN v === tipe /\ typeConstraint fragment
65 }
50 }
66
51
67− P.Record fields -> do
52+ P.Data name patterns ->
68− pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields
53+ do (_kind, cvars, args, result) <-
69− let tenv = Map.fromList (map (second varN) pairs)
54+ Env.freshDataScheme env (V.toString name)
70− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
55+
71− return $ Fragment {
56+ fragList <- Monad.zipWithM (constrain env) patterns args
72− typeEnv = tenv,
57+ let fragment = joinFragments fragList
73− vars = map snd pairs,
58+ return $ fragment
74− typeConstraint = c
59+ { typeConstraint = typeConstraint fragment /\ tipe === result
60+ , vars = cvars ++ vars fragment
75− }
61+ }
76
62
77−instance Error (A.Region -> PP.Doc) where
63+ P.Record fields ->
78− noMsg _ = PP.empty
64+ do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields
79− strMsg str span =
65+ let tenv = Map.fromList (map (second varN) pairs)
80− PP.vcat [ PP.text $ "Type error " ++ show span
66+ c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
81− , PP.text str ]
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 @@
1module Type.Environment where
1module Type.Environment where
2
2
3import Control.Applicative ((<$>), (<*>))
3import Control.Applicative ((<$>), (<*>))
4−import Control.Exception (try, SomeException)
4+import Control.Monad (forM)
5−import Control.Monad
6−import Control.Monad.Error (ErrorT, throwError, liftIO)
7import qualified Control.Monad.State as State
5import qualified Control.Monad.State as State
8import qualified Data.Traversable as Traverse
6import qualified Data.Traversable as Traverse
9import qualified Data.Map as Map
7import qualified Data.Map as Map
10import qualified Data.Set as Set
8import qualified Data.Set as Set
11import Data.List (isPrefixOf)
9import Data.List (isPrefixOf)
12−import qualified Text.PrettyPrint as PP
13
10
14import qualified AST.Type as T
11import qualified AST.Type as T
15import qualified AST.Variable as V
12import qualified AST.Variable as V
16−import AST.Module (CanonicalAdt, AdtInfo)
13+import qualified AST.Module as Module
17import Type.Type
14import Type.Type
18
15
19
16
@@ -28,7 +25,7 @@ data Environment = Environment
28 }
25 }
29
26
30
27
31−initialEnvironment :: [CanonicalAdt] -> IO Environment
28+initialEnvironment :: [Module.CanonicalAdt] -> IO Environment
32initialEnvironment datatypes =
29initialEnvironment datatypes =
33 do types <- makeTypes datatypes
30 do types <- makeTypes datatypes
34 let env =
31 let env =
@@ -40,13 +37,13 @@ initialEnvironment datatypes =
40 return $ env { constructor = makeConstructors env datatypes }
37 return $ env { constructor = makeConstructors env datatypes }
41
38
42
39
43−makeTypes :: [CanonicalAdt] -> IO TypeDict
40+makeTypes :: [Module.CanonicalAdt] -> IO TypeDict
44makeTypes datatypes =
41makeTypes datatypes =
45 do adts <- mapM makeImported datatypes
42 do adts <- mapM makeImported datatypes
46 bs <- mapM makeBuiltin builtins
43 bs <- mapM makeBuiltin builtins
47 return (Map.fromList (adts ++ bs))
44 return (Map.fromList (adts ++ bs))
48 where
45 where
49− makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
46+ makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)
50 makeImported (var, _) =
47 makeImported (var, _) =
51 do tvar <- namedVar Constant var
48 do tvar <- namedVar Constant var
52 return (V.toString var, varN tvar)
49 return (V.toString var, varN tvar)
@@ -70,7 +67,7 @@ makeTypes datatypes =
70
67
71makeConstructors
68makeConstructors
72 :: Environment
69 :: Environment
73− -> [CanonicalAdt]
70+ -> [Module.CanonicalAdt]
74 -> Map.Map String (IO (Int, [Variable], [Type], Type))
71 -> Map.Map String (IO (Int, [Variable], [Type], Type))
75makeConstructors env datatypes =
72makeConstructors env datatypes =
76 Map.fromList builtins
73 Map.fromList builtins
@@ -98,18 +95,18 @@ makeConstructors env datatypes =
98
95
99ctorToType
96ctorToType
100 :: Environment
97 :: Environment
101− -> (V.Canonical, AdtInfo V.Canonical)
98+ -> (V.Canonical, Module.AdtInfo V.Canonical)
102 -> [(String, IO (Int, [Variable], [Type], Type))]
99 -> [(String, IO (Int, [Variable], [Type], Type))]
103ctorToType env (name, (tvars, ctors)) =
100ctorToType env (name, (tvars, ctors)) =
104 zip (map (V.toString . fst) ctors) (map inst ctors)
101 zip (map (V.toString . fst) ctors) (map inst ctors)
105 where
102 where
106− inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
103+ inst :: (V.Canonical, [T.Canonical]) -> IO (Int, [Variable], [Type], Type)
107 inst ctor =
104 inst ctor =
108 do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
105 do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
109 return (length args, Map.elems dict, args, tipe)
106 return (length args, Map.elems dict, args, tipe)
110
107
111
108
112− go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
109+ go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)
113 go (_, args) =
110 go (_, args) =
114 do types <- mapM (instantiator env) args
111 do types <- mapM (instantiator env) args
115 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
112 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
@@ -133,22 +130,17 @@ freshDataScheme env name =
133
130
134instantiateType
131instantiateType
135 :: Environment
132 :: Environment
136− -> T.CanonicalType
133+ -> T.Canonical
137 -> VarDict
134 -> VarDict
138− -> ErrorT [PP.Doc] IO ([Variable], Type)
135+ -> IO ([Variable], Type)
139instantiateType env sourceType dict =
136instantiateType env sourceType dict =
140− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
137+ do (tipe, dict') <- 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)
138+ return (Map.elems dict', tipe)
147
139
148
140
149instantiator
141instantiator
150 :: Environment
142 :: Environment
151− -> T.CanonicalType
143+ -> T.Canonical
152 -> State.StateT VarDict IO Type
144 -> State.StateT VarDict IO Type
153instantiator env sourceType =
145instantiator env sourceType =
154 instantiatorHelp env Set.empty sourceType
146 instantiatorHelp env Set.empty sourceType
@@ -157,7 +149,7 @@ instantiator env sourceType =
157instantiatorHelp
149instantiatorHelp
158 :: Environment
150 :: Environment
159 -> Set.Set String
151 -> Set.Set String
160− -> T.CanonicalType
152+ -> T.Canonical
161 -> State.StateT VarDict IO Type
153 -> State.StateT VarDict IO Type
162instantiatorHelp env aliasVars sourceType =
154instantiatorHelp env aliasVars sourceType =
163 let go = instantiatorHelp env aliasVars
155 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
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6
6
7import Type.Type
7import Type.Type
8−import AST.Annotation (noneNoDocs)
8+
9
9
10data Fragment = Fragment
10data Fragment = Fragment
11− { typeEnv :: Map.Map String Type
11+ { typeEnv :: Map.Map String Type
12− , vars :: [Variable]
12+ , vars :: [Variable]
13 , typeConstraint :: TypeConstraint
13 , typeConstraint :: TypeConstraint
14 }
14 }
15
15
16
16
17emptyFragment :: Fragment
17emptyFragment :: Fragment
18emptyFragment =
18emptyFragment =
19− Fragment Map.empty [] (noneNoDocs CTrue)
19+ Fragment Map.empty [] CTrue
20
20
21
21
22joinFragment :: Fragment -> Fragment -> Fragment
22joinFragment :: Fragment -> Fragment -> Fragment
23joinFragment f1 f2 =
23joinFragment f1 f2 =
24 Fragment
24 Fragment
25− { typeEnv =
25+ { typeEnv =
26− Map.union (typeEnv f1) (typeEnv f2)
26+ Map.union (typeEnv f1) (typeEnv f2)
27
27
28− , vars =
28+ , vars =
29− vars f1 ++ vars f2
29+ vars f1 ++ vars f2
30
30
31− , typeConstraint =
31+ , typeConstraint =
32− typeConstraint f1 /\ typeConstraint f2
32+ typeConstraint f1 /\ typeConstraint f2
33− }
33+ }
34
34
35
35
36joinFragments :: [Fragment] -> Fragment
36joinFragments :: [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 @@
1module Type.Inference where
1module Type.Inference where
2
2
3import Control.Arrow (first, second)
3import Control.Arrow (first, second)
4−import Control.Monad.State (execStateT, forM)
4+import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)
5−import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)
6import qualified Data.Map as Map
5import qualified Data.Map as Map
7−import Text.PrettyPrint
6+import qualified Data.Traversable as Traverse
8
7
9−import qualified AST.Annotation as A
10import AST.Module as Module
8import AST.Module as Module
11−import AST.Type (CanonicalType)
9+import qualified AST.Type as Type
12import qualified AST.Variable as Var
10import qualified AST.Variable as Var
11+import qualified Reporting.Annotation as A
12+import qualified Reporting.Error.Type as Error
13import qualified Type.Constrain.Expression as TcExpr
13import qualified Type.Constrain.Expression as TcExpr
14import qualified Type.Environment as Env
14import qualified Type.Environment as Env
15−import qualified Type.ExtraChecks as Check
16import qualified Type.Solve as Solve
15import qualified Type.Solve as Solve
17import qualified Type.State as TS
16import qualified Type.State as TS
18import qualified Type.Type as T
17import qualified Type.Type as T
@@ -22,50 +21,56 @@ import System.IO.Unsafe
22 -- I don't think that'd be worthwhile though.
21 -- I don't think that'd be worthwhile though.
23
22
24
23
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)
26infer interfaces modul =
28infer interfaces modul =
27− unsafePerformIO $ runErrorT $
29+ either throwError return $ unsafePerformIO $ runExceptT $
30+ do (header, constraint) <-
28− do (header, constraint) <- genConstraints interfaces modul
31+ liftIO (genConstraints interfaces modul)
29−
30− state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
31
32
32− () <- case TS.sHint state of
33+ state <- Solve.solve constraint
33− hints@(_:_) -> throwError hints
34− [] -> return ()
35
34
36 let header' = Map.delete "::" header
35 let header' = Map.delete "::" header
37− types = Map.difference (TS.sSavedEnv state) header'
36+ let types = Map.difference (TS.sSavedEnv state) header'
38
37
39− Check.effectTypes types
38+ liftIO (Traverse.traverse T.toSrcType types)
40
39
41
40
42genConstraints
41genConstraints
43 :: Interfaces
42 :: Interfaces
44 -> CanonicalModule
43 -> CanonicalModule
45− -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)
44+ -> IO (Env.TypeDict, T.TypeConstraint)
46genConstraints interfaces modul =
45genConstraints interfaces modul =
46+ do env <-
47− do env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
47+ Env.initialEnvironment (canonicalizeAdts interfaces modul)
48
48
49+ ctors <-
49− ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
50+ forM (Map.keys (Env.constructor env)) $ \name ->
50− (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
51+ do (_, vars, args, result) <- Env.freshDataScheme env name
51− return (name, (vars, foldr (T.==>) result args))
52+ return (name, (vars, foldr (T.==>) result args))
52
53
54+ importedVars <-
53− importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
55+ mapM (canonicalizeValues env) (Map.toList interfaces)
54
56
55 let allTypes = concat (ctors : importedVars)
57 let allTypes = concat (ctors : importedVars)
56− vars = concatMap (fst . snd) allTypes
58+ let vars = concatMap (fst . snd) allTypes
57− header = Map.map snd (Map.fromList allTypes)
59+ let header = Map.map snd (Map.fromList allTypes)
58− environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
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)
59
66
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)
63
68
64
69
65canonicalizeValues
70canonicalizeValues
66 :: Env.Environment
71 :: Env.Environment
67 -> (Module.Name, Interface)
72 -> (Module.Name, Interface)
68− -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
73+ -> IO [(String, ([T.Variable], T.Type))]
69canonicalizeValues env (moduleName, iface) =
74canonicalizeValues env (moduleName, iface) =
70 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
75 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
71 do tipe' <- Env.instantiateType env tipe Map.empty
76 do tipe' <- Env.instantiateType env tipe Map.empty
src/Type/Solve.hs+158−92
@@ -1,29 +1,32 @@
1module Type.Solve (solve) where
1module Type.Solve (solve) where
2
2
3+import Control.Applicative ((<$>), (<*>))
3import Control.Monad
4import Control.Monad
4−import Control.Monad.State
5+import Control.Monad.State (StateT, execStateT, liftIO)
6+import Control.Monad.Except (ExceptT, throwError)
5import qualified Data.List as List
7import qualified Data.List as List
6import qualified Data.Map as Map
8import qualified Data.Map as Map
7import qualified Data.Traversable as Traversable
9import qualified Data.Traversable as Traversable
8import qualified Data.UnionFind.IO as UF
10import 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
9import Type.Type
15import Type.Type
10import Type.Unify
16import 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
15
17
16
18
17−-- | Every variable has rank less than or equal to the maxRank of the pool.
19+{-| 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.
20+This sorts variables into the young and old pools accordingly.
21+-}
19generalize :: TS.Pool -> StateT TS.SolverState IO ()
22generalize :: TS.Pool -> StateT TS.SolverState IO ()
20generalize youngPool =
23generalize youngPool =
21− do youngMark <- TS.uniqueMark
24+ do youngMark <- TS.uniqueMark
22 let youngRank = TS.maxRank youngPool
25 let youngRank = TS.maxRank youngPool
23− insert dict var = do
26+ let insert dict var =
24− descriptor <- liftIO $ UF.descriptor var
27+ do descriptor <- liftIO $ UF.descriptor var
25− liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
28+ liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
26− return $ Map.insertWith (++) (rank descriptor) [var] dict
29+ return $ Map.insertWith (++) (rank descriptor) [var] dict
27
30
28 -- Sort the youngPool variables by rank.
31 -- Sort the youngPool variables by rank.
29 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)
32 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)
@@ -37,9 +40,9 @@ generalize youngPool =
37
40
38 -- For variables that have rank lowerer than youngRank, register them in
41 -- For variables that have rank lowerer than youngRank, register them in
39 -- the old pool if they are not redundant.
42 -- the old pool if they are not redundant.
40− let registerIfNotRedundant var = do
43+ let registerIfNotRedundant var =
41− isRedundant <- liftIO $ UF.redundant var
44+ do isRedundant <- liftIO $ UF.redundant var
42− if isRedundant then return var else TS.register var
45+ if isRedundant then return var else TS.register var
43
46
44 let rankDict' = Map.delete youngRank rankDict
47 let rankDict' = Map.delete youngRank rankDict
45 Traversable.traverse (mapM registerIfNotRedundant) rankDict'
48 Traversable.traverse (mapM registerIfNotRedundant) rankDict'
@@ -58,7 +61,7 @@ generalize youngPool =
58 False -> do
61 False -> do
59 let flex' = case flex desc of { Flexible -> Rigid ; other -> other }
62 let flex' = case flex desc of { Flexible -> Rigid ; other -> other }
60 liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
63 liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
61−
64+
62 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
65 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
63
66
64
67
@@ -85,73 +88,96 @@ adjustRank youngMark visitedMark groupRank var =
85 | otherwise ->
88 | otherwise ->
86 return (rank descriptor)
89 return (rank descriptor)
87 where
90 where
91+ adjust =
88− adjust = adjustRank youngMark visitedMark groupRank
92+ adjustRank youngMark visitedMark groupRank
89
93
90 adjustTerm term =
94 adjustTerm term =
91 case term of
95 case term of
96+ App1 a b ->
92− App1 a b -> max `liftM` adjust a `ap` adjust b
97+ max `liftM` adjust a `ap` adjust b
98+
99+ Fun1 a b ->
93− Fun1 a b -> max `liftM` adjust a `ap` adjust b
100+ max `liftM` adjust a `ap` adjust b
101+
102+ Var1 x ->
94− Var1 x -> adjust x
103+ adjust x
104+
105+ EmptyRecord1 ->
95− EmptyRecord1 -> return outermostRank
106+ return outermostRank
107+
96 Record1 fields extension ->
108 Record1 fields extension ->
97− do ranks <- mapM adjust (concat (Map.elems fields))
109+ do ranks <- mapM adjust (concat (Map.elems fields))
98− rnk <- adjust extension
110+ rnk <- adjust extension
99− return . maximum $ rnk : ranks
111+ return . maximum $ rnk : ranks
112+
113+
114+-- SOLVER
100
115
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
101
125
126+
102−solve :: TypeConstraint -> StateT TS.SolverState IO ()
127+actuallySolve :: TypeConstraint -> StateT TS.SolverState IO ()
103−solve (A.A region constraint) =
128+actuallySolve constraint =
104 case constraint of
129 case constraint of
105 CTrue ->
130 CTrue ->
106− return ()
131+ return ()
107
132
108 CSaveEnv ->
133 CSaveEnv ->
109− TS.saveLocalEnv
134+ TS.saveLocalEnv
110
135
111− CEqual term1 term2 ->
136+ CEqual hint region term1 term2 ->
112− do t1 <- TS.flatten term1
137+ do t1 <- TS.flatten term1
113− t2 <- TS.flatten term2
138+ t2 <- TS.flatten term2
114− unify region t1 t2
139+ unify hint region t1 t2
115
140
116 CAnd cs ->
141 CAnd cs ->
117− mapM_ solve cs
142+ mapM_ actuallySolve cs
118
143
119− CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) ->
144+ CLet [Scheme [] fqs constraint' _] CTrue ->
120− do oldEnv <- TS.getEnv
145+ do oldEnv <- TS.getEnv
121− mapM TS.introduce fqs
146+ mapM TS.introduce fqs
122− solve constraint'
147+ actuallySolve constraint'
123− TS.modifyEnv (\_ -> oldEnv)
148+ TS.modifyEnv (\_ -> oldEnv)
124
149
125 CLet schemes constraint' ->
150 CLet schemes constraint' ->
126− do oldEnv <- TS.getEnv
151+ do oldEnv <- TS.getEnv
127− headers <- Map.unions `fmap` mapM (solveScheme region) schemes
152+ headers <- Map.unions `fmap` mapM solveScheme schemes
128− TS.modifyEnv $ \env -> Map.union headers env
153+ TS.modifyEnv $ \env -> Map.union headers env
129− solve constraint'
154+ actuallySolve constraint'
130− mapM Check.occurs $ Map.toList headers
155+ mapM occurs $ Map.toList headers
131− TS.modifyEnv (\_ -> oldEnv)
156+ TS.modifyEnv (\_ -> oldEnv)
132−
157+
133− CInstance name term ->
158+ CInstance region name term ->
134− do env <- TS.getEnv
159+ do env <- TS.getEnv
135− freshCopy <-
160+ freshCopy <-
136− case Map.lookup name env of
161+ case Map.lookup name env of
162+ Just tipe ->
137− Just tipe -> TS.makeInstance tipe
163+ TS.makeInstance tipe
138− Nothing
164+ Nothing ->
139− | List.isPrefixOf "Native." name -> liftIO (variable Flexible)
165+ if List.isPrefixOf "Native." name
140− | otherwise ->
166+ then liftIO (variable Flexible)
141− error ("Could not find '" ++ name ++ "' when solving type constraints.")
167+ else error ("Could not find '" ++ name ++ "' when solving type constraints.")
142−
168+
143− t <- TS.flatten term
169+ t <- TS.flatten term
144− unify region freshCopy t
170+ unify Error.None region freshCopy t
145−
171+
146−
172+
147−solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
173+solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
148−solveScheme region scheme =
174+solveScheme scheme =
149− case scheme of
175+ case scheme of
150− Scheme [] [] constraint header ->
176+ Scheme [] [] constraint header ->
151− do solve constraint
177+ do actuallySolve constraint
152 Traversable.traverse TS.flatten header
178 Traversable.traverse TS.flatten header
153
179
154− Scheme rigidQuantifiers flexibleQuantifiers constraint header ->
180+ Scheme rigidQuantifiers flexibleQuantifiers constraint header ->
155 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
181 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
156 oldPool <- TS.getPool
182 oldPool <- TS.getPool
157
183
@@ -160,54 +186,94 @@ solveScheme region scheme =
160 TS.switchToPool freshPool
186 TS.switchToPool freshPool
161 mapM TS.introduce quantifiers
187 mapM TS.introduce quantifiers
162 header' <- Traversable.traverse TS.flatten header
188 header' <- Traversable.traverse TS.flatten header
163− solve constraint
189+ actuallySolve constraint
164
190
165− allDistinct region rigidQuantifiers
191+ allDistinct rigidQuantifiers
166 youngPool <- TS.getPool
192 youngPool <- TS.getPool
167 TS.switchToPool oldPool
193 TS.switchToPool oldPool
168 generalize youngPool
194 generalize youngPool
169− mapM (isGeneric region) rigidQuantifiers
195+ mapM isGeneric rigidQuantifiers
170 return header'
196 return header'
171
197
172
198
173−addHint
199+-- ADDITIONAL CHECKS
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−
183
200
184-- Checks that all of the given variables belong to distinct equivalence classes.
201-- Checks that all of the given variables belong to distinct equivalence classes.
185-- Also checks that their structure is Nothing, so they represent a variable, not
202-- Also checks that their structure is Nothing, so they represent a variable, not
186-- a more complex term.
203-- a more complex term.
187−allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
204+allDistinct :: [Variable] -> StateT TS.SolverState IO ()
188−allDistinct region vars =
205+allDistinct vars =
189 do seen <- TS.uniqueMark
206 do seen <- TS.uniqueMark
190 forM_ vars $ \var ->
207 forM_ vars $ \var ->
191 do desc <- liftIO $ UF.descriptor var
208 do desc <- liftIO $ UF.descriptor var
192 case structure desc of
209 case structure desc of
193 Just _ ->
210 Just _ ->
194− let msg = "Cannot generalize something that is not a type variable."
211+ crash "Cannot generalize something that is not a type variable."
195− in
196− addHint region (Just msg) var var
197
212
198 Nothing ->
213 Nothing ->
199− do when (mark desc == seen) $
214+ if mark desc == seen
200− do let msg = "Duplicate variable during generalization."
215+ then crash "Duplicate variable during generalization."
201− addHint region (Just msg) var var
202− liftIO $ UF.setDescriptor var (desc { mark = seen })
216+ else liftIO (UF.setDescriptor var (desc { mark = seen }))
203
217
204
218
205-- Check that a variable has rank == noRank, meaning that it can be generalized.
219-- Check that a variable has rank == noRank, meaning that it can be generalized.
206−isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
220+isGeneric :: Variable -> StateT TS.SolverState IO ()
207−isGeneric region var =
221+isGeneric var =
208 do desc <- liftIO $ UF.descriptor var
222 do desc <- liftIO $ UF.descriptor var
209 if rank desc == noRank
223 if rank desc == noRank
210 then return ()
224 then return ()
211− else
212− let msg = "Unable to generalize a type variable. It is not unranked."
225+ else crash "Unable to generalize a type variable. It is not unranked."
213− in addHint region (Just msg) var var
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
8import qualified Data.Traversable as Traversable
8import qualified Data.Traversable as Traversable
9import qualified Data.UnionFind.IO as UF
9import qualified Data.UnionFind.IO as UF
10
10
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
12import Type.Type
14import Type.Type
13
15
14
16
@@ -40,7 +42,7 @@ data SolverState = SS
40 , sSavedEnv :: Env
42 , sSavedEnv :: Env
41 , sPool :: Pool
43 , sPool :: Pool
42 , sMark :: Int
44 , sMark :: Int
43− , sHint :: [Hint.Hint]
45+ , sError :: [A.Located Error.Error]
44 }
46 }
45
47
46
48
@@ -51,7 +53,7 @@ initialState =
51 , sSavedEnv = Map.empty
53 , sSavedEnv = Map.empty
52 , sPool = emptyPool
54 , sPool = emptyPool
53 , sMark = noMark + 1 -- The mark must never be equal to noMark!
55 , sMark = noMark + 1 -- The mark must never be equal to noMark!
54− , sHint = []
56+ , sError = []
55 }
57 }
56
58
57
59
@@ -65,9 +67,9 @@ modifyPool f =
65 modify $ \state -> state { sPool = f (sPool state) }
67 modify $ \state -> state { sPool = f (sPool state) }
66
68
67
69
68−addHint :: Hint.Hint -> StateT SolverState IO ()
70+addError :: R.Region -> Error.Error -> StateT SolverState IO ()
69−addHint hint =
71+addError region err =
70− modify $ \state -> state { sHint = hint : sHint state }
72+ modify $ \state -> state { sError = A.A region err : sError state }
71
73
72
74
73switchToPool :: (MonadState SolverState m) => Pool -> m ()
75switchToPool :: (MonadState SolverState m) => Pool -> m ()
src/Type/Type.hs+84−63
@@ -3,7 +3,6 @@ module Type.Type where
3import Control.Applicative ((<$>),(<*>))
3import Control.Applicative ((<$>),(<*>))
4import Control.Monad.State (StateT)
4import Control.Monad.State (StateT)
5import qualified Control.Monad.State as State
5import qualified Control.Monad.State as State
6−import Control.Monad.Error (ErrorT, Error, liftIO)
7import qualified Data.Char as Char
6import qualified Data.Char as Char
8import qualified Data.Map as Map
7import qualified Data.Map as Map
9import qualified Data.Set as Set
8import qualified Data.Set as Set
@@ -12,10 +11,10 @@ import qualified Data.UnionFind.IO as UF
12import Text.PrettyPrint as P
11import Text.PrettyPrint as P
13import System.IO.Unsafe
12import System.IO.Unsafe
14
13
15−import AST.Annotation
16−import qualified AST.PrettyPrint as PP
17import qualified AST.Type as T
14import qualified AST.Type as T
18import qualified AST.Variable as Var
15import qualified AST.Variable as Var
16+import qualified Reporting.Error.Type as Error
17+import qualified Reporting.Region as R
19import Type.PrettyPrint
18import Type.PrettyPrint
20
19
21
20
@@ -103,16 +102,13 @@ data SuperType
103
102
104-- CONSTRAINTS
103-- CONSTRAINTS
105
104
106−type Constraint a b =
105+data Constraint a b
107− Located (BasicConstraint a b)
108−
109−data BasicConstraint a b
110 = CTrue
106 = CTrue
111 | CSaveEnv
107 | CSaveEnv
112− | CEqual a a
108+ | CEqual Error.Hint R.Region a a
113 | CAnd [Constraint a b]
109 | CAnd [Constraint a b]
114 | CLet [Scheme a b] (Constraint a b)
110 | CLet [Scheme a b] (Constraint a b)
115− | CInstance SchemeName a
111+ | CInstance R.Region SchemeName a
116
112
117type SchemeName = String
113type SchemeName = String
118
114
@@ -170,40 +166,40 @@ variable flex = UF.fresh $ Descriptor
170
166
171monoscheme :: Map.Map String a -> Scheme a b
167monoscheme :: Map.Map String a -> Scheme a b
172monoscheme headers =
168monoscheme headers =
173− Scheme [] [] (noneNoDocs CTrue) headers
169+ Scheme [] [] CTrue headers
174
170
175
171
176infixl 8 /\
172infixl 8 /\
177
173
178(/\) :: Constraint a b -> Constraint a b -> Constraint a b
174(/\) :: Constraint a b -> Constraint a b -> Constraint a b
179−(/\) a@(A _ c1) b@(A _ c2) =
175+(/\) c1 c2 =
180 case (c1, c2) of
176 case (c1, c2) of
181− (CTrue, _) -> b
177+ (CTrue, _) -> c2
182− (_, CTrue) -> a
178+ (_, CTrue) -> c1
183− _ -> mergeOldDocs a b (CAnd [a,b])
179+ _ -> CAnd [c1,c2]
184
180
185
181
186-- ex qs constraint == exists qs. constraint
182-- ex qs constraint == exists qs. constraint
187ex :: [Variable] -> TypeConstraint -> TypeConstraint
183ex :: [Variable] -> TypeConstraint -> TypeConstraint
188−ex fqs constraint@(A ann _) =
184+ex fqs constraint =
189− A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
185+ CLet [Scheme [] fqs constraint Map.empty] CTrue
190
186
191
187
192-- fl qs constraint == forall qs. constraint
188-- fl qs constraint == forall qs. constraint
193fl :: [Variable] -> TypeConstraint -> TypeConstraint
189fl :: [Variable] -> TypeConstraint -> TypeConstraint
194−fl rqs constraint@(A ann _) =
190+fl rqs constraint =
195− A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
191+ CLet [Scheme rqs [] constraint Map.empty] CTrue
196
192
197
193
198−exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
194+exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint
199exists f =
195exists f =
200− do v <- liftIO $ variable Flexible
196+ do v <- variable Flexible
201 ex [v] <$> f (varN v)
197 ex [v] <$> f (varN v)
202
198
203
199
204−existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
200+existsNumber :: (Type -> IO TypeConstraint) -> IO TypeConstraint
205existsNumber f =
201existsNumber f =
206− do v <- liftIO $ variable (Is Number)
202+ do v <- variable (Is Number)
207 ex [v] <$> f (varN v)
203 ex [v] <$> f (varN v)
208
204
209
205
@@ -214,11 +210,6 @@ instance PrettyType a => PrettyType (UF.Point a) where
214 unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
210 unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
215
211
216
212
217−instance PrettyType t => PrettyType (Annotated a t) where
218− pretty when (A _ e) =
219− pretty when e
220−
221−
222instance PrettyType a => PrettyType (Term1 a) where
213instance PrettyType a => PrettyType (Term1 a) where
223 pretty when term =
214 pretty when term =
224 let prty = pretty Never in
215 let prty = pretty Never in
@@ -280,14 +271,20 @@ instance PrettyType a => PrettyType (TermN a) where
280 case maybeAlias of
271 case maybeAlias of
281 Nothing -> doc
272 Nothing -> doc
282 Just (name, args) ->
273 Just (name, args) ->
274+ P.hang
275+ (P.text (Var.toString name))
276+ 2
283− P.hang (PP.pretty name) 2 (P.sep (map (pretty App . snd) args))
277+ (P.sep (map (pretty App . snd) args))
284
278
285
279
286instance PrettyType Descriptor where
280instance PrettyType Descriptor where
287 pretty when desc =
281 pretty when desc =
288 case (alias desc, structure desc, name desc) of
282 case (alias desc, structure desc, name desc) of
289 (Just (name, args), _, _) ->
283 (Just (name, args), _, _) ->
284+ P.hang
285+ (P.text (Var.toString name))
286+ 4
290− P.hang (PP.pretty name) 4 (P.sep (map (pretty App . snd) args))
287+ (P.sep (map (pretty App . snd) args))
291
288
292 (_, Just term, _) ->
289 (_, Just term, _) ->
293 pretty when term
290 pretty when term
@@ -301,72 +298,96 @@ instance PrettyType Descriptor where
301 _ -> P.text "?"
298 _ -> P.text "?"
302
299
303
300
304−instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
301+instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where
305 pretty _ constraint =
302 pretty _ constraint =
306 let prty = pretty Never in
303 let prty = pretty Never in
307 case constraint of
304 case constraint of
305+ CTrue ->
308− CTrue -> P.text "True"
306+ P.text "True"
307+
308+ CSaveEnv ->
309− CSaveEnv -> P.text "SaveTheEnvironment!!!"
309+ P.text "SaveTheEnvironment!!!"
310+
311+ CEqual _ _ a b ->
310− CEqual a b -> prty a <+> P.text "=" <+> prty b
312+ prty a <+> P.text "=" <+> prty b
313+
314+ CAnd [] ->
311− CAnd [] -> P.text "True"
315+ P.text "True"
312
316
313 CAnd cs ->
317 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)
315
319
316− CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->
320+ CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->
317 P.sep [ binder, pretty Never c ]
321 P.sep [ binder, pretty Never c ]
318 where
322 where
319− mergeExists vs (A _ c) =
323+ mergeExists vs c =
320 case c of
324 case c of
321− CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'
325+ CLet [Scheme [] fqs' c' _] CTrue -> mergeExists (vs ++ fqs') c'
322 _ -> (vs, c)
326 _ -> (vs, c)
323
327
324 (fqs', c) = mergeExists fqs constraint
328 (fqs', c) = mergeExists fqs constraint
325
329
330+ binder =
331+ if null fqs'
326− binder = if null fqs' then P.empty else
332+ then P.empty
333+ else
327− P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."
334+ P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."
328
335
329 CLet schemes constraint ->
336 CLet schemes constraint ->
337+ P.fsep
330− P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
338+ [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
331− , P.text "in", pretty Never constraint ]
339+ , P.text "in", pretty Never constraint
340+ ]
332
341
333− CInstance name tipe ->
342+ CInstance _region name tipe ->
334− P.text name <+> P.text "<" <+> prty tipe
343+ P.text name <+> P.text "<" <+> prty tipe
335
344
336
345
337instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
346instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
338− pretty _ (Scheme rqs fqs (A _ constraint) headers) =
347+ pretty _ (Scheme rqs fqs constraint headers) =
339 P.sep [ forall, cs, headers' ]
348 P.sep [ forall, cs, headers' ]
340 where
349 where
341 prty = pretty Never
350 prty = pretty Never
342
351
352+ forall =
343− forall = if null rqs && null fqs then P.empty else
353+ if null rqs && null fqs
354+ then P.empty
344− P.text "\x2200" <+> frees <+> rigids
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)
345
369
346− frees = P.hsep $ map prty fqs
370+ headers' =
347− rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs
371+ if Map.size headers > 0 then dict else P.empty
348
372
349− cs = case constraint of
373+ dict =
350− CTrue -> P.empty
374+ P.parens . commaSep . map prettyPair $ Map.toList headers
351− CAnd [] -> P.empty
352− _ -> P.brackets (pretty Never constraint)
353
375
354− headers' = if Map.size headers > 0 then dict else P.empty
376+ prettyPair (n,t) =
355− dict = P.parens . commaSep . map prettyPair $ Map.toList headers
356− prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t
377+ P.text n <+> P.text ":" <+> pretty Never t
357
378
358
379
359-- CONVERT TO SOURCE TYPES
380-- CONVERT TO SOURCE TYPES
360
381
361-- TODO: Attach resulting type to the descriptor so that you
382-- TODO: Attach resulting type to the descriptor so that you
362-- never have to do extra work, particularly nice for aliased types
383-- never have to do extra work, particularly nice for aliased types
363−toSrcType :: Variable -> IO T.CanonicalType
384+toSrcType :: Variable -> IO T.Canonical
364toSrcType variable =
385toSrcType variable =
365 do addNames variable
386 do addNames variable
366 variableToSrcType variable variable
387 variableToSrcType variable variable
367
388
368
389
369−variableToSrcType :: Variable -> Variable -> IO T.CanonicalType
390+variableToSrcType :: Variable -> Variable -> IO T.Canonical
370variableToSrcType rootVariable variable =
391variableToSrcType rootVariable variable =
371 do desc <- UF.descriptor variable
392 do desc <- UF.descriptor variable
372 srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)
393 srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)
@@ -383,7 +404,7 @@ variableToSrcType rootVariable variable =
383 do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args
404 do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args
384 return (T.Aliased name args' (T.Filled srcType))
405 return (T.Aliased name args' (T.Filled srcType))
385 where
406 where
386− backupSrcType :: Descriptor -> IO T.CanonicalType
407+ backupSrcType :: Descriptor -> IO T.Canonical
387 backupSrcType desc =
408 backupSrcType desc =
388 case name desc of
409 case name desc of
389 Just v@(Var.Canonical _ x@(c:_))
410 Just v@(Var.Canonical _ x@(c:_))
@@ -401,7 +422,7 @@ variableToSrcType rootVariable variable =
401 ]
422 ]
402
423
403
424
404−termToSrcType :: Variable -> Term1 Variable -> IO T.CanonicalType
425+termToSrcType :: Variable -> Term1 Variable -> IO T.Canonical
405termToSrcType rootVariable term =
426termToSrcType rootVariable term =
406 let go = variableToSrcType rootVariable in
427 let go = variableToSrcType rootVariable in
407 case term of
428 case term of
@@ -433,7 +454,7 @@ termToSrcType rootVariable term =
433 T.Var _ -> T.Record fields (Just ext')
454 T.Var _ -> T.Record fields (Just ext')
434 _ -> error "Used toSrcType on a type that is not well-formed"
455 _ -> error "Used toSrcType on a type that is not well-formed"
435 where
456 where
436− dealias :: T.CanonicalType -> T.CanonicalType
457+ dealias :: T.Canonical -> T.Canonical
437 dealias tipe =
458 dealias tipe =
438 case tipe of
459 case tipe of
439 T.Aliased _ args tipe' ->
460 T.Aliased _ args tipe' ->
@@ -473,7 +494,7 @@ data NameState = NameState
473
494
474varAddNames :: Variable -> StateT NameState IO ()
495varAddNames :: Variable -> StateT NameState IO ()
475varAddNames var =
496varAddNames var =
476− do desc <- liftIO (UF.descriptor var)
497+ do desc <- State.liftIO (UF.descriptor var)
477 case alias desc of
498 case alias desc of
478 Nothing ->
499 Nothing ->
479 return ()
500 return ()
@@ -490,7 +511,7 @@ varAddNames var =
490 Just _ -> return ()
511 Just _ -> return ()
491 Nothing ->
512 Nothing ->
492 do name' <- createName desc
513 do name' <- createName desc
493− liftIO $ UF.modifyDescriptor var $ \desc ->
514+ State.liftIO $ UF.modifyDescriptor var $ \desc ->
494 desc { name = Just (Var.local name') }
515 desc { name = Just (Var.local name') }
495
516
496
517
src/Type/Unify.hs+94−90
@@ -1,60 +1,74 @@
1module Type.Unify (unify) where
1module Type.Unify (unify) where
2
2
3import Control.Applicative ((<|>))
3import Control.Applicative ((<|>))
4−import Control.Monad.Error (ErrorT, throwError, runErrorT)
4+import Control.Monad.Except (ExceptT, throwError, runExceptT)
5import Control.Monad.State as State
5import Control.Monad.State as State
6import qualified Data.List as List
6import qualified Data.List as List
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8−import qualified Data.Maybe as Maybe
9import qualified Data.UnionFind.IO as UF
8import qualified Data.UnionFind.IO as UF
10import Text.PrettyPrint (render)
9import Text.PrettyPrint (render)
11
10
12−import qualified AST.Annotation as A
11+import qualified AST.Type as AstType
13import qualified AST.Variable as Var
12import qualified AST.Variable as Var
13+import qualified Reporting.Region as R
14+import qualified Reporting.Error.Type as Error
14import qualified Type.State as TS
15import qualified Type.State as TS
15−import Type.Type
16+import Type.Type as Type
16import Type.PrettyPrint
17import Type.PrettyPrint
17−import qualified Type.Hint as Hint
18import Elm.Utils ((|>))
18import Elm.Utils ((|>))
19
19
20
20
21+unify
22+ :: Error.Hint
23+ -> R.Region
24+ -> Variable
25+ -> Variable
21−unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
26+ -> StateT TS.SolverState IO ()
22−unify region variable1 variable2 =
27+unify hint region variable1 variable2 =
23− do result <- runErrorT (unifyHelp region variable1 variable2)
28+ do result <- runExceptT (unifyHelp variable1 variable2)
24− either TS.addHint return result
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
25
36
26
37
27-- ACTUALLY UNIFY STUFF
38-- ACTUALLY UNIFY STUFF
28
39
40+type Unify =
29−type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)
41+ ExceptT RawMismatch (StateT TS.SolverState IO)
42+
43+
44+newtype RawMismatch =
45+ RawMismatch (AstType.Canonical, AstType.Canonical, Error.Note)
30
46
31
47
32typeError
48typeError
33− :: A.Region
34− -> Maybe String
35− -> UF.Point Descriptor
49+ :: UF.Point Descriptor
36 -> UF.Point Descriptor
50 -> UF.Point Descriptor
51+ -> Error.Note
37 -> Unify a
52 -> Unify a
38−typeError region hint t1 t2 =
53+typeError leftType rightType note =
39− do msg <- liftIO (Hint.create region hint t1 t2)
54+ do leftSrcType <- liftIO (toSrcType leftType)
40− throwError msg
55+ rightSrcType <- liftIO (toSrcType rightType)
56+ throwError (RawMismatch (leftSrcType, rightSrcType, note))
41
57
42
58
43−unifyHelp :: A.Region -> Variable -> Variable -> Unify ()
59+unifyHelp :: Variable -> Variable -> Unify ()
44−unifyHelp region variable1 variable2 = do
60+unifyHelp variable1 variable2 =
45− equivalent <- liftIO $ UF.equivalent variable1 variable2
61+ do equivalent <- liftIO $ UF.equivalent variable1 variable2
46− if equivalent
62+ if equivalent
47− then return ()
63+ then return ()
48− else actuallyUnify region variable1 variable2
64+ else actuallyUnify variable1 variable2
49
65
50
66
51−actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()
67+actuallyUnify :: Variable -> Variable -> Unify ()
52−actuallyUnify region variable1 variable2 = do
68+actuallyUnify variable1 variable2 = do
53 desc1 <- liftIO $ UF.descriptor variable1
69 desc1 <- liftIO $ UF.descriptor variable1
54 desc2 <- liftIO $ UF.descriptor variable2
70 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
58
72
59 merge1 :: Unify ()
73 merge1 :: Unify ()
60 merge1 =
74 merge1 =
@@ -100,30 +114,23 @@ actuallyUnify region variable1 variable2 = do
100
114
101 flexAndUnify v =
115 flexAndUnify v =
102 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
116 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
103− unifyHelp' variable1 variable2
117+ unifyHelp variable1 variable2
104
118
105 unifyNumber svar (Var.Canonical home name) =
119 unifyNumber svar (Var.Canonical home name) =
106 case home of
120 case home of
107 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
121 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
108 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
122 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
109 _ ->
123 _ ->
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
124+ typeError variable1 variable2 Error.NoNote
113−
125+
114− comparableError maybe =
126+ comparableError maybeHint =
115− typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
127+ typeError variable1 variable2 $ Error.PostNote $
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."
128+ "Note: comparable types include Int, Float, Char, String, lists, and tuples."
120−
129+ ++ maybe "" ("\n"++) maybeHint
130+
121− appendableError maybe =
131+ appendableError =
122− typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
132+ typeError variable1 variable2 $ Error.PostNote $
123− where
124− msg =
125− "Looks like you want something appendable, but the only Strings, Lists,\n\
133+ "Note: appendable types include only Strings, Lists, and Text."
126− \and Text can be appended with the (++) operator."
127
134
128 unifyComparable v (Var.Canonical home name) =
135 unifyComparable v (Var.Canonical home name) =
129 case home of
136 case home of
@@ -139,29 +146,30 @@ actuallyUnify region variable1 variable2 = do
139
146
140 List v ->
147 List v ->
141 do flexAndUnify varSuper
148 do flexAndUnify varSuper
142− unifyHelp' v =<< liftIO (variable $ Is Comparable)
149+ unifyHelp v =<< liftIO (variable $ Is Comparable)
143
150
144 Tuple vs
151 Tuple vs
145 | length vs > 6 ->
152 | length vs > 6 ->
153+ comparableError $ Just $
146− comparableError $ Just "Cannot compare a tuple with more than 6 elements."
154+ "Furthermore, it cannot be a tuple with more than 6 elements."
147 | otherwise ->
155 | otherwise ->
148 do flexAndUnify varSuper
156 do flexAndUnify varSuper
149 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
157 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
150− zipWithM_ unifyHelp' vs cmpVars
158+ zipWithM_ unifyHelp vs cmpVars
151
159
152 unifyAppendable varSuper varFlex =
160 unifyAppendable varSuper varFlex =
153 do struct <- liftIO $ collectApps varFlex
161 do struct <- liftIO $ collectApps varFlex
154 case struct of
162 case struct of
155 List _ -> flexAndUnify varSuper
163 List _ -> flexAndUnify varSuper
156− _ -> appendableError Nothing
164+ _ -> appendableError
157
165
158 rigidError var =
166 rigidError var =
167+ let v = render (pretty Never var)
168+ in
159− typeError region (Just hint) variable1 variable2
169+ typeError variable1 variable2 $ Error.PreNote $
160− where
161− hint =
162− "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
170+ "Could not unify rigid type variable '" ++ v ++ "'. The problem probably\n"
163− "The problem probably relates to the type variable being shared between a\n\
171+ ++ "relates to the type variable being shared between two type annotations.\n"
164− \top-level type annotation and a related let-bound type annotation."
172+ ++ "Try commenting out some type annotations and see what happens."
165
173
166 superUnify =
174 superUnify =
167 case (flex desc1, flex desc2, name desc1, name desc2) of
175 case (flex desc1, flex desc2, name desc1, name desc2) of
@@ -187,7 +195,7 @@ actuallyUnify region variable1 variable2 = do
187
195
188 (Rigid, _, _, _) -> rigidError variable1
196 (Rigid, _, _, _) -> rigidError variable1
189 (_, Rigid, _, _) -> rigidError variable2
197 (_, Rigid, _, _) -> rigidError variable2
190− _ -> typeError region Nothing variable1 variable2
198+ _ -> typeError variable1 variable2 Error.NoNote
191
199
192 case (structure desc1, structure desc2) of
200 case (structure desc1, structure desc2) of
193 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
201 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
@@ -200,10 +208,10 @@ actuallyUnify region variable1 variable2 = do
200 merge1
208 merge1
201
209
202 (Just (Var1 v), _) ->
210 (Just (Var1 v), _) ->
203− unifyHelp' v variable2
211+ unifyHelp v variable2
204
212
205 (_, Just (Var1 v)) ->
213 (_, Just (Var1 v)) ->
206− unifyHelp' variable1 v
214+ unifyHelp variable1 v
207
215
208 (Nothing, _) ->
216 (Nothing, _) ->
209 superUnify
217 superUnify
@@ -215,38 +223,37 @@ actuallyUnify region variable1 variable2 = do
215 case (type1,type2) of
223 case (type1,type2) of
216 (App1 term1 term2, App1 term1' term2') ->
224 (App1 term1 term2, App1 term1' term2') ->
217 do merge
225 do merge
218− unifyHelp' term1 term1'
226+ unifyHelp term1 term1'
219− unifyHelp' term2 term2'
227+ unifyHelp term2 term2'
220 (Fun1 term1 term2, Fun1 term1' term2') ->
228 (Fun1 term1 term2, Fun1 term1' term2') ->
221 do merge
229 do merge
222− unifyHelp' term1 term1'
230+ unifyHelp term1 term1'
223− unifyHelp' term2 term2'
231+ unifyHelp term2 term2'
224
232
225 (EmptyRecord1, EmptyRecord1) ->
233 (EmptyRecord1, EmptyRecord1) ->
226 return ()
234 return ()
227
235
228− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2
236+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
229− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' variable1 ext
237+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
230
238
231 (Record1 _ _, Record1 _ _) ->
239 (Record1 _ _, Record1 _ _) ->
232− recordUnify region fresh variable1 variable2
240+ recordUnify fresh variable1 variable2
233
241
234− _ -> typeError region Nothing variable1 variable2
242+ _ -> typeError variable1 variable2 Error.NoNote
235
243
236
244
237-- RECORD UNIFICATION
245-- RECORD UNIFICATION
238
246
239recordUnify
247recordUnify
240− :: A.Region
241− -> (Maybe (Term1 Variable) -> Unify Variable)
248+ :: (Maybe (Term1 Variable) -> Unify Variable)
242 -> Variable
249 -> Variable
243 -> Variable
250 -> Variable
244 -> Unify ()
251 -> Unify ()
245−recordUnify region fresh variable1 variable2 =
252+recordUnify fresh variable1 variable2 =
246 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
253 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
247 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
254 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
248
255
249− unifyOverlappingFields region fields1 fields2
256+ unifyOverlappingFields fields1 fields2
250
257
251 let freshRecord fields ext =
258 let freshRecord fields ext =
252 fresh (Just (Record1 fields ext))
259 fresh (Just (Record1 fields ext))
@@ -255,59 +262,57 @@ recordUnify region fresh variable1 variable2 =
255 let uniqueFields2 = diffFields fields2 fields1
262 let uniqueFields2 = diffFields fields2 fields1
256
263
257 let addFieldMismatchError missingFields =
264 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
261
267
262 case (ext1, ext2) of
268 case (ext1, ext2) of
263 (Empty _, Empty _) ->
269 (Empty _, Empty _) ->
264 case Map.null uniqueFields1 && Map.null uniqueFields2 of
270 case Map.null uniqueFields1 && Map.null uniqueFields2 of
265 True -> return ()
271 True -> return ()
266− False -> typeError region Nothing variable1 variable2
272+ False -> typeError variable1 variable2 Error.NoNote
267
273
268 (Empty var1, Extension var2) ->
274 (Empty var1, Extension var2) ->
269 case (Map.null uniqueFields1, Map.null uniqueFields2) of
275 case (Map.null uniqueFields1, Map.null uniqueFields2) of
270 (_, False) -> addFieldMismatchError uniqueFields2
276 (_, False) -> addFieldMismatchError uniqueFields2
271− (True, True) -> unifyHelp region var1 var2
277+ (True, True) -> unifyHelp var1 var2
272 (False, True) ->
278 (False, True) ->
273 do subRecord <- freshRecord uniqueFields1 var1
279 do subRecord <- freshRecord uniqueFields1 var1
274− unifyHelp region subRecord var2
280+ unifyHelp subRecord var2
275
281
276 (Extension var1, Empty var2) ->
282 (Extension var1, Empty var2) ->
277 case (Map.null uniqueFields1, Map.null uniqueFields2) of
283 case (Map.null uniqueFields1, Map.null uniqueFields2) of
278 (False, _) -> addFieldMismatchError uniqueFields1
284 (False, _) -> addFieldMismatchError uniqueFields1
279− (True, True) -> unifyHelp region var1 var2
285+ (True, True) -> unifyHelp var1 var2
280 (True, False) ->
286 (True, False) ->
281 do subRecord <- freshRecord uniqueFields2 var2
287 do subRecord <- freshRecord uniqueFields2 var2
282− unifyHelp region var1 subRecord
288+ unifyHelp var1 subRecord
283
289
284 (Extension var1, Extension var2) ->
290 (Extension var1, Extension var2) ->
285 case (Map.null uniqueFields1, Map.null uniqueFields2) of
291 case (Map.null uniqueFields1, Map.null uniqueFields2) of
286 (True, True) ->
292 (True, True) ->
287− unifyHelp region var1 var2
293+ unifyHelp var1 var2
288
294
289 (True, False) ->
295 (True, False) ->
290 do subRecord <- freshRecord uniqueFields2 var2
296 do subRecord <- freshRecord uniqueFields2 var2
291− unifyHelp region var1 subRecord
297+ unifyHelp var1 subRecord
292
298
293 (False, True) ->
299 (False, True) ->
294 do subRecord <- freshRecord uniqueFields1 var1
300 do subRecord <- freshRecord uniqueFields1 var1
295− unifyHelp region subRecord var2
301+ unifyHelp subRecord var2
296
302
297 (False, False) ->
303 (False, False) ->
298 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
304 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
299 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
305 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
300− unifyHelp region record1' var2
306+ unifyHelp record1' var2
301− unifyHelp region var1 record2'
307+ unifyHelp var1 record2'
302
308
303
309
304unifyOverlappingFields
310unifyOverlappingFields
305− :: A.Region
306− -> Map.Map String [Variable]
311+ :: Map.Map String [Variable]
307 -> Map.Map String [Variable]
312 -> Map.Map String [Variable]
308 -> Unify ()
313 -> Unify ()
309−unifyOverlappingFields region fields1 fields2 =
314+unifyOverlappingFields fields1 fields2 =
310− Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2
315+ Map.intersectionWith (zipWith unifyHelp) fields1 fields2
311 |> Map.elems
316 |> Map.elems
312 |> concat
317 |> concat
313 |> sequence_
318 |> sequence_
@@ -351,10 +356,9 @@ fieldMismatchError missingFields =
351 case Map.keys missingFields of
356 case Map.keys missingFields of
352 [] -> ""
357 [] -> ""
353 [key] ->
358 [key] ->
354− "Looks like a record is missing the field '" ++ key ++ "'.\n " ++
359+ "Looks like a record is missing the field '" ++ key ++ "'"
355− "Maybe there is a misspelling in a record access or record update?"
356 keys ->
360 keys ->
357− "Looks like one record is missing fields "
361+ "Looks like a record is missing fields "
358 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
362 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
359
363
360
364
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+