git.iko.soy/elk
on master help sign in
Error reporting overhaul (BIG)
ee3b209Evan Czaplicki
elm-compiler.cabal+4−13
compare with master
unifiedsplit
@@ -46,7 +46,6 @@ Library
46 Elm.Utils
46 Elm.Utils
47
47
48 other-modules:
48 other-modules:
49− AST.Annotation,
50 AST.Declaration,
49 AST.Declaration,
51 AST.Expression.General,
50 AST.Expression.General,
52 AST.Expression.Source,
51 AST.Expression.Source,
@@ -56,7 +55,6 @@ Library
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,
62 Compile,
60 Compile,
@@ -74,10 +72,6 @@ Library
74 Transform.Canonicalize.Setup,
72 Transform.Canonicalize.Setup,
75 Transform.Canonicalize.Type,
73 Transform.Canonicalize.Type,
76 Transform.Canonicalize.Variable,
74 Transform.Canonicalize.Variable,
77− Transform.Check,
78− Transform.Expression,
79− Transform.Declaration,
80− Transform.Definition,
81 Transform.Interface,
75 Transform.Interface,
82 Transform.SortDefinitions,
76 Transform.SortDefinitions,
83 Transform.Substitute,
77 Transform.Substitute,
@@ -96,7 +90,6 @@ Library
96 Type.Environment,
90 Type.Environment,
97 Type.ExtraChecks,
91 Type.ExtraChecks,
98 Type.Fragment,
92 Type.Fragment,
99− Type.Hint,
100 Type.Inference,
93 Type.Inference,
101 Type.PrettyPrint,
94 Type.PrettyPrint,
102 Type.Solve,
95 Type.Solve,
@@ -121,7 +114,7 @@ Library
121 indents >= 0.3 && < 0.4,
114 indents >= 0.3 && < 0.4,
122 language-ecmascript >= 0.15 && < 0.18,
115 language-ecmascript >= 0.15 && < 0.18,
123 language-glsl >= 0.0.2 && < 0.2,
116 language-glsl >= 0.0.2 && < 0.2,
124− mtl >= 2 && < 3,
117+ mtl >= 2.2 && < 3,
125 parsec >= 3.1.1 && < 3.5,
118 parsec >= 3.1.1 && < 3.5,
126 pretty >= 1.0 && < 2.0,
119 pretty >= 1.0 && < 2.0,
127 process,
120 process,
@@ -143,14 +136,12 @@ Executable elm-doc
143
136
144 other-modules:
137 other-modules:
145 Elm.Compiler.Version,
138 Elm.Compiler.Version,
146− AST.Annotation,
147 AST.Declaration,
139 AST.Declaration,
148 AST.Expression.General,
140 AST.Expression.General,
149 AST.Helpers,
141 AST.Helpers,
150 AST.Literal,
142 AST.Literal,
151 AST.Module,
143 AST.Module,
152 AST.Pattern,
144 AST.Pattern,
153− AST.PrettyPrint,
154 AST.Type,
145 AST.Type,
155 AST.Variable,
146 AST.Variable,
156 Parse.Binop,
147 Parse.Binop,
@@ -174,7 +165,7 @@ Executable elm-doc
174 filepath >= 1 && < 2.0,
165 filepath >= 1 && < 2.0,
175 indents >= 0.3 && < 0.4,
166 indents >= 0.3 && < 0.4,
176 language-glsl >= 0.0.2 && < 0.2,
167 language-glsl >= 0.0.2 && < 0.2,
177− mtl >= 2 && < 3,
168+ mtl >= 2.2 && < 3,
178 parsec >= 3.1.1 && < 3.5,
169 parsec >= 3.1.1 && < 3.5,
179 pretty >= 1.0 && < 2.0,
170 pretty >= 1.0 && < 2.0,
180 process,
171 process,
@@ -208,7 +199,7 @@ Executable elm
208 filepath >= 1 && < 2.0,
199 filepath >= 1 && < 2.0,
209 indents >= 0.3 && < 0.4,
200 indents >= 0.3 && < 0.4,
210 language-glsl >= 0.0.2 && < 0.2,
201 language-glsl >= 0.0.2 && < 0.2,
211− mtl >= 2 && < 3,
202+ mtl >= 2.2 && < 3,
212 parsec >= 3.1.1 && < 3.5,
203 parsec >= 3.1.1 && < 3.5,
213 pretty >= 1.0 && < 2.0,
204 pretty >= 1.0 && < 2.0,
214 process,
205 process,
@@ -258,7 +249,7 @@ Test-Suite compiler-tests
258 indents >= 0.3 && < 0.4,
249 indents >= 0.3 && < 0.4,
259 language-ecmascript >= 0.15 && < 0.18,
250 language-ecmascript >= 0.15 && < 0.18,
260 language-glsl >= 0.0.2 && < 0.2,
251 language-glsl >= 0.0.2 && < 0.2,
261− mtl >= 2 && < 3,
252+ mtl >= 2.2 && < 3,
262 parsec >= 3.1.1 && < 3.5,
253 parsec >= 3.1.1 && < 3.5,
263 pretty >= 1.0 && < 2.0,
254 pretty >= 1.0 && < 2.0,
264 process,
255 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+32−69
@@ -4,55 +4,57 @@ 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 =
42− Module (Var.Listing Var.Value) [Decl.SourceDecl]
41+ Module [UserImport] (Var.Listing Var.Value) [Decl.SourceDecl]
43
42
44type ValidModule =
43type ValidModule =
44+ Module
45+ ([DefaultImport], [UserImport])
45− Module (Var.Listing Var.Value) [Decl.ValidDecl]
46+ (Var.Listing Var.Value)
47+ [Decl.ValidDecl]
46
48
47type CanonicalModule =
49type CanonicalModule =
48− Module [Var.Value] CanonicalBody
50+ Module [Name] [Var.Value] CanonicalBody
49
51
50
52
51−data Module exports body = Module
53+data Module imports exports body = Module
52 { names :: Name
54 { names :: Name
53 , path :: FilePath
55 , path :: FilePath
54 , exports :: exports
56 , exports :: exports
55− , imports :: [(Name, ImportMethod)]
57+ , imports :: imports
56 , body :: body
58 , body :: body
57 }
59 }
58
60
@@ -69,10 +71,10 @@ data CanonicalBody = CanonicalBody
69-- HEADERS
71-- HEADERS
70
72
71{-| Basic info needed to identify modules and determine dependencies. -}
73{-| Basic info needed to identify modules and determine dependencies. -}
72−data HeaderAndImports = HeaderAndImports
74+data Header imports = Header
73 { _names :: Name
75 { _names :: Name
74 , _exports :: Var.Listing Var.Value
76 , _exports :: Var.Listing Var.Value
75− , _imports :: [(Name, ImportMethod)]
77+ , _imports :: imports
76 }
78 }
77
79
78
80
@@ -91,6 +93,19 @@ nameIsNative name =
91 _ -> False
93 _ -> False
92
94
93
95
96+-- IMPORTs
97+
98+type UserImport = A.Located (Name, ImportMethod)
99+
100+
101+type DefaultImport = (Name, ImportMethod)
102+
103+
104+data ImportMethod = ImportMethod
105+ { alias :: Maybe String
106+ , exposedVars :: !(Var.Listing Var.Value)
107+ }
108+
94
109
95-- INTERFACES
110-- INTERFACES
96
111
@@ -99,7 +114,7 @@ data Interface = Interface
99 { iVersion :: String
114 { iVersion :: String
100 , iExports :: [Var.Value]
115 , iExports :: [Var.Value]
101 , iTypes :: Types
116 , iTypes :: Types
102− , iImports :: [(Name, ImportMethod)]
117+ , iImports :: [Name]
103 , iAdts :: ADTs
118 , iAdts :: ADTs
104 , iAliases :: Aliases
119 , iAliases :: Aliases
105 , iFixities :: [(Decl.Assoc, Int, String)]
120 , iFixities :: [(Decl.Assoc, Int, String)]
@@ -131,55 +146,3 @@ instance Binary Interface where
131 put (iAliases modul)
146 put (iAliases modul)
132 put (iFixities modul)
147 put (iFixities modul)
133 put (iPorts modul)
148 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+95−69
@@ -1,109 +1,135 @@
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−
26
31
27−type CanonicalPattern =
28− Pattern Var.Canonical
29
32
33+type RawPattern' =
34+ Pattern' R.Region Var.Raw
30
35
31−cons :: RawPattern -> RawPattern -> RawPattern
32−cons h t =
33− Data (Var.Raw "::") [h,t]
34
36
37+type CanonicalPattern =
38+ Pattern R.Region Var.Canonical
35
39
36−nil :: RawPattern
37−nil =
38− Data (Var.Raw "[]") []
39
40
41+list :: R.Position -> [RawPattern] -> RawPattern
42+list end patterns =
43+ case patterns of
44+ [] ->
45+ A.at end end (Data (Var.Raw "[]") [])
40
46
41−list :: [RawPattern] -> RawPattern
47+ pattern@(A.A (R.Region start _) _) : rest ->
42−list patterns =
48+ A.at start end (Data (Var.Raw "::") [pattern, list end rest])
43− foldr cons nil patterns
44
49
45
50
46−tuple :: [RawPattern] -> RawPattern
51+tuple :: [RawPattern] -> RawPattern'
47tuple patterns =
52tuple patterns =
48 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns
53 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns
49
54
50
55
51−boundVarList :: Pattern var -> [String]
56+-- FIND VARIABLES
52−boundVarList pattern =
53− Set.toList (boundVars pattern)
54−
55
57
56−boundVars :: Pattern var -> Set.Set String
58+boundVars :: Pattern ann var -> [A.Annotated ann String]
57−boundVars pattern =
59+boundVars (A.A ann pattern) =
58 case pattern of
60 case pattern of
59− Var x -> Set.singleton x
61+ Var x ->
60− Alias x p -> Set.insert x (boundVars p)
62+ [A.A ann x]
61− Data _ ps -> Set.unions (map boundVars ps)
63+
64+ Alias name realPattern ->
65+ A.A ann name : boundVars realPattern
66+
67+ Data _ patterns ->
68+ concatMap boundVars patterns
69+
62− Record fields -> Set.fromList fields
70+ Record fields ->
71+ map (A.A ann) fields
72+
63− Anything -> Set.empty
73+ Anything ->
74+ []
75+
64− Literal _ -> Set.empty
76+ Literal _ ->
77+ []
78+
79+
80+member :: String -> Pattern ann var -> Bool
81+member name pattern =
82+ any (name==) (map A.drop (boundVars pattern))
83+
84+
85+boundVarSet :: Pattern ann var -> Set.Set String
86+boundVarSet pattern =
87+ Set.fromList (map A.drop (boundVars pattern))
88+
89+
90+boundVarList :: Pattern ann var -> [String]
91+boundVarList pattern =
92+ Set.toList (boundVarSet pattern)
93+
65
94
95+-- PRETTY PRINTING
66
96
67−instance Var.ToString var => Pretty (Pattern var) where
97+instance Var.ToString var => P.Pretty (Pattern' ann var) where
68− pretty pattern =
98+ pretty needsParens pattern =
69 case pattern of
99 case pattern of
70− Var x ->
100+ Var name ->
71− variable x
101+ P.text name
72
102
73 Literal literal ->
103 Literal literal ->
74− pretty literal
104+ P.pretty needsParens literal
75
105
76 Record fields ->
106 Record fields ->
77− PP.braces (commaCat (map variable fields))
107+ P.braces (P.commaCat (map P.text fields))
78
108
79− Alias x p ->
109+ Alias x ptrn ->
80− prettyParens p <+> PP.text "as" <+> variable x
110+ P.parensIf needsParens $
111+ P.pretty True ptrn <+> P.text "as" <+> P.text x
81
112
82 Anything ->
113 Anything ->
83− PP.text "_"
114+ P.text "_"
84−
115+
116+ Data name [A.A _ hd, A.A _ tl]
85− Data name [hd,tl] | Var.toString name == "::" ->
117+ | Var.toString name == "::" ->
86− parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
118+ P.parensIf isCons (P.pretty False hd)
119+ <+> P.text "::"
120+ <+> P.pretty False tl
87− where
121+ where
88− isCons =
122+ isCons =
89− case hd of
123+ case hd of
90− Data ctor _ -> Var.toString ctor == "::"
124+ Data ctor _ -> Var.toString ctor == "::"
91− _ -> False
125+ _ -> False
92−
126+
93− Data name ps ->
127+ Data name patterns ->
94− let name' = Var.toString name
128+ let name' = Var.toString name
95− in
129+ in
96 if Help.isTuple name'
130 if Help.isTuple name'
131+ then
97− then PP.parens (commaCat (map pretty ps))
132+ P.parens (P.commaCat (map (P.pretty False) patterns))
133+ else
134+ P.parensIf needsParens $
98− else hsep (PP.text name' : map prettyParens ps)
135+ 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/Type.hs+83−76
@@ -1,57 +1,64 @@
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 Text.PrettyPrint as P
15
16
16import qualified AST.Variable as Var
17import qualified AST.Variable as Var
17−import AST.PrettyPrint
18import qualified AST.Helpers as Help
18import qualified AST.Helpers as Help
19+import qualified Reporting.Annotation as A
19−import Text.PrettyPrint as P
20+import qualified Reporting.PrettyPrint as P
21+import qualified Reporting.Region as R
20
22
21
23
22-- DEFINITION
24-- DEFINITION
23
25
24−data Type var
26+type Raw =
25− = Lambda (Type var) (Type var)
27+ 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
28
33
29
34−data AliasType var
30+data Raw'
35− = Holey (Type var)
31+ = RLambda Raw Raw
36− | Filled (Type var)
32+ | RVar String
33+ | RType Var.Raw
34+ | RApp Raw [Raw]
35+ | RRecord [(String, Raw)] (Maybe Raw)
37− deriving (Eq, Ord, Show)
36+ deriving (Show)
38
37
39
38
40−type RawType =
39+data Canonical
40+ = Lambda Canonical Canonical
41+ | Var String
41− Type Var.Raw
42+ | Type Var.Canonical
43+ | App Canonical [Canonical]
44+ | Record [(String, Canonical)] (Maybe Canonical)
45+ | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)
46+ deriving (Eq, Ord, Show)
42
47
43
48
44−type CanonicalType =
49+data Aliased t
45− Type Var.Canonical
50+ = Holey t
51+ | Filled t
52+ deriving (Eq, Ord, Show)
46
53
47
54
48−data PortType var
55+data Port t
49− = Normal (Type var)
56+ = Normal t
50− | Signal { root :: Type var, arg :: Type var }
57+ | Signal { root :: t, arg :: t }
51 deriving (Show)
58 deriving (Show)
52
59
53
60
54−portType :: PortType var -> Type var
61+portType :: Port tipe -> tipe
55portType portType =
62portType portType =
56 case portType of
63 case portType of
57 Normal tipe -> tipe
64 Normal tipe -> tipe
@@ -65,7 +72,7 @@ fieldMap fields =
65 in
72 in
66 foldl add Map.empty fields
73 foldl add Map.empty fields
67
74
68−
75+{--
69recordOf :: [(String, Type var)] -> Type var
76recordOf :: [(String, Type var)] -> Type var
70recordOf fields =
77recordOf fields =
71 Record fields Nothing
78 Record fields Nothing
@@ -74,18 +81,18 @@ recordOf fields =
74listOf :: RawType -> RawType
81listOf :: RawType -> RawType
75listOf tipe =
82listOf tipe =
76 App (Type (Var.Raw "List")) [tipe]
83 App (Type (Var.Raw "List")) [tipe]
84+--}
77
85
78−
86+tuple :: R.Region -> [Raw] -> Raw
79−tupleOf :: [RawType] -> RawType
87+tuple region types =
80−tupleOf types =
81 let name = Var.Raw ("_Tuple" ++ show (length types))
88 let name = Var.Raw ("_Tuple" ++ show (length types))
82 in
89 in
83− App (Type name) types
90+ A.A region (RApp (A.A region (RType name)) types)
84
91
85
92
86-- DEALIASING
93-- DEALIASING
87
94
88−deepDealias :: Type v -> Type v
95+deepDealias :: Canonical -> Canonical
89deepDealias tipe =
96deepDealias tipe =
90 let go = deepDealias in
97 let go = deepDealias in
91 case tipe of
98 case tipe of
@@ -108,7 +115,7 @@ deepDealias tipe =
108 App (go f) (map go args)
115 App (go f) (map go args)
109
116
110
117
111−dealias :: [(String, Type v)] -> AliasType v -> Type v
118+dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
112dealias args aliasType =
119dealias args aliasType =
113 case aliasType of
120 case aliasType of
114 Holey tipe ->
121 Holey tipe ->
@@ -118,7 +125,7 @@ dealias args aliasType =
118 tipe
125 tipe
119
126
120
127
121−dealiasHelp :: Map.Map String (Type var) -> Type var -> Type var
128+dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
122dealiasHelp typeTable tipe =
129dealiasHelp typeTable tipe =
123 let go = dealiasHelp typeTable in
130 let go = dealiasHelp typeTable in
124 case tipe of
131 case tipe of
@@ -143,27 +150,37 @@ dealiasHelp typeTable tipe =
143
150
144-- PRETTY PRINTING
151-- PRETTY PRINTING
145
152
146−instance (Pretty var, Var.ToString var) => Pretty (PortType var) where
153+instance (P.Pretty t) => P.Pretty (Port t) where
147− pretty portType =
154+ pretty needsParens portType =
148 case portType of
155 case portType of
149 Normal tipe ->
156 Normal tipe ->
150− pretty tipe
157+ P.pretty needsParens tipe
151
158
152 Signal tipe _ ->
159 Signal tipe _ ->
153− pretty tipe
160+ P.pretty needsParens tipe
161+
154
162
163+instance P.Pretty Raw' where
164+ pretty _ tipe =
165+ P.text (show tipe)
155
166
167+
156−instance (Var.ToString var, Pretty var) => Pretty (Type var) where
168+instance P.Pretty Canonical where
157− pretty tipe =
169+ pretty needsParens tipe =
158 case tipe of
170 case tipe of
159 Lambda _ _ ->
171 Lambda _ _ ->
172+ P.parensIf needsParens $
160− P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
173+ P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
161 where
174 where
175+ t:ts =
162− t:ts = map prettyLambda (collectLambdas tipe)
176+ map prettyLambda (collectLambdas tipe)
177+
163 prettyLambda t =
178 prettyLambda t =
164 case t of
179 case t of
165− Lambda _ _ -> P.parens (pretty t)
180+ Lambda _ _ ->
166− _ -> pretty t
181+ P.pretty True t
182+ _ ->
183+ P.pretty False t
167
184
168 Var x ->
185 Var x ->
169 P.text x
186 P.text x
@@ -177,9 +194,18 @@ instance (Var.ToString var, Pretty var) => Pretty (Type var) where
177 case (f,args) of
194 case (f,args) of
178 (Type name, _)
195 (Type name, _)
179 | Help.isTuple (Var.toString name) ->
196 | Help.isTuple (Var.toString name) ->
197+ P.parens $ P.sep $
180− P.parens (P.sep (P.punctuate P.comma (map pretty args)))
198+ P.punctuate P.comma (map (P.pretty False) args)
199+
200+ (_, []) ->
201+ P.pretty True f
181
202
182− _ -> P.hang (pretty f) 2 (P.sep (map prettyParens args))
203+ (_, _) ->
204+ P.parensIf needsParens $
205+ P.hang
206+ (P.pretty True f)
207+ 2
208+ (P.sep (map (P.pretty True) args))
183
209
184 Record _ _ ->
210 Record _ _ ->
185 case flattenRecord tipe of
211 case flattenRecord tipe of
@@ -202,13 +228,17 @@ instance (Var.ToString var, Pretty var) => Pretty (Type var) where
202 ])
228 ])
203 where
229 where
204 prettyField (field, tipe) =
230 prettyField (field, tipe) =
205− P.text field <+> P.text ":" <+> pretty tipe
231+ P.text field <+> P.text ":" <+> P.pretty False tipe
206
232
207 Aliased name args _ ->
233 Aliased name args _ ->
234+ P.parensIf (needsParens && not (null args)) $
235+ P.hang
236+ (P.pretty False name)
237+ 2
208− P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args))
238+ (P.sep (map (P.pretty True . snd) args))
209
239
210
240
211−collectLambdas :: Type var -> [Type var]
241+collectLambdas :: Canonical -> [Canonical]
212collectLambdas tipe =
242collectLambdas tipe =
213 case tipe of
243 case tipe of
214 Lambda arg body ->
244 Lambda arg body ->
@@ -218,30 +248,7 @@ collectLambdas tipe =
218 [tipe]
248 [tipe]
219
249
220
250
221−prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
222−prettyParens tipe =
223− parensIf (needed tipe) (pretty tipe)
224− where
225− needed t =
226− case t of
227− Aliased _ [] _ -> False
228−
229− Aliased _ _ _ -> True
230−
231− Lambda _ _ -> True
232−
233− App (Type name) _
234− | Help.isTuple (Var.toString name) ->
235− False
236−
237− App t' [] -> needed t'
238−
239− App _ _ -> True
240−
241− _ -> False
242−
243−
244−flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
251+flattenRecord :: Canonical -> ( [(String, Canonical)], Maybe String )
245flattenRecord tipe =
252flattenRecord tipe =
246 case tipe of
253 case tipe of
247 Var x ->
254 Var x ->
@@ -264,7 +271,7 @@ flattenRecord tipe =
264
271
265-- BINARY
272-- BINARY
266
273
267−instance Binary var => Binary (Type var) where
274+instance Binary Canonical where
268 put tipe =
275 put tipe =
269 case tipe of
276 case tipe of
270 Lambda t1 t2 ->
277 Lambda t1 t2 ->
@@ -297,7 +304,7 @@ instance Binary var => Binary (Type var) where
297 _ -> error "Error reading a valid type from serialized string"
304 _ -> error "Error reading a valid type from serialized string"
298
305
299
306
300−instance Binary var => Binary (AliasType var) where
307+instance Binary t => Binary (Aliased t) where
301 put aliasType =
308 put aliasType =
302 case aliasType of
309 case aliasType of
303 Holey tipe ->
310 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/Compile.hs+16−21
@@ -1,16 +1,16 @@
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 Elm.Utils ((|>))
7import qualified Parse.Helpers as Parse
7import qualified Parse.Helpers as Parse
8import qualified Parse.Parse as Parse
8import qualified Parse.Parse as Parse
9−import qualified Transform.AddDefaultImports as DefaultImports
9+import qualified Reporting.Error as Error
10+import qualified Reporting.Task as Task
10−import qualified Transform.Check as Check
11+import qualified Reporting.Warning as Warning
11import qualified Type.Inference as TI
12import qualified Type.Inference as TI
12import qualified Transform.Canonicalize as Canonical
13import qualified Transform.Canonicalize as Canonical
13−import Elm.Utils ((|>))
14
14
15
15
16compile
16compile
@@ -18,33 +18,28 @@ compile
18 -> String
18 -> String
19 -> Module.Interfaces
19 -> Module.Interfaces
20 -> String
20 -> String
21− -> Either [Doc] Module.CanonicalModule
21+ -> Task.Task Warning.Warning Error.Error Module.CanonicalModule
22
22
23compile user projectName interfaces source =
23compile user projectName interfaces source =
24− do
24+ do
25− -- Parse the source code
26− parsedModule <-
27− Parse.program (getOpTable interfaces) source
28−
29 -- determine if default imports should be added
25 -- determine if default imports should be added
30 -- only elm-lang/core is exempt
26 -- only elm-lang/core is exempt
31 let needsDefaults =
27 let needsDefaults =
32 not (user == "elm-lang" && projectName == "core")
28 not (user == "elm-lang" && projectName == "core")
33
29
34− -- add default imports if necessary
30+ -- Parse the source code
35− let rawModule =
31+ validModule <-
36− DefaultImports.add needsDefaults parsedModule
32+ Task.mapError Error.Syntax $
37−
33+ 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
34
43 -- Canonicalize all variables, pinning down where they came from.
35 -- Canonicalize all variables, pinning down where they came from.
36+ canonicalModule <-
44− canonicalModule <- Canonical.module' interfaces rawModule
37+ Canonical.module' interfaces validModule
45
38
46 -- Run type inference on the program.
39 -- Run type inference on the program.
40+ types <-
41+ Task.from Error.Type $
47− types <- TI.infer interfaces canonicalModule
42+ TI.infer interfaces canonicalModule
48
43
49 -- Add the real list of tyes
44 -- Add the real list of tyes
50 let body = (Module.body canonicalModule) { Module.types = types }
45 let body = (Module.body canonicalModule) { Module.types = types }
@@ -57,4 +52,4 @@ getOpTable interfaces =
57 Map.elems interfaces
52 Map.elems interfaces
58 |> concatMap Module.iFixities
53 |> concatMap Module.iFixities
59 |> map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
54 |> map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
60− |> Map.fromList
55+ |> Map.fromList
src/Elm/Compiler.hs+14−15
@@ -5,19 +5,18 @@ module Elm.Compiler
5 , parseDependencies, compile
5 , parseDependencies, compile
6 ) where
6 ) where
7
7
8−import Control.Monad.Error (MonadError, throwError)
8+import Control.Monad.Error.Class (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
19import qualified Parse.Helpers as Help
16import qualified Parse.Helpers as Help
20import qualified Parse.Module as Parse
17import qualified Parse.Module as Parse
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.Task as Task
21
20
22
21
23-- VERSION
22-- VERSION
@@ -39,14 +38,14 @@ parseDependencies
39 => String
38 => String
40 -> m (PublicModule.Name, [PublicModule.Name])
39 -> m (PublicModule.Name, [PublicModule.Name])
41parseDependencies src =
40parseDependencies src =
42− case Help.iParse Parse.headerAndImports src of
41+ case Help.iParse Parse.header src of
43 Left msg ->
42 Left msg ->
44 throwError (show msg)
43 throwError (show msg)
45
44
46− Right (Module.HeaderAndImports names _exports imports) ->
45+ Right (Module.Header names _exports imports) ->
47 return
46 return
48 ( PublicModule.Name names
47 ( PublicModule.Name names
49− , map (PublicModule.Name . fst) imports
48+ , map (PublicModule.Name . fst . A.drop) imports
50 )
49 )
51
50
52
51
@@ -62,13 +61,13 @@ compile
62compile user packageName source interfaces =
61compile user packageName source interfaces =
63 let unwrappedInterfaces =
62 let unwrappedInterfaces =
64 Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces
63 Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces
64+
65+ task =
66+ Compile.compile user packageName unwrappedInterfaces source
65 in
67 in
66− case Compile.compile user packageName unwrappedInterfaces source of
68+ case Task.run task of
67− Right modul ->
69+ (Right modul, _warnings) ->
68 Right (Module.toInterface modul, JS.generate modul)
70 Right (Module.toInterface modul, JS.generate modul)
69
71
70− Left docs ->
72+ (Left _docs, _warnings) ->
71− map P.render docs
73+ Left [error "TODO:compile"]
72− |> List.intersperse ""
73− |> unlines
74− |> Left
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+170−118
@@ -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
15+import qualified Reporting.Annotation as A
16import Transform.Substitute (subst)
16import Transform.Substitute (subst)
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) -> 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 (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+ 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 -> 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/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+5−5
@@ -12,19 +12,19 @@ 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 <$> (Expr.typeAnnotation <|> Expr.definition)
22 D.Definition <$> (Expr.typeAnnotation <|> Expr.definition)
23
23
24
24
25-- TYPE ALIAS and UNION TYPES
25-- TYPE ALIAS and UNION TYPES
26
26
27−typeDecl :: IParser D.SourceDecl
27+typeDecl :: IParser D.SourceDecl'
28typeDecl =
28typeDecl =
29 do try (reserved "type") <?> "type declaration"
29 do try (reserved "type") <?> "type declaration"
30 forcedWS
30 forcedWS
@@ -46,7 +46,7 @@ typeDecl =
46
46
47-- INFIX
47-- INFIX
48
48
49−infixDecl :: IParser D.SourceDecl
49+infixDecl :: IParser D.SourceDecl'
50infixDecl =
50infixDecl =
51 do assoc <-
51 do assoc <-
52 choice
52 choice
@@ -62,7 +62,7 @@ infixDecl =
62
62
63-- PORT
63-- PORT
64
64
65−port :: IParser D.SourceDecl
65+port :: IParser D.SourceDecl'
66port =
66port =
67 do try (reserved "port")
67 do try (reserved "port")
68 whitespace
68 whitespace
src/Parse/Expression.hs+115−68
@@ -12,12 +12,12 @@ 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 --------
@@ -30,24 +30,42 @@ varTerm =
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) <-
48 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
59 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
60+
61+ let ann e =
49− let loc e = Annotation.at start end e
62+ A.at start end e
63+
64+ return $
65+ E.Binop
66+ (Var.Raw "-")
50− return (E.Binop (Var.Raw "-") (loc $ E.Literal (L.IntNum 0)) nTerm)
67+ (ann (E.Literal (L.IntNum 0)))
68+ nTerm
51
69
52
70
53-------- Complex Terms --------
71-------- Complex Terms --------
@@ -56,45 +74,65 @@ listTerm :: IParser Source.Expr'
56listTerm =
74listTerm =
57 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
75 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
58 where
76 where
59− range = do
77+ range =
60− lo <- expr
78+ do lo <- expr
61− padded (string "..")
79+ padded (string "..")
62− E.Range lo <$> expr
80+ E.Range lo <$> expr
63
81
64− shader' = do
82+ shader' =
65− pos <- getPosition
83+ do pos <- getPosition
66− let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
84+ let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
67− (rawSrc, tipe) <- Help.shader
85+ (rawSrc, tipe) <- Help.shader
68− return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
86+ return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
69
87
70
88
71parensTerm :: IParser Source.Expr
89parensTerm :: IParser Source.Expr
72parensTerm =
90parensTerm =
91+ choice
92+ [ try (parens opFn)
73− try (parens opFn) <|> parens (tupleFn <|> parened)
93+ , parens (tupleFn <|> parened)
94+ ]
74 where
95 where
96+ lambda start end x body =
97+ A.at start end (E.Lambda (A.at start end (P.Var x)) body)
98+
99+ var start end x =
100+ A.at start end (E.rawVar x)
101+
75− opFn = do
102+ opFn =
76− (start, op, end) <- located anyOp
103+ do (start, op, end) <- located anyOp
77− let loc = Annotation.at start end
104+ return $
78− return . loc . E.Lambda (P.Var "x") . loc . E.Lambda (P.Var "y") . loc $
105+ lambda start end "x" $
106+ lambda start end "y" $
107+ A.at start end $
79− E.Binop (Var.Raw op) (loc (E.rawVar "x")) (loc (E.rawVar "y"))
108+ E.Binop (Var.Raw op) (var start end "x") (var start end "y")
80−
109+
81− tupleFn = do
110+ tupleFn =
82− let comma = char ',' <?> "comma ','"
111+ do (start, commas, end) <-
83− (start, commas, end) <- located (comma >> many (whitespace >> comma))
112+ located (comma >> many (whitespace >> comma))
113+
84− let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
114+ let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
85− loc = Annotation.at start end
115+
86− return $ foldr (\x e -> loc $ E.Lambda x e)
116+ return $
87− (loc . E.tuple $ map (loc . E.rawVar) vars) (map P.Var vars)
117+ foldr
88−
118+ (lambda start end)
119+ (A.at start end (E.tuple (map (var start end) vars)))
120+ vars
121+
89− parened = do
122+ parened =
90− (start, es, end) <- located (commaSep expr)
123+ do (start, expressions, end) <- located (commaSep expr)
91− return $ case es of
124+ return $
92− [e] -> e
125+ case expressions of
126+ [expression] ->
127+ expression
128+ _ ->
93− _ -> Annotation.at start end (E.tuple es)
129+ A.at start end (E.tuple expressions)
130+
94
131
95recordTerm :: IParser Source.Expr
132recordTerm :: IParser Source.Expr
96recordTerm =
133recordTerm =
134+ addLocation $
97− brackets $ choice [ misc, addLocation record ]
135+ brackets $ choice [ misc, record ]
98 where
136 where
99 field =
137 field =
100 do label <- rLabel
138 do label <- rLabel
@@ -112,23 +150,29 @@ recordTerm =
112 (,) lbl <$> expr
150 (,) lbl <$> expr
113
151
114 remove r =
152 remove r =
153+ do string "-"
154+ whitespace
115− addLocation (string "-" >> whitespace >> E.Remove r <$> rLabel)
155+ E.Remove r <$> rLabel
116
156
117 insert r =
157 insert r =
118− addLocation $
158+ do string "|"
119− do string "|" >> whitespace
159+ whitespace
120− E.Insert r <$> rLabel <*> (padded equals >> expr)
160+ E.Insert r <$> rLabel <*> (padded equals >> expr)
121
161
122 modify r =
162 modify r =
163+ do string "|"
164+ whitespace
123− addLocation (string "|" >> whitespace >> E.Modify r <$> commaSep1 change)
165+ E.Modify r <$> commaSep1 change
124
166
125 misc =
167 misc =
126 try $ do
168 try $ do
127 record <- addLocation (E.rawVar <$> rLabel)
169 record <- addLocation (E.rawVar <$> rLabel)
128− opt <- padded (optionMaybe (remove record))
170+ opt <- padded (optionMaybe (addLocation (remove record)))
129 case opt of
171 case opt of
172+ Just e@(A.A _ e') ->
130− Just e -> try (insert e) <|> return e
173+ try (insert e) <|> return e'
174+ Nothing ->
131− Nothing -> try (insert record) <|> try (modify record)
175+ try (insert record) <|> try (modify record)
132
176
133
177
134term :: IParser Source.Expr
178term :: IParser Source.Expr
@@ -148,7 +192,7 @@ appExpr =
148 return $
192 return $
149 case ts of
193 case ts of
150 [] -> t
194 [] -> t
151− _ -> List.foldl' (\f x -> Annotation.merge f x $ E.App f x) t ts
195+ _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts
152
196
153
197
154-------- Normal Expressions --------
198-------- Normal Expressions --------
@@ -185,7 +229,7 @@ ifExpr =
185 elseBranch <- expr
229 elseBranch <- expr
186 return $ E.MultiIf
230 return $ E.MultiIf
187 [ (bool, thenBranch)
231 [ (bool, thenBranch)
188− , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
232+ , (A.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
189 ]
233 ]
190
234
191 multiIf =
235 multiIf =
@@ -246,7 +290,7 @@ letExpr =
246
290
247typeAnnotation :: IParser Source.Def
291typeAnnotation :: IParser Source.Def
248typeAnnotation =
292typeAnnotation =
249− Source.TypeAnnotation <$> try start <*> Type.expr
293+ addLocation (Source.TypeAnnotation <$> try start <*> Type.expr)
250 where
294 where
251 start =
295 start =
252 do v <- lowVar <|> parens symOp
296 do v <- lowVar <|> parens symOp
@@ -258,6 +302,7 @@ typeAnnotation =
258
302
259definition :: IParser Source.Def
303definition :: IParser Source.Def
260definition =
304definition =
305+ addLocation $
261 withPos $
306 withPos $
262 do (name:args) <- defStart
307 do (name:args) <- defStart
263 padded equals
308 padded equals
@@ -266,29 +311,31 @@ definition =
266
311
267
312
268makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
313makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
269−makeFunction args body@(Annotation.A ann _) =
314+makeFunction args body@(A.A ann _) =
270− foldr (\arg body' -> Annotation.A ann $ E.Lambda arg body') body args
315+ foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args
271
316
272
317
273defStart :: IParser [P.RawPattern]
318defStart :: IParser [P.RawPattern]
274defStart =
319defStart =
275 choice
320 choice
276− [ do p1 <- try Pattern.term
321+ [ do pattern <- try Pattern.term
277− infics p1 <|> func p1
322+ infics pattern <|> func pattern
278− , func =<< (P.Var <$> parens symOp)
323+ , do opPattern <- addLocation (P.Var <$> parens symOp)
324+ func opPattern
279 ]
325 ]
280 <?> "the definition of a variable (x = ...)"
326 <?> "the definition of a variable (x = ...)"
281− where
327+ where
282− func pattern =
328+ func pattern =
283− case pattern of
329+ case pattern of
330+ A.A _ (P.Var _) ->
284− P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
331+ (pattern:) <$> spacePrefix Pattern.term
285− _ -> do try (lookAhead (whitespace >> string "="))
332+
333+ _ ->
286− return [pattern]
334+ return [pattern]
287−
335+
288− infics p1 =
336+ infics p1 =
289− do o:p <- try (whitespace >> anyOp)
337+ do (start, o:p, end) <- try (whitespace >> located anyOp)
290− p2 <- (whitespace >> Pattern.term)
338+ p2 <- (whitespace >> Pattern.term)
291− return $
339+ let opName =
292− if o == '`'
293− then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
340+ if o == '`' then takeWhile (/='`') p else o:p
294− else [ P.Var (o:p), p1, p2 ]
341+ return [ A.at start end (P.Var opName), p1, p2 ]
src/Parse/Helpers.hs+30−22
@@ -8,19 +8,19 @@ 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.Region as R
24
24
25
25
26reserveds :: [String]
26reserveds :: [String]
@@ -148,9 +148,14 @@ spaceySepBy1 sep p =
148 (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))
148 (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))
149
149
150
150
151+comma :: IParser Char
152+comma =
153+ char ',' <?> "comma ','"
154+
155+
151commaSep1 :: IParser a -> IParser [a]
156commaSep1 :: IParser a -> IParser [a]
152commaSep1 =
157commaSep1 =
153− spaceySepBy1 (char ',' <?> "comma ','")
158+ spaceySepBy1 comma
154
159
155
160
156commaSep :: IParser a -> IParser [a]
161commaSep :: IParser a -> IParser [a]
@@ -238,25 +243,30 @@ brackets =
238
243
239-- HELPERS FOR EXPRESSIONS
244-- HELPERS FOR EXPRESSIONS
240
245
246+getMyPosition :: IParser R.Position
247+getMyPosition =
248+ R.fromSourcePos <$> getPosition
249+
250+
241−addLocation :: (P.Pretty a) => IParser a -> IParser (Annotation.Located a)
251+addLocation :: IParser a -> IParser (A.Located a)
242addLocation expr =
252addLocation expr =
243 do (start, e, end) <- located expr
253 do (start, e, end) <- located expr
244− return (Annotation.at start end e)
254+ return (A.at start end e)
245
255
246
256
247−located :: IParser a -> IParser (SourcePos, a, SourcePos)
257+located :: IParser a -> IParser (R.Position, a, R.Position)
248−located p =
258+located parser =
249− do start <- getPosition
259+ do start <- getMyPosition
250− e <- p
260+ value <- parser
251− end <- getPosition
261+ end <- getMyPosition
252− return (start, e, end)
262+ return (start, value, end)
253
263
254
264
255accessible :: IParser Source.Expr -> IParser Source.Expr
265accessible :: IParser Source.Expr -> IParser Source.Expr
256accessible exprParser =
266accessible exprParser =
257− do start <- getPosition
267+ do start <- getMyPosition
258
268
259− annotatedRootExpr@(Annotation.A _ rootExpr) <- exprParser
269+ annotatedRootExpr@(A.A _ rootExpr) <- exprParser
260
270
261 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
271 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
262
272
@@ -267,8 +277,8 @@ accessible exprParser =
267 Just _ ->
277 Just _ ->
268 accessible $
278 accessible $
269 do v <- var <?> "field access (e.g. List.map)"
279 do v <- var <?> "field access (e.g. List.map)"
270− end <- getPosition
280+ end <- getMyPosition
271− return . Annotation.at start end $
281+ return . A.at start end $
272 case rootExpr of
282 case rootExpr of
273 E.Var (Variable.Raw name@(c:_))
283 E.Var (Variable.Raw name@(c:_))
274 | isUpper c ->
284 | isUpper c ->
@@ -427,12 +437,10 @@ withSource p =
427
437
428anyUntilPos :: SourcePos -> IParser String
438anyUntilPos :: SourcePos -> IParser String
429anyUntilPos pos =
439anyUntilPos pos =
430− go
431− where
432− go = do currentPos <- getPosition
440+ do currentPos <- getPosition
433− case currentPos == pos of
441+ if currentPos == pos
434− True -> return []
442+ then return []
435− False -> (:) <$> anyChar <*> go
443+ else (:) <$> anyChar <*> anyUntilPos pos
436
444
437
445
438-- BASIC LANGUAGE LITERALS
446-- BASIC LANGUAGE LITERALS
src/Parse/Module.hs+11−10
@@ -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)
@@ -16,21 +16,21 @@ getModuleName source =
16 where
16 where
17 getModuleName =
17 getModuleName =
18 do optional freshLine
18 do optional freshLine
19− (names, _) <- header
19+ (names, _) <- moduleDecl
20 return (Module.nameToString names)
20 return (Module.nameToString names)
21
21
22
22
23−headerAndImports :: IParser Module.HeaderAndImports
23+header :: IParser (Module.Header [Module.UserImport])
24−headerAndImports =
24+header =
25 do optional freshLine
25 do optional freshLine
26 (names, exports) <-
26 (names, exports) <-
27− option (["Main"], Var.openListing) (header `followedBy` freshLine)
27+ option (["Main"], Var.openListing) (moduleDecl `followedBy` freshLine)
28 imports' <- imports
28 imports' <- imports
29− return $ Module.HeaderAndImports names exports imports'
29+ return (Module.Header names exports imports')
30
30
31
31
32−header :: IParser ([String], Var.Listing Var.Value)
32+moduleDecl :: IParser ([String], Var.Listing Var.Value)
33−header =
33+moduleDecl =
34 do try (reserved "module")
34 do try (reserved "module")
35 whitespace
35 whitespace
36 names <- dotSep1 capVar <?> "name of module"
36 names <- dotSep1 capVar <?> "name of module"
@@ -41,13 +41,14 @@ header =
41 return (names, exports)
41 return (names, exports)
42
42
43
43
44−imports :: IParser [(Module.Name, Module.ImportMethod)]
44+imports :: IParser [Module.UserImport]
45imports =
45imports =
46 many (import' `followedBy` freshLine)
46 many (import' `followedBy` freshLine)
47
47
48
48
49−import' :: IParser (Module.Name, Module.ImportMethod)
49+import' :: IParser Module.UserImport
50import' =
50import' =
51+ addLocation $
51 do try (reserved "import")
52 do try (reserved "import")
52 whitespace
53 whitespace
53 names <- dotSep1 capVar
54 names <- dotSep1 capVar
src/Parse/Parse.hs+111−52
@@ -1,79 +1,138 @@
1+{-# OPTIONS_GHC -Wall #-}
1module Parse.Parse (program) where
2module Parse.Parse (program) 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
11import Parse.Helpers
12import Parse.Helpers
12−import Parse.Declaration (infixDecl)
13import qualified Parse.Module as Module
13import qualified Parse.Module as Module
14import qualified Parse.Declaration as Decl
14import qualified Parse.Declaration as Decl
15−import Transform.Declaration (combineAnnotations)
15+import qualified Reporting.Region as R
16+import qualified Reporting.Error.Syntax as Error
17+import qualified Reporting.Task as Task
18+import qualified Transform.AddDefaultImports as DefaultImports
19+import qualified Validate
16
20
17
21
22+program
23+ :: Bool
24+ -> OpTable
25+ -> String
26+ -> Task.Task 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+ DefaultImports.add needsDefaults 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 <?> "at least one datatype or variable definition")
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 <?> "another datatype or variable definition"
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 -> Task.Task 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+ Task.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+ -> Task.Task 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+ -> Task.Task 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 Task.throw region (Error.InfixDuplicate op)
116+ else return info
117+
118+ InfixInfo region _ : _ ->
119+ Task.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+76−37
@@ -5,64 +5,103 @@ 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+ <?> "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 =
67− patterns <- consSep1 (patternConstructor <|> term)
107+ asPattern (patternConstructor <|> term) <?> "pattern"
68− asPattern (foldr1 P.cons patterns) <?> "pattern"
src/Parse/Type.hs+47−32
@@ -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 <?> "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 <?> "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 >> arrow)
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+55
@@ -0,0 +1,55 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Error where
3+
4+import Data.Aeson ((.=))
5+import qualified Data.Aeson as Json
6+
7+import qualified Reporting.Error.Canonicalize as Canonicalize
8+import qualified Reporting.Error.Syntax as Syntax
9+import qualified Reporting.Error.Type as Type
10+import qualified Reporting.Region as R
11+
12+
13+-- ALL POSSIBLE ERRORS
14+
15+data Error
16+ = Syntax Syntax.Error
17+ | Canonicalize Canonicalize.Error
18+ | Type Type.Error
19+
20+
21+-- TO STRING
22+
23+toString :: R.Region -> Error -> String
24+toString region err =
25+ case err of
26+ Syntax syntaxError ->
27+ Syntax.toString region syntaxError
28+
29+ Canonicalize canonicalizeError ->
30+ Canonicalize.toString region canonicalizeError
31+
32+ Type typeError ->
33+ Type.toString region typeError
34+
35+
36+-- JSON
37+
38+toJson :: R.Region -> Error -> Json.Value
39+toJson region err =
40+ let json =
41+ case err of
42+ Syntax syntaxError ->
43+ Syntax.toJson syntaxError
44+
45+ Canonicalize canonicalizeError ->
46+ Canonicalize.toJson canonicalizeError
47+
48+ Type typeError ->
49+ Type.toJson typeError
50+ in
51+ Json.object
52+ [ "tag" .= ("error" :: String)
53+ , "region" .= region
54+ , "error" .= json
55+ ]
src/Transform/Canonicalize/Error.hs → src/Reporting/Error/Canonicalize.hsrenamed+60−28
@@ -1,20 +1,24 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2−module Transform.Canonicalize.Error where
3+module Reporting.Error.Canonicalize where
3
4
4−import Data.Aeson ((.=))
5+--import Data.Aeson ((.=))
5import qualified Data.Aeson as Json
6import qualified Data.Aeson as Json
7+--import qualified Data.Aeson.Types as Json
6import Data.Function (on)
8import Data.Function (on)
7import qualified Data.List as List
9import qualified Data.List as List
8import qualified Text.EditDistance as Dist
10import qualified Text.EditDistance as Dist
9
11
10import qualified AST.Module as Module
12import qualified AST.Module as Module
11−import qualified AST.Type as T
13+import qualified AST.Type as Type
12import qualified AST.Variable as Var
14import qualified AST.Variable as Var
13import Elm.Utils ((|>))
15import Elm.Utils ((|>))
16+import qualified Reporting.Region as R
14
17
15
18
16data Error
19data Error
17 = Var VarError
20 = Var VarError
21+ | Pattern PatternError
18 | Alias AliasError
22 | Alias AliasError
19 | Import Module.Name ImportError
23 | Import Module.Name ImportError
20 | Export String [String]
24 | Export String [String]
@@ -42,6 +46,17 @@ var kind name problem =
42 Var (VarError kind name problem)
46 Var (VarError kind name problem)
43
47
44
48
49+-- PATTERN
50+
51+data PatternError
52+ = PatternArgMismatch Var.Canonical Int Int
53+
54+
55+argMismatch :: Var.Canonical -> Int -> Int -> Error
56+argMismatch name expected actual =
57+ Pattern (PatternArgMismatch name expected actual)
58+
59+
45-- IMPORTS
60-- IMPORTS
46
61
47data ImportError
62data ImportError
@@ -62,18 +77,14 @@ valueNotFound name value possibilities =
62-- ALIASES
77-- ALIASES
63
78
64data AliasError
79data AliasError
65− = ArgMissmatch Var.Canonical Int Int
80+ = ArgMismatch Var.Canonical Int Int
66− | Recursive [(String, [String], T.RawType)]
81+ | SelfRecursive String [String] Type.Raw
82+ | MutuallyRecursive [(R.Region, String, [String], Type.Raw)]
67
83
68
84
69alias :: Var.Canonical -> Int -> Int -> Error
85alias :: Var.Canonical -> Int -> Int -> Error
70alias name expected actual =
86alias name expected actual =
71− Alias (ArgMissmatch name expected actual)
87+ Alias (ArgMismatch name expected actual)
72−
73−
74−recursiveAlias :: [(String, [String], T.RawType)] -> Error
75−recursiveAlias aliases =
76− Alias (Recursive aliases)
77
88
78
89
79-- PORTS
90-- PORTS
@@ -81,8 +92,8 @@ recursiveAlias aliases =
81data PortError = PortError
92data PortError = PortError
82 { portName :: String
93 { portName :: String
83 , portIsInbound :: Bool
94 , portIsInbound :: Bool
84− , portRootType :: T.CanonicalType
95+ , portRootType :: Type.Canonical
85− , portLocalType :: T.CanonicalType
96+ , portLocalType :: Type.Canonical
86 , portMessage :: String
97 , portMessage :: String
87 }
98 }
88
99
@@ -90,8 +101,8 @@ data PortError = PortError
90port
101port
91 :: String
102 :: String
92 -> Bool
103 -> Bool
93− -> T.CanonicalType
104+ -> Type.Canonical
94− -> T.CanonicalType
105+ -> Type.Canonical
95 -> String
106 -> String
96 -> Error
107 -> Error
97port name isInbound rootType localType message =
108port name isInbound rootType localType message =
@@ -117,13 +128,32 @@ distance x y =
117 Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y
128 Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y
118
129
119
130
120−-- JSON
131+-- TO STRING
132+
133+toString :: R.Region -> Error -> String
134+toString region err =
135+ case err of
136+ _ -> error "Canonicalize.toString" region
121
137
138+
139+-- TO JSON
140+
141+toJson :: Error -> Json.Value
142+toJson err =
143+ case err of
144+ _ -> error "Canonicalize.toJson"
145+
146+{--
147+(.=.) key value =
148+ key .= (value :: String)
149+
150+
151+errorToJson :: LError -> Json.Value
122−errorToJson err =
152+errorToJson (A.A region err) =
123 Json.object (generals ++ specifics)
153 Json.object (generals ++ specifics)
124 where
154 where
125 generals =
155 generals =
126− [ "category" .= "canonicalization"
156+ [ "category" .=. "canonicalization"
127 , "region" .= region
157 , "region" .= region
128 ]
158 ]
129
159
@@ -137,25 +167,25 @@ errorToJson err =
137
167
138 Alias aliasError ->
168 Alias aliasError ->
139 case aliasError of
169 case aliasError of
140− ArgMissmatch name expected actual ->
170+ ArgMismatch name expected actual ->
141− [ "tag" .= "alias-args"
171+ [ "tag" .=. "alias-args"
142− , "name" .= name
172+ , "name" .= Var.toString name
143 , "expected-args" .= expected
173 , "expected-args" .= expected
144 , "actual-args" .= actual
174 , "actual-args" .= actual
145 ]
175 ]
146
176
147 Recursive [(name, tvars, tipe)] ->
177 Recursive [(name, tvars, tipe)] ->
148− [ "tag" .= "recursive-alias"
178+ [ "tag" .=. "recursive-alias"
149 ]
179 ]
150
180
151 Recursive aliases ->
181 Recursive aliases ->
152− [ "tag" .= "mutually-recursive-aliases"
182+ [ "tag" .=. "mutually-recursive-aliases"
153 ]
183 ]
154
184
155 Import moduleName importError ->
185 Import moduleName importError ->
156 case importError of
186 case importError of
157 ModuleNotFound suggestions ->
187 ModuleNotFound suggestions ->
158− [ "tag" .= "unknown-import"
188+ [ "tag" .=. "unknown-import"
159 , "name" .= moduleName
189 , "name" .= moduleName
160 , "suggestions" .= suggestions
190 , "suggestions" .= suggestions
161 ]
191 ]
@@ -169,10 +199,10 @@ errorToJson err =
169 []
199 []
170
200
171
201
172−varProblemToJson :: VarProblem -> Json.Value
202+varProblemToJson :: VarProblem -> [Json.Pair]
173varProblemToJson varProblem =
203varProblemToJson varProblem =
174 let details tag suggestions =
204 let details tag suggestions =
175− [ "tag" .= tag
205+ [ "tag" .=. tag
176 , "suggestions" .= suggestions
206 , "suggestions" .= suggestions
177 ]
207 ]
178 in
208 in
@@ -181,14 +211,16 @@ varProblemToJson varProblem =
181 details "ambiguous" possibilities
211 details "ambiguous" possibilities
182
212
183 UnknownQualifier possibleModules ->
213 UnknownQualifier possibleModules ->
214+ details
184− details "unknown-qualifier" possibleModules
215+ "unknown-qualifier"
216+ (map Module.nameToString possibleModules)
185
217
186 QualifiedUnknown possibilities ->
218 QualifiedUnknown possibilities ->
187 details "qualified-unknown" possibilities
219 details "qualified-unknown" possibilities
188
220
189 ExposedUnknown closeExposed closeQualified ->
221 ExposedUnknown closeExposed closeQualified ->
190 details "exposed-unknown" (closeExposed ++ closeQualified)
222 details "exposed-unknown" (closeExposed ++ closeQualified)
191−
223+--}
192
224
193{-- TO STRING
225{-- TO STRING
194
226
src/Reporting/Error/Syntax.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Reporting.Error.Syntax where
3+
4+import qualified Data.Aeson as Json
5+import qualified Text.Parsec.Error as Parsec
6+
7+import qualified Reporting.Region as R
8+
9+
10+data Error
11+ = Parse [Parsec.Message]
12+ | InfixDuplicate String
13+ | TypeWithoutDefinition String
14+ | PortWithoutAnnotation String
15+ | DuplicateValueDeclaration String
16+ | DuplicateTypeDeclaration String
17+ | DuplicateDefinition String
18+ | UnboundTypeVar String String
19+
20+
21+-- TO STRING
22+
23+toString :: R.Region -> Error -> String
24+toString region err =
25+ case err of
26+ _ -> error "Syntax.toString" region
27+
28+
29+-- TO JSON
30+
31+toJson :: Error -> Json.Value
32+toJson err =
33+ case err of
34+ _ -> error "Syntax.toJson"
35+
src/Reporting/Error/Type.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Reporting.Error.Type where
3+
4+--import Data.Aeson ((.=))
5+import qualified Data.Aeson as Json
6+
7+import qualified AST.Type as T
8+import qualified Reporting.Region as R
9+
10+
11+data Error
12+ = Mismatch Mismatch
13+ | InfiniteType R.Region
14+ | BadMain T.Canonical
15+ | ProblemWithInferenceAlgorithm String
16+
17+
18+data Mismatch = MismatchInfo
19+ { hint :: Maybe String
20+ , leftType :: T.Canonical
21+ , rightType :: T.Canonical
22+ }
23+
24+
25+-- TO STRING
26+
27+toString :: R.Region -> Error -> String
28+toString region err =
29+ case err of
30+ _ -> error "Type.toString" region
31+
32+
33+-- TO JSON
34+
35+toJson :: Error -> Json.Value
36+toJson err =
37+ case err of
38+ _ -> error "Type.toJson"
39+
src/AST/PrettyPrint.hs → src/Reporting/PrettyPrint.hsrenamed+4−22
@@ -1,26 +1,17 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2−module AST.PrettyPrint where
2+module Reporting.PrettyPrint where
3
3
4−import Control.Monad.Trans.Error
5import Text.PrettyPrint as P
4import Text.PrettyPrint as P
6import qualified AST.Helpers as Help
5import qualified AST.Helpers as Help
7
6
8
7
9class Pretty a where
8class Pretty a where
10− pretty :: a -> Doc
9+ pretty :: Bool -> a -> Doc
11−
12−
13−instance Pretty Doc where
14− pretty doc = doc
15
10
16
11
17instance Pretty String where
12instance Pretty String where
18− pretty = P.text
13+ pretty _ str =
19−
14+ P.text str
20−
21−renderPretty :: (Pretty a) => a -> String
22−renderPretty e =
23− render (pretty e)
24
15
25
16
26commaCat :: [Doc] -> Doc
17commaCat :: [Doc] -> Doc
@@ -53,12 +44,3 @@ eightyCharLines indent message = answer
53 step (sentence, slen, space) (word, wlen)
44 step (sentence, slen, space) (word, wlen)
54 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
45 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
55 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
46 | 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/Reporting/Region.hsnew file+73
@@ -0,0 +1,73 @@
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+ let posToString pos =
40+ "(line " ++ show (line pos) ++
41+ ", column " ++ show (column pos) ++ ")"
42+ in
43+ posToString start ++ " to " ++ posToString end
44+
45+
46+toPrettyString :: Region -> String
47+toPrettyString (Region start end) =
48+ case line start == line end of
49+ False ->
50+ "between lines " ++ show (line start)
51+ ++ " and " ++ show (line end)
52+
53+ True ->
54+ "on line " ++ show (line end) ++ ", column "
55+ ++ show (column start) ++ " to " ++ show (column end)
56+
57+
58+-- JSON
59+
60+instance Json.ToJSON Region where
61+ toJSON (Region start end) =
62+ Json.object
63+ [ "start" .= start
64+ , "end" .= end
65+ ]
66+
67+
68+instance Json.ToJSON Position where
69+ toJSON (Position line column) =
70+ Json.object
71+ [ "line" .= line
72+ , "column" .= column
73+ ]
src/Reporting/Task.hsnew file+51
@@ -0,0 +1,51 @@
1+module Reporting.Task where
2+
3+import Control.Monad.Except (Except, ExceptT, runExcept, runExceptT, throwError, withExceptT)
4+import qualified Control.Monad.State as State
5+
6+import qualified Reporting.Annotation as A
7+import qualified Reporting.Region as R
8+
9+
10+-- TASK
11+
12+type Task warning error result =
13+ ExceptT [A.Located error] (State.State [A.Located warning]) result
14+
15+
16+-- RUN TASKS
17+
18+run :: Task w e a -> (Either [A.Located e] a, [A.Located w])
19+run task =
20+ State.runState (runExceptT task) []
21+
22+
23+-- WARNINGS
24+
25+addWarnings :: [A.Located w] -> Task w e ()
26+addWarnings warnings =
27+ State.modify (warnings++)
28+
29+
30+-- ERRORS
31+
32+throw :: R.Region -> e -> Task w e a
33+throw region err =
34+ throwError [A.A region err]
35+
36+
37+mapError :: (e -> e') -> Task w e a -> Task w e' a
38+mapError f task =
39+ withExceptT (map (A.map f)) task
40+
41+
42+from :: (e -> e') -> Except [A.Located e] a -> Task w e' a
43+from f except =
44+ case runExcept except of
45+ Right answer ->
46+ return answer
47+
48+ Left errors ->
49+ throwError (map (A.map f) errors)
50+
51+
src/Reporting/Warning.hsnew file+8
@@ -0,0 +1,8 @@
1+module Reporting.Warning where
2+
3+import qualified AST.Module as Module
4+
5+
6+data Warning
7+ = UnusedImport Module.Name
8+ | MissingTypeAnnotation String
src/Transform/AddDefaultImports.hs+10−7
@@ -10,7 +10,7 @@ import qualified AST.Variable as Var
10(==>) = (,)
10(==>) = (,)
11
11
12
12
13−defaultImports :: [(Module.Name, Module.ImportMethod)]
13+defaultImports :: [Module.DefaultImport]
14defaultImports =
14defaultImports =
15 [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing
15 [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing
16 , ["List"] ==> exposing [Var.Value "::"]
16 , ["List"] ==> exposing [Var.Value "::"]
@@ -27,11 +27,14 @@ exposing vars =
27
27
28-- ADDING DEFAULT IMPORTS TO A MODULE
28-- ADDING DEFAULT IMPORTS TO A MODULE
29
29
30−add :: Bool -> Module.Module exs body -> Module.Module exs body
30+add
31+ :: Bool
32+ -> [Module.UserImport]
33+ -> ([Module.DefaultImport], [Module.UserImport])
31−add needsDefaults (Module.Module moduleName path exports imports decls) =
34+add needsDefaults imports =
32− Module.Module moduleName path exports ammendedImports decls
35+ (defaults, imports)
33 where
36 where
34− ammendedImports =
37+ defaults =
35 if needsDefaults
38 if needsDefaults
36− then defaultImports ++ imports
39+ then defaultImports
37− else imports
40+ else []
src/Transform/Canonicalize.hs+83−57
@@ -1,26 +1,30 @@
1module Transform.Canonicalize (module') where
1module Transform.Canonicalize (module') where
2
2
3import Control.Applicative ((<$>),(<*>))
3import Control.Applicative ((<$>),(<*>))
4+import Control.Monad.Except (throwError)
4import qualified Data.List as List
5import qualified Data.List as List
5import qualified Data.Map as Map
6import qualified Data.Map as Map
7+import qualified Data.Maybe as Maybe
6import qualified Data.Set as Set
8import qualified Data.Set as Set
7import qualified Data.Traversable as T
9import qualified Data.Traversable as T
8
10
9import AST.Expression.General (Expr'(..), dummyLet)
11import AST.Expression.General (Expr'(..), dummyLet)
12+import AST.Module (CanonicalBody(..))
13+
14+import qualified AST.Declaration as D
10import qualified AST.Expression.General as E
15import qualified AST.Expression.General as E
11import qualified AST.Expression.Valid as Valid
16import qualified AST.Expression.Valid as Valid
12import qualified AST.Expression.Canonical as Canonical
17import qualified AST.Expression.Canonical as Canonical
13−
14−import AST.Module (CanonicalBody(..))
15−import qualified AST.Annotation as A
16−import qualified AST.Declaration as D
17import qualified AST.Module as Module
18import qualified AST.Module as Module
18import qualified AST.Pattern as P
19import qualified AST.Pattern as P
19import qualified AST.Type as Type
20import qualified AST.Type as Type
20import qualified AST.Variable as Var
21import qualified AST.Variable as Var
21−
22+import qualified Reporting.Annotation as A
23+import qualified Reporting.Error as Error
24+import qualified Reporting.Error.Canonicalize as CError
25+import qualified Reporting.Task as Task
26+import qualified Reporting.Warning as Warning
22import qualified Transform.Canonicalize.Environment as Env
27import qualified Transform.Canonicalize.Environment as Env
23−import qualified Transform.Canonicalize.Error as Error
24import qualified Transform.Canonicalize.Port as Port
28import qualified Transform.Canonicalize.Port as Port
25import qualified Transform.Canonicalize.Result as Result
29import qualified Transform.Canonicalize.Result as Result
26import qualified Transform.Canonicalize.Setup as Setup
30import qualified Transform.Canonicalize.Setup as Setup
@@ -30,33 +34,31 @@ import qualified Transform.SortDefinitions as Transform
30import qualified Transform.Declaration as Transform
34import qualified Transform.Declaration as Transform
31
35
32
36
37+-- MODULES
38+
33module'
39module'
34 :: Module.Interfaces
40 :: Module.Interfaces
35 -> Module.ValidModule
41 -> Module.ValidModule
36− -> ([Module.Name], Either [Error.Error] Module.CanonicalModule)
42+ -> Task.Task Warning.Warning Error.Error Module.CanonicalModule
37−module' interfaces modul@(Module.Module _ _ _ imports _) =
43+module' interfaces modul@(Module.Module _ _ _ (_, imports) _) =
38 let (Result.Result uses rawResults) =
44 let (Result.Result uses rawResults) =
39 moduleHelp interfaces modul
45 moduleHelp interfaces modul
40
46
41− unusedImports =
47+ in
42− filter (\name -> not (Set.member name uses)) (map fst imports)
48+ do Task.addWarnings (Maybe.mapMaybe (warnUnusedImport uses) imports)
43−
44− either =
45 case rawResults of
49 case rawResults of
46 Result.Ok canonicalModule ->
50 Result.Ok canonicalModule ->
47− Right canonicalModule
51+ return canonicalModule
48
52
49 Result.Err msgs ->
53 Result.Err msgs ->
50− Left msgs
54+ throwError (map (A.map Error.Canonicalize) msgs)
51− in
52− (unusedImports, either)
53
55
54
56
55moduleHelp
57moduleHelp
56 :: Module.Interfaces
58 :: Module.Interfaces
57 -> Module.ValidModule
59 -> Module.ValidModule
58− -> Result.Result Module.CanonicalModule
60+ -> Result.ResultErr Module.CanonicalModule
59−moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
61+moduleHelp interfaces modul@(Module.Module _ _ exports (defaults, imports) decls) =
60 canonicalModule
62 canonicalModule
61 <$> canonicalDeclsResult
63 <$> canonicalDeclsResult
62 <*> resolveExports locals exports
64 <*> resolveExports locals exports
@@ -64,6 +66,7 @@ moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
64 canonicalModule canonicalDecls canonicalExports =
66 canonicalModule canonicalDecls canonicalExports =
65 modul
67 modul
66 { Module.exports = canonicalExports
68 { Module.exports = canonicalExports
69+ , Module.imports = map fst defaults ++ map (fst . A.drop) imports
67 , Module.body = body canonicalDecls
70 , Module.body = body canonicalDecls
68 }
71 }
69
72
@@ -77,26 +80,47 @@ moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
77
80
78 body :: [D.CanonicalDecl] -> Module.CanonicalBody
81 body :: [D.CanonicalDecl] -> Module.CanonicalBody
79 body decls =
82 body decls =
83+ let nakedDecls = map A.drop decls
84+ in
80 Module.CanonicalBody
85 Module.CanonicalBody
81 { program =
86 { program =
82− let expr = Transform.toExpr (Module.names modul) decls
87+ let expr = Transform.toExpr (Module.names modul) decls
88+ in
83− in Transform.sortDefs (dummyLet expr)
89+ Transform.sortDefs (dummyLet expr)
90+
91+ , types =
84− , types = Map.empty
92+ Map.empty
93+
85 , datatypes =
94 , datatypes =
86− Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]
95+ Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- nakedDecls ]
96+
87 , fixities =
97 , fixities =
88− [ (assoc,level,op) | D.Fixity assoc level op <- decls ]
98+ [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]
99+
89 , aliases =
100 , aliases =
90− Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]
101+ Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- nakedDecls ]
102+
91 , ports =
103 , ports =
92− [ E.portName impl | D.Port (D.CanonicalPort impl) <- decls ]
104+ [ E.portName impl | D.Port (D.CanonicalPort impl) <- nakedDecls ]
93 }
105 }
94
106
95
107
108+-- IMPORTS / EXPORTS
109+
110+warnUnusedImport
111+ :: Set.Set Module.Name
112+ -> Module.UserImport
113+ -> Maybe (A.Located Warning.Warning)
114+warnUnusedImport uses (A.A region (name, _method)) =
115+ if Set.member name uses
116+ then Nothing
117+ else Just (A.A region (Warning.UnusedImport name))
118+
119+
96resolveExports
120resolveExports
97 :: [Var.Value]
121 :: [Var.Value]
98 -> Var.Listing Var.Value
122 -> Var.Listing Var.Value
99− -> Result.Result [Var.Value]
123+ -> Result.ResultErr [Var.Value]
100resolveExports fullList (Var.Listing partialList open) =
124resolveExports fullList (Var.Listing partialList open) =
101 if open
125 if open
102 then Result.ok fullList
126 then Result.ok fullList
@@ -148,12 +172,10 @@ resolveExports fullList (Var.Listing partialList open) =
148 Result.errors (map (notFound possibilities) nameList)
172 Result.errors (map (notFound possibilities) nameList)
149
173
150 notFound possibilities name =
174 notFound possibilities name =
175+ A.A undefined $ CError.Export name $
151− Error.Export name (Error.nearbyNames id name possibilities)
176+ CError.nearbyNames id name possibilities
152
177
153
178
154−{-| Split a list of values into categories so we can work with them
155−independently.
156−-}
157splitValues
179splitValues
158 :: [Var.Value]
180 :: [Var.Value]
159 -> ([String], [String], [(String, Var.Listing String)])
181 -> ([String], [String], [(String, Var.Listing String)])
@@ -173,8 +195,10 @@ splitValues mixedValues =
173 (values, aliases, (name, listing) : adts)
195 (values, aliases, (name, listing) : adts)
174
196
175
197
198+-- DECLARATIONS
199+
176declToValue :: D.ValidDecl -> [Var.Value]
200declToValue :: D.ValidDecl -> [Var.Value]
177−declToValue decl =
201+declToValue (A.A _ decl) =
178 case decl of
202 case decl of
179 D.Definition (Valid.Definition pattern _ _) ->
203 D.Definition (Valid.Definition pattern _ _) ->
180 map Var.Value (P.boundVarList pattern)
204 map Var.Value (P.boundVarList pattern)
@@ -184,7 +208,7 @@ declToValue decl =
184
208
185 D.TypeAlias name _ tipe ->
209 D.TypeAlias name _ tipe ->
186 case tipe of
210 case tipe of
187− Type.Record _ _ ->
211+ A.A _ (Type.RRecord _ _) ->
188 [ Var.Alias name, Var.Value name ]
212 [ Var.Alias name, Var.Value name ]
189 _ -> [ Var.Alias name ]
213 _ -> [ Var.Alias name ]
190
214
@@ -194,11 +218,12 @@ declToValue decl =
194declaration
218declaration
195 :: Env.Environment
219 :: Env.Environment
196 -> D.ValidDecl
220 -> D.ValidDecl
197− -> Result.Result D.CanonicalDecl
221+ -> Result.ResultErr D.CanonicalDecl
198−declaration env decl =
222+declaration env (A.A region decl) =
199 let canonicalize kind _context _pattern env v =
223 let canonicalize kind _context _pattern env v =
200 kind env v
224 kind env v
201 in
225 in
226+ A.A region <$>
202 case decl of
227 case decl of
203 D.Definition (Valid.Definition p e t) ->
228 D.Definition (Valid.Definition p e t) ->
204 D.Definition <$> (
229 D.Definition <$> (
@@ -244,14 +269,11 @@ declaration env decl =
244expression
269expression
245 :: Env.Environment
270 :: Env.Environment
246 -> Valid.Expr
271 -> Valid.Expr
247− -> Result.Result Canonical.Expr
272+ -> Result.ResultErr Canonical.Expr
248−expression env (A.A ann validExpr) =
273+expression env (A.A region validExpr) =
249 let go = expression env
274 let go = expression env
250− tipe' environ =
251− format . Canonicalize.tipe environ
252− format = id
253 in
275 in
254− A.A ann <$>
276+ A.A region <$>
255 case validExpr of
277 case validExpr of
256 Literal lit ->
278 Literal lit ->
257 Result.ok (Literal lit)
279 Result.ok (Literal lit)
@@ -279,14 +301,14 @@ expression env (A.A ann validExpr) =
279
301
280 Binop (Var.Raw op) leftExpr rightExpr ->
302 Binop (Var.Raw op) leftExpr rightExpr ->
281 Binop
303 Binop
282− <$> format (Canonicalize.variable env op)
304+ <$> Canonicalize.variable region env op
283 <*> go leftExpr
305 <*> go leftExpr
284 <*> go rightExpr
306 <*> go rightExpr
285
307
286 Lambda arg body ->
308 Lambda arg body ->
287 let env' = Env.addPattern arg env
309 let env' = Env.addPattern arg env
288 in
310 in
289− Lambda <$> format (pattern env' arg) <*> expression env' body
311+ Lambda <$> pattern env' arg <*> expression env' body
290
312
291 App func arg ->
313 App func arg ->
292 App <$> go func <*> go arg
314 App <$> go func <*> go arg
@@ -305,12 +327,12 @@ expression env (A.A ann validExpr) =
305
327
306 rename' (Valid.Definition p body mtipe) =
328 rename' (Valid.Definition p body mtipe) =
307 Canonical.Definition
329 Canonical.Definition
308− <$> format (pattern env' p)
330+ <$> pattern env' p
309 <*> expression env' body
331 <*> expression env' body
310− <*> T.traverse (tipe' env') mtipe
332+ <*> T.traverse (Canonicalize.tipe env') mtipe
311
333
312 Var (Var.Raw x) ->
334 Var (Var.Raw x) ->
313− Var <$> format (Canonicalize.variable env x)
335+ Var <$> Canonicalize.variable region env x
314
336
315 Data name exprs ->
337 Data name exprs ->
316 Data name <$> T.traverse go exprs
338 Data name <$> T.traverse go exprs
@@ -321,18 +343,21 @@ expression env (A.A ann validExpr) =
321 Case expr cases ->
343 Case expr cases ->
322 Case <$> go expr <*> T.traverse branch cases
344 Case <$> go expr <*> T.traverse branch cases
323 where
345 where
324− branch (p,b) =
346+ branch (ptrn, brnch) =
325− (,) <$> format (pattern env p)
347+ (,) <$> pattern env ptrn
326− <*> expression (Env.addPattern p env) b
348+ <*> expression (Env.addPattern ptrn env) brnch
327
349
328 Port impl ->
350 Port impl ->
329 let portType pt =
351 let portType pt =
330 case pt of
352 case pt of
331 Type.Normal t ->
353 Type.Normal t ->
332− Type.Normal <$> tipe' env t
354+ Type.Normal
355+ <$> Canonicalize.tipe env t
333
356
334 Type.Signal root arg ->
357 Type.Signal root arg ->
335− Type.Signal <$> tipe' env root <*> tipe' env arg
358+ Type.Signal
359+ <$> Canonicalize.tipe env root
360+ <*> Canonicalize.tipe env arg
336 in
361 in
337 Port <$>
362 Port <$>
338 case impl of
363 case impl of
@@ -352,8 +377,9 @@ expression env (A.A ann validExpr) =
352pattern
377pattern
353 :: Env.Environment
378 :: Env.Environment
354 -> P.RawPattern
379 -> P.RawPattern
355− -> Result.Result P.CanonicalPattern
380+ -> Result.ResultErr P.CanonicalPattern
356−pattern env ptrn =
381+pattern env (A.A region ptrn) =
382+ A.A region <$>
357 case ptrn of
383 case ptrn of
358 P.Var x ->
384 P.Var x ->
359 Result.ok (P.Var x)
385 Result.ok (P.Var x)
@@ -361,8 +387,8 @@ pattern env ptrn =
361 P.Literal lit ->
387 P.Literal lit ->
362 Result.ok (P.Literal lit)
388 Result.ok (P.Literal lit)
363
389
364− P.Record fs ->
390+ P.Record fields ->
365− Result.ok (P.Record fs)
391+ Result.ok (P.Record fields)
366
392
367 P.Anything ->
393 P.Anything ->
368 Result.ok P.Anything
394 Result.ok P.Anything
@@ -370,7 +396,7 @@ pattern env ptrn =
370 P.Alias x p ->
396 P.Alias x p ->
371 P.Alias x <$> pattern env p
397 P.Alias x <$> pattern env p
372
398
373− P.Data (Var.Raw name) ps ->
399+ P.Data (Var.Raw name) patterns ->
374 P.Data
400 P.Data
375− <$> Canonicalize.pvar env name
401+ <$> Canonicalize.pvar region env name (length patterns)
376− <*> T.traverse (pattern env) ps
402+ <*> T.traverse (pattern env) patterns
src/Transform/Canonicalize/Environment.hs+21−11
@@ -18,8 +18,8 @@ data Environment = Env
18 { _home :: Module.Name
18 { _home :: Module.Name
19 , _values :: Dict Var.Canonical
19 , _values :: Dict Var.Canonical
20 , _adts :: Dict Var.Canonical
20 , _adts :: Dict Var.Canonical
21− , _aliases :: Dict (Var.Canonical, [String], Type.CanonicalType)
21+ , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)
22− , _patterns :: Dict Var.Canonical
22+ , _patterns :: Dict (Var.Canonical, Int)
23 }
23 }
24
24
25
25
@@ -34,7 +34,7 @@ fromPatches moduleName patches =
34 (Env moduleName Map.empty Map.empty Map.empty Map.empty)
34 (Env moduleName Map.empty Map.empty Map.empty Map.empty)
35
35
36
36
37−addPattern :: P.Pattern var -> Environment -> Environment
37+addPattern :: P.Pattern ann var -> Environment -> Environment
38addPattern pattern env =
38addPattern pattern env =
39 let patches =
39 let patches =
40 map (\x -> Value x (Var.local x)) (P.boundVarList pattern)
40 map (\x -> Value x (Var.local x)) (P.boundVarList pattern)
@@ -47,8 +47,8 @@ addPattern pattern env =
47data Patch
47data Patch
48 = Value String Var.Canonical
48 = Value String Var.Canonical
49 | Union String Var.Canonical
49 | Union String Var.Canonical
50− | Alias String (Var.Canonical, [String], Type.CanonicalType)
50+ | Alias String (Var.Canonical, [String], Type.Canonical)
51− | Pattern String Var.Canonical
51+ | Pattern String (Var.Canonical, Int)
52
52
53
53
54-- ADD PATCH TO ENVIRONMENT
54-- ADD PATCH TO ENVIRONMENT
@@ -84,13 +84,23 @@ insert key value =
84builtinPatches :: [Patch]
84builtinPatches :: [Patch]
85builtinPatches =
85builtinPatches =
86 concat
86 concat
87− [ builtIn Value (tuples ++ [saveEnvName])
87+ [ map (patch Value) (tupleNames ++ [saveEnvName])
88− , builtIn Union (tuples ++ ["List","Int","Float","Char","Bool","String"])
88+ , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])
89− , builtIn Pattern (tuples ++ ["::","[]"])
89+ , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])
90 ]
90 ]
91 where
91 where
92− builtIn patch xs =
92+ patch mkPatch name =
93− map (\x -> patch x (Var.Canonical Var.BuiltIn x)) xs
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
94
100
95 tuples =
101 tuples =
96− map (\n -> "_Tuple" ++ show n) [0 .. 9 :: Int]
102+ map toTuple [0..9]
103+
104+ toTuple :: Int -> (String, Int)
105+ toTuple n =
106+ ("_Tuple" ++ show n, n)
src/Transform/Canonicalize/Port.hs+12−10
@@ -8,7 +8,8 @@ import qualified AST.Expression.General as E
8import qualified AST.Expression.Canonical as Canonical
8import qualified AST.Expression.Canonical as Canonical
9import qualified AST.Type as T
9import qualified AST.Type as T
10import qualified AST.Variable as Var
10import qualified AST.Variable as Var
11−import qualified Transform.Canonicalize.Error as Error
11+import qualified Reporting.Annotation as A
12+import qualified Reporting.Error.Canonicalize as Error
12import qualified Transform.Canonicalize.Result as Result
13import qualified Transform.Canonicalize.Result as Result
13
14
14
15
@@ -17,8 +18,8 @@ import qualified Transform.Canonicalize.Result as Result
17check
18check
18 :: String
19 :: String
19 -> Maybe Canonical.Expr
20 -> Maybe Canonical.Expr
20− -> T.CanonicalType
21+ -> T.Canonical
21− -> Result.Result D.CanonicalPort
22+ -> Result.ResultErr D.CanonicalPort
22check name maybeExpr rootType =
23check name maybeExpr rootType =
23 D.CanonicalPort <$> checkHelp name maybeExpr rootType rootType
24 D.CanonicalPort <$> checkHelp name maybeExpr rootType rootType
24
25
@@ -26,9 +27,9 @@ check name maybeExpr rootType =
26checkHelp
27checkHelp
27 :: String
28 :: String
28 -> Maybe Canonical.Expr
29 -> Maybe Canonical.Expr
29− -> T.CanonicalType
30+ -> T.Canonical
30− -> T.CanonicalType
31+ -> T.Canonical
31− -> Result.Result (E.PortImpl Canonical.Expr Var.Canonical)
32+ -> Result.ResultErr (E.PortImpl Canonical.Expr T.Canonical)
32checkHelp name maybeExpr rootType tipe =
33checkHelp name maybeExpr rootType tipe =
33 case (maybeExpr, tipe) of
34 case (maybeExpr, tipe) of
34 (_, T.Aliased _ args t) ->
35 (_, T.Aliased _ args t) ->
@@ -71,15 +72,16 @@ checkHelp name maybeExpr rootType tipe =
71validForeignType
72validForeignType
72 :: String
73 :: String
73 -> Bool
74 -> Bool
74− -> T.CanonicalType
75+ -> T.Canonical
75− -> T.CanonicalType
76+ -> T.Canonical
76− -> Result.Result ()
77+ -> Result.ResultErr ()
77validForeignType name isInbound rootType tipe =
78validForeignType name isInbound rootType tipe =
78 let valid localType =
79 let valid localType =
79 validForeignType name isInbound rootType localType
80 validForeignType name isInbound rootType localType
80
81
81 err problem =
82 err problem =
83+ Result.err $ A.A undefined $
82− Result.err (Error.port name isInbound rootType tipe problem)
84+ Error.port name isInbound rootType tipe problem
83 in
85 in
84 case tipe of
86 case tipe of
85 T.Aliased _ args t ->
87 T.Aliased _ args t ->
src/Transform/Canonicalize/Result.hs+17−13
@@ -8,11 +8,15 @@ import qualified Data.Set as Set
8
8
9import qualified AST.Module as Module
9import qualified AST.Module as Module
10import qualified AST.Variable as Var
10import qualified AST.Variable as Var
11−import qualified Transform.Canonicalize.Error as Error
11+import qualified Reporting.Annotation as A
12+import qualified Reporting.Error.Canonicalize as Error
12
13
13
14
15+type ResultErr a = Result (A.Located Error.Error) a
16+
17+
14−data Result a =
18+data Result err a =
15− Result (Set.Set Module.Name) (RawResult Error.Error a)
19+ Result (Set.Set Module.Name) (RawResult err a)
16
20
17
21
18data RawResult err a
22data RawResult err a
@@ -22,22 +26,22 @@ data RawResult err a
22
26
23-- RESULT HELPERS
27-- RESULT HELPERS
24
28
25−ok :: a -> Result a
29+ok :: a -> Result e a
26ok value =
30ok value =
27 Result Set.empty (Ok value)
31 Result Set.empty (Ok value)
28
32
29
33
30−err :: Error.Error -> Result a
34+err :: e -> Result e a
31err msg =
35err msg =
32 errors [msg]
36 errors [msg]
33
37
34
38
35−errors :: [Error.Error] -> Result a
39+errors :: [e] -> Result e a
36errors msgs =
40errors msgs =
37 Result Set.empty (Err msgs)
41 Result Set.empty (Err msgs)
38
42
39
43
40−foldl :: (a -> b -> Result b) -> b -> [a] -> Result b
44+foldl :: (a -> b -> Result e b) -> b -> [a] -> Result e b
41foldl f acc list =
45foldl f acc list =
42 case list of
46 case list of
43 [] ->
47 [] ->
@@ -47,7 +51,7 @@ foldl f acc list =
47 f x acc `andThen` (\acc' -> foldl f acc' xs)
51 f x acc `andThen` (\acc' -> foldl f acc' xs)
48
52
49
53
50−andThen :: Result a -> (a -> Result b) -> Result b
54+andThen :: Result e a -> (a -> Result e b) -> Result e b
51andThen (Result uses rawResult) callback =
55andThen (Result uses rawResult) callback =
52 case rawResult of
56 case rawResult of
53 Err msg ->
57 Err msg ->
@@ -57,7 +61,7 @@ andThen (Result uses rawResult) callback =
57 callback value
61 callback value
58
62
59
63
60−instance F.Functor Result where
64+instance F.Functor (Result e) where
61 fmap func (Result uses result) =
65 fmap func (Result uses result) =
62 case result of
66 case result of
63 Ok a ->
67 Ok a ->
@@ -67,7 +71,7 @@ instance F.Functor Result where
67 Result uses (Err msgs)
71 Result uses (Err msgs)
68
72
69
73
70−instance A.Applicative Result where
74+instance A.Applicative (Result e) where
71 pure value =
75 pure value =
72 ok value
76 ok value
73
77
@@ -89,12 +93,12 @@ instance A.Applicative Result where
89
93
90-- TRACK USES OF IMPORTS
94-- TRACK USES OF IMPORTS
91
95
92−addModule :: Module.Name -> Result a -> Result a
96+addModule :: Module.Name -> Result e a -> Result e a
93addModule home (Result uses result) =
97addModule home (Result uses result) =
94 Result (Set.insert home uses) result
98 Result (Set.insert home uses) result
95
99
96
100
97−var' :: (a -> Var.Canonical) -> a -> Result a
101+var' :: (a -> Var.Canonical) -> a -> Result e a
98var' toVar value =
102var' toVar value =
99 case toVar value of
103 case toVar value of
100 Var.Canonical (Var.Module moduleName) _name ->
104 Var.Canonical (Var.Module moduleName) _name ->
@@ -104,7 +108,7 @@ var' toVar value =
104 ok value
108 ok value
105
109
106
110
107−var :: Var.Canonical -> Result Var.Canonical
111+var :: Var.Canonical -> Result e Var.Canonical
108var variable =
112var variable =
109 var' id variable
113 var' id variable
110
114
src/Transform/Canonicalize/Setup.hs+75−50
@@ -2,6 +2,7 @@
2module Transform.Canonicalize.Setup (environment) where
2module Transform.Canonicalize.Setup (environment) where
3
3
4import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
5+import Control.Arrow (second)
5import qualified Data.Graph as Graph
6import qualified Data.Graph as Graph
6import qualified Data.Map as Map
7import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.Maybe as Maybe
@@ -14,8 +15,10 @@ import qualified AST.Pattern as P
14import qualified AST.Type as Type
15import qualified AST.Type as Type
15import qualified AST.Variable as Var
16import qualified AST.Variable as Var
16import Elm.Utils ((|>))
17import Elm.Utils ((|>))
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.Error.Canonicalize as Error
20+import qualified Reporting.Region as R
17import qualified Transform.Canonicalize.Environment as Env
21import qualified Transform.Canonicalize.Environment as Env
18−import qualified Transform.Canonicalize.Error as Error
19import qualified Transform.Canonicalize.Result as Result
22import qualified Transform.Canonicalize.Result as Result
20import qualified Transform.Canonicalize.Type as Canonicalize
23import qualified Transform.Canonicalize.Type as Canonicalize
21import qualified Transform.Interface as Interface
24import qualified Transform.Interface as Interface
@@ -24,14 +27,16 @@ import qualified Transform.Interface as Interface
24environment
27environment
25 :: Module.Interfaces
28 :: Module.Interfaces
26 -> Module.ValidModule
29 -> Module.ValidModule
27− -> Result.Result Env.Environment
30+ -> Result.ResultErr Env.Environment
28−environment interfaces modul@(Module.Module _ _ _ imports decls) =
31+environment interfaces modul@(Module.Module _ _ _ (defaults, imports) decls) =
29 let moduleName =
32 let moduleName =
30 Module.names modul
33 Module.names modul
31
34
35+ allImports =
36+ imports ++ map (A.A (error "default import not found")) defaults
37+
32 importPatchesResult =
38 importPatchesResult =
33− concat <$>
34− Trav.traverse (importPatches interfaces) imports
39+ concat <$> Trav.traverse (importPatches interfaces) allImports
35
40
36 (typeAliasNodes, declPatches) =
41 (typeAliasNodes, declPatches) =
37 declarationsToPatches moduleName decls
42 declarationsToPatches moduleName decls
@@ -47,9 +52,9 @@ environment interfaces modul@(Module.Module _ _ _ imports decls) =
47
52
48importPatches
53importPatches
49 :: Module.Interfaces
54 :: Module.Interfaces
50− -> (Module.Name, Module.ImportMethod)
55+ -> A.Located (Module.Name, Module.ImportMethod)
51− -> Result.Result [Env.Patch]
56+ -> Result.ResultErr [Env.Patch]
52−importPatches allInterfaces (importName, method) =
57+importPatches allInterfaces (A.A region (importName, method)) =
53 case Interface.filterExports <$> Map.lookup importName allInterfaces of
58 case Interface.filterExports <$> Map.lookup importName allInterfaces of
54 Nothing
59 Nothing
55 | Module.nameIsNative importName ->
60 | Module.nameIsNative importName ->
@@ -60,6 +65,7 @@ importPatches allInterfaces (importName, method) =
60 |> Map.keys
65 |> Map.keys
61 |> Error.nearbyNames Module.nameToString importName
66 |> Error.nearbyNames Module.nameToString importName
62 |> Error.moduleNotFound importName
67 |> Error.moduleNotFound importName
68+ |> A.A region
63 |> Result.err
69 |> Result.err
64
70
65 Just interface ->
71 Just interface ->
@@ -78,7 +84,7 @@ importPatches allInterfaces (importName, method) =
78 unqualifiedPatches =
84 unqualifiedPatches =
79 if open
85 if open
80 then Result.ok (interfacePatches importName "" interface)
86 then Result.ok (interfacePatches importName "" interface)
81− else concat <$> Trav.traverse (valueToPatches importName interface) exposedValues
87+ else concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
82 in
88 in
83 (++) qualifiedPatches <$> unqualifiedPatches
89 (++) qualifiedPatches <$> unqualifiedPatches
84
90
@@ -95,34 +101,46 @@ interfacePatches moduleName prefix interface =
95 genericPatch Env.Alias name
101 genericPatch Env.Alias name
96 (Var.fromModule moduleName name, tvars, tipe)
102 (Var.fromModule moduleName name, tvars, tipe)
97
103
104+ patternPatch (name, args) =
105+ genericPatch Env.Pattern name
106+ (Var.fromModule moduleName name, length args)
107+
108+ ctors =
109+ concatMap snd (Map.elems (Module.iAdts interface))
110+
98 ctorNames =
111 ctorNames =
99− concatMap (map fst . snd) (Map.elems (Module.iAdts interface))
112+ map fst ctors
100 in
113 in
101 concat
114 concat
102 [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
115 [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
103 , map (patch Env.Value) ctorNames
116 , map (patch Env.Value) ctorNames
104 , map (patch Env.Union) (Map.keys (Module.iAdts interface))
117 , map (patch Env.Union) (Map.keys (Module.iAdts interface))
105 , map aliasPatch (Map.toList (Module.iAliases interface))
118 , map aliasPatch (Map.toList (Module.iAliases interface))
106− , map (patch Env.Pattern) ctorNames
119+ , map patternPatch ctors
107 ]
120 ]
108
121
109
122
110-- PATCHES FOR INDIVIDUAL VALUES
123-- PATCHES FOR INDIVIDUAL VALUES
111
124
112valueToPatches
125valueToPatches
126+ :: R.Region
113− :: Module.Name
127+ -> Module.Name
114 -> Module.Interface
128 -> Module.Interface
115 -> Var.Value
129 -> Var.Value
116− -> Result.Result [Env.Patch]
130+ -> Result.ResultErr [Env.Patch]
117−valueToPatches moduleName interface value =
131+valueToPatches region moduleName interface value =
118 let patch mkPatch x =
132 let patch mkPatch x =
119 mkPatch x (Var.fromModule moduleName x)
133 mkPatch x (Var.fromModule moduleName x)
120
134
135+ patternPatch (x, numArgs) =
136+ Env.Pattern x (Var.fromModule moduleName x, numArgs)
137+
121 notFound getNames x =
138 notFound getNames x =
122 Module.iExports interface
139 Module.iExports interface
123 |> getNames
140 |> getNames
124 |> Error.nearbyNames id x
141 |> Error.nearbyNames id x
125 |> Error.valueNotFound moduleName x
142 |> Error.valueNotFound moduleName x
143+ |> A.A region
126 |> Result.err
144 |> Result.err
127 in
145 in
128 case value of
146 case value of
@@ -164,62 +182,60 @@ valueToPatches moduleName interface value =
164 Just (_tvars, realCtors) ->
182 Just (_tvars, realCtors) ->
165 patches <$>
183 patches <$>
166 if open
184 if open
167− then Result.ok realCtorNames
185+ then Result.ok realCtorList
168 else Trav.traverse ctorExists givenCtorNames
186 else Trav.traverse ctorExists givenCtorNames
169 where
187 where
170− realCtorNames =
188+ realCtorList =
171− map fst realCtors
189+ map (second length) realCtors
190+
191+ realCtorDict =
192+ Map.fromList realCtorList
172
193
173 ctorExists givenCtorName =
194 ctorExists givenCtorName =
174− if givenCtorName `elem` realCtorNames
195+ case Map.lookup givenCtorName realCtorDict of
196+ Just numArgs ->
175− then Result.ok givenCtorName
197+ Result.ok (givenCtorName, numArgs)
198+ Nothing ->
176− else notFound (const realCtorNames) givenCtorName
199+ notFound (const (map fst realCtors)) givenCtorName
177
200
178− patches ctorNames =
201+ patches ctors =
179 patch Env.Union givenName
202 patch Env.Union givenName
180− : map (patch Env.Value) ctorNames
203+ : map (patch Env.Value . fst) ctors
181− ++ map (patch Env.Pattern) ctorNames
204+ ++ map patternPatch ctors
182
205
183
206
184-- PATCHES FOR TYPE ALIASES
207-- PATCHES FOR TYPE ALIASES
185
208
186−type Node = ((String, [String], Type.RawType), String, [String])
209+type Node = ((R.Region, String, [String], Type.Raw), String, [String])
187
210
188
211
189−node :: String -> [String] -> Type.RawType -> Node
212+node :: R.Region -> String -> [String] -> Type.Raw -> Node
190−node name tvars alias =
213+node region name tvars alias =
191− ((name, tvars, alias), name, edges alias)
214+ ((region, name, tvars, alias), name, edges alias)
192 where
215 where
193− edges tipe =
216+ edges (A.A _ tipe) =
194 case tipe of
217 case tipe of
195− Type.Lambda t1 t2 ->
218+ Type.RLambda t1 t2 ->
196 edges t1 ++ edges t2
219 edges t1 ++ edges t2
197
220
198− Type.Var _ ->
221+ Type.RVar _ ->
199 []
222 []
200
223
201− Type.Type (Var.Raw x) ->
224+ Type.RType (Var.Raw x) ->
202 [x]
225 [x]
203
226
204− Type.App t ts ->
227+ Type.RApp t ts ->
205 edges t ++ concatMap edges ts
228 edges t ++ concatMap edges ts
206
229
207− Type.Record fs ext ->
230+ Type.RRecord fs ext ->
208 maybe [] edges ext ++ concatMap (edges . snd) fs
231 maybe [] edges ext ++ concatMap (edges . snd) fs
209
232
210− Type.Aliased _ args aliasType ->
211− case aliasType of
212− Type.Holey t ->
213− edges t ++ concatMap (edges . snd) args
214− Type.Filled t ->
215− edges t
216−
217
233
218addTypeAliases
234addTypeAliases
219 :: Module.Name
235 :: Module.Name
220 -> [Node]
236 -> [Node]
221 -> Env.Environment
237 -> Env.Environment
222− -> Result.Result Env.Environment
238+ -> Result.ResultErr Env.Environment
223addTypeAliases moduleName typeAliasNodes initialEnv =
239addTypeAliases moduleName typeAliasNodes initialEnv =
224 Result.foldl
240 Result.foldl
225 (addTypeAlias moduleName)
241 (addTypeAlias moduleName)
@@ -229,12 +245,12 @@ addTypeAliases moduleName typeAliasNodes initialEnv =
229
245
230addTypeAlias
246addTypeAlias
231 :: Module.Name
247 :: Module.Name
232− -> Graph.SCC (String, [String], Type.RawType)
248+ -> Graph.SCC (R.Region, String, [String], Type.Raw)
233 -> Env.Environment
249 -> Env.Environment
234− -> Result.Result Env.Environment
250+ -> Result.ResultErr Env.Environment
235addTypeAlias moduleName scc env =
251addTypeAlias moduleName scc env =
236 case scc of
252 case scc of
237− Graph.AcyclicSCC (name, tvars, alias) ->
253+ Graph.AcyclicSCC (_, name, tvars, alias) ->
238 addToEnv <$> Canonicalize.tipe env alias
254 addToEnv <$> Canonicalize.tipe env alias
239 where
255 where
240 addToEnv alias' =
256 addToEnv alias' =
@@ -243,8 +259,14 @@ addTypeAlias moduleName scc env =
243 in
259 in
244 env { Env._aliases = Env.insert name value (Env._aliases env) }
260 env { Env._aliases = Env.insert name value (Env._aliases env) }
245
261
246− Graph.CyclicSCC aliases ->
262+ Graph.CyclicSCC [] ->
263+ Result.ok env
264+
265+ Graph.CyclicSCC [(region, name, tvars, alias)] ->
266+ Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))
267+
268+ Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
247− Result.err (Error.recursiveAlias aliases)
269+ Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))
248
270
249
271
250-- DECLARATIONS TO PATCHES
272-- DECLARATIONS TO PATCHES
@@ -267,12 +289,15 @@ declToPatches
267 :: Module.Name
289 :: Module.Name
268 -> D.ValidDecl
290 -> D.ValidDecl
269 -> (Maybe Node, [Env.Patch])
291 -> (Maybe Node, [Env.Patch])
270−declToPatches moduleName decl =
292+declToPatches moduleName (A.A region decl) =
271 let local mkPatch x =
293 let local mkPatch x =
272 mkPatch x (Var.local x)
294 mkPatch x (Var.local x)
273
295
274 namespaced mkPatch x =
296 namespaced mkPatch x =
275 mkPatch x (Var.fromModule moduleName x)
297 mkPatch x (Var.fromModule moduleName x)
298+
299+ patternPatch (name, args) =
300+ Env.Pattern name (Var.fromModule moduleName name, length args)
276 in
301 in
277 case decl of
302 case decl of
278 D.Definition (Valid.Definition pattern _ _) ->
303 D.Definition (Valid.Definition pattern _ _) ->
@@ -286,13 +311,13 @@ declToPatches moduleName decl =
286 ( Nothing
311 ( Nothing
287 , namespaced Env.Union name
312 , namespaced Env.Union name
288 : map (local Env.Value) ctorNames
313 : map (local Env.Value) ctorNames
289− ++ map (namespaced Env.Pattern) ctorNames
314+ ++ map patternPatch ctors
290 )
315 )
291
316
292 D.TypeAlias name tvars alias ->
317 D.TypeAlias name tvars alias ->
293− ( Just (node name tvars alias)
318+ ( Just (node region name tvars alias)
294 , case alias of
319 , case alias of
295− Type.Record _ _ ->
320+ A.A _ (Type.RRecord _ _) ->
296 [local Env.Value name]
321 [local Env.Value name]
297 _ ->
322 _ ->
298 []
323 []
src/Transform/Canonicalize/Type.hs+30−29
@@ -7,50 +7,50 @@ import qualified Data.Traversable as Trav
7import qualified AST.Type as T
7import qualified AST.Type as T
8import qualified AST.Variable as Var
8import qualified AST.Variable as Var
9
9
10+import qualified Reporting.Annotation as A
11+import qualified Reporting.Error.Canonicalize as Error
12+import qualified Reporting.Region as R
10import qualified Transform.Canonicalize.Environment as Env
13import qualified Transform.Canonicalize.Environment as Env
11−import qualified Transform.Canonicalize.Error as Error
12import qualified Transform.Canonicalize.Result as Result
14import qualified Transform.Canonicalize.Result as Result
13import qualified Transform.Canonicalize.Variable as Canonicalize
15import qualified Transform.Canonicalize.Variable as Canonicalize
14
16
15
17
16tipe
18tipe
17 :: Env.Environment
19 :: Env.Environment
18− -> T.RawType
20+ -> T.Raw
19− -> Result.Result T.CanonicalType
21+ -> Result.ResultErr T.Canonical
20−tipe env typ =
22+tipe env typ@(A.A region typ') =
21 let go = tipe env
23 let go = tipe env
22 goSnd (name,t) =
24 goSnd (name,t) =
23 (,) name <$> go t
25 (,) name <$> go t
24 in
26 in
25− case typ of
27+ case typ' of
26− T.Var x ->
28+ T.RVar x ->
27 Result.ok (T.Var x)
29 Result.ok (T.Var x)
28
30
29− T.Type _ ->
31+ T.RType _ ->
30− canonicalizeApp env typ []
32+ canonicalizeApp region env typ []
31
33
32− T.App t ts ->
34+ T.RApp t ts ->
33− canonicalizeApp env t ts
35+ canonicalizeApp region env t ts
34
36
35− T.Lambda a b ->
37+ T.RLambda a b ->
36 T.Lambda <$> go a <*> go b
38 T.Lambda <$> go a <*> go b
37
39
38− T.Record fields ext ->
40+ T.RRecord fields ext ->
39 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext
41 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext
40
42
41− T.Aliased _ _ _ ->
42− error "a RawType should never have an alias in it"
43−
44
43
45canonicalizeApp
44canonicalizeApp
45+ :: R.Region
46− :: Env.Environment
46+ -> Env.Environment
47− -> T.RawType
47+ -> T.Raw
48− -> [T.RawType]
48+ -> [T.Raw]
49− -> Result.Result T.CanonicalType
49+ -> Result.ResultErr T.Canonical
50−canonicalizeApp env f args =
50+canonicalizeApp region env f args =
51 case f of
51 case f of
52− T.Type (Var.Raw rawName) ->
52+ A.A _ (T.RType (Var.Raw rawName)) ->
53− Canonicalize.tvar env rawName
53+ Canonicalize.tvar region env rawName
54 `Result.andThen` canonicalizeWithTvar
54 `Result.andThen` canonicalizeWithTvar
55
55
56 _ ->
56 _ ->
@@ -60,7 +60,7 @@ canonicalizeApp env f args =
60 canonicalizeWithTvar tvar =
60 canonicalizeWithTvar tvar =
61 case tvar of
61 case tvar of
62 Right alias ->
62 Right alias ->
63− canonicalizeAlias env alias args
63+ canonicalizeAlias region env alias args
64
64
65 Left name ->
65 Left name ->
66 case args of
66 case args of
@@ -71,13 +71,14 @@ canonicalizeApp env f args =
71
71
72
72
73canonicalizeAlias
73canonicalizeAlias
74+ :: R.Region
74− :: Env.Environment
75+ -> Env.Environment
75− -> (Var.Canonical, [String], T.CanonicalType)
76+ -> (Var.Canonical, [String], T.Canonical)
76− -> [T.RawType]
77+ -> [T.Raw]
77− -> Result.Result T.CanonicalType
78+ -> Result.ResultErr T.Canonical
78−canonicalizeAlias env (name, tvars, dealiasedTipe) types =
79+canonicalizeAlias region env (name, tvars, dealiasedTipe) types =
79 if typesLen /= tvarsLen
80 if typesLen /= tvarsLen
80− then Result.err (Error.alias name tvarsLen typesLen)
81+ then Result.err (A.A region (Error.alias name tvarsLen typesLen))
81 else toAlias <$> Trav.traverse (tipe env) types
82 else toAlias <$> Trav.traverse (tipe env) types
82 where
83 where
83 typesLen = length types
84 typesLen = length types
src/Transform/Canonicalize/Variable.hs+50−34
@@ -9,50 +9,53 @@ import qualified AST.Helpers as Help
9import qualified AST.Module as Module
9import qualified AST.Module as Module
10import qualified AST.Type as Type
10import qualified AST.Type as Type
11import qualified AST.Variable as Var
11import 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
12−import Transform.Canonicalize.Environment as Env
15+import qualified Transform.Canonicalize.Environment as Env
13−import qualified Transform.Canonicalize.Error as Error
14import qualified Transform.Canonicalize.Result as Result
16import qualified Transform.Canonicalize.Result as Result
15import Elm.Utils ((|>))
17import Elm.Utils ((|>))
16
18
17
19
18−variable :: Environment -> String -> Result.Result Var.Canonical
20+variable :: R.Region -> Env.Environment -> String -> Result.ResultErr Var.Canonical
19−variable env var =
21+variable region env var =
20 case toVarName var of
22 case toVarName var of
21 Right (name, varName)
23 Right (name, varName)
22 | Module.nameIsNative name ->
24 | Module.nameIsNative name ->
23 Result.var (Var.Canonical (Var.Module name) varName)
25 Result.var (Var.Canonical (Var.Module name) varName)
24
26
25 _ ->
27 _ ->
26− case Set.toList `fmap` Map.lookup var (_values env) of
28+ case Set.toList `fmap` Map.lookup var (Env._values env) of
27 Just [v] ->
29 Just [v] ->
28 Result.var v
30 Result.var v
29
31
30 Just vs ->
32 Just vs ->
31− preferLocals env "variable" vs var
33+ preferLocals region env "variable" vs var
32
34
33 Nothing ->
35 Nothing ->
34− notFound "variable" (Map.keys (_values env)) var
36+ notFound region "variable" (Map.keys (Env._values env)) var
35
37
36
38
37tvar
39tvar
40+ :: R.Region
38− :: Environment
41+ -> Env.Environment
39 -> String
42 -> String
40− -> Result.Result
43+ -> Result.ResultErr
41 (Either
44 (Either
42 Var.Canonical
45 Var.Canonical
43− (Var.Canonical, [String], Type.CanonicalType)
46+ (Var.Canonical, [String], Type.Canonical)
44 )
47 )
45−tvar env var =
48+tvar region env var =
46 case adts ++ aliases of
49 case adts ++ aliases of
47− [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var
50+ [] -> notFound region "type" (Map.keys (Env._adts env) ++ Map.keys (Env._aliases env)) var
48 [v] -> Result.var' extract v
51 [v] -> Result.var' extract v
49− vs -> preferLocals' env extract "type" vs var
52+ vs -> preferLocals' region env extract "type" vs var
50 where
53 where
51 adts =
54 adts =
52− map Left (maybe [] Set.toList (Map.lookup var (_adts env)))
55+ map Left (maybe [] Set.toList (Map.lookup var (Env._adts env)))
53
56
54 aliases =
57 aliases =
55− map Right (maybe [] Set.toList (Map.lookup var (_aliases env)))
58+ map Right (maybe [] Set.toList (Map.lookup var (Env._aliases env)))
56
59
57 extract value =
60 extract value =
58 case value of
61 case value of
@@ -60,39 +63,52 @@ tvar env var =
60 Right (v,_,_) -> v
63 Right (v,_,_) -> v
61
64
62
65
66+pvar
67+ :: R.Region
68+ -> Env.Environment
69+ -> String
70+ -> Int
63−pvar :: Environment -> String -> Result.Result Var.Canonical
71+ -> Result.ResultErr Var.Canonical
64−pvar env var =
72+pvar region env var actualArgs =
65− case Set.toList `fmap` Map.lookup var (_patterns env) of
73+ case Set.toList `fmap` Map.lookup var (Env._patterns env) of
66− Just [v] ->
74+ Just [value] ->
67− Result.var v
75+ foundArgCheck value
68
76
69− Just vs ->
77+ Just values ->
70− preferLocals env "pattern" vs var
78+ preferLocals' region env fst "pattern" values var
79+ `Result.andThen` foundArgCheck
71
80
72 Nothing ->
81 Nothing ->
73− notFound "pattern" (Map.keys (_patterns env)) var
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))
74
88
75
89
76-- FOUND
90-- FOUND
77
91
78preferLocals
92preferLocals
93+ :: R.Region
79− :: Environment
94+ -> Env.Environment
80 -> String
95 -> String
81 -> [Var.Canonical]
96 -> [Var.Canonical]
82 -> String
97 -> String
83− -> Result.Result Var.Canonical
98+ -> Result.ResultErr Var.Canonical
84−preferLocals env =
99+preferLocals region env =
85− preferLocals' env id
100+ preferLocals' region env id
86
101
87
102
88preferLocals'
103preferLocals'
104+ :: R.Region
89− :: Environment
105+ -> Env.Environment
90 -> (a -> Var.Canonical)
106 -> (a -> Var.Canonical)
91 -> String
107 -> String
92 -> [a]
108 -> [a]
93 -> String
109 -> String
94− -> Result.Result a
110+ -> Result.ResultErr a
95−preferLocals' env extract kind possibilities var =
111+preferLocals' region env extract kind possibilities var =
96 case filter (isLocal . extract) possibilities of
112 case filter (isLocal . extract) possibilities of
97 [] ->
113 [] ->
98 ambiguous possibilities
114 ambiguous possibilities
@@ -112,7 +128,7 @@ preferLocals' env extract kind possibilities var =
112 name == Env._home env
128 name == Env._home env
113
129
114 ambiguous possibleVars =
130 ambiguous possibleVars =
115− Result.err (Error.var kind var (Error.Ambiguous vars))
131+ Result.err (A.A region (Error.var kind var (Error.Ambiguous vars)))
116 where
132 where
117 vars = map (Var.toString . extract) possibleVars
133 vars = map (Var.toString . extract) possibleVars
118
134
@@ -149,8 +165,8 @@ isOp name =
149
165
150-- NOT FOUND
166-- NOT FOUND
151
167
152−notFound :: String -> [String] -> String -> Result.Result a
168+notFound :: R.Region -> String -> [String] -> String -> Result.ResultErr a
153−notFound kind possibilities var =
169+notFound region kind possibilities var =
154 let name =
170 let name =
155 toVarName var
171 toVarName var
156
172
@@ -165,7 +181,7 @@ notFound kind possibilities var =
165 Right (modul, varName) ->
181 Right (modul, varName) ->
166 qualifiedProblem modul varName (Either.rights possibleNames)
182 qualifiedProblem modul varName (Either.rights possibleNames)
167 in
183 in
168− Result.err (Error.var kind var problem)
184+ Result.err (A.A region (Error.var kind var problem))
169
185
170
186
171exposedProblem :: VarName -> [VarName] -> Error.VarProblem
187exposedProblem :: VarName -> [VarName] -> Error.VarProblem
src/Transform/Check.hsdeleted−160
@@ -1,160 +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 Transform.Expression as Expr
13−
14−import AST.PrettyPrint
15−import Elm.Utils ((|>))
16−import Text.PrettyPrint as P
17−
18−
19−mistakes :: [D.ValidDecl] -> [Doc]
20−mistakes decls =
21− concat
22− [ illFormedTypeDecls decls
23− , map P.text (duplicateTypeDeclarations decls)
24− , map P.text (duplicateValues decls)
25− ]
26−
27−
28−-- DUPLICATES
29−
30−dups :: Ord a => [a] -> [a]
31−dups names =
32− List.sort names
33− |> List.group
34− |> filter ((>1) . length)
35− |> map head
36−
37−
38−duplicateValues :: [D.ValidDecl] -> [String]
39−duplicateValues decls =
40− map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
41− case mapM exprDups defExprs of
42− Left name -> [msg name]
43− Right _ -> []
44−
45− where
46− msg x =
47− "Name Collision: There can only be one definition of '" ++ x ++ "'."
48−
49− (defPatterns, defExprs) =
50− unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]
51−
52− portNames =
53− [ D.validPortName port | D.Port port <- decls ]
54−
55− exprDups :: Valid.Expr -> Either String Valid.Expr
56− exprDups expr =
57− Expr.crawlLet defsDups expr
58−
59− defsDups :: [Valid.Def] -> Either String [Valid.Def]
60− defsDups defs =
61− let varsIn (Valid.Definition pattern _ _) =
62− Pattern.boundVarList pattern
63− in
64− case dups (concatMap varsIn defs) of
65− [] -> Right defs
66− name:_ -> Left name
67−
68−
69−duplicateTypeDeclarations :: [D.ValidDecl] -> [String]
70−duplicateTypeDeclarations decls =
71− map dupTypeError (dups (typeNames ++ aliasNames))
72− ++ map dupCtorError (dups (ctorNames ++ aliasNames))
73− where
74− typeNames =
75− [ name | D.Datatype name _ _ <- decls ]
76−
77− aliasNames =
78− [ name | D.TypeAlias name _ _ <- decls ]
79−
80− ctorNames =
81− concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
82−
83−
84−dupTypeError :: String -> String
85−dupTypeError name =
86− "Name Collision: There can only be one type named '" ++ name ++ "'"
87−
88−
89−dupCtorError :: String -> String
90−dupCtorError name =
91− "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"
92− ++ " Constructors are created for record type aliases and for union types, so\n"
93− ++ " something should be renamed or moved to a different module."
94−
95−
96−-- FREE TYPE VARIABLES IN TYPE DECLARATIONS
97−
98−illFormedTypeDecls :: [D.ValidDecl] -> [Doc]
99−illFormedTypeDecls decls =
100− map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
101− where
102− aliases =
103− [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
104−
105− adts =
106− [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
107−
108− freeVars tipe =
109− case tipe of
110− T.Lambda t1 t2 ->
111− Set.union (freeVars t1) (freeVars t2)
112−
113− T.Var x ->
114− Set.singleton x
115−
116− T.Type _ ->
117− Set.empty
118−
119− T.App t ts ->
120− Set.unions (map freeVars (t:ts))
121−
122− T.Record fields ext ->
123− let ext' = maybe Set.empty freeVars ext
124− in
125− Set.unions (ext' : map (freeVars . snd) fields)
126−
127− T.Aliased _ args t ->
128− freeVars (T.dealias args t)
129−
130− undeclared tvars tipes =
131− Set.difference used declared
132− where
133− used = Set.unions (map freeVars tipes)
134− declared = Set.fromList tvars
135−
136− isIllFormed (decl, tvars, tipes) =
137− let unbound = undeclared tvars tipes in
138− if Set.null unbound
139− then Nothing
140− else Just (decl, Set.toList unbound)
141−
142− report (decl, tvars) =
143− P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
144− , P.text "\n"
145− , nest 4 (pretty decl) ]
146− where
147− listing =
148− case tvars of
149− [tvar] -> " " ++ quote tvar ++ " is"
150− _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
151−
152− addCommas xs
153− | length xs < 3 = concat xs
154− | otherwise = List.intercalate "," xs
155−
156− addAnd xs
157− | length xs < 2 = xs
158− | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
159−
160− quote tvar = "'" ++ tvar ++ "'"
src/Transform/Declaration.hs+32−89
@@ -1,92 +1,28 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Transform.Declaration (combineAnnotations, toExpr) where
2+module Transform.Declaration (toExpr) where
3
3
4−import Control.Applicative ((<$>))
5−
6−import qualified AST.Annotation as A
7import qualified AST.Declaration as D
4import qualified AST.Declaration as D
8import qualified AST.Expression.General as E
5import qualified AST.Expression.General as E
9−import qualified AST.Expression.Source as Source
10−import qualified AST.Expression.Valid as Valid
11import qualified AST.Expression.Canonical as Canonical
6import qualified AST.Expression.Canonical as Canonical
12import qualified AST.Module as Module
7import qualified AST.Module as Module
13import qualified AST.Pattern as P
8import qualified AST.Pattern as P
14import qualified AST.Type as T
9import qualified AST.Type as T
15import qualified AST.Variable as Var
10import qualified AST.Variable as Var
16−
17−import qualified Transform.Expression as Expr
11+import qualified Reporting.Annotation as A
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
12
81
13
82toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]
14toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]
83−toExpr moduleName =
15+toExpr moduleName decls =
84− concatMap (toDefs moduleName)
16+ concatMap (toDefs moduleName) decls
85
17
86
18
87toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]
19toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]
88−toDefs moduleName decl =
20+toDefs moduleName (A.A region decl) =
89− let typeVar = Var.Canonical (Var.Module moduleName) in
21+ let typeVar = Var.fromModule moduleName
22+
23+ loc expr =
24+ A.A region expr
25+ in
90 case decl of
26 case decl of
91 D.Definition def ->
27 D.Definition def ->
92 [def]
28 [def]
@@ -95,9 +31,9 @@ toDefs moduleName decl =
95 concatMap toDefs' constructors
31 concatMap toDefs' constructors
96 where
32 where
97 toDefs' (ctor, tipes) =
33 toDefs' (ctor, tipes) =
98− let vars = take (length tipes) arguments
34+ let vars = take (length tipes) infiniteArgs
99 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
35 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
100− body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
36+ body = loc . E.Data ctor $ map (loc . E.localVar) vars
101 in
37 in
102 [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
38 [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
103
39
@@ -110,15 +46,19 @@ toDefs moduleName decl =
110 args =
46 args =
111 map snd fields ++ maybe [] (:[]) ext
47 map snd fields ++ maybe [] (:[]) ext
112
48
113− var = A.none . E.localVar
49+ var = loc . E.localVar
114− vars = take (length args) arguments
50+ vars = take (length args) infiniteArgs
51+
52+ efields =
53+ zip (map fst fields) (map var vars)
115
54
116− efields = zip (map fst fields) (map var vars)
117 record =
55 record =
118 case ext of
56 case ext of
57+ Nothing ->
119− Nothing -> A.none $ E.Record efields
58+ loc (E.Record efields)
59+
120 Just _ ->
60 Just _ ->
121− foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
61+ foldl (\r (f,v) -> loc (E.Insert r f v)) (var (last vars)) efields
122
62
123 -- Type aliases must be added to an extended equality dictionary,
63 -- Type aliases must be added to an extended equality dictionary,
124 -- but they do not require any basic constraints.
64 -- but they do not require any basic constraints.
@@ -126,7 +66,7 @@ toDefs moduleName decl =
126 []
66 []
127
67
128 D.Port (D.CanonicalPort impl) ->
68 D.Port (D.CanonicalPort impl) ->
129− let body = A.none (E.Port impl)
69+ let body = loc (E.Port impl)
130 in
70 in
131 case impl of
71 case impl of
132 E.In name tipe ->
72 E.In name tipe ->
@@ -143,16 +83,19 @@ toDefs moduleName decl =
143 []
83 []
144
84
145
85
146−arguments :: [String]
86+infiniteArgs :: [String]
147−arguments =
87+infiniteArgs =
148 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
88 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
149
89
150
90
151buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
91buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
152−buildFunction body@(A.A s _) vars =
92+buildFunction body@(A.A ann _) vars =
93+ foldr
94+ (\pattern expr -> A.A ann (E.Lambda pattern expr))
95+ body
153− foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
96+ (map (A.A ann . P.Var) vars)
154
97
155
98
156−definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
99+definition :: String -> Canonical.Expr -> T.Canonical -> Canonical.Def
157−definition name expr tipe =
100+definition name expr@(A.A ann _) tipe =
158− Canonical.Definition (P.Var name) expr (Just tipe)
101+ Canonical.Definition (A.A ann (P.Var name)) expr (Just tipe)
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/SortDefinitions.hs+29−17
@@ -8,21 +8,31 @@ 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
18ctors :: P.CanonicalPattern -> [String]
18ctors :: P.CanonicalPattern -> [String]
19−ctors pattern =
19+ctors (A.A _ pattern) =
20 case pattern of
20 case pattern of
21− P.Var _ -> []
21+ P.Var _ ->
22+ []
23+
22− P.Alias _ p -> ctors p
24+ P.Alias _ p ->
25+ ctors p
26+
23− P.Record _ -> []
27+ P.Record _ ->
28+ []
29+
24− P.Anything -> []
30+ P.Anything ->
31+ []
32+
25− P.Literal _ -> []
33+ P.Literal _ ->
34+ []
35+
26 P.Data (V.Canonical home name) ps ->
36 P.Data (V.Canonical home name) ps ->
27 case home of
37 case home of
28 V.Local -> name : rest
38 V.Local -> name : rest
@@ -45,9 +55,11 @@ freeIfLocal (V.Canonical home name) =
45 V.Module _ -> return ()
55 V.Module _ -> return ()
46
56
47
57
48−bound :: Set.Set String -> State (Set.Set String) ()
58+bound :: P.CanonicalPattern -> State (Set.Set String) ()
59+bound pattern =
49−bound boundVars =
60+ let boundVars = P.boundVarSet pattern
61+ in
50− modify (\freeVars -> Set.difference freeVars boundVars)
62+ modify (\freeVars -> Set.difference freeVars boundVars)
51
63
52
64
53sortDefs :: Canonical.Expr -> Canonical.Expr
65sortDefs :: Canonical.Expr -> Canonical.Expr
@@ -56,8 +68,8 @@ sortDefs expression =
56
68
57
69
58reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
70reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
59−reorder (A ann expression) =
71+reorder (A.A ann expression) =
60− A ann <$>
72+ A.A ann <$>
61 case expression of
73 case expression of
62 -- Be careful adding and restricting freeVars
74 -- Be careful adding and restricting freeVars
63 Var var ->
75 Var var ->
@@ -140,11 +152,11 @@ reorder (A ann expression) =
140
152
141 -- remove let-bound variables from the context
153 -- remove let-bound variables from the context
142 forM_ defs $ \(Canonical.Definition pattern _ _) -> do
154 forM_ defs $ \(Canonical.Definition pattern _ _) -> do
143− bound (P.boundVars pattern)
155+ bound pattern
144 mapM free (ctors pattern)
156 mapM free (ctors pattern)
145
157
146− let A _ let' =
158+ let (A.A _ let') =
147− foldr (\ds bod -> A ann (Let ds bod)) body' defss
159+ foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
148
160
149 return let'
161 return let'
150
162
@@ -154,7 +166,7 @@ bindingReorder
154 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
166 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
155bindingReorder (pattern,expr) =
167bindingReorder (pattern,expr) =
156 do expr' <- reorder expr
168 do expr' <- reorder expr
157− bound (P.boundVars pattern)
169+ bound pattern
158 mapM_ free (ctors pattern)
170 mapM_ free (ctors pattern)
159 return (pattern, expr')
171 return (pattern, expr')
160
172
@@ -187,7 +199,7 @@ buildDefDict defs =
187
199
188 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
200 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
189 variableToKey (Canonical.Definition pattern _ _, key, _) =
201 variableToKey (Canonical.Definition pattern _ _, key, _) =
190− [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
202+ [ (var, key) | var <- P.boundVarList pattern ]
191
203
192 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
204 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
193 variableToKeyMap pdefsDeps =
205 variableToKeyMap pdefsDeps =
src/Transform/Substitute.hs+22−15
@@ -2,18 +2,18 @@
2module Transform.Substitute (subst) where
2module Transform.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/Type/Constrain/Expression.hs+113−105
@@ -3,103 +3,102 @@ 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
21−import qualified Type.Environment as Env
22import qualified Type.Constrain.Literal as Literal
16import qualified Type.Constrain.Literal as Literal
23import qualified Type.Constrain.Pattern as Pattern
17import qualified Type.Constrain.Pattern as Pattern
18+import qualified Type.Environment as Env
19+import qualified Type.Fragment as Fragment
20+import Type.Type hiding (Descriptor(..))
24
21
25
22
26constrain
23constrain
27 :: Env.Environment
24 :: Env.Environment
28 -> Canonical.Expr
25 -> Canonical.Expr
29 -> Type
26 -> Type
30− -> ErrorT [PP.Doc] IO TypeConstraint
27+ -> IO TypeConstraint
31−constrain env (A region expression) tipe =
28+constrain env (A.A region expression) tipe =
32 let list t = Env.get env Env.types "List" <| t
29 let list t = Env.get env Env.types "List" <| t
33− and = A region . CAnd
30+ (===) = CEqual region
34− true = A region CTrue
35− t1 === t2 = A region (CEqual t1 t2)
36− x <? t = A region (CInstance x t)
31+ (<?) = CInstance region
37− clet schemes c = A region (CLet schemes c)
38 in
32 in
39 case expression of
33 case expression of
40− Literal lit ->
34+ E.Literal lit ->
41− liftIO $ Literal.constrain env region lit tipe
35+ Literal.constrain env region lit tipe
42
36
43− GLShader _uid _src gltipe ->
37+ E.GLShader _uid _src gltipe ->
44 exists $ \attr ->
38 exists $ \attr ->
45 exists $ \unif ->
39 exists $ \unif ->
46 let
40 let
41+ shaderTipe a u v =
47− shaderTipe a u v = Env.get env Env.types "WebGL.Shader" <| a <| u <| v
42+ Env.get env Env.types "WebGL.Shader" <| a <| u <| v
43+
44+ glTipe =
48− glTipe = Env.get env Env.types . Lit.glTipeName
45+ Env.get env Env.types . Lit.glTipeName
46+
49− makeRec accessor baseRec =
47+ makeRec accessor baseRec =
50− let decls = accessor gltipe
48+ let decls = accessor gltipe
49+ in
51− in if Map.size decls == 0
50+ if Map.size decls == 0
52− then baseRec
51+ then baseRec
53− else record (Map.map (\t -> [glTipe t]) decls) baseRec
52+ else record (Map.map (\t -> [glTipe t]) decls) baseRec
53+
54− attribute = makeRec Lit.attribute attr
54+ attribute = makeRec Lit.attribute attr
55− uniform = makeRec Lit.uniform unif
55+ uniform = makeRec Lit.uniform unif
56− varying = makeRec Lit.varying (termN EmptyRecord1)
56+ varying = makeRec Lit.varying (termN EmptyRecord1)
57 in
57 in
58− return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
58+ return (tipe === shaderTipe attribute uniform varying)
59
59
60− Var var
60+ E.Var var ->
61+ let name = V.toString var
62+ in
61− | name == saveEnvName -> return (A region CSaveEnv)
63+ return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
62− | otherwise -> return (name <? tipe)
63− where
64− name = V.toString var
65
64
66− Range lo hi ->
65+ E.Range lo hi ->
67 existsNumber $ \n ->
66 existsNumber $ \n ->
68 do clo <- constrain env lo n
67 do clo <- constrain env lo n
69 chi <- constrain env hi n
68 chi <- constrain env hi n
70− return $ and [clo, chi, list n === tipe]
69+ return $ CAnd [clo, chi, list n === tipe]
71
70
72− ExplicitList exprs ->
71+ E.ExplicitList exprs ->
73 exists $ \x ->
72 exists $ \x ->
74 do constraints <- mapM (\e -> constrain env e x) exprs
73 do constraints <- mapM (\e -> constrain env e x) exprs
75− return . and $ list x === tipe : constraints
74+ return $ CAnd (list x === tipe : constraints)
76
75
77− Binop op e1 e2 ->
76+ E.Binop op e1 e2 ->
78 exists $ \t1 ->
77 exists $ \t1 ->
79 exists $ \t2 ->
78 exists $ \t2 ->
80 do c1 <- constrain env e1 t1
79 do c1 <- constrain env e1 t1
81 c2 <- constrain env e2 t2
80 c2 <- constrain env e2 t2
82− return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]
81+ return $ CAnd [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]
83
82
84− Lambda p e ->
83+ E.Lambda pattern body ->
85 exists $ \t1 ->
84 exists $ \t1 ->
86 exists $ \t2 ->
85 exists $ \t2 ->
87− do fragment <- try region $ Pattern.constrain env p t1
86+ do fragment <- Pattern.constrain env pattern t1
88− c2 <- constrain env e t2
87+ c2 <- constrain env body t2
89 let c = ex (Fragment.vars fragment)
88 let c = ex (Fragment.vars fragment)
90− (clet [monoscheme (Fragment.typeEnv fragment)]
89+ (CLet [monoscheme (Fragment.typeEnv fragment)]
91 (Fragment.typeConstraint fragment /\ c2)
90 (Fragment.typeConstraint fragment /\ c2)
92 )
91 )
93 return $ c /\ tipe === (t1 ==> t2)
92 return $ c /\ tipe === (t1 ==> t2)
94
93
95− App e1 e2 ->
94+ E.App e1 e2 ->
96 exists $ \t ->
95 exists $ \t ->
97 do c1 <- constrain env e1 (t ==> tipe)
96 do c1 <- constrain env e1 (t ==> tipe)
98 c2 <- constrain env e2 t
97 c2 <- constrain env e2 t
99 return $ c1 /\ c2
98 return $ c1 /\ c2
100
99
101− MultiIf branches ->
100+ E.MultiIf branches ->
102− and <$> mapM constrain' branches
101+ CAnd <$> mapM constrain' branches
103 where
102 where
104 bool = Env.get env Env.types "Bool"
103 bool = Env.get env Env.types "Bool"
105
104
@@ -108,107 +107,116 @@ constrain env (A region expression) tipe =
108 ce <- constrain env expr tipe
107 ce <- constrain env expr tipe
109 return (cb /\ ce)
108 return (cb /\ ce)
110
109
111− Case expr branches ->
110+ E.Case expr branches ->
112 exists $ \t ->
111 exists $ \t ->
113− do ce <- constrain env expr t
112+ do exprConstraint <- constrain env expr t
114− and . (:) ce <$> mapM (branch t) branches
113+ branchConstraints <- mapM (branch t) branches
114+ return (CAnd (exprConstraint : branchConstraints))
115 where
115 where
116 branch t (pattern, branchExpr) =
116 branch t (pattern, branchExpr) =
117− do fragment <- try region $ Pattern.constrain env pattern t
117+ do fragment <- Pattern.constrain env pattern t
118− clet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe
118+ CLet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe
119
119
120− Data name exprs ->
120+ E.Data name exprs ->
121− do vars <- forM exprs $ \_ -> liftIO (variable Flexible)
121+ do vars <- Monad.forM exprs $ \_ -> variable Flexible
122 let pairs = zip exprs (map varN vars)
122 let pairs = zip exprs (map varN vars)
123− (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)
123+ (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
124 return $ ex vars (cs /\ name <? ctipe)
124 return $ ex vars (cs /\ name <? ctipe)
125 where
125 where
126 step (t,c) (e,x) =
126 step (t,c) (e,x) =
127 do c' <- constrain env e x
127 do c' <- constrain env e x
128 return (x ==> t, c /\ c')
128 return (x ==> t, c /\ c')
129
129
130− Access expr label ->
130+ E.Access expr label ->
131 exists $ \t ->
131 exists $ \t ->
132 constrain env expr (record (Map.singleton label [tipe]) t)
132 constrain env expr (record (Map.singleton label [tipe]) t)
133
133
134− Remove expr label ->
134+ E.Remove expr label ->
135 exists $ \t ->
135 exists $ \t ->
136 constrain env expr (record (Map.singleton label [t]) tipe)
136 constrain env expr (record (Map.singleton label [t]) tipe)
137
137
138− Insert expr label value ->
138+ E.Insert expr label value ->
139 exists $ \tVal ->
139 exists $ \tVal ->
140 exists $ \tRec ->
140 exists $ \tRec ->
141 do cVal <- constrain env value tVal
141 do cVal <- constrain env value tVal
142 cRec <- constrain env expr tRec
142 cRec <- constrain env expr tRec
143 let c = tipe === record (Map.singleton label [tVal]) tRec
143 let c = tipe === record (Map.singleton label [tVal]) tRec
144− return (and [cVal, cRec, c])
144+ return (CAnd [cVal, cRec, c])
145
145
146− Modify expr fields ->
146+ E.Modify expr fields ->
147 exists $ \t ->
147 exists $ \t ->
148− do oldVars <- forM fields $ \_ -> liftIO (variable Flexible)
148+ do oldVars <- Monad.forM fields $ \_ -> variable Flexible
149 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))
149 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))
150 cOld <- ex oldVars <$> constrain env expr (record oldFields t)
150 cOld <- ex oldVars <$> constrain env expr (record oldFields t)
151
151
152− newVars <- forM fields $ \_ -> liftIO (variable Flexible)
152+ newVars <- Monad.forM fields $ \_ -> variable Flexible
153 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))
153 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))
154 let cNew = tipe === record newFields t
154 let cNew = tipe === record newFields t
155
155
156− cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)
156+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)
157
157
158− return $ cOld /\ ex newVars (and (cNew : cs))
158+ return $ cOld /\ ex newVars (CAnd (cNew : cs))
159
159
160− Record fields ->
160+ E.Record fields ->
161− do vars <- forM fields $ \_ -> liftIO (variable Flexible)
161+ do vars <- Monad.forM fields $ \_ -> variable Flexible
162− cs <- zipWithM (constrain env) (map snd fields) (map varN vars)
162+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN vars)
163 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
163 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
164 let recordType = record fields' (termN EmptyRecord1)
164 let recordType = record fields' (termN EmptyRecord1)
165− return . ex vars . and $ tipe === recordType : cs
165+ return . ex vars . CAnd $ tipe === recordType : cs
166
166
167− Let defs body ->
167+ E.Let defs body ->
168 do c <- constrain env body tipe
168 do c <- constrain env body tipe
169
169
170 (Info schemes rqs fqs headers c2 c1) <-
170 (Info schemes rqs fqs headers c2 c1) <-
171 Monad.foldM
171 Monad.foldM
172 (constrainDef env)
172 (constrainDef env)
173− (Info [] [] [] Map.empty true true)
173+ (Info [] [] [] Map.empty CTrue CTrue)
174 (concatMap expandPattern defs)
174 (concatMap expandPattern defs)
175
175
176− let letScheme = [ Scheme rqs fqs (clet [monoscheme headers] c2) headers ]
176+ let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
177
177
178− return $ clet schemes (clet letScheme (c1 /\ c))
178+ return $ CLet schemes (CLet letScheme (c1 /\ c))
179
179
180− Port impl ->
180+ E.Port impl ->
181 case impl of
181 case impl of
182− In _ _ ->
182+ E.In _ _ ->
183− return true
183+ return CTrue
184
184
185− Out _ expr _ ->
185+ E.Out _ expr _ ->
186 constrain env expr tipe
186 constrain env expr tipe
187
187
188− Task _ expr _ ->
188+ E.Task _ expr _ ->
189 constrain env expr tipe
189 constrain env expr tipe
190
190
191
191
192expandPattern :: Canonical.Def -> [Canonical.Def]
192expandPattern :: Canonical.Def -> [Canonical.Def]
193−expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =
193+expandPattern def@(Canonical.Definition lpattern expr maybeType) =
194+ let (A.A patternRegion pattern) = lpattern
195+ in
194− case pattern of
196+ case pattern of
195− P.Var _ ->
197+ P.Var _ ->
196− [def]
198+ [def]
199+
197− _ ->
200+ _ ->
198− Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars
201+ mainDef : map toDef vars
199− where
202+ where
200− vars = P.boundVarList pattern
203+ vars = P.boundVarList lpattern
201− x = "$" ++ concat vars
202− mkVar = A r . localVar
203− toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
204
204
205+ combinedName = "$" ++ concat vars
205
206
206−try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
207+ pvar name =
207−try region computation =
208+ A.A patternRegion (P.Var name)
208− do result <- liftIO $ runErrorT computation
209+
209− case result of
210+ localVar name =
210− Left err -> throwError [err region]
211+ A.A patternRegion (E.localVar name)
211− Right value -> return value
212+
213+ mainDef = Canonical.Definition (pvar combinedName) expr maybeType
214+
215+ toDef name =
216+ let extract =
217+ E.Case (localVar combinedName) [(lpattern, localVar name)]
218+ in
219+ Canonical.Definition (pvar name) (A.A patternRegion extract) Nothing
212
220
213
221
214-- CONSTRAIN DEFINITIONS
222-- CONSTRAIN DEFINITIONS
@@ -223,8 +231,8 @@ data Info = Info
223 }
231 }
224
232
225
233
226−constrainDef :: Env.Environment -> Info -> Canonical.Def -> ErrorT [PP.Doc] IO Info
234+constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
227−constrainDef env info (Canonical.Definition pattern expr maybeTipe) =
235+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...
236 let qs = [] -- should come from the def, but I'm not sure what would live there...
229 in
237 in
230 case (pattern, maybeTipe) of
238 case (pattern, maybeTipe) of
@@ -243,13 +251,13 @@ constrainAnnotatedDef
243 -> [String]
251 -> [String]
244 -> String
252 -> String
245 -> Canonical.Expr
253 -> Canonical.Expr
246− -> ST.CanonicalType
254+ -> ST.Canonical
247− -> ErrorT [PP.Doc] IO Info
255+ -> IO Info
248constrainAnnotatedDef env info qs name expr tipe =
256constrainAnnotatedDef env info qs name expr tipe =
249 do -- Some mistake may be happening here. Currently, qs is always [].
257 do -- Some mistake may be happening here. Currently, qs is always [].
250− rigidVars <- forM qs (\_ -> liftIO $ variable Rigid)
258+ rigidVars <- Monad.forM qs (\_ -> variable Rigid)
251
259
252− flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)
260+ flexiVars <- Monad.forM qs (\_ -> variable Flexible)
253
261
254 let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars
262 let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars
255
263
@@ -261,7 +269,7 @@ constrainAnnotatedDef env info qs name expr tipe =
261 Scheme
269 Scheme
262 { rigidQuantifiers = []
270 { rigidQuantifiers = []
263 , flexibleQuantifiers = flexiVars ++ vars
271 , flexibleQuantifiers = flexiVars ++ vars
264− , constraint = Ann.noneNoDocs CTrue
272+ , constraint = CTrue
265 , header = Map.singleton name typ
273 , header = Map.singleton name typ
266 }
274 }
267
275
@@ -279,12 +287,12 @@ constrainUnannotatedDef
279 -> [String]
287 -> [String]
280 -> String
288 -> String
281 -> Canonical.Expr
289 -> Canonical.Expr
282− -> ErrorT [PP.Doc] IO Info
290+ -> IO Info
283constrainUnannotatedDef env info qs name expr =
291constrainUnannotatedDef env info qs name expr =
284 do -- Some mistake may be happening here. Currently, qs is always [].
292 do -- Some mistake may be happening here. Currently, qs is always [].
285− rigidVars <- forM qs (\_ -> liftIO $ variable Rigid)
293+ rigidVars <- Monad.forM qs (\_ -> variable Rigid)
286
294
287− v <- liftIO $ variable Flexible
295+ v <- variable Flexible
288
296
289 let tipe = varN v
297 let tipe = varN v
290
298
src/Type/Constrain/Literal.hs+23−16
@@ -1,21 +1,28 @@
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.Region as R
5−import Type.Type
5+import qualified Type.Type as T
6−import Type.Environment as Env
6+import qualified Type.Environment as Env
7
7
8+
9+constrain
10+ :: Env.Environment
11+ -> R.Region
12+ -> L.Literal
13+ -> T.Type
8−constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
14+ -> IO T.TypeConstraint
9constrain env region literal tipe =
15constrain env region literal tipe =
10− do tipe' <- litType
16+ do tipe' <- litType
11− return . A region $ CEqual tipe tipe'
17+ return (T.CEqual region tipe tipe')
12− where
18+ where
19+ prim name =
13− prim name = return (Env.get env Env.types name)
20+ return (Env.get env Env.types name)
14
21
15− litType =
22+ litType =
16− case literal of
23+ case literal of
17− IntNum _ -> varN `fmap` variable (Is Number)
24+ L.IntNum _ -> T.varN `fmap` T.variable (T.Is T.Number)
18− FloatNum _ -> prim "Float"
25+ L.FloatNum _ -> prim "Float"
19− Chr _ -> prim "Char"
26+ L.Chr _ -> prim "Char"
20− Str _ -> prim "String"
27+ L.Str _ -> prim "String"
21− Boolean _ -> prim "Bool"
28+ L.Boolean _ -> prim "Bool"
src/Type/Constrain/Pattern.hs+51−62
@@ -4,78 +4,67 @@ 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
16−import Type.Fragment
17−import Type.Environment as Env
18import qualified Type.Constrain.Literal as Literal
12import qualified Type.Constrain.Literal as Literal
13+import qualified Type.Environment as Env
14+import Type.Fragment
15+import Type.Type
19
16
20
17
18+constrain
19+ :: Env.Environment
21−constrain :: Environment -> P.CanonicalPattern -> Type
20+ -> P.CanonicalPattern
21+ -> Type
22− -> ErrorT (A.Region -> PP.Doc) IO Fragment
22+ -> IO Fragment
23−constrain env pattern tipe =
23+constrain env (A.A region pattern) tipe =
24− let region = A.None (pretty pattern)
24+ let (===) = CEqual region
25− t1 === t2 = A.A region (CEqual t1 t2)
26− in
25+ in
27− case pattern of
26+ case pattern of
28− P.Anything -> return emptyFragment
27+ P.Anything ->
29−
30− P.Literal lit -> do
31− c <- liftIO $ Literal.constrain env region lit tipe
32− return $ emptyFragment { typeConstraint = c }
28+ return emptyFragment
33
29
34− P.Var name -> do
30+ P.Literal lit ->
35− v <- liftIO $ variable Flexible
31+ 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
32+ return $ emptyFragment { typeConstraint = c }
40− }
41
33
42− P.Alias name p -> do
34+ P.Var name ->
43− v <- liftIO $ variable Flexible
35+ do v <- variable Flexible
44− fragment <- constrain env p tipe
45− return $ fragment
36+ return $ Fragment
46− { typeEnv = Map.insert name (varN v) (typeEnv fragment)
37+ { typeEnv = Map.singleton name (varN v)
47− , vars = v : vars fragment
38+ , vars = [v]
48− , typeConstraint = varN v === tipe /\ typeConstraint fragment
39+ , typeConstraint = varN v === tipe
49− }
40+ }
50
41
51− P.Data name patterns -> do
42+ P.Alias name p ->
52− (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)
43+ 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)
44+ fragment <- constrain env p tipe
62− return $ fragment {
45+ return $ fragment
63− typeConstraint = typeConstraint fragment /\ tipe === result,
46+ { typeEnv = Map.insert name (varN v) (typeEnv fragment)
64− vars = cvars ++ vars fragment
47+ , vars = v : vars fragment
48+ , typeConstraint = varN v === tipe /\ typeConstraint fragment
65 }
49 }
66
50
67− P.Record fields -> do
51+ P.Data name patterns ->
68− pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields
52+ do (_kind, cvars, args, result) <-
69− let tenv = Map.fromList (map (second varN) pairs)
53+ Env.freshDataScheme env (V.toString name)
70− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
54+
71− return $ Fragment {
55+ fragList <- Monad.zipWithM (constrain env) patterns args
72− typeEnv = tenv,
56+ let fragment = joinFragments fragList
73− vars = map snd pairs,
57+ return $ fragment
74− typeConstraint = c
58+ { typeConstraint = typeConstraint fragment /\ tipe === result
59+ , vars = cvars ++ vars fragment
75− }
60+ }
76
61
77−instance Error (A.Region -> PP.Doc) where
62+ P.Record fields ->
78− noMsg _ = PP.empty
63+ do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields
79− strMsg str span =
64+ let tenv = Map.fromList (map (second varN) pairs)
80− PP.vcat [ PP.text $ "Type error " ++ show span
65+ c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
81− , PP.text str ]
66+ return $ Fragment
67+ { typeEnv = tenv
68+ , vars = map snd pairs
69+ , typeConstraint = c
70+ }
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.hs+11−93
@@ -1,45 +1,26 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2
2
3{-| This module contains checks to be run *after* type inference has completed
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
4+successfully. At that point we still need to ensure that `main` has an
5−`main` has an acceptable type.
5+acceptable type.
6-}
6-}
7−module Type.ExtraChecks (effectTypes, occurs) where
7+module Type.ExtraChecks (mainType) where
8
8
9import Prelude hiding (maybe)
9import Prelude hiding (maybe)
10−import Control.Applicative ((<$>),(<*>))
10+import Control.Monad.Except (ExceptT, throwError)
11−import Control.Monad.Error
12−import Control.Monad.State
13import qualified Data.Map as Map
11import 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
12
18−import qualified AST.Annotation as A
19−import qualified AST.PrettyPrint as PP
20import qualified AST.Type as ST
13import qualified AST.Type as ST
21import qualified AST.Variable as Var
14import 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
15
35
16
36-- MAIN TYPE
17-- MAIN TYPE
37
18
38−mainCheck
19+mainType
39 :: (Monad m)
20 :: (Monad m)
40− => Map.Map String ST.CanonicalType
21+ => Map.Map String ST.Canonical
41− -> ErrorT [P.Doc] m ()
22+ -> ExceptT ST.Canonical m ()
42−mainCheck env =
23+mainType env =
43 case Map.lookup "main" env of
24 case Map.lookup "main" env of
44 Nothing ->
25 Nothing ->
45 return ()
26 return ()
@@ -49,10 +30,10 @@ mainCheck env =
49 in
30 in
50 if tipe `elem` validMainTypes
31 if tipe `elem` validMainTypes
51 then return ()
32 then return ()
52− else throwError [ badMainMessage typeOfMain ]
33+ else throwError typeOfMain
53
34
54
35
55−validMainTypes :: [ST.CanonicalType]
36+validMainTypes :: [ST.Canonical]
56validMainTypes =
37validMainTypes =
57 [ element
38 [ element
58 , html
39 , html
@@ -60,7 +41,7 @@ validMainTypes =
60 , signal html
41 , signal html
61 ]
42 ]
62 where
43 where
63− fromModule :: [String] -> String -> ST.CanonicalType
44+ fromModule :: [String] -> String -> ST.Canonical
64 fromModule home name =
45 fromModule home name =
65 ST.Type (Var.fromModule home name)
46 ST.Type (Var.fromModule home name)
66
47
@@ -95,66 +76,3 @@ validMainTypes =
95 )
76 )
96 ]
77 ]
97 Nothing
78 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+41−28
@@ -1,15 +1,15 @@
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, withExceptT)
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
15import qualified Type.ExtraChecks as Check
15import qualified Type.ExtraChecks as Check
@@ -22,50 +22,63 @@ import System.IO.Unsafe
22 -- I don't think that'd be worthwhile though.
22 -- I don't think that'd be worthwhile though.
23
23
24
24
25−infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
25+infer
26+ :: Interfaces
27+ -> CanonicalModule
28+ -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)
26infer interfaces modul =
29infer interfaces modul =
27− unsafePerformIO $ runErrorT $
30+ either throwError return $ unsafePerformIO $ runExceptT $
31+ do (header, constraint) <-
28− do (header, constraint) <- genConstraints interfaces modul
32+ liftIO (genConstraints interfaces modul)
29
33
30− state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
34+ state <- Solve.solve constraint
31−
32− () <- case TS.sHint state of
33− hints@(_:_) -> throwError hints
34− [] -> return ()
35
35
36 let header' = Map.delete "::" header
36 let header' = Map.delete "::" header
37− types = Map.difference (TS.sSavedEnv state) header'
37+ let types = Map.difference (TS.sSavedEnv state) header'
38+
39+ srcTypes <-
40+ liftIO (Traverse.traverse T.toSrcType types)
38
41
39− Check.effectTypes types
42+ withExceptT
43+ (\tipe -> [A.A (error "TODO:infer") (Error.BadMain tipe)])
44+ (Check.mainType srcTypes)
45+
46+ return srcTypes
40
47
41
48
42genConstraints
49genConstraints
43 :: Interfaces
50 :: Interfaces
44 -> CanonicalModule
51 -> CanonicalModule
45− -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)
52+ -> IO (Env.TypeDict, T.TypeConstraint)
46genConstraints interfaces modul =
53genConstraints interfaces modul =
54+ do env <-
47− do env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
55+ Env.initialEnvironment (canonicalizeAdts interfaces modul)
48
56
57+ ctors <-
49− ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
58+ forM (Map.keys (Env.constructor env)) $ \name ->
50− (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
59+ do (_, vars, args, result) <- Env.freshDataScheme env name
51− return (name, (vars, foldr (T.==>) result args))
60+ return (name, (vars, foldr (T.==>) result args))
52
61
62+ importedVars <-
53− importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
63+ mapM (canonicalizeValues env) (Map.toList interfaces)
54
64
55 let allTypes = concat (ctors : importedVars)
65 let allTypes = concat (ctors : importedVars)
56− vars = concatMap (fst . snd) allTypes
66+ let vars = concatMap (fst . snd) allTypes
57− header = Map.map snd (Map.fromList allTypes)
67+ let header = Map.map snd (Map.fromList allTypes)
58− environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
68+ let environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
69+
70+ fvar <- T.variable T.Flexible
71+
72+ constraint <-
73+ TcExpr.constrain env (program (body modul)) (T.varN fvar)
59
74
60− fvar <- liftIO $ T.variable T.Flexible
61− c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)
62− return (header, environ c)
75+ return (header, environ constraint)
63
76
64
77
65canonicalizeValues
78canonicalizeValues
66 :: Env.Environment
79 :: Env.Environment
67 -> (Module.Name, Interface)
80 -> (Module.Name, Interface)
68− -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
81+ -> IO [(String, ([T.Variable], T.Type))]
69canonicalizeValues env (moduleName, iface) =
82canonicalizeValues env (moduleName, iface) =
70 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
83 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
71 do tipe' <- Env.instantiateType env tipe Map.empty
84 do tipe' <- Env.instantiateType env tipe Map.empty
src/Type/Solve.hs+146−89
@@ -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
100
112
101
113
114+-- SOLVER
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
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 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 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 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,85 @@ 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+ TS.addError (error "Cannot generalize something that is not a type variable.") undefined
195− in
196− addHint region (Just msg) var var
197
212
198 Nothing ->
213 Nothing ->
199 do when (mark desc == seen) $
214 do when (mark desc == seen) $
200− do let msg = "Duplicate variable during generalization."
215+ TS.addError (error "Duplicate variable during generalization.") undefined
201− addHint region (Just msg) var var
202 liftIO $ UF.setDescriptor var (desc { mark = seen })
216 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
225 else
212− let msg = "Unable to generalize a type variable. It is not unranked."
226+ TS.addError (error "Unable to generalize a type variable. It is not unranked.") undefined
213− in addHint region (Just msg) var var
227+
228+
229+occurs :: (String, Variable) -> StateT TS.SolverState IO ()
230+occurs (_name, variable) =
231+ do vars <- liftIO $ infiniteVars [] variable
232+ case vars of
233+ [] ->
234+ return ()
235+
236+ var : _ ->
237+ do desc <- liftIO $ UF.descriptor var
238+ case structure desc of
239+ Nothing ->
240+ error "occurs check triggered"
241+
242+ Just _ ->
243+ error "occurs check triggered"
244+ where
245+ infiniteVars :: [Variable] -> Variable -> IO [Variable]
246+ infiniteVars seen var =
247+ let go = infiniteVars (var:seen)
248+ in
249+ if var `elem` seen
250+ then return [var]
251+ else do
252+ desc <- UF.descriptor var
253+ case structure desc of
254+ Nothing -> return []
255+ Just struct ->
256+ case struct of
257+ App1 a b ->
258+ (++) <$> go a <*> go b
259+
260+ Fun1 a b ->
261+ (++) <$> go a <*> go b
262+
263+ Var1 a ->
264+ go a
265+
266+ EmptyRecord1 ->
267+ return []
268+
269+ Record1 fields ext ->
270+ 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+83−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,9 @@ 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.Region as R
19import Type.PrettyPrint
17import Type.PrettyPrint
20
18
21
19
@@ -103,16 +101,13 @@ data SuperType
103
101
104-- CONSTRAINTS
102-- CONSTRAINTS
105
103
106−type Constraint a b =
104+data Constraint a b
107− Located (BasicConstraint a b)
108−
109−data BasicConstraint a b
110 = CTrue
105 = CTrue
111 | CSaveEnv
106 | CSaveEnv
112− | CEqual a a
107+ | CEqual R.Region a a
113 | CAnd [Constraint a b]
108 | CAnd [Constraint a b]
114 | CLet [Scheme a b] (Constraint a b)
109 | CLet [Scheme a b] (Constraint a b)
115− | CInstance SchemeName a
110+ | CInstance R.Region SchemeName a
116
111
117type SchemeName = String
112type SchemeName = String
118
113
@@ -170,40 +165,40 @@ variable flex = UF.fresh $ Descriptor
170
165
171monoscheme :: Map.Map String a -> Scheme a b
166monoscheme :: Map.Map String a -> Scheme a b
172monoscheme headers =
167monoscheme headers =
173− Scheme [] [] (noneNoDocs CTrue) headers
168+ Scheme [] [] CTrue headers
174
169
175
170
176infixl 8 /\
171infixl 8 /\
177
172
178(/\) :: Constraint a b -> Constraint a b -> Constraint a b
173(/\) :: Constraint a b -> Constraint a b -> Constraint a b
179−(/\) a@(A _ c1) b@(A _ c2) =
174+(/\) c1 c2 =
180 case (c1, c2) of
175 case (c1, c2) of
181− (CTrue, _) -> b
176+ (CTrue, _) -> c2
182− (_, CTrue) -> a
177+ (_, CTrue) -> c1
183− _ -> mergeOldDocs a b (CAnd [a,b])
178+ _ -> CAnd [c1,c2]
184
179
185
180
186-- ex qs constraint == exists qs. constraint
181-- ex qs constraint == exists qs. constraint
187ex :: [Variable] -> TypeConstraint -> TypeConstraint
182ex :: [Variable] -> TypeConstraint -> TypeConstraint
188−ex fqs constraint@(A ann _) =
183+ex fqs constraint =
189− A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
184+ CLet [Scheme [] fqs constraint Map.empty] CTrue
190
185
191
186
192-- fl qs constraint == forall qs. constraint
187-- fl qs constraint == forall qs. constraint
193fl :: [Variable] -> TypeConstraint -> TypeConstraint
188fl :: [Variable] -> TypeConstraint -> TypeConstraint
194−fl rqs constraint@(A ann _) =
189+fl rqs constraint =
195− A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
190+ CLet [Scheme rqs [] constraint Map.empty] CTrue
196
191
197
192
198−exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
193+exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint
199exists f =
194exists f =
200− do v <- liftIO $ variable Flexible
195+ do v <- variable Flexible
201 ex [v] <$> f (varN v)
196 ex [v] <$> f (varN v)
202
197
203
198
204−existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
199+existsNumber :: (Type -> IO TypeConstraint) -> IO TypeConstraint
205existsNumber f =
200existsNumber f =
206− do v <- liftIO $ variable (Is Number)
201+ do v <- variable (Is Number)
207 ex [v] <$> f (varN v)
202 ex [v] <$> f (varN v)
208
203
209
204
@@ -214,11 +209,6 @@ instance PrettyType a => PrettyType (UF.Point a) where
214 unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
209 unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
215
210
216
211
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
212instance PrettyType a => PrettyType (Term1 a) where
223 pretty when term =
213 pretty when term =
224 let prty = pretty Never in
214 let prty = pretty Never in
@@ -280,14 +270,20 @@ instance PrettyType a => PrettyType (TermN a) where
280 case maybeAlias of
270 case maybeAlias of
281 Nothing -> doc
271 Nothing -> doc
282 Just (name, args) ->
272 Just (name, args) ->
273+ P.hang
274+ (P.text (Var.toString name))
275+ 2
283− P.hang (PP.pretty name) 2 (P.sep (map (pretty App . snd) args))
276+ (P.sep (map (pretty App . snd) args))
284
277
285
278
286instance PrettyType Descriptor where
279instance PrettyType Descriptor where
287 pretty when desc =
280 pretty when desc =
288 case (alias desc, structure desc, name desc) of
281 case (alias desc, structure desc, name desc) of
289 (Just (name, args), _, _) ->
282 (Just (name, args), _, _) ->
283+ P.hang
284+ (P.text (Var.toString name))
285+ 4
290− P.hang (PP.pretty name) 4 (P.sep (map (pretty App . snd) args))
286+ (P.sep (map (pretty App . snd) args))
291
287
292 (_, Just term, _) ->
288 (_, Just term, _) ->
293 pretty when term
289 pretty when term
@@ -301,72 +297,96 @@ instance PrettyType Descriptor where
301 _ -> P.text "?"
297 _ -> P.text "?"
302
298
303
299
304−instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
300+instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where
305 pretty _ constraint =
301 pretty _ constraint =
306 let prty = pretty Never in
302 let prty = pretty Never in
307 case constraint of
303 case constraint of
304+ CTrue ->
308− CTrue -> P.text "True"
305+ P.text "True"
306+
307+ CSaveEnv ->
309− CSaveEnv -> P.text "SaveTheEnvironment!!!"
308+ P.text "SaveTheEnvironment!!!"
309+
310+ CEqual _region a b ->
310− CEqual a b -> prty a <+> P.text "=" <+> prty b
311+ prty a <+> P.text "=" <+> prty b
312+
313+ CAnd [] ->
311− CAnd [] -> P.text "True"
314+ P.text "True"
312
315
313 CAnd cs ->
316 CAnd cs ->
314− P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
317+ P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
315
318
316− CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->
319+ CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->
317 P.sep [ binder, pretty Never c ]
320 P.sep [ binder, pretty Never c ]
318 where
321 where
319− mergeExists vs (A _ c) =
322+ mergeExists vs c =
320 case c of
323 case c of
321− CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'
324+ CLet [Scheme [] fqs' c' _] CTrue -> mergeExists (vs ++ fqs') c'
322 _ -> (vs, c)
325 _ -> (vs, c)
323
326
324 (fqs', c) = mergeExists fqs constraint
327 (fqs', c) = mergeExists fqs constraint
325
328
329+ binder =
330+ if null fqs'
326− binder = if null fqs' then P.empty else
331+ then P.empty
332+ else
327− P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."
333+ P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."
328
334
329 CLet schemes constraint ->
335 CLet schemes constraint ->
336+ P.fsep
330− P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
337+ [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
331− , P.text "in", pretty Never constraint ]
338+ , P.text "in", pretty Never constraint
339+ ]
332
340
333− CInstance name tipe ->
341+ CInstance _region name tipe ->
334− P.text name <+> P.text "<" <+> prty tipe
342+ P.text name <+> P.text "<" <+> prty tipe
335
343
336
344
337instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
345instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
338− pretty _ (Scheme rqs fqs (A _ constraint) headers) =
346+ pretty _ (Scheme rqs fqs constraint headers) =
339 P.sep [ forall, cs, headers' ]
347 P.sep [ forall, cs, headers' ]
340 where
348 where
341 prty = pretty Never
349 prty = pretty Never
342
350
351+ forall =
343− forall = if null rqs && null fqs then P.empty else
352+ if null rqs && null fqs
353+ then P.empty
344− P.text "\x2200" <+> frees <+> rigids
354+ else P.text "\x2200" <+> frees <+> rigids
355+
356+ frees = P.hsep (map prty fqs)
357+
358+ rigids =
359+ if null rqs
360+ then P.empty
361+ else P.braces . P.hsep $ map prty rqs
362+
363+ cs =
364+ case constraint of
365+ CTrue -> P.empty
366+ CAnd [] -> P.empty
367+ _ -> P.brackets (pretty Never constraint)
345
368
346− frees = P.hsep $ map prty fqs
369+ headers' =
347− rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs
370+ if Map.size headers > 0 then dict else P.empty
348
371
349− cs = case constraint of
372+ dict =
350− CTrue -> P.empty
373+ P.parens . commaSep . map prettyPair $ Map.toList headers
351− CAnd [] -> P.empty
352− _ -> P.brackets (pretty Never constraint)
353
374
354− headers' = if Map.size headers > 0 then dict else P.empty
375+ 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
376+ P.text n <+> P.text ":" <+> pretty Never t
357
377
358
378
359-- CONVERT TO SOURCE TYPES
379-- CONVERT TO SOURCE TYPES
360
380
361-- TODO: Attach resulting type to the descriptor so that you
381-- TODO: Attach resulting type to the descriptor so that you
362-- never have to do extra work, particularly nice for aliased types
382-- never have to do extra work, particularly nice for aliased types
363−toSrcType :: Variable -> IO T.CanonicalType
383+toSrcType :: Variable -> IO T.Canonical
364toSrcType variable =
384toSrcType variable =
365 do addNames variable
385 do addNames variable
366 variableToSrcType variable variable
386 variableToSrcType variable variable
367
387
368
388
369−variableToSrcType :: Variable -> Variable -> IO T.CanonicalType
389+variableToSrcType :: Variable -> Variable -> IO T.Canonical
370variableToSrcType rootVariable variable =
390variableToSrcType rootVariable variable =
371 do desc <- UF.descriptor variable
391 do desc <- UF.descriptor variable
372 srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)
392 srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)
@@ -383,7 +403,7 @@ variableToSrcType rootVariable variable =
383 do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args
403 do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args
384 return (T.Aliased name args' (T.Filled srcType))
404 return (T.Aliased name args' (T.Filled srcType))
385 where
405 where
386− backupSrcType :: Descriptor -> IO T.CanonicalType
406+ backupSrcType :: Descriptor -> IO T.Canonical
387 backupSrcType desc =
407 backupSrcType desc =
388 case name desc of
408 case name desc of
389 Just v@(Var.Canonical _ x@(c:_))
409 Just v@(Var.Canonical _ x@(c:_))
@@ -401,7 +421,7 @@ variableToSrcType rootVariable variable =
401 ]
421 ]
402
422
403
423
404−termToSrcType :: Variable -> Term1 Variable -> IO T.CanonicalType
424+termToSrcType :: Variable -> Term1 Variable -> IO T.Canonical
405termToSrcType rootVariable term =
425termToSrcType rootVariable term =
406 let go = variableToSrcType rootVariable in
426 let go = variableToSrcType rootVariable in
407 case term of
427 case term of
@@ -433,7 +453,7 @@ termToSrcType rootVariable term =
433 T.Var _ -> T.Record fields (Just ext')
453 T.Var _ -> T.Record fields (Just ext')
434 _ -> error "Used toSrcType on a type that is not well-formed"
454 _ -> error "Used toSrcType on a type that is not well-formed"
435 where
455 where
436− dealias :: T.CanonicalType -> T.CanonicalType
456+ dealias :: T.Canonical -> T.Canonical
437 dealias tipe =
457 dealias tipe =
438 case tipe of
458 case tipe of
439 T.Aliased _ args tipe' ->
459 T.Aliased _ args tipe' ->
@@ -473,7 +493,7 @@ data NameState = NameState
473
493
474varAddNames :: Variable -> StateT NameState IO ()
494varAddNames :: Variable -> StateT NameState IO ()
475varAddNames var =
495varAddNames var =
476− do desc <- liftIO (UF.descriptor var)
496+ do desc <- State.liftIO (UF.descriptor var)
477 case alias desc of
497 case alias desc of
478 Nothing ->
498 Nothing ->
479 return ()
499 return ()
@@ -490,7 +510,7 @@ varAddNames var =
490 Just _ -> return ()
510 Just _ -> return ()
491 Nothing ->
511 Nothing ->
492 do name' <- createName desc
512 do name' <- createName desc
493− liftIO $ UF.modifyDescriptor var $ \desc ->
513+ State.liftIO $ UF.modifyDescriptor var $ \desc ->
494 desc { name = Just (Var.local name') }
514 desc { name = Just (Var.local name') }
495
515
496
516
src/Type/Unify.hs+61−60
@@ -1,7 +1,7 @@
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
@@ -9,52 +9,55 @@ import qualified Data.Maybe as Maybe
9import qualified Data.UnionFind.IO as UF
9import qualified Data.UnionFind.IO as UF
10import Text.PrettyPrint (render)
10import Text.PrettyPrint (render)
11
11
12−import qualified AST.Annotation as A
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
15import Type.Type
16import Type.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 :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
21+unify :: R.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
22unify region variable1 variable2 =
22unify region variable1 variable2 =
23− do result <- runErrorT (unifyHelp region variable1 variable2)
23+ do result <- runExceptT (unifyHelp variable1 variable2)
24− either TS.addHint return result
24+ case result of
25+ Right state ->
26+ return state
27+
28+ Left mismatch ->
29+ TS.addError region (Error.Mismatch mismatch)
25
30
26
31
27-- ACTUALLY UNIFY STUFF
32-- ACTUALLY UNIFY STUFF
28
33
29−type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)
34+type Unify = ExceptT Error.Mismatch (StateT TS.SolverState IO)
30
35
31
36
32typeError
37typeError
33− :: A.Region
34− -> Maybe String
38+ :: Maybe String
35 -> UF.Point Descriptor
39 -> UF.Point Descriptor
36 -> UF.Point Descriptor
40 -> UF.Point Descriptor
37 -> Unify a
41 -> Unify a
38−typeError region hint t1 t2 =
42+typeError hint leftType rightType =
39− do msg <- liftIO (Hint.create region hint t1 t2)
43+ do leftSrcType <- liftIO (toSrcType leftType)
40− throwError msg
44+ rightSrcType <- liftIO (toSrcType rightType)
45+ throwError (Error.MismatchInfo hint leftSrcType rightSrcType)
41
46
42
47
43−unifyHelp :: A.Region -> Variable -> Variable -> Unify ()
48+unifyHelp :: Variable -> Variable -> Unify ()
44−unifyHelp region variable1 variable2 = do
49+unifyHelp variable1 variable2 =
45− equivalent <- liftIO $ UF.equivalent variable1 variable2
50+ do equivalent <- liftIO $ UF.equivalent variable1 variable2
46− if equivalent
51+ if equivalent
47− then return ()
52+ then return ()
48− else actuallyUnify region variable1 variable2
53+ else actuallyUnify variable1 variable2
49
54
50
55
51−actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()
56+actuallyUnify :: Variable -> Variable -> Unify ()
52−actuallyUnify region variable1 variable2 = do
57+actuallyUnify variable1 variable2 = do
53 desc1 <- liftIO $ UF.descriptor variable1
58 desc1 <- liftIO $ UF.descriptor variable1
54 desc2 <- liftIO $ UF.descriptor variable2
59 desc2 <- liftIO $ UF.descriptor variable2
55− let unifyHelp' = unifyHelp region
56−
57− (name', flex', rank', alias') = combinedDescriptors desc1 desc2
60+ let (name', flex', rank', alias') = combinedDescriptors desc1 desc2
58
61
59 merge1 :: Unify ()
62 merge1 :: Unify ()
60 merge1 =
63 merge1 =
@@ -100,7 +103,7 @@ actuallyUnify region variable1 variable2 = do
100
103
101 flexAndUnify v =
104 flexAndUnify v =
102 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
105 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
103− unifyHelp' variable1 variable2
106+ unifyHelp variable1 variable2
104
107
105 unifyNumber svar (Var.Canonical home name) =
108 unifyNumber svar (Var.Canonical home name) =
106 case home of
109 case home of
@@ -109,17 +112,17 @@ actuallyUnify region variable1 variable2 = do
109 _ ->
112 _ ->
110 let hint = "Looks like something besides an Int or Float is being used as a number."
113 let hint = "Looks like something besides an Int or Float is being used as a number."
111 in
114 in
112− typeError region (Just hint) variable1 variable2
115+ typeError (Just hint) variable1 variable2
113
116
114 comparableError maybe =
117 comparableError maybe =
115− typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
118+ typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
116 where
119 where
117 msg =
120 msg =
118 "Looks like you want something comparable, but the only valid comparable\n\
121 "Looks like you want something comparable, but the only valid comparable\n\
119 \types are Int, Float, Char, String, lists, or tuples."
122 \types are Int, Float, Char, String, lists, or tuples."
120
123
121 appendableError maybe =
124 appendableError maybe =
122− typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
125+ typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
123 where
126 where
124 msg =
127 msg =
125 "Looks like you want something appendable, but the only Strings, Lists,\n\
128 "Looks like you want something appendable, but the only Strings, Lists,\n\
@@ -139,7 +142,7 @@ actuallyUnify region variable1 variable2 = do
139
142
140 List v ->
143 List v ->
141 do flexAndUnify varSuper
144 do flexAndUnify varSuper
142− unifyHelp' v =<< liftIO (variable $ Is Comparable)
145+ unifyHelp v =<< liftIO (variable $ Is Comparable)
143
146
144 Tuple vs
147 Tuple vs
145 | length vs > 6 ->
148 | length vs > 6 ->
@@ -147,7 +150,7 @@ actuallyUnify region variable1 variable2 = do
147 | otherwise ->
150 | otherwise ->
148 do flexAndUnify varSuper
151 do flexAndUnify varSuper
149 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
152 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
150− zipWithM_ unifyHelp' vs cmpVars
153+ zipWithM_ unifyHelp vs cmpVars
151
154
152 unifyAppendable varSuper varFlex =
155 unifyAppendable varSuper varFlex =
153 do struct <- liftIO $ collectApps varFlex
156 do struct <- liftIO $ collectApps varFlex
@@ -156,7 +159,7 @@ actuallyUnify region variable1 variable2 = do
156 _ -> appendableError Nothing
159 _ -> appendableError Nothing
157
160
158 rigidError var =
161 rigidError var =
159− typeError region (Just hint) variable1 variable2
162+ typeError (Just hint) variable1 variable2
160 where
163 where
161 hint =
164 hint =
162 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
165 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
@@ -187,7 +190,7 @@ actuallyUnify region variable1 variable2 = do
187
190
188 (Rigid, _, _, _) -> rigidError variable1
191 (Rigid, _, _, _) -> rigidError variable1
189 (_, Rigid, _, _) -> rigidError variable2
192 (_, Rigid, _, _) -> rigidError variable2
190− _ -> typeError region Nothing variable1 variable2
193+ _ -> typeError Nothing variable1 variable2
191
194
192 case (structure desc1, structure desc2) of
195 case (structure desc1, structure desc2) of
193 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
196 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
@@ -200,10 +203,10 @@ actuallyUnify region variable1 variable2 = do
200 merge1
203 merge1
201
204
202 (Just (Var1 v), _) ->
205 (Just (Var1 v), _) ->
203− unifyHelp' v variable2
206+ unifyHelp v variable2
204
207
205 (_, Just (Var1 v)) ->
208 (_, Just (Var1 v)) ->
206− unifyHelp' variable1 v
209+ unifyHelp variable1 v
207
210
208 (Nothing, _) ->
211 (Nothing, _) ->
209 superUnify
212 superUnify
@@ -215,38 +218,37 @@ actuallyUnify region variable1 variable2 = do
215 case (type1,type2) of
218 case (type1,type2) of
216 (App1 term1 term2, App1 term1' term2') ->
219 (App1 term1 term2, App1 term1' term2') ->
217 do merge
220 do merge
218− unifyHelp' term1 term1'
221+ unifyHelp term1 term1'
219− unifyHelp' term2 term2'
222+ unifyHelp term2 term2'
220 (Fun1 term1 term2, Fun1 term1' term2') ->
223 (Fun1 term1 term2, Fun1 term1' term2') ->
221 do merge
224 do merge
222− unifyHelp' term1 term1'
225+ unifyHelp term1 term1'
223− unifyHelp' term2 term2'
226+ unifyHelp term2 term2'
224
227
225 (EmptyRecord1, EmptyRecord1) ->
228 (EmptyRecord1, EmptyRecord1) ->
226 return ()
229 return ()
227
230
228− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2
231+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
229− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' variable1 ext
232+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
230
233
231 (Record1 _ _, Record1 _ _) ->
234 (Record1 _ _, Record1 _ _) ->
232− recordUnify region fresh variable1 variable2
235+ recordUnify fresh variable1 variable2
233
236
234− _ -> typeError region Nothing variable1 variable2
237+ _ -> typeError Nothing variable1 variable2
235
238
236
239
237-- RECORD UNIFICATION
240-- RECORD UNIFICATION
238
241
239recordUnify
242recordUnify
240− :: A.Region
241− -> (Maybe (Term1 Variable) -> Unify Variable)
243+ :: (Maybe (Term1 Variable) -> Unify Variable)
242 -> Variable
244 -> Variable
243 -> Variable
245 -> Variable
244 -> Unify ()
246 -> Unify ()
245−recordUnify region fresh variable1 variable2 =
247+recordUnify fresh variable1 variable2 =
246 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
248 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
247 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
249 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
248
250
249− unifyOverlappingFields region fields1 fields2
251+ unifyOverlappingFields fields1 fields2
250
252
251 let freshRecord fields ext =
253 let freshRecord fields ext =
252 fresh (Just (Record1 fields ext))
254 fresh (Just (Record1 fields ext))
@@ -257,57 +259,56 @@ recordUnify region fresh variable1 variable2 =
257 let addFieldMismatchError missingFields =
259 let addFieldMismatchError missingFields =
258 let msg = fieldMismatchError missingFields
260 let msg = fieldMismatchError missingFields
259 in
261 in
260− typeError region (Just msg) variable1 variable2
262+ typeError (Just msg) variable1 variable2
261
263
262 case (ext1, ext2) of
264 case (ext1, ext2) of
263 (Empty _, Empty _) ->
265 (Empty _, Empty _) ->
264 case Map.null uniqueFields1 && Map.null uniqueFields2 of
266 case Map.null uniqueFields1 && Map.null uniqueFields2 of
265 True -> return ()
267 True -> return ()
266− False -> typeError region Nothing variable1 variable2
268+ False -> typeError Nothing variable1 variable2
267
269
268 (Empty var1, Extension var2) ->
270 (Empty var1, Extension var2) ->
269 case (Map.null uniqueFields1, Map.null uniqueFields2) of
271 case (Map.null uniqueFields1, Map.null uniqueFields2) of
270 (_, False) -> addFieldMismatchError uniqueFields2
272 (_, False) -> addFieldMismatchError uniqueFields2
271− (True, True) -> unifyHelp region var1 var2
273+ (True, True) -> unifyHelp var1 var2
272 (False, True) ->
274 (False, True) ->
273 do subRecord <- freshRecord uniqueFields1 var1
275 do subRecord <- freshRecord uniqueFields1 var1
274− unifyHelp region subRecord var2
276+ unifyHelp subRecord var2
275
277
276 (Extension var1, Empty var2) ->
278 (Extension var1, Empty var2) ->
277 case (Map.null uniqueFields1, Map.null uniqueFields2) of
279 case (Map.null uniqueFields1, Map.null uniqueFields2) of
278 (False, _) -> addFieldMismatchError uniqueFields1
280 (False, _) -> addFieldMismatchError uniqueFields1
279− (True, True) -> unifyHelp region var1 var2
281+ (True, True) -> unifyHelp var1 var2
280 (True, False) ->
282 (True, False) ->
281 do subRecord <- freshRecord uniqueFields2 var2
283 do subRecord <- freshRecord uniqueFields2 var2
282− unifyHelp region var1 subRecord
284+ unifyHelp var1 subRecord
283
285
284 (Extension var1, Extension var2) ->
286 (Extension var1, Extension var2) ->
285 case (Map.null uniqueFields1, Map.null uniqueFields2) of
287 case (Map.null uniqueFields1, Map.null uniqueFields2) of
286 (True, True) ->
288 (True, True) ->
287− unifyHelp region var1 var2
289+ unifyHelp var1 var2
288
290
289 (True, False) ->
291 (True, False) ->
290 do subRecord <- freshRecord uniqueFields2 var2
292 do subRecord <- freshRecord uniqueFields2 var2
291− unifyHelp region var1 subRecord
293+ unifyHelp var1 subRecord
292
294
293 (False, True) ->
295 (False, True) ->
294 do subRecord <- freshRecord uniqueFields1 var1
296 do subRecord <- freshRecord uniqueFields1 var1
295− unifyHelp region subRecord var2
297+ unifyHelp subRecord var2
296
298
297 (False, False) ->
299 (False, False) ->
298 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
300 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
299 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
301 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
300− unifyHelp region record1' var2
302+ unifyHelp record1' var2
301− unifyHelp region var1 record2'
303+ unifyHelp var1 record2'
302
304
303
305
304unifyOverlappingFields
306unifyOverlappingFields
305− :: A.Region
306− -> Map.Map String [Variable]
307+ :: Map.Map String [Variable]
307 -> Map.Map String [Variable]
308 -> Map.Map String [Variable]
308 -> Unify ()
309 -> Unify ()
309−unifyOverlappingFields region fields1 fields2 =
310+unifyOverlappingFields fields1 fields2 =
310− Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2
311+ Map.intersectionWith (zipWith unifyHelp) fields1 fields2
311 |> Map.elems
312 |> Map.elems
312 |> concat
313 |> concat
313 |> sequence_
314 |> sequence_
src/Validate.hsnew file+391
@@ -0,0 +1,391 @@
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.Task as Task
21+
22+
23+-- VALIDATE DECLARATIONS
24+
25+declarations
26+ :: [D.SourceDecl]
27+ -> Task.Task 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+ -> Task.Task 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+ -> Task.Task 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+ -> Task.Task 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+ Task.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+ -> Task.Task 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+ Task.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] -> Task.Task 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] -> Task.Task 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+ Task.throw region (Error.TypeWithoutDefinition name)
158+
159+
160+-- VALIDATE EXPRESSIONS
161+
162+expression :: Source.Expr -> Task.Task 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) -> Task.Task wrn Error.Error (a, Valid.Expr)
254+second (value, expr) =
255+ (,) value <$> expression expr
256+
257+
258+both
259+ :: (Source.Expr, Source.Expr)
260+ -> Task.Task 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+ -> Task.Task 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+ Task.throw region (tag name)
282+
283+ _ ->
284+ return ()
285+ in
286+ F.traverse_ check (makeGroups names)
287+
288+
289+defDuplicates
290+ :: [Pattern.RawPattern]
291+ -> Task.Task wrn Error.Error ()
292+defDuplicates patterns =
293+ concatMap Pattern.boundVars patterns
294+ |> detectDuplicates Error.DuplicateDefinition
295+
296+
297+declDuplicates :: [D.ValidDecl] -> Task.Task 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 -> Task.Task wrn Error.Error ()
343+checkDecl (A.A _ decl) =
344+ case decl of
345+ D.Definition _ ->
346+ return ()
347+
348+ D.Datatype name boundVars ctors ->
349+ F.traverse_ (checkTypeVars name boundVars) (concatMap snd ctors)
350+
351+ D.TypeAlias name boundVars tipe ->
352+ checkTypeVars name boundVars tipe
353+
354+ D.Port _ ->
355+ return ()
356+
357+ D.Fixity _ _ _ ->
358+ return ()
359+
360+
361+checkTypeVars :: String -> [String] -> Type.Raw -> Task.Task wrn Error.Error ()
362+checkTypeVars name boundVars tipe =
363+ let bounds = Set.fromList boundVars
364+
365+ check (A.A region free) =
366+ if Set.member free bounds
367+ then return ()
368+ else Task.throw region (Error.UnboundTypeVar name free)
369+ in
370+ F.traverse_ check (freeVars tipe)
371+
372+
373+freeVars :: Type.Raw -> [A.Located String]
374+freeVars (A.A region tipe) =
375+ case tipe of
376+ Type.RLambda t1 t2 ->
377+ freeVars t1 ++ freeVars t2
378+
379+ Type.RVar x ->
380+ [A.A region x]
381+
382+ Type.RType _ ->
383+ []
384+
385+ Type.RApp t ts ->
386+ concatMap freeVars (t:ts)
387+
388+ Type.RRecord fields ext ->
389+ maybe [] freeVars ext
390+ ++ concatMap (freeVars . snd) fields
391+