git.iko.soy/elk
on master help sign in
Error reporting overhaul (BIG)

* Move all reporting tools to Reporting/ * Centralize validation in Validate.hs * Add locations to types, patterns, defs, decls, imports * Improve pretty printing API regarding parens * Switch from Error to Except * Warnings for unused imports * Constraint gen is IO instead of ExceptT _ IO * Only keep regions for CEqual and CInstance * Modernize indentation here and there

commitee3b209ecaaaf97baaaf6935e7eb28af6c738923 authorEvan Czaplicki <info@elm-lang.org> dateMon 4 May 2015, 05:49 (11 years ago) parent7362137
63 files changed+3012−2409
compare with master
unifiedsplit
elm-compiler.cabal+4−13 src/AST/Annotation.hs−111 src/AST/Declaration.hs+27−116 src/AST/Expression/Canonical.hs+12−11 src/AST/Expression/General.hs+127−92 src/AST/Expression/Source.hs+12−20 src/AST/Expression/Valid.hs+7−25 src/AST/Literal.hs+15−13 src/AST/Module.hs+32−69 src/AST/Pattern.hs+95−69 src/AST/Type.hs+83−76 src/AST/Variable.hs+68−46 src/Compile.hs+16−21 src/Elm/Compiler.hs+14−15 src/Elm/Compiler/Type/Extract.hs+1−1 src/Elm/Utils.hs+1−1 src/Generate/Cases.hs+170−118 src/Generate/JavaScript.hs+81−56 src/Generate/JavaScript/Helpers.hs+4−4 src/Generate/JavaScript/Port.hs+34−34 src/Parse/Binop.hs+102−55 src/Parse/Declaration.hs+5−5 src/Parse/Expression.hs+115−68 src/Parse/Helpers.hs+30−22 src/Parse/Module.hs+11−10 src/Parse/Parse.hs+111−52 src/Parse/Pattern.hs+76−37 src/Parse/Type.hs+47−32 src/Reporting/Annotation.hs+52 src/Reporting/Error.hs+55 src/Transform/Canonicalize/Error.hs → src/Reporting/Error/Canonicalize.hs+60−28 src/Reporting/Error/Syntax.hs+35 src/Reporting/Error/Type.hs+39 src/AST/PrettyPrint.hs → src/Reporting/PrettyPrint.hs+4−22 src/Reporting/Region.hs+73 src/Reporting/Task.hs+51 src/Reporting/Warning.hs+8 src/Transform/AddDefaultImports.hs+10−7 src/Transform/Canonicalize.hs+83−57 src/Transform/Canonicalize/Environment.hs+21−11 src/Transform/Canonicalize/Port.hs+12−10 src/Transform/Canonicalize/Result.hs+17−13 src/Transform/Canonicalize/Setup.hs+75−50 src/Transform/Canonicalize/Type.hs+30−29 src/Transform/Canonicalize/Variable.hs+50−34 src/Transform/Check.hs−160 src/Transform/Declaration.hs+32−89 src/Transform/Expression.hs−84 src/Transform/SortDefinitions.hs+29−17 src/Transform/Substitute.hs+22−15 src/Type/Constrain/Expression.hs+113−105 src/Type/Constrain/Literal.hs+23−16 src/Type/Constrain/Pattern.hs+51−62 src/Type/Environment.hs+15−23 src/Type/ExtraChecks.hs+11−93 src/Type/Fragment.hs+11−11 src/Type/Hint.hs−35 src/Type/Inference.hs+41−28 src/Type/Solve.hs+146−89 src/Type/State.hs+8−6 src/Type/Type.hs+83−63 src/Type/Unify.hs+61−60 src/Validate.hs+391
elm-compiler.cabal+4−13
@@ -46,7 +46,6 @@ Library
4646 Elm.Utils
4747
4848 other-modules:
49− AST.Annotation,
5049 AST.Declaration,
5150 AST.Expression.General,
5251 AST.Expression.Source,
@@ -56,7 +55,6 @@ Library
5655 AST.Literal,
5756 AST.Module,
5857 AST.Pattern,
59− AST.PrettyPrint,
6058 AST.Type,
6159 AST.Variable,
6260 Compile,
@@ -74,10 +72,6 @@ Library
7472 Transform.Canonicalize.Setup,
7573 Transform.Canonicalize.Type,
7674 Transform.Canonicalize.Variable,
77− Transform.Check,
78− Transform.Expression,
79− Transform.Declaration,
80− Transform.Definition,
8175 Transform.Interface,
8276 Transform.SortDefinitions,
8377 Transform.Substitute,
@@ -96,7 +90,6 @@ Library
9690 Type.Environment,
9791 Type.ExtraChecks,
9892 Type.Fragment,
99− Type.Hint,
10093 Type.Inference,
10194 Type.PrettyPrint,
10295 Type.Solve,
@@ -121,7 +114,7 @@ Library
121114 indents >= 0.3 && < 0.4,
122115 language-ecmascript >= 0.15 && < 0.18,
123116 language-glsl >= 0.0.2 && < 0.2,
124− mtl >= 2 && < 3,
117+ mtl >= 2.2 && < 3,
125118 parsec >= 3.1.1 && < 3.5,
126119 pretty >= 1.0 && < 2.0,
127120 process,
@@ -143,14 +136,12 @@ Executable elm-doc
143136
144137 other-modules:
145138 Elm.Compiler.Version,
146− AST.Annotation,
147139 AST.Declaration,
148140 AST.Expression.General,
149141 AST.Helpers,
150142 AST.Literal,
151143 AST.Module,
152144 AST.Pattern,
153− AST.PrettyPrint,
154145 AST.Type,
155146 AST.Variable,
156147 Parse.Binop,
@@ -174,7 +165,7 @@ Executable elm-doc
174165 filepath >= 1 && < 2.0,
175166 indents >= 0.3 && < 0.4,
176167 language-glsl >= 0.0.2 && < 0.2,
177− mtl >= 2 && < 3,
168+ mtl >= 2.2 && < 3,
178169 parsec >= 3.1.1 && < 3.5,
179170 pretty >= 1.0 && < 2.0,
180171 process,
@@ -208,7 +199,7 @@ Executable elm
208199 filepath >= 1 && < 2.0,
209200 indents >= 0.3 && < 0.4,
210201 language-glsl >= 0.0.2 && < 0.2,
211− mtl >= 2 && < 3,
202+ mtl >= 2.2 && < 3,
212203 parsec >= 3.1.1 && < 3.5,
213204 pretty >= 1.0 && < 2.0,
214205 process,
@@ -258,7 +249,7 @@ Test-Suite compiler-tests
258249 indents >= 0.3 && < 0.4,
259250 language-ecmascript >= 0.15 && < 0.18,
260251 language-glsl >= 0.0.2 && < 0.2,
261− mtl >= 2 && < 3,
252+ mtl >= 2.2 && < 3,
262253 parsec >= 3.1.1 && < 3.5,
263254 pretty >= 1.0 && < 2.0,
264255 process,
src/AST/Annotation.hsdeleted−111
@@ -1,111 +0,0 @@
1−module AST.Annotation where
2−
3−import qualified Text.Parsec.Pos as Parsec
4−import qualified Text.PrettyPrint as P
5−import AST.PrettyPrint
6−
7−
8−data Annotated annotation expr
9− = A annotation expr
10− deriving (Show)
11−
12−
13−data Region
14− = Span Position Position P.Doc
15− | None P.Doc
16− deriving (Show)
17−
18−
19−data Position = Position
20− { line :: Int
21− , column :: Int
22− }
23− deriving (Show)
24−
25−
26−type Located expr =
27− Annotated Region expr
28−
29−
30−none :: (Pretty expr) => expr -> Located expr
31−none e =
32− A (None (pretty e)) e
33−
34−
35−noneNoDocs :: a -> Located a
36−noneNoDocs e =
37− A (None P.empty) e
38−
39−
40−at :: (Pretty expr)
41− => Parsec.SourcePos
42− -> Parsec.SourcePos
43− -> expr
44− -> Annotated Region expr
45−at start end e =
46− A (Span (position start) (position end) (pretty e)) e
47− where
48− position loc =
49− Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
50−
51−
52−merge :: (Pretty expr) => Located a -> Located b -> expr -> Located expr
53−merge (A s1 _) (A s2 _) e =
54− A (span (pretty e)) e
55− where
56− span =
57− case (s1,s2) of
58− (Span start _ _, Span _ end _) ->
59− Span start end
60−
61− (Span start end _, _) ->
62− Span start end
63−
64− (_, Span start end _) ->
65− Span start end
66−
67− (_, _) -> None
68−
69−
70−mergeOldDocs :: Located a -> Located b -> c -> Located c
71−mergeOldDocs (A s1 _) (A s2 _) e =
72− A span e
73− where
74− span =
75− case (s1,s2) of
76− (Span start _ d1, Span _ end d2) ->
77− Span start end (P.vcat [d1, P.text "\n", d2])
78−
79− (Span _ _ _, _) -> s1
80−
81− (_, Span _ _ _) -> s2
82−
83− (_, _) -> None P.empty
84−
85−
86−sameAs :: Annotated a expr -> expr' -> Annotated a expr'
87−sameAs (A annotation _) expr =
88− A annotation expr
89−
90−
91−getRegionDocs :: Region -> P.Doc
92−getRegionDocs region =
93− case region of
94− Span _ _ doc -> doc
95− None doc -> doc
96−
97−
98−instance Pretty Region where
99− pretty span =
100− case span of
101− None _ -> P.empty
102− Span start end _ ->
103− P.text $
104− case line start == line end of
105− False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
106− True -> "on line " ++ show (line end) ++ ", column " ++
107− show (column start) ++ " to " ++ show (column end)
108−
109−
110−instance Pretty e => Pretty (Annotated a e) where
111− pretty (A _ e) = pretty e
src/AST/Declaration.hs+27−116
@@ -2,58 +2,71 @@
22module AST.Declaration where
33
44import Data.Binary
5+
56import qualified AST.Expression.General as General
67import qualified AST.Expression.Source as Source
78import qualified AST.Expression.Valid as Valid
89import qualified AST.Expression.Canonical as Canonical
9−import qualified AST.Type as T
10−import qualified AST.Variable as Var
11−import AST.PrettyPrint
12−import Text.PrettyPrint as P
10+import qualified AST.Type as Type
11+import qualified Reporting.Annotation as A
1312
1413
1514-- DECLARATIONS
1615
17−data Declaration' port def var expr
16+data Declaration' port def tipe expr
1817 = Definition def
19− | Datatype String [String] [(String, [T.Type var])]
20− | TypeAlias String [String] (T.Type var)
18+ | Datatype String [String] [(String, [tipe])]
19+ | TypeAlias String [String] tipe
2120 | Port port
2221 | Fixity Assoc Int String
2322
2423
24+-- INFIX STUFF
25+
2526data Assoc = L | N | R
2627 deriving (Eq)
2728
2829
30+assocToString :: Assoc -> String
31+assocToString assoc =
32+ case assoc of
33+ L -> "left"
34+ N -> "non"
35+ R -> "right"
36+
37+
2938-- DECLARATION PHASES
3039
40+type SourceDecl' =
41+ Declaration' SourcePort Source.Def Type.Raw Source.Expr
42+
43+
3144type SourceDecl =
32− Declaration' SourcePort Source.Def Var.Raw Source.Expr
45+ A.Located SourceDecl'
3346
3447
3548type ValidDecl =
36− Declaration' ValidPort Valid.Def Var.Raw Valid.Expr
49+ A.Located (Declaration' ValidPort Valid.Def Type.Raw Valid.Expr)
3750
3851
3952type CanonicalDecl =
40− Declaration' CanonicalPort Canonical.Def Var.Canonical Canonical.Expr
53+ A.Located (Declaration' CanonicalPort Canonical.Def Type.Canonical Canonical.Expr)
4154
4255
4356-- PORTS
4457
4558data SourcePort
46− = PortAnnotation String T.RawType
59+ = PortAnnotation String Type.Raw
4760 | PortDefinition String Source.Expr
4861
4962
5063data ValidPort
51− = In String T.RawType
52− | Out String Valid.Expr T.RawType
64+ = In String Type.Raw
65+ | Out String Valid.Expr Type.Raw
5366
5467
5568newtype CanonicalPort
56− = CanonicalPort (General.PortImpl Canonical.Expr Var.Canonical)
69+ = CanonicalPort (General.PortImpl Canonical.Expr Type.Canonical)
5770
5871
5972validPortName :: ValidPort -> String
@@ -80,105 +93,3 @@ instance Binary Assoc where
8093 L -> 0
8194 N -> 1
8295 R -> 2
83−
84−
85−-- PRETTY STRINGS
86−
87−assocToString :: Assoc -> String
88−assocToString assoc =
89− case assoc of
90− L -> "left"
91− N -> "non"
92− R -> "right"
93−
94−
95−instance (Pretty port, Pretty def, Pretty var, Var.ToString var, Pretty expr) =>
96− Pretty (Declaration' port def var expr) where
97− pretty decl =
98− case decl of
99− Definition def -> pretty def
100−
101− Datatype tipe tvars ctors ->
102− P.hang
103− (P.text "type" <+> P.text tipe <+> P.hsep (map P.text tvars))
104− 4
105− (P.sep $ zipWith (<+>) seperators (map prettyCtor ctors))
106− where
107− seperators =
108− map P.text ("=" : repeat "|")
109−
110− prettyCtor (name, tipes) =
111− P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))
112−
113− TypeAlias name tvars tipe ->
114− P.hang
115− (P.text "type" <+> P.text "alias" <+> name' <+> P.equals)
116− 4
117− (pretty tipe)
118− where
119− name' =
120− P.text name <+> P.hsep (map P.text tvars)
121−
122− Port port ->
123− pretty port
124−
125− Fixity assoc prec op ->
126− P.text "infix" <> assoc' <+> P.int prec <+> P.text op
127− where
128− assoc' =
129− case assoc of
130− L -> P.text "l"
131− N -> P.empty
132− R -> P.text "r"
133−
134−
135−instance Pretty SourcePort where
136− pretty port =
137− case port of
138− PortAnnotation name tipe ->
139− prettyPortType name tipe
140−
141− PortDefinition name expr ->
142− prettyPortDef name expr
143−
144−
145−instance Pretty ValidPort where
146− pretty port =
147− case port of
148− In name tipe ->
149− prettyPortType name tipe
150−
151− Out name expr tipe ->
152− prettyPort name expr tipe
153−
154−
155−instance Pretty CanonicalPort where
156− pretty (CanonicalPort impl) =
157− case impl of
158− General.In name tipe ->
159− prettyPortType name tipe
160−
161− General.Out name expr tipe ->
162− prettyPort name expr tipe
163−
164− General.Task name expr tipe ->
165− prettyPort name expr tipe
166−
167−
168−
169−prettyPort :: (Pretty expr, Pretty tipe) => String -> expr -> tipe -> P.Doc
170−prettyPort name expr tipe =
171− P.vcat
172− [ prettyPortType name tipe
173− , prettyPortDef name expr
174− ]
175−
176−
177−prettyPortType :: (Pretty tipe) => String -> tipe -> P.Doc
178−prettyPortType name tipe =
179− P.text "port" <+> P.text name <+> P.colon <+> pretty tipe
180−
181−
182−prettyPortDef :: (Pretty expr) => String -> expr -> P.Doc
183−prettyPortDef name expr =
184− P.hang (P.text "port" <+> P.text name <+> P.equals) 4 (pretty expr)
src/AST/Expression/Canonical.hs+12−11
@@ -1,37 +1,38 @@
11{-# OPTIONS_GHC -Wall #-}
2−
32module AST.Expression.Canonical where
43
5−import AST.PrettyPrint
64import Text.PrettyPrint as P
5+
76import qualified AST.Expression.General as General
8−import AST.Type (CanonicalType)
9−import qualified AST.Annotation as Annotation
107import qualified AST.Pattern as Pattern
8+import qualified AST.Type as Type
119import qualified AST.Variable as Var
10+import qualified Reporting.PrettyPrint as P
11+import qualified Reporting.Region as R
1212
1313
1414{-| Canonicalized expressions. All variables are fully resolved to the module
1515they came from.
1616-}
1717type Expr =
18− General.Expr Annotation.Region Def Var.Canonical
18+ General.Expr R.Region Def Var.Canonical Type.Canonical
1919
2020
2121type Expr' =
22− General.Expr' Annotation.Region Def Var.Canonical
22+ General.Expr' R.Region Def Var.Canonical Type.Canonical
2323
2424
25−data Def = Definition Pattern.CanonicalPattern Expr (Maybe CanonicalType)
25+data Def
26+ = Definition Pattern.CanonicalPattern Expr (Maybe Type.Canonical)
2627 deriving (Show)
2728
2829
29−instance Pretty Def where
30− pretty (Definition pattern expr maybeTipe) =
30+instance P.Pretty Def where
31+ pretty _ (Definition pattern expr maybeTipe) =
3132 P.vcat [ annotation, definition ]
3233 where
3334 definition =
34− pretty pattern <+> P.equals <+> pretty expr
35+ P.pretty True pattern <+> P.equals <+> P.pretty False expr
3536
3637 annotation =
3738 case maybeTipe of
@@ -39,4 +40,4 @@ instance Pretty Def where
3940 P.empty
4041
4142 Just tipe ->
42− pretty pattern <+> P.colon <+> pretty tipe
43+ P.pretty True pattern <+> P.colon <+> P.pretty False tipe
src/AST/Expression/General.hs+127−92
@@ -8,15 +8,15 @@ enrich the AST with more information.
88-}
99module AST.Expression.General where
1010
11−import AST.PrettyPrint
1211import Text.PrettyPrint as P
1312
14−import qualified AST.Annotation as Annotation
1513import qualified AST.Helpers as Help
1614import qualified AST.Literal as Literal
1715import qualified AST.Pattern as Pattern
1816import qualified AST.Type as Type
1917import qualified AST.Variable as Var
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.PrettyPrint as P
2020
2121
2222---- GENERAL AST ----
@@ -36,43 +36,43 @@ move through the compilation process. The type holes are used to represent:
3636 with information about what module a variable came from.
3737
3838-}
39−type Expr annotation definition variable =
40− Annotation.Annotated annotation (Expr' annotation definition variable)
39+type Expr annotation definition variable tipe =
40+ A.Annotated annotation (Expr' annotation definition variable tipe)
4141
4242
43−data Expr' ann def var
43+data Expr' ann def var typ
4444 = Literal Literal.Literal
4545 | Var var
46− | Range (Expr ann def var) (Expr ann def var)
47− | ExplicitList [Expr ann def var]
48− | Binop var (Expr ann def var) (Expr ann def var)
49− | Lambda (Pattern.Pattern var) (Expr ann def var)
50− | App (Expr ann def var) (Expr ann def var)
51− | MultiIf [(Expr ann def var,Expr ann def var)]
52− | Let [def] (Expr ann def var)
53− | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)]
54− | Data String [Expr ann def var]
55− | Access (Expr ann def var) String
56− | Remove (Expr ann def var) String
57− | Insert (Expr ann def var) String (Expr ann def var)
58− | Modify (Expr ann def var) [(String, Expr ann def var)]
59− | Record [(String, Expr ann def var)]
46+ | Range (Expr ann def var typ) (Expr ann def var typ)
47+ | ExplicitList [Expr ann def var typ]
48+ | Binop var (Expr ann def var typ) (Expr ann def var typ)
49+ | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)
50+ | App (Expr ann def var typ) (Expr ann def var typ)
51+ | MultiIf [(Expr ann def var typ,Expr ann def var typ)]
52+ | Let [def] (Expr ann def var typ)
53+ | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]
54+ | Data String [Expr ann def var typ]
55+ | Access (Expr ann def var typ) String
56+ | Remove (Expr ann def var typ) String
57+ | Insert (Expr ann def var typ) String (Expr ann def var typ)
58+ | Modify (Expr ann def var typ) [(String, Expr ann def var typ)]
59+ | Record [(String, Expr ann def var typ)]
6060 -- for type checking and code gen only
61− | Port (PortImpl (Expr ann def var) var)
61+ | Port (PortImpl (Expr ann def var typ) typ)
6262 | GLShader String String Literal.GLShaderTipe
6363 deriving (Show)
6464
6565
6666-- PORTS
6767
68−data PortImpl expr var
69− = In String (Type.PortType var)
70− | Out String expr (Type.PortType var)
71− | Task String expr (Type.PortType var)
68+data PortImpl expr tipe
69+ = In String (Type.Port tipe)
70+ | Out String expr (Type.Port tipe)
71+ | Task String expr (Type.Port tipe)
7272 deriving (Show)
7373
7474
75−portName :: PortImpl expr var -> String
75+portName :: PortImpl expr tipe -> String
7676portName impl =
7777 case impl of
7878 In name _ -> name
@@ -82,17 +82,17 @@ portName impl =
8282
8383---- UTILITIES ----
8484
85−rawVar :: String -> Expr' ann def Var.Raw
85+rawVar :: String -> Expr' ann def Var.Raw typ
8686rawVar x =
8787 Var (Var.Raw x)
8888
8989
90−localVar :: String -> Expr' ann def Var.Canonical
90+localVar :: String -> Expr' ann def Var.Canonical typ
9191localVar x =
9292 Var (Var.Canonical Var.Local x)
9393
9494
95−tuple :: [Expr ann def var] -> Expr' ann def var
95+tuple :: [Expr ann def var typ] -> Expr' ann def var typ
9696tuple expressions =
9797 Data ("_Tuple" ++ show (length expressions)) expressions
9898
@@ -102,102 +102,151 @@ saveEnvName =
102102 "_save_the_environment!!!"
103103
104104
105−dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical
105+dummyLet :: (P.Pretty def) => [def] -> Expr ann def Var.Canonical typ
106106dummyLet defs =
107− Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))
107+ let body =
108+ A.A undefined (Var (Var.builtin saveEnvName))
109+ in
110+ A.A undefined (Let defs body)
108111
109112
110−instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where
111− pretty expression =
113+-- PRETTY PRINTING
114+
115+instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where
116+ pretty needsParens expression =
112117 case expression of
113118 Literal literal ->
114− pretty literal
119+ P.pretty needsParens literal
115120
116121 Var x ->
117− pretty x
122+ P.pretty needsParens x
118123
119124 Range lowExpr highExpr ->
120− P.brackets (pretty lowExpr <> P.text ".." <> pretty highExpr)
125+ P.brackets $
126+ P.pretty False lowExpr
127+ <> P.text ".."
128+ <> P.pretty False highExpr
121129
122130 ExplicitList elements ->
123− P.brackets (commaCat (map pretty elements))
131+ P.brackets (P.commaCat (map (P.pretty False) elements))
124132
125− Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) expr
133+ Binop op (A.A _ (Literal (Literal.IntNum 0))) expr
126134 | Var.toString op == "-" ->
127− P.text "-" <> prettyParens expr
135+ P.text "-" <> P.pretty True expr
128136
129137 Binop op leftExpr rightExpr ->
130− P.hang (prettyParens leftExpr) 2 (P.text op'' <+> prettyParens rightExpr)
138+ P.parensIf needsParens $
139+ P.hang
140+ (P.pretty True leftExpr)
141+ 2
142+ (P.text op'' <+> P.pretty True rightExpr)
131143 where
132144 op' = Var.toString op
133145 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
134146
135147 Lambda pattern expr ->
136− P.text "\\" <> args <+> P.text "->" <+> pretty body
148+ P.parensIf needsParens $
149+ P.text "\\" <> args <+> P.text "->" <+> P.pretty False body
137150 where
138− (patterns, body) = collectLambdas expr
139− args = P.sep (map Pattern.prettyParens (pattern : patterns))
151+ (patterns, body) =
152+ collectLambdas expr
153+
154+ args =
155+ P.sep (map (P.pretty True) (pattern : patterns))
140156
141157 App expr arg ->
142− P.hang func 2 (P.sep args)
158+ P.parensIf needsParens $
159+ P.hang func 2 (P.sep args)
143160 where
144161 func:args =
145− map prettyParens (collectApps expr ++ [arg])
162+ map (P.pretty True) (collectApps expr ++ [arg])
146163
147164 MultiIf branches ->
148− P.text "if" $$ nest 3 (vcat $ map iff branches)
165+ P.parensIf needsParens $
166+ P.text "if" $$ nest 3 (vcat $ map iff branches)
149167 where
150− iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
168+ iff (condition, branch) =
169+ P.text "|" <+>
170+ P.hang
171+ (P.pretty False condition <+> P.text "->")
172+ 2
173+ (P.pretty False branch)
151174
152175 Let defs body ->
153− P.sep
154− [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
155− , P.text "in" <+> pretty body
156− ]
176+ P.parensIf needsParens $
177+ P.sep
178+ [ P.hang
179+ (P.text "let")
180+ 4
181+ (P.vcat (map (P.pretty False) defs))
182+ , P.text "in" <+> P.pretty False body
183+ ]
157184
158185 Case expr branches ->
159− P.hang pexpr 2 (P.vcat (map pretty' branches))
186+ P.parensIf needsParens $
187+ P.hang pexpr 2 (P.vcat (map pretty' branches))
160188 where
161− pexpr = P.sep [ P.text "case" <+> pretty expr, P.text "of" ]
189+ pexpr =
190+ P.text "case" <+> P.pretty False expr <+> P.text "of"
191+
162192 pretty' (pattern, branch) =
163− pretty pattern <+> P.text "->" <+> pretty branch
193+ P.pretty False pattern
194+ <+> P.text "->"
195+ <+> P.pretty False branch
164196
165197 Data "::" [hd,tl] ->
166− pretty hd <+> P.text "::" <+> pretty tl
198+ P.parensIf needsParens $
199+ P.pretty True hd <+> P.text "::" <+> P.pretty True tl
167200
168201 Data "[]" [] ->
169202 P.text "[]"
170203
171− Data name exprs
172− | Help.isTuple name ->
173− P.parens (commaCat (map pretty exprs))
174− | otherwise ->
175− P.hang (P.text name) 2 (P.sep (map prettyParens exprs))
204+ Data name exprs ->
205+ if Help.isTuple name
206+ then
207+ P.parens (P.commaCat (map (P.pretty False) exprs))
208+ else
209+ P.parensIf (needsParens && not (null exprs)) $
210+ P.hang
211+ (P.text name)
212+ 2
213+ (P.sep (map (P.pretty True) exprs))
176214
177215 Access record field ->
178− prettyParens record <> P.text "." <> variable field
216+ P.pretty True record <> P.text "." <> P.text field
179217
180218 Remove record field ->
181− P.braces (pretty record <+> P.text "-" <+> variable field)
219+ P.braces (P.pretty False record <+> P.text "-" <+> P.text field)
182220
183− Insert (Annotation.A _ (Remove record y)) x v ->
221+ Insert (A.A _ (Remove record oldField)) newField expr ->
184222 P.braces $
185223 P.hsep
186− [ pretty record, P.text "-", variable y, P.text "|"
187− , variable x, P.equals, pretty v
224+ [ P.pretty False record
225+ , P.text "-"
226+ , P.text oldField
227+ , P.text "|"
228+ , P.text newField
229+ , P.equals
230+ , P.pretty False expr
188231 ]
189232
190233 Insert record field expr ->
191− P.braces (pretty record <+> P.text "|" <+> variable field <+> P.equals <+> pretty expr)
234+ P.braces $
235+ P.pretty False record
236+ <+> P.text "|"
237+ <+> P.text field
238+ <+> P.equals
239+ <+> P.pretty False expr
192240
193241 Modify record fields ->
194242 P.braces $
195243 P.hang
196− (pretty record <+> P.text "|")
244+ (P.pretty False record <+> P.text "|")
197245 4
198− (commaSep $ map field fields)
246+ (P.commaSep $ map prettyField fields)
199247 where
200− field (k,v) = variable k <+> P.text "<-" <+> pretty v
248+ prettyField (field, expr) =
249+ P.text field <+> P.text "<-" <+> P.pretty False expr
201250
202251 Record fields ->
203252 P.sep
@@ -206,48 +255,34 @@ instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var
206255 ]
207256 where
208257 field (name, expr) =
209− variable name <+> P.equals <+> pretty expr
258+ P.text name <+> P.equals <+> P.pretty False expr
210259
211260 GLShader _ _ _ ->
212261 P.text "[glsl| ... |]"
213262
214263 Port portImpl ->
215− pretty portImpl
264+ P.pretty needsParens portImpl
216265
217266
218−instance (Pretty expr, Pretty var) => Pretty (PortImpl expr var) where
219− pretty impl =
267+instance P.Pretty (PortImpl expr tipe) where
268+ pretty _ impl =
220269 P.text ("<port:" ++ portName impl ++ ">")
221270
222271
223−collectApps :: Expr ann def var -> [Expr ann def var]
224−collectApps annExpr@(Annotation.A _ expr) =
272+collectApps :: Expr ann def var typ -> [Expr ann def var typ]
273+collectApps annExpr@(A.A _ expr) =
225274 case expr of
226275 App a b -> collectApps a ++ [b]
227276 _ -> [annExpr]
228277
229278
230−collectLambdas :: Expr ann def var -> ([Pattern.Pattern var], Expr ann def var)
231−collectLambdas lexpr@(Annotation.A _ expr) =
279+collectLambdas
280+ :: Expr ann def var typ
281+ -> ([Pattern.Pattern ann var], Expr ann def var typ)
282+collectLambdas lexpr@(A.A _ expr) =
232283 case expr of
233284 Lambda pattern body ->
234285 let (ps, body') = collectLambdas body
235286 in (pattern : ps, body')
236287
237288 _ -> ([], lexpr)
238−
239−
240−prettyParens :: (Pretty def, Pretty var, Var.ToString var) => Expr ann def var -> Doc
241−prettyParens (Annotation.A _ expr) =
242− parensIf needed (pretty expr)
243− where
244− needed =
245− case expr of
246− Binop _ _ _ -> True
247− Lambda _ _ -> True
248− App _ _ -> True
249− MultiIf _ -> True
250− Let _ _ -> True
251− Case _ _ -> True
252− Data name (_:_) -> not (name == "::" || Help.isTuple name)
253− _ -> False
src/AST/Expression/Source.hs+12−20
@@ -1,14 +1,12 @@
11{-# OPTIONS_GHC -Wall #-}
2−
32module AST.Expression.Source where
43
5−import AST.PrettyPrint
6−import Text.PrettyPrint as P
74import qualified AST.Expression.General as General
8−import AST.Type (RawType)
9−import qualified AST.Variable as Var
10−import qualified AST.Annotation as Annotation
115import qualified AST.Pattern as Pattern
6+import qualified AST.Type as Type
7+import qualified AST.Variable as Var
8+import qualified Reporting.Annotation as A
9+import qualified Reporting.Region as R
1210
1311
1412{-| Expressions created by the parser. These use a split representation of type
@@ -16,24 +14,18 @@ annotations and definitions, which is how they appear in source code and how
1614they are parsed.
1715-}
1816type Expr =
19− General.Expr Annotation.Region Def Var.Raw
17+ General.Expr R.Region Def Var.Raw Type.Raw
2018
2119
2220type Expr' =
23− General.Expr' Annotation.Region Def Var.Raw
24−
21+ General.Expr' R.Region Def Var.Raw Type.Raw
2522
26−data Def
27− = Definition Pattern.RawPattern Expr
28− | TypeAnnotation String RawType
29− deriving (Show)
3023
24+type Def =
25+ A.Located Def'
3126
32−instance Pretty Def where
33− pretty def =
34− case def of
35− TypeAnnotation name tipe ->
36− variable name <+> P.colon <+> pretty tipe
3727
38− Definition pattern expr ->
39− pretty pattern <+> P.equals <+> pretty expr
28+data Def'
29+ = Definition Pattern.RawPattern Expr
30+ | TypeAnnotation String Type.Raw
31+ deriving (Show)
src/AST/Expression/Valid.hs+7−25
@@ -1,14 +1,11 @@
11{-# OPTIONS_GHC -Wall #-}
2−
32module AST.Expression.Valid where
43
5−import AST.PrettyPrint
6−import Text.PrettyPrint as P
74import qualified AST.Expression.General as General
8−import AST.Type (RawType)
9−import qualified AST.Variable as Var
10−import qualified AST.Annotation as Annotation
115import qualified AST.Pattern as Pattern
6+import qualified AST.Type as Type
7+import qualified AST.Variable as Var
8+import qualified Reporting.Region as R
129
1310
1411{-| "Normal" expressions. When the compiler checks that type annotations and
@@ -16,28 +13,13 @@ ports are all paired with definitions in the appropriate order, it collapses
1613them into a Def that is easier to work with in later phases of compilation.
1714-}
1815type Expr =
19− General.Expr Annotation.Region Def Var.Raw
16+ General.Expr R.Region Def Var.Raw Type.Raw
2017
2118
2219type Expr' =
23− General.Expr' Annotation.Region Def Var.Raw
20+ General.Expr' R.Region Def Var.Raw Type.Raw
2421
2522
26−data Def = Definition Pattern.RawPattern Expr (Maybe RawType)
23+data Def
24+ = Definition Pattern.RawPattern Expr (Maybe Type.Raw)
2725 deriving (Show)
28−
29−
30−instance Pretty Def where
31− pretty (Definition pattern expr maybeTipe) =
32− P.vcat [ annotation, definition ]
33− where
34− definition =
35− pretty pattern <+> P.equals <+> pretty expr
36−
37− annotation =
38− case maybeTipe of
39− Nothing ->
40− P.empty
41−
42− Just tipe ->
43− pretty pattern <+> P.colon <+> pretty tipe
src/AST/Literal.hs+15−13
@@ -1,9 +1,11 @@
11{-# OPTIONS_GHC -Wall #-}
22module AST.Literal where
33
4−import AST.PrettyPrint
5−import Data.Map (Map)
6−import qualified Text.PrettyPrint as PP
4+import qualified Data.Map as Map
5+import qualified Text.PrettyPrint as P
6+
7+import qualified Reporting.PrettyPrint as P
8+
79
810data Literal
911 = IntNum Int
@@ -14,14 +16,14 @@ data Literal
1416 deriving (Eq, Ord, Show)
1517
1618
17−instance Pretty Literal where
18− pretty literal =
19+instance P.Pretty Literal where
20+ pretty _ literal =
1921 case literal of
20− IntNum n -> PP.int n
21− FloatNum n -> PP.double n
22− Chr c -> PP.text . show $ c
23− Str s -> PP.text . show $ s
24− Boolean bool -> PP.text (show bool)
22+ IntNum n -> P.int n
23+ FloatNum n -> P.double n
24+ Chr c -> P.text . show $ c
25+ Str s -> P.text . show $ s
26+ Boolean bool -> P.text (show bool)
2527
2628
2729data GLTipe
@@ -48,8 +50,8 @@ glTipeName glTipe =
4850
4951
5052data GLShaderTipe = GLShaderTipe
51− { attribute :: Map String GLTipe
52− , uniform :: Map String GLTipe
53− , varying :: Map String GLTipe
53+ { attribute :: Map.Map String GLTipe
54+ , uniform :: Map.Map String GLTipe
55+ , varying :: Map.Map String GLTipe
5456 }
5557 deriving (Show)
src/AST/Module.hs+32−69
@@ -4,55 +4,57 @@ module AST.Module
44 , AdtInfo, CanonicalAdt
55 , SourceModule, ValidModule, CanonicalModule
66 , Module(..), CanonicalBody(..)
7− , HeaderAndImports(..)
7+ , Header(..)
88 , Name, nameToString, nameIsNative
99 , Interface(..), toInterface
10− , ImportMethod(..)
10+ , UserImport, DefaultImport, ImportMethod(..)
1111 ) where
1212
13+import Control.Applicative ((<$>),(<*>))
1314import Data.Binary
1415import qualified Data.List as List
1516import qualified Data.Map as Map
16−import Control.Applicative ((<$>),(<*>))
1717
18−import qualified AST.Expression.Canonical as Canonical
1918import qualified AST.Declaration as Decl
19+import qualified AST.Expression.Canonical as Canonical
2020import qualified AST.Type as Type
2121import qualified AST.Variable as Var
22−import AST.PrettyPrint
2322import qualified Elm.Compiler.Version as Compiler
24−import Text.PrettyPrint as P
23+import qualified Reporting.Annotation as A
2524
2625
2726-- HELPFUL TYPE ALIASES
2827
2928type Interfaces = Map.Map Name Interface
3029
31−type Types = Map.Map String Type.CanonicalType
32−type Aliases = Map.Map String ([String], Type.CanonicalType)
30+type Types = Map.Map String Type.Canonical
31+type Aliases = Map.Map String ([String], Type.Canonical)
3332type ADTs = Map.Map String (AdtInfo String)
3433
35−type AdtInfo v = ( [String], [(v, [Type.CanonicalType])] )
34+type AdtInfo v = ( [String], [(v, [Type.Canonical])] )
3635type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)
3736
3837
3938-- MODULES
4039
4140type SourceModule =
42− Module (Var.Listing Var.Value) [Decl.SourceDecl]
41+ Module [UserImport] (Var.Listing Var.Value) [Decl.SourceDecl]
4342
4443type ValidModule =
45− Module (Var.Listing Var.Value) [Decl.ValidDecl]
44+ Module
45+ ([DefaultImport], [UserImport])
46+ (Var.Listing Var.Value)
47+ [Decl.ValidDecl]
4648
4749type CanonicalModule =
48− Module [Var.Value] CanonicalBody
50+ Module [Name] [Var.Value] CanonicalBody
4951
5052
51−data Module exports body = Module
53+data Module imports exports body = Module
5254 { names :: Name
5355 , path :: FilePath
5456 , exports :: exports
55− , imports :: [(Name, ImportMethod)]
57+ , imports :: imports
5658 , body :: body
5759 }
5860
@@ -69,10 +71,10 @@ data CanonicalBody = CanonicalBody
6971-- HEADERS
7072
7173{-| Basic info needed to identify modules and determine dependencies. -}
72−data HeaderAndImports = HeaderAndImports
74+data Header imports = Header
7375 { _names :: Name
7476 , _exports :: Var.Listing Var.Value
75− , _imports :: [(Name, ImportMethod)]
77+ , _imports :: imports
7678 }
7779
7880
@@ -91,6 +93,19 @@ nameIsNative name =
9193 _ -> False
9294
9395
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+
94109
95110-- INTERFACES
96111
@@ -99,7 +114,7 @@ data Interface = Interface
99114 { iVersion :: String
100115 , iExports :: [Var.Value]
101116 , iTypes :: Types
102− , iImports :: [(Name, ImportMethod)]
117+ , iImports :: [Name]
103118 , iAdts :: ADTs
104119 , iAliases :: Aliases
105120 , iFixities :: [(Decl.Assoc, Int, String)]
@@ -131,55 +146,3 @@ instance Binary Interface where
131146 put (iAliases modul)
132147 put (iFixities modul)
133148 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 @@
11{-# OPTIONS_GHC -Wall #-}
22module AST.Pattern where
33
4−import qualified AST.Helpers as Help
5−import AST.PrettyPrint
6−import Text.PrettyPrint as PP
74import qualified Data.Set as Set
5+import Text.PrettyPrint as P
86
7+import qualified AST.Helpers as Help
8+import qualified AST.Literal as L
99import qualified AST.Variable as Var
10−import AST.Literal as Literal
10+import qualified Reporting.Annotation as A
11+import qualified Reporting.PrettyPrint as P
12+import qualified Reporting.Region as R
13+
1114
15+type Pattern ann var =
16+ A.Annotated ann (Pattern' ann var)
1217
13−data Pattern var
14− = Data var [Pattern var]
18+
19+data Pattern' ann var
20+ = Data var [Pattern ann var]
1521 | Record [String]
16− | Alias String (Pattern var)
22+ | Alias String (Pattern ann var)
1723 | Var String
1824 | Anything
19− | Literal Literal.Literal
20− deriving (Eq, Ord, Show)
25+ | Literal L.Literal
26+ deriving (Show)
2127
2228
2329type RawPattern =
24− Pattern Var.Raw
25−
30+ Pattern R.Region Var.Raw
2631
27−type CanonicalPattern =
28− Pattern Var.Canonical
2932
33+type RawPattern' =
34+ Pattern' R.Region Var.Raw
3035
31−cons :: RawPattern -> RawPattern -> RawPattern
32−cons h t =
33− Data (Var.Raw "::") [h,t]
3436
37+type CanonicalPattern =
38+ Pattern R.Region Var.Canonical
3539
36−nil :: RawPattern
37−nil =
38− Data (Var.Raw "[]") []
3940
41+list :: R.Position -> [RawPattern] -> RawPattern
42+list end patterns =
43+ case patterns of
44+ [] ->
45+ A.at end end (Data (Var.Raw "[]") [])
4046
41−list :: [RawPattern] -> RawPattern
42−list patterns =
43− foldr cons nil patterns
47+ pattern@(A.A (R.Region start _) _) : rest ->
48+ A.at start end (Data (Var.Raw "::") [pattern, list end rest])
4449
4550
46−tuple :: [RawPattern] -> RawPattern
51+tuple :: [RawPattern] -> RawPattern'
4752tuple patterns =
4853 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns
4954
5055
51−boundVarList :: Pattern var -> [String]
52−boundVarList pattern =
53− Set.toList (boundVars pattern)
54−
56+-- FIND VARIABLES
5557
56−boundVars :: Pattern var -> Set.Set String
57−boundVars pattern =
58+boundVars :: Pattern ann var -> [A.Annotated ann String]
59+boundVars (A.A ann pattern) =
5860 case pattern of
59− Var x -> Set.singleton x
60− Alias x p -> Set.insert x (boundVars p)
61− Data _ ps -> Set.unions (map boundVars ps)
62− Record fields -> Set.fromList fields
63− Anything -> Set.empty
64− Literal _ -> Set.empty
61+ Var x ->
62+ [A.A ann x]
63+
64+ Alias name realPattern ->
65+ A.A ann name : boundVars realPattern
66+
67+ Data _ patterns ->
68+ concatMap boundVars patterns
69+
70+ Record fields ->
71+ map (A.A ann) fields
72+
73+ Anything ->
74+ []
75+
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+
6594
95+-- PRETTY PRINTING
6696
67−instance Var.ToString var => Pretty (Pattern var) where
68− pretty pattern =
97+instance Var.ToString var => P.Pretty (Pattern' ann var) where
98+ pretty needsParens pattern =
6999 case pattern of
70− Var x ->
71− variable x
100+ Var name ->
101+ P.text name
72102
73103 Literal literal ->
74− pretty literal
104+ P.pretty needsParens literal
75105
76106 Record fields ->
77− PP.braces (commaCat (map variable fields))
107+ P.braces (P.commaCat (map P.text fields))
78108
79− Alias x p ->
80− prettyParens p <+> PP.text "as" <+> variable x
109+ Alias x ptrn ->
110+ P.parensIf needsParens $
111+ P.pretty True ptrn <+> P.text "as" <+> P.text x
81112
82113 Anything ->
83− PP.text "_"
84−
85− Data name [hd,tl] | Var.toString name == "::" ->
86− parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
87− where
88− isCons =
89− case hd of
90− Data ctor _ -> Var.toString ctor == "::"
91− _ -> False
92−
93− Data name ps ->
94− let name' = Var.toString name
95− in
114+ P.text "_"
115+
116+ Data name [A.A _ hd, A.A _ tl]
117+ | Var.toString name == "::" ->
118+ P.parensIf isCons (P.pretty False hd)
119+ <+> P.text "::"
120+ <+> P.pretty False tl
121+ where
122+ isCons =
123+ case hd of
124+ Data ctor _ -> Var.toString ctor == "::"
125+ _ -> False
126+
127+ Data name patterns ->
128+ let name' = Var.toString name
129+ in
96130 if Help.isTuple name'
97− then PP.parens (commaCat (map pretty ps))
98− else hsep (PP.text name' : map prettyParens ps)
99−
100−
101−prettyParens :: Var.ToString var => Pattern var -> Doc
102−prettyParens pattern =
103− parensIf needsThem (pretty pattern)
104− where
105− needsThem =
106− case pattern of
107− Data name (_:_) | not (Help.isTuple (Var.toString name)) -> True
108− Alias _ _ -> True
109− _ -> False
131+ then
132+ P.parens (P.commaCat (map (P.pretty False) patterns))
133+ else
134+ P.parensIf needsParens $
135+ P.hsep (P.text name' : map (P.pretty True) patterns)
src/AST/Type.hs+83−76
@@ -1,57 +1,64 @@
11module AST.Type
2− ( Type(..), AliasType(..)
3− , RawType, CanonicalType
4− , PortType(..), portType
5− , fieldMap, recordOf, listOf, tupleOf
2+ ( Raw, Raw'(..)
3+ , Canonical(..), Aliased(..)
4+ , Port(..), portType
65 , deepDealias, dealias
76 , collectLambdas
8− , prettyParens
7+ , fieldMap
8+ , tuple
99 ) where
1010
1111import Control.Applicative ((<$>), (<*>))
1212import Control.Arrow (second)
1313import Data.Binary
1414import qualified Data.Map as Map
15+import Text.PrettyPrint as P
1516
1617import qualified AST.Variable as Var
17−import AST.PrettyPrint
1818import qualified AST.Helpers as Help
19−import Text.PrettyPrint as P
19+import qualified Reporting.Annotation as A
20+import qualified Reporting.PrettyPrint as P
21+import qualified Reporting.Region as R
2022
2123
2224-- DEFINITION
2325
24−data Type var
25− = Lambda (Type var) (Type var)
26− | Var String
27− | Type var
28− | App (Type var) [Type var]
29− | Record [(String, Type var)] (Maybe (Type var))
30− | Aliased Var.Canonical [(String, Type var)] (AliasType var)
31− deriving (Eq, Ord, Show)
26+type Raw =
27+ A.Located Raw'
3228
3329
34−data AliasType var
35− = Holey (Type var)
36− | Filled (Type var)
37− deriving (Eq, Ord, Show)
30+data Raw'
31+ = RLambda Raw Raw
32+ | RVar String
33+ | RType Var.Raw
34+ | RApp Raw [Raw]
35+ | RRecord [(String, Raw)] (Maybe Raw)
36+ deriving (Show)
3837
3938
40−type RawType =
41− Type Var.Raw
39+data Canonical
40+ = Lambda Canonical Canonical
41+ | Var String
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)
4247
4348
44−type CanonicalType =
45− Type Var.Canonical
49+data Aliased t
50+ = Holey t
51+ | Filled t
52+ deriving (Eq, Ord, Show)
4653
4754
48−data PortType var
49− = Normal (Type var)
50− | Signal { root :: Type var, arg :: Type var }
55+data Port t
56+ = Normal t
57+ | Signal { root :: t, arg :: t }
5158 deriving (Show)
5259
5360
54−portType :: PortType var -> Type var
61+portType :: Port tipe -> tipe
5562portType portType =
5663 case portType of
5764 Normal tipe -> tipe
@@ -65,7 +72,7 @@ fieldMap fields =
6572 in
6673 foldl add Map.empty fields
6774
68−
75+{--
6976recordOf :: [(String, Type var)] -> Type var
7077recordOf fields =
7178 Record fields Nothing
@@ -74,18 +81,18 @@ recordOf fields =
7481listOf :: RawType -> RawType
7582listOf tipe =
7683 App (Type (Var.Raw "List")) [tipe]
84+--}
7785
78−
79−tupleOf :: [RawType] -> RawType
80−tupleOf types =
86+tuple :: R.Region -> [Raw] -> Raw
87+tuple region types =
8188 let name = Var.Raw ("_Tuple" ++ show (length types))
8289 in
83− App (Type name) types
90+ A.A region (RApp (A.A region (RType name)) types)
8491
8592
8693-- DEALIASING
8794
88−deepDealias :: Type v -> Type v
95+deepDealias :: Canonical -> Canonical
8996deepDealias tipe =
9097 let go = deepDealias in
9198 case tipe of
@@ -108,7 +115,7 @@ deepDealias tipe =
108115 App (go f) (map go args)
109116
110117
111−dealias :: [(String, Type v)] -> AliasType v -> Type v
118+dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
112119dealias args aliasType =
113120 case aliasType of
114121 Holey tipe ->
@@ -118,7 +125,7 @@ dealias args aliasType =
118125 tipe
119126
120127
121−dealiasHelp :: Map.Map String (Type var) -> Type var -> Type var
128+dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
122129dealiasHelp typeTable tipe =
123130 let go = dealiasHelp typeTable in
124131 case tipe of
@@ -143,27 +150,37 @@ dealiasHelp typeTable tipe =
143150
144151-- PRETTY PRINTING
145152
146−instance (Pretty var, Var.ToString var) => Pretty (PortType var) where
147− pretty portType =
153+instance (P.Pretty t) => P.Pretty (Port t) where
154+ pretty needsParens portType =
148155 case portType of
149156 Normal tipe ->
150− pretty tipe
157+ P.pretty needsParens tipe
151158
152159 Signal tipe _ ->
153− pretty tipe
160+ P.pretty needsParens tipe
161+
154162
163+instance P.Pretty Raw' where
164+ pretty _ tipe =
165+ P.text (show tipe)
155166
156−instance (Var.ToString var, Pretty var) => Pretty (Type var) where
157− pretty tipe =
167+
168+instance P.Pretty Canonical where
169+ pretty needsParens tipe =
158170 case tipe of
159171 Lambda _ _ ->
160− P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
172+ P.parensIf needsParens $
173+ P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
161174 where
162− t:ts = map prettyLambda (collectLambdas tipe)
175+ t:ts =
176+ map prettyLambda (collectLambdas tipe)
177+
163178 prettyLambda t =
164179 case t of
165− Lambda _ _ -> P.parens (pretty t)
166− _ -> pretty t
180+ Lambda _ _ ->
181+ P.pretty True t
182+ _ ->
183+ P.pretty False t
167184
168185 Var x ->
169186 P.text x
@@ -177,9 +194,18 @@ instance (Var.ToString var, Pretty var) => Pretty (Type var) where
177194 case (f,args) of
178195 (Type name, _)
179196 | Help.isTuple (Var.toString name) ->
180− P.parens (P.sep (P.punctuate P.comma (map pretty args)))
197+ P.parens $ P.sep $
198+ P.punctuate P.comma (map (P.pretty False) args)
199+
200+ (_, []) ->
201+ P.pretty True f
181202
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))
183209
184210 Record _ _ ->
185211 case flattenRecord tipe of
@@ -202,13 +228,17 @@ instance (Var.ToString var, Pretty var) => Pretty (Type var) where
202228 ])
203229 where
204230 prettyField (field, tipe) =
205− P.text field <+> P.text ":" <+> pretty tipe
231+ P.text field <+> P.text ":" <+> P.pretty False tipe
206232
207233 Aliased name args _ ->
208− P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args))
234+ P.parensIf (needsParens && not (null args)) $
235+ P.hang
236+ (P.pretty False name)
237+ 2
238+ (P.sep (map (P.pretty True . snd) args))
209239
210240
211−collectLambdas :: Type var -> [Type var]
241+collectLambdas :: Canonical -> [Canonical]
212242collectLambdas tipe =
213243 case tipe of
214244 Lambda arg body ->
@@ -218,30 +248,7 @@ collectLambdas tipe =
218248 [tipe]
219249
220250
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 )
245252flattenRecord tipe =
246253 case tipe of
247254 Var x ->
@@ -264,7 +271,7 @@ flattenRecord tipe =
264271
265272-- BINARY
266273
267−instance Binary var => Binary (Type var) where
274+instance Binary Canonical where
268275 put tipe =
269276 case tipe of
270277 Lambda t1 t2 ->
@@ -297,7 +304,7 @@ instance Binary var => Binary (Type var) where
297304 _ -> error "Error reading a valid type from serialized string"
298305
299306
300−instance Binary var => Binary (AliasType var) where
307+instance Binary t => Binary (Aliased t) where
301308 put aliasType =
302309 case aliasType of
303310 Holey tipe ->
src/AST/Variable.hs+68−46
@@ -5,28 +5,29 @@ import Data.Binary
55import qualified Data.List as List
66import qualified Data.Maybe as Maybe
77import Text.PrettyPrint as P
8+
89import qualified AST.Helpers as Help
9−import AST.PrettyPrint
10+import qualified Reporting.PrettyPrint as P
1011
1112
1213-- VARIABLES
1314
1415newtype Raw = Raw String
15− deriving (Eq,Ord,Show)
16+ deriving (Eq, Ord, Show)
1617
1718
1819data Home
1920 = BuiltIn
2021 | Module [String]
2122 | Local
22− deriving (Eq,Ord,Show)
23+ deriving (Eq, Ord, Show)
2324
2425
2526data Canonical = Canonical
2627 { home :: !Home
2728 , name :: !String
2829 }
29− deriving (Eq,Ord,Show)
30+ deriving (Eq, Ord, Show)
3031
3132
3233local :: String -> Canonical
@@ -88,8 +89,10 @@ isTuple v =
8889isPrimitive :: Canonical -> Bool
8990isPrimitive v =
9091 case v of
91− Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]
92− _ -> False
92+ Canonical BuiltIn name ->
93+ name `elem` ["Int","Float","String","Bool"]
94+ _ ->
95+ False
9396
9497
9598isPrim :: String -> Canonical -> Bool
@@ -117,10 +120,10 @@ instance ToString Raw where
117120
118121instance ToString Canonical where
119122 toString (Canonical home name) =
120− case home of
121− BuiltIn -> name
122− Module path -> List.intercalate "." (path ++ [name])
123− Local -> name
123+ case home of
124+ BuiltIn -> name
125+ Module path -> List.intercalate "." (path ++ [name])
126+ Local -> name
124127
125128
126129-- LISTINGS
@@ -129,7 +132,8 @@ instance ToString Canonical where
129132data Listing a = Listing
130133 { _explicits :: [a]
131134 , _open :: Bool
132− } deriving (Eq,Ord,Show)
135+ }
136+ deriving (Eq, Ord, Show)
133137
134138
135139openListing :: Listing a
@@ -152,7 +156,7 @@ data Value
152156 = Value !String
153157 | Alias !String
154158 | Union !String !(Listing String)
155− deriving (Eq,Ord,Show)
159+ deriving (Eq, Ord, Show)
156160
157161
158162-- CATEGORIZING VALUES
@@ -198,30 +202,36 @@ getUnion value =
198202
199203-- PRETTY VARIABLES
200204
201−instance Pretty Raw where
202− pretty (Raw name) =
203− variable name
205+instance P.Pretty Raw where
206+ pretty _ (Raw name) =
207+ if Help.isOp name
208+ then P.parens (P.text name)
209+ else P.text name
204210
205211
206−instance Pretty Canonical where
207− pretty var =
212+instance P.Pretty Canonical where
213+ pretty _ var =
208214 P.text (toString var)
209215
210216
211−instance Pretty a => Pretty (Listing a) where
212− pretty (Listing explicits open) =
213− P.parens (commaCat (map pretty explicits ++ dots))
214− where
215− dots = [if open then P.text ".." else P.empty]
217+instance P.Pretty a => P.Pretty (Listing a) where
218+ pretty _ (Listing explicits open) =
219+ let dots = [if open then P.text ".." else P.empty]
220+ in
221+ P.parens (P.commaCat (map (P.pretty False) explicits ++ dots))
216222
217223
218−instance Pretty Value where
219− pretty portable =
224+instance P.Pretty Value where
225+ pretty _ portable =
220226 case portable of
221− Value name -> P.text name
222− Alias name -> P.text name
227+ Value name ->
228+ P.text name
229+
230+ Alias name ->
231+ P.text name
232+
223233 Union name ctors ->
224− P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })
234+ P.text name <> P.pretty False ctors
225235
226236
227237-- BINARY SERIALIZATION
@@ -229,31 +239,43 @@ instance Pretty Value where
229239instance Binary Canonical where
230240 put (Canonical home name) =
231241 case home of
232− BuiltIn -> putWord8 0 >> put name
233− Module path -> putWord8 1 >> put path >> put name
234− Local -> putWord8 2 >> put name
242+ BuiltIn ->
243+ putWord8 0 >> put name
244+
245+ Module path ->
246+ putWord8 1 >> put path >> put name
247+
248+ Local ->
249+ putWord8 2 >> put name
235250
236− get = do tag <- getWord8
237− case tag of
238− 0 -> Canonical BuiltIn <$> get
239− 1 -> Canonical . Module <$> get <*> get
240− 2 -> Canonical Local <$> get
241− _ -> error "Unexpected tag when deserializing canonical variable"
251+ get =
252+ do tag <- getWord8
253+ case tag of
254+ 0 -> Canonical BuiltIn <$> get
255+ 1 -> Canonical . Module <$> get <*> get
256+ 2 -> Canonical Local <$> get
257+ _ -> error "Unexpected tag when deserializing canonical variable"
242258
243259
244260instance Binary Value where
245261 put portable =
246262 case portable of
247− Value name -> putWord8 0 >> put name
248− Alias name -> putWord8 1 >> put name
249− Union name ctors -> putWord8 2 >> put name >> put ctors
250−
251− get = do tag <- getWord8
252− case tag of
253− 0 -> Value <$> get
254− 1 -> Alias <$> get
255− 2 -> Union <$> get <*> get
256− _ -> error "Error reading valid import/export information from serialized string"
263+ Value name ->
264+ putWord8 0 >> put name
265+
266+ Alias name ->
267+ putWord8 1 >> put name
268+
269+ Union name ctors ->
270+ putWord8 2 >> put name >> put ctors
271+
272+ get =
273+ do tag <- getWord8
274+ case tag of
275+ 0 -> Value <$> get
276+ 1 -> Alias <$> get
277+ 2 -> Union <$> get <*> get
278+ _ -> error "Error reading valid import/export information from serialized string"
257279
258280
259281instance (Binary a) => Binary (Listing a) where
src/Compile.hs+16−21
@@ -1,16 +1,16 @@
11module Compile (compile) where
22
33import qualified Data.Map as Map
4−import Text.PrettyPrint (Doc)
54
65import qualified AST.Module as Module
6+import Elm.Utils ((|>))
77import qualified Parse.Helpers as Parse
88import qualified Parse.Parse as Parse
9−import qualified Transform.AddDefaultImports as DefaultImports
10−import qualified Transform.Check as Check
9+import qualified Reporting.Error as Error
10+import qualified Reporting.Task as Task
11+import qualified Reporting.Warning as Warning
1112import qualified Type.Inference as TI
1213import qualified Transform.Canonicalize as Canonical
13−import Elm.Utils ((|>))
1414
1515
1616compile
@@ -18,33 +18,28 @@ compile
1818 -> String
1919 -> Module.Interfaces
2020 -> String
21− -> Either [Doc] Module.CanonicalModule
21+ -> Task.Task Warning.Warning Error.Error Module.CanonicalModule
2222
2323compile user projectName interfaces source =
24− do
25− -- Parse the source code
26− parsedModule <-
27− Parse.program (getOpTable interfaces) source
28−
24+ do
2925 -- determine if default imports should be added
3026 -- only elm-lang/core is exempt
3127 let needsDefaults =
3228 not (user == "elm-lang" && projectName == "core")
3329
34− -- add default imports if necessary
35− let rawModule =
36− DefaultImports.add needsDefaults parsedModule
37−
38− -- validate module (e.g. all variables exist)
39− case Check.mistakes (Module.body rawModule) of
40− [] -> return ()
41− ms -> Left ms
30+ -- Parse the source code
31+ validModule <-
32+ Task.mapError Error.Syntax $
33+ Parse.program needsDefaults (getOpTable interfaces) source
4234
4335 -- Canonicalize all variables, pinning down where they came from.
44− canonicalModule <- Canonical.module' interfaces rawModule
36+ canonicalModule <-
37+ Canonical.module' interfaces validModule
4538
4639 -- Run type inference on the program.
47− types <- TI.infer interfaces canonicalModule
40+ types <-
41+ Task.from Error.Type $
42+ TI.infer interfaces canonicalModule
4843
4944 -- Add the real list of tyes
5045 let body = (Module.body canonicalModule) { Module.types = types }
@@ -57,4 +52,4 @@ getOpTable interfaces =
5752 Map.elems interfaces
5853 |> concatMap Module.iFixities
5954 |> 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
55 , parseDependencies, compile
66 ) where
77
8−import Control.Monad.Error (MonadError, throwError)
9−import qualified Data.List as List
8+import Control.Monad.Error.Class (MonadError, throwError)
109import qualified Data.Map as Map
11−import qualified Text.PrettyPrint as P
1210
13−import qualified AST.Module as Module (HeaderAndImports(HeaderAndImports), toInterface)
11+import qualified AST.Module as Module
1412import qualified Compile
1513import qualified Elm.Compiler.Module as PublicModule
1614import qualified Elm.Compiler.Version as Version
17−import Elm.Utils ((|>))
1815import qualified Generate.JavaScript as JS
1916import qualified Parse.Helpers as Help
2017import qualified Parse.Module as Parse
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.Task as Task
2120
2221
2322-- VERSION
@@ -39,14 +38,14 @@ parseDependencies
3938 => String
4039 -> m (PublicModule.Name, [PublicModule.Name])
4140parseDependencies src =
42− case Help.iParse Parse.headerAndImports src of
41+ case Help.iParse Parse.header src of
4342 Left msg ->
4443 throwError (show msg)
4544
46− Right (Module.HeaderAndImports names _exports imports) ->
45+ Right (Module.Header names _exports imports) ->
4746 return
4847 ( PublicModule.Name names
49− , map (PublicModule.Name . fst) imports
48+ , map (PublicModule.Name . fst . A.drop) imports
5049 )
5150
5251
@@ -62,13 +61,13 @@ compile
6261compile user packageName source interfaces =
6362 let unwrappedInterfaces =
6463 Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces
64+
65+ task =
66+ Compile.compile user packageName unwrappedInterfaces source
6567 in
66− case Compile.compile user packageName unwrappedInterfaces source of
67− Right modul ->
68+ case Task.run task of
69+ (Right modul, _warnings) ->
6870 Right (Module.toInterface modul, JS.generate modul)
6971
70− Left docs ->
71− map P.render docs
72− |> List.intersperse ""
73− |> unlines
74− |> Left
72+ (Left _docs, _warnings) ->
73+ Left [error "TODO:compile"]
src/Elm/Compiler/Type/Extract.hs+1−1
@@ -8,7 +8,7 @@ import qualified Elm.Compiler.Type as T
88
99-- INTERNAL TYPE to PUBLIC TYPE
1010
11−fromInternalType :: Var.ToString a => Type.Type a -> T.Type
11+fromInternalType :: Type.Canonical -> T.Type
1212fromInternalType astType =
1313 case astType of
1414 Type.Lambda t1 t2 ->
src/Elm/Utils.hs+1−1
@@ -2,7 +2,7 @@
22{-# LANGUAGE FlexibleContexts #-}
33module Elm.Utils ((|>), (<|), getAsset, run, unwrappedRun, CommandError(..)) where
44
5−import Control.Monad.Error (MonadError, MonadIO, liftIO, throwError)
5+import Control.Monad.Except (MonadError, MonadIO, liftIO, throwError)
66import System.Directory (doesFileExist)
77import System.Environment (getEnv)
88import System.Exit (ExitCode(ExitSuccess, ExitFailure))
src/Generate/Cases.hs+170−118
@@ -4,29 +4,19 @@ import Control.Applicative ((<$>))
44import Control.Arrow (first)
55import Control.Monad.State (State)
66import qualified Control.Monad.State as State
7−import Data.List (groupBy,sortBy)
7+import qualified Data.List as List
88import Data.Maybe (fromMaybe)
99
10−import qualified AST.Annotation as A
1110import qualified AST.Expression.General as Expr
1211import qualified AST.Expression.Canonical as Canonical
1312import qualified AST.Literal as Literal
1413import qualified AST.Pattern as P
1514import qualified AST.Variable as Var
15+import qualified Reporting.Annotation as A
1616import Transform.Substitute (subst)
1717
18−toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)
19−toMatch patterns = do
20− v <- newVar
21− (,) v <$> match [v] (map (first (:[])) patterns) Fail
22−
23−
24−newVar :: State Int String
25−newVar =
26− do n <- State.get
27− State.modify (+1)
28− return $ "_v" ++ show n
2918
19+-- MATCHES
3020
3121data Match
3222 = Match String [Clause] Match
@@ -42,47 +32,51 @@ data Clause =
4232 deriving Show
4333
4434
45−type Case =
35+type Branch =
4636 ([P.CanonicalPattern], Canonical.Expr)
4737
4838
39+-- PUBLIC FUNCTIONS
40+
41+toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)
42+toMatch patterns =
43+ do v <- newVar
44+ (,) v <$> buildMatch [v] (map (first (:[])) patterns) Fail
45+
46+
47+newVar :: State Int String
48+newVar =
49+ do n <- State.get
50+ State.modify (+1)
51+ return $ "_v" ++ show n
52+
53+
4954matchSubst :: [(String,String)] -> Match -> Match
5055matchSubst pairs match =
51− case match of
52− Break -> Break
53−
54− Fail -> Fail
55−
56− Seq ms ->
57− Seq (map (matchSubst pairs) ms)
58−
59− Other (A.A a e) ->
60− Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs
61−
62− Match n cs m ->
63− Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
64− where
65− varSubst v = fromMaybe v (lookup v pairs)
66− clauseSubst (Clause c vs m) =
67− Clause c (map varSubst vs) (matchSubst pairs m)
56+ case match of
57+ Break -> Break
6858
59+ Fail -> Fail
6960
70−isCon :: ([P.Pattern var], expr) -> Bool
71−isCon ([] , _) = noMatch "isCon"
72−isCon (p:_, _) =
73− case p of
74− P.Data _ _ -> True
75− P.Literal _ -> True
76− _ -> False
61+ Seq ms ->
62+ Seq (map (matchSubst pairs) ms)
63+
64+ Other (A.A a e) ->
65+ Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs
7766
67+ Match n cs m ->
68+ Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
69+ where
70+ varSubst v = fromMaybe v (lookup v pairs)
71+ clauseSubst (Clause c vs m) =
72+ Clause c (map varSubst vs) (matchSubst pairs m)
7873
79−isVar :: ([P.Pattern var], expr) -> Bool
80−isVar p = not (isCon p)
8174
75+-- BUILD MATCHES
8276
83−match :: [String] -> [Case] -> Match -> State Int Match
84−match variables cases match =
85− case (variables, cases, match) of
77+buildMatch :: [String] -> [Branch] -> Match -> State Int Match
78+buildMatch variables branches match =
79+ case (variables, branches, match) of
8680 ([], [], _) ->
8781 return match
8882
@@ -93,115 +87,173 @@ match variables cases match =
9387 return $ Other expr
9488
9589 ([], _, _) ->
96− return $ Seq (map (Other . snd) cases ++ [match])
90+ return $ Seq (map (Other . snd) branches ++ [match])
9791
9892 (var:_, _, _)
99− | all isVar cases' -> matchVar variables cases' match
100− | all isCon cases' -> matchCon variables cases' match
101− | otherwise -> matchMix variables cases' match
93+ | all isVar branches' -> matchVar variables branches' match
94+ | all isCon branches' -> matchCon variables branches' match
95+ | otherwise -> matchMix variables branches' match
10296 where
103− cases' = map (dealias var) cases
97+ branches' = map (dealias var) branches
10498
10599
106−dealias :: String -> Case -> Case
100+dealias :: String -> Branch -> Branch
107101dealias _ ([], _) = noMatch "dealias"
108−dealias v c@(p:ps, A.A a e) =
102+dealias var branch@(p:ps, A.A ann e) =
109103 case p of
110− P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)
111− _ -> c
104+ A.A _ (P.Alias alias pattern) ->
105+ ( pattern:ps
106+ , A.A ann (subst alias (Expr.localVar var) e)
107+ )
112108
109+ _ ->
110+ branch
111+
112+
113+isCon :: ([P.Pattern ann var], expr) -> Bool
114+isCon ([], _) = noMatch "isCon"
115+isCon (A.A _ pattern : _, _) =
116+ case pattern of
117+ P.Data _ _ -> True
118+ P.Literal _ -> True
119+ _ -> False
113120
114−matchVar :: [String] -> [Case] -> Match -> State Int Match
121+
122+isVar :: ([P.Pattern ann var], expr) -> Bool
123+isVar p =
124+ not (isCon p)
125+
126+
127+-- VARIABLE MATCHES
128+
129+matchVar :: [String] -> [Branch] -> Match -> State Int Match
115130matchVar [] _ _ = noMatch "matchVar"
116−matchVar (v:vs) cs def =
117− match vs (map subVar cs) def
131+matchVar (var:vars) branches match =
132+ buildMatch vars (map subVar branches) match
118133 where
119134 subVar ([], _) = noMatch "matchVar.subVar"
120− subVar (p:ps, (A.A a expr)) =
121− (ps, A.A a $ subOnePattern p expr)
135+ subVar (A.A _ pattern : patterns, (A.A ann expr)) =
136+ ( patterns
137+ , A.A ann (subOnePattern pattern expr)
138+ )
122139 where
123140 subOnePattern pattern expr =
124141 case pattern of
125− P.Anything -> expr
142+ P.Anything ->
143+ expr
126144
127145 P.Var x ->
128− subst x (Expr.localVar v) expr
146+ subst x (Expr.localVar var) expr
129147
130− P.Record fs ->
131− foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) expr fs
148+ P.Record fields ->
149+ let access = Expr.Access (A.A ann (Expr.localVar var))
150+ in
151+ foldr (\x -> subst x (access x)) expr fields
132152
133− _ -> noMatch "matchVar.subVar"
153+ _ ->
154+ noMatch "matchVar.subVar"
134155
135156
136−matchCon :: [String] -> [Case] -> Match -> State Int Match
137−matchCon variables cases match =
157+-- CONSTRUCTOR MATCHES
158+
159+matchCon :: [String] -> [Branch] -> Match -> State Int Match
160+matchCon variables branches match =
138161 case variables of
139162 [] -> noMatch "matchCon"
140163
141164 var : _vars ->
142165 flip (Match var) match <$> mapM toClause caseGroups
143166 where
144− caseGroups :: [[Case]]
167+ caseGroups :: [[Branch]]
145168 caseGroups =
146− groupBy eq (sortBy cmp cases)
147−
148− eq :: Case -> Case -> Bool
149− eq (patterns1, _) (patterns2, _) =
150− case (patterns1, patterns2) of
151− (pattern1:_, pattern2:_) ->
152− case (pattern1, pattern2) of
153− (P.Data name1 _, P.Data name2 _) -> name1 == name2
154− (_, _) -> pattern1 == pattern2
155− (_, _) -> noMatch "matchCon.eq"
156−
157− cmp :: Case -> Case -> Ordering
158− cmp (patterns1, _) (patterns2, _) =
159− case (patterns1, patterns2) of
160− (pattern1:_, pattern2:_) ->
161− case (pattern1, pattern2) of
162− (P.Data name1 _, P.Data name2 _) -> compare name1 name2
163− (_, _) -> compare pattern1 pattern2
164− (_, _) -> noMatch "matchCon.cmp"
165−
166− toClause :: [Case] -> State Int Clause
167− toClause cases =
168− case head cases of
169− (P.Data name _ : _, _) ->
170− matchClause (Left name) variables cases Break
171−
172− (P.Literal lit : _, _) ->
173− matchClause (Right lit) variables cases Break
169+ List.groupBy branchEq (List.sortBy branchCmp branches)
170+
171+ toClause :: [Branch] -> State Int Clause
172+ toClause branches =
173+ case head branches of
174+ (A.A _ (P.Data name _) : _, _) ->
175+ matchClause (Left name) variables branches Break
176+
177+ (A.A _ (P.Literal lit) : _, _) ->
178+ matchClause (Right lit) variables branches Break
174179
175180 _ -> noMatch "matchCon"
176181
177182
178−matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match
179− -> State Int Clause
183+matchClause
184+ :: Either Var.Canonical Literal.Literal
185+ -> [String]
186+ -> [Branch]
187+ -> Match
188+ -> State Int Clause
180189matchClause _ [] _ _ = noMatch "matchClause"
181−matchClause c (_:vs) cs mtch =
182− do vs' <- getVars
183− Clause c vs' <$> match (vs' ++ vs) (map flatten cs) mtch
184− where
185− flatten ([], _) = noMatch "matchClause.flatten"
186− flatten (p:ps, e) =
187− case p of
188− P.Data _ ps' -> (ps' ++ ps, e)
189− P.Literal _ -> (ps, e)
190− _ -> noMatch "matchClause.flatten"
191−
192− getVars :: State Int [String]
193− getVars =
194− case head cs of
195− (P.Data _ ps : _, _) -> State.forM ps (const newVar)
196− (P.Literal _ : _, _) -> return []
197− _ -> noMatch "matchClause.getVars"
198−
199−
200−matchMix :: [String] -> [Case] -> Match -> State Int Match
201−matchMix vs cs def =
202− State.foldM (flip $ match vs) def (reverse css)
190+matchClause c (_:vs) branches match =
191+ do vs' <- getVars
192+ Clause c vs' <$> buildMatch (vs' ++ vs) (map flatten branches) match
193+ where
194+ flatten ([], _) = noMatch "matchClause.flatten"
195+ flatten (A.A _ pattern : patterns, expr) =
196+ case pattern of
197+ P.Data _ argPatterns ->
198+ (argPatterns ++ patterns, expr)
199+
200+ P.Literal _ ->
201+ (patterns, expr)
202+
203+ _ ->
204+ noMatch "matchClause.flatten"
205+
206+ getVars :: State Int [String]
207+ getVars =
208+ case head branches of
209+ (A.A _ (P.Data _ argPatterns) : _, _) ->
210+ State.forM argPatterns (const newVar)
211+
212+ (A.A _ (P.Literal _) : _, _) ->
213+ return []
214+
215+ _ ->
216+ noMatch "matchClause.getVars"
217+
218+
219+branchEq :: Branch -> Branch -> Bool
220+branchEq (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
221+ case (pattern, pattern') of
222+ (P.Data name _, P.Data name' _) ->
223+ name == name'
224+
225+ (P.Literal lit, P.Literal lit') ->
226+ lit == lit'
227+
228+ (_, _) ->
229+ noMatch "matchCon.branchEq"
230+
231+branchEq _ _ = noMatch "matchCon.branchEq"
232+
233+
234+branchCmp :: Branch -> Branch -> Ordering
235+branchCmp (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
236+ case (pattern, pattern') of
237+ (P.Data name _, P.Data name' _) ->
238+ compare name name'
239+
240+ (P.Literal lit, P.Literal lit') ->
241+ compare lit lit'
242+
243+ (_, _) ->
244+ noMatch "matchCon.branchCmp"
245+
246+branchCmp _ _ = noMatch "matchCon.branchCmp"
247+
248+
249+-- MIX MATCHES
250+
251+matchMix :: [String] -> [Branch] -> Match -> State Int Match
252+matchMix vs branches def =
253+ State.foldM (flip $ buildMatch vs) def (reverse branchGroups)
203254 where
204− css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
255+ branchGroups =
256+ List.groupBy (\p1 p2 -> isCon p1 == isCon p2) branches
205257
206258
207259noMatch :: String -> a
src/Generate/JavaScript.hs+81−56
@@ -9,12 +9,6 @@ import qualified Data.Set as Set
99import Language.ECMAScript3.PrettyPrint
1010import Language.ECMAScript3.Syntax
1111
12−import Generate.JavaScript.Helpers as Help
13−import qualified Generate.Cases as Case
14−import qualified Generate.JavaScript.Port as Port
15−import qualified Generate.JavaScript.Variable as Var
16−
17−import AST.Annotation
1812import AST.Module
1913import AST.Expression.General
2014import qualified AST.Expression.Canonical as Canonical
@@ -23,6 +17,13 @@ import AST.Literal
2317import qualified AST.Module as Module
2418import qualified AST.Pattern as P
2519import qualified AST.Variable as Var
20+import Elm.Utils ((|>))
21+import Generate.JavaScript.Helpers as Help
22+import qualified Generate.Cases as Case
23+import qualified Generate.JavaScript.Port as Port
24+import qualified Generate.JavaScript.Variable as Var
25+import qualified Reporting.Annotation as A
26+import qualified Reporting.Region as R
2627
2728
2829internalImports :: Module.Name -> [VarDecl ()]
@@ -59,7 +60,7 @@ literal lit =
5960
6061
6162expression :: Canonical.Expr -> State Int (Expression ())
62−expression (A region expr) =
63+expression (A.A region expr) =
6364 case expr of
6465 Var var ->
6566 return $ Var.canonical var
@@ -117,7 +118,7 @@ expression (A region expr) =
117118 Binop op e1 e2 ->
118119 binop region op e1 e2
119120
120− Lambda p e@(A ann _) ->
121+ Lambda pattern rawBody@(A.A ann _) ->
121122 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
122123 body' <- expression body
123124 return $
@@ -127,17 +128,20 @@ expression (A region expr) =
127128 where
128129 depattern (args, body) pattern =
129130 case pattern of
130− P.Var x ->
131+ A.A _ (P.Var x) ->
131132 return (args ++ [ Var.varName x ], body)
133+
132134 _ ->
133135 do arg <- Case.newVar
134− return ( args ++ [arg]
135− , A ann (Case (A ann (localVar arg)) [(pattern, body)])
136− )
136+ return
137+ ( args ++ [arg]
138+ , A.A ann (Case (A.A ann (localVar arg)) [(pattern, body)])
139+ )
137140
138− (patterns, innerBody) = collect [p] e
141+ (patterns, innerBody) =
142+ collect [pattern] rawBody
139143
140− collect patterns lexpr@(A _ expr) =
144+ collect patterns lexpr@(A.A _ expr) =
141145 case expr of
142146 Lambda p e -> collect (p:patterns) e
143147 _ -> (patterns, lexpr)
@@ -155,7 +159,7 @@ expression (A region expr) =
155159 (func, args) = getArgs e1 [e2]
156160 getArgs func args =
157161 case func of
158− (A _ (App f arg)) -> getArgs f (arg : args)
162+ (A.A _ (App f arg)) -> getArgs f (arg : args)
159163 _ -> (func, args)
160164
161165 Let defs e ->
@@ -168,9 +172,9 @@ expression (A region expr) =
168172 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
169173 return $
170174 case last branches of
171− (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
175+ (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
172176 safeIfs branches'
173− (A _ (Literal (Boolean True)), _) ->
177+ (A.A _ (Literal (Boolean True)), _) ->
174178 safeIfs branches'
175179 _ ->
176180 ifs branches' (throw "badIf" region)
@@ -183,7 +187,7 @@ expression (A region expr) =
183187 do (tempVar,initialMatch) <- Case.toMatch cases
184188 (revisedMatch, stmt) <-
185189 case e of
186− A _ (Var (Var.Canonical Var.Local x)) ->
190+ A.A _ (Var (Var.Canonical Var.Local x)) ->
187191 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
188192 _ ->
189193 do e' <- expression e
@@ -221,9 +225,10 @@ expression (A region expr) =
221225
222226
223227definition :: Canonical.Def -> State Int [Statement ()]
224−definition (Canonical.Definition pattern expr@(A region _) _) =
228+definition (Canonical.Definition annPattern expr@(A.A region _) _) =
225229 do expr' <- expression expr
226230 let assign x = varDecl x expr'
231+ let (A.A patternRegion pattern) = annPattern
227232 case pattern of
228233 P.Var x
229234 | Help.isOp x ->
@@ -243,9 +248,12 @@ definition (Canonical.Definition pattern expr@(A region _) _) =
243248 vars = getVars patterns
244249 getVars patterns =
245250 case patterns of
246− P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
247− [] -> Just []
248− _ -> Nothing
251+ A.A _ (P.Var x) : rest ->
252+ (Var.varName x :) `fmap` getVars rest
253+ [] ->
254+ Just []
255+ _ ->
256+ Nothing
249257
250258 decl x n = varDecl x (obj ["$","_" ++ show n])
251259 setup vars
@@ -260,15 +268,16 @@ definition (Canonical.Definition pattern expr@(A region _) _) =
260268 do defs' <- concat <$> mapM toDef vars
261269 return (VarDeclStmt () [assign "_"] : defs')
262270 where
263− vars = P.boundVarList pattern
264− mkVar = A region . localVar
271+ vars = P.boundVarList annPattern
272+ mkVar = A.A region . localVar
265273 toDef y =
266− let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
274+ let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]
275+ pat = A.A patternRegion (P.Var y)
267276 in
268− definition $ Canonical.Definition (P.Var y) expr Nothing
277+ definition (Canonical.Definition pat expr Nothing)
269278
270279
271−match :: Region -> Case.Match -> State Int [Statement ()]
280+match :: R.Region -> Case.Match -> State Int [Statement ()]
272281match region mtch =
273282 case mtch of
274283 Case.Match name clauses mtch' ->
@@ -309,7 +318,7 @@ match region mtch =
309318 _ -> dropEnd (acc ++ [m]) ms
310319
311320
312−clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
321+clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
313322clause region variable (Case.Clause value vars mtch) =
314323 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
315324 where
@@ -329,7 +338,7 @@ clause region variable (Case.Clause value vars mtch) =
329338
330339
331340flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
332−flattenLets defs lexpr@(A _ expr) =
341+flattenLets defs lexpr@(A.A _ expr) =
333342 case expr of
334343 Let ds body -> flattenLets (defs ++ ds) body
335344 _ -> (defs, lexpr)
@@ -359,13 +368,17 @@ generate modul =
359368 ]
360369
361370 localVars :: [VarDecl ()]
362− localVars = varDecl "_op" (ObjectLit () []) :
363− internalImports (Module.names modul) ++
364− explicitImports
371+ localVars =
372+ varDecl "_op" (ObjectLit () [])
373+ : internalImports (Module.names modul)
374+ ++ explicitImports
365375 where
366376 explicitImports :: [VarDecl ()]
367377 explicitImports =
368− map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
378+ Module.imports modul
379+ |> Set.fromList
380+ |> Set.toList
381+ |> map jsImport
369382
370383 jsImport :: Module.Name -> VarDecl ()
371384 jsImport name =
@@ -373,29 +386,41 @@ generate modul =
373386 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
374387
375388 body :: [Statement ()]
376− body = concat $ evalState defs 0
389+ body =
390+ concat (evalState defs 0)
377391 where
378− defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
379−
380− setup namespace path = map create paths
392+ defs =
393+ Module.program (Module.body modul)
394+ |> flattenLets []
395+ |> fst
396+ |> mapM definition
397+
398+ setup namespace path =
399+ map create paths
381400 where
382− create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
383− paths = drop 2 . init . List.inits $ namespace : path
384−
385− jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
386− where
387− exs = map entry $ "_op" : concatMap extract (exports modul)
388− entry x = (prop x, ref x)
389− extract value =
390− case value of
391− Var.Alias _ -> []
401+ create name =
402+ assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
403+ paths =
404+ namespace : path
405+ |> List.inits
406+ |> init
407+ |> drop 2
408+
409+ jsExports =
410+ assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
411+ where
412+ exs = map entry $ "_op" : concatMap extract (exports modul)
413+ entry x = (prop x, ref x)
414+ extract value =
415+ case value of
416+ Var.Alias _ -> []
392417
393− Var.Value x
394− | Help.isOp x -> []
395− | otherwise -> [Var.varName x]
418+ Var.Value x
419+ | Help.isOp x -> []
420+ | otherwise -> [Var.varName x]
396421
397− Var.Union _ (Var.Listing ctors _) ->
398− map Var.varName ctors
422+ Var.Union _ (Var.Listing ctors _) ->
423+ map Var.varName ctors
399424
400425 assign path expr =
401426 case path of
@@ -406,7 +431,7 @@ generate modul =
406431
407432
408433binop
409− :: Region
434+ :: R.Region
410435 -> Var.Canonical
411436 -> Canonical.Expr
412437 -> Canonical.Expr
@@ -427,7 +452,7 @@ binop region func@(Var.Canonical home op) e1 e2 =
427452 return $ foldr (<|) e2' es
428453
429454 (Var.BuiltIn, "::") ->
430− expression (A region (Data "::" [e1,e2]))
455+ expression (A.A region (Data "::" [e1,e2]))
431456
432457 (Var.Module ["Basics"], _) ->
433458 do e1' <- expression e1
@@ -447,13 +472,13 @@ binop region func@(Var.Canonical home op) e1 e2 =
447472 where
448473 collectRightAssoc es e =
449474 case e of
450− A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
475+ A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
451476 collectRightAssoc (es ++ [e1]) e2
452477 _ -> es ++ [e]
453478
454479 collectLeftAssoc es e =
455480 case e of
456− A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
481+ A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
457482 collectLeftAssoc (e2 : es) e1
458483 _ -> e : es
459484
src/Generate/JavaScript/Helpers.hs+4−4
@@ -1,9 +1,9 @@
11module Generate.JavaScript.Helpers where
22
3−import AST.Annotation (Region)
4−import qualified AST.PrettyPrint as PP
53import Language.ECMAScript3.Syntax
64
5+import qualified Reporting.Region as R
6+
77
88localRuntime :: String
99localRuntime =
@@ -59,11 +59,11 @@ localModuleName =
5959 "$moduleName"
6060
6161
62−throw :: String -> Region -> Expression ()
62+throw :: String -> R.Region -> Expression ()
6363throw kind region =
6464 let args =
6565 [ ref localModuleName
66− , string (PP.renderPretty region)
66+ , string (R.toString region)
6767 ]
6868 in
6969 obj ["_U",kind] `call` args
src/Generate/JavaScript/Port.hs+34−34
@@ -3,15 +3,15 @@ module Generate.JavaScript.Port (inbound, outbound, task) where
33import qualified Data.List as List
44import Language.ECMAScript3.Syntax
55
6−import AST.PrettyPrint (pretty)
7−import AST.Type as T
6+import qualified AST.Type as T
87import qualified AST.Variable as Var
98import Generate.JavaScript.Helpers
9+import qualified Reporting.PrettyPrint as P
1010
1111
1212-- TASK
1313
14−task :: String -> Expression () -> T.PortType var -> Expression ()
14+task :: String -> Expression () -> T.Port t -> Expression ()
1515task name expr portType =
1616 case portType of
1717 T.Normal _ ->
@@ -90,42 +90,42 @@ check x jsType continue =
9090
9191-- INBOUND
9292
93−inbound :: String -> T.PortType Var.Canonical -> Expression ()
93+inbound :: String -> T.Port T.Canonical -> Expression ()
9494inbound name portType =
9595 case portType of
9696 T.Normal tipe ->
9797 _Port "inbound" `call`
9898 [ string name
99− , string (show (pretty tipe))
99+ , string (show (P.pretty False tipe))
100100 , toTypeFunction tipe
101101 ]
102102
103103 T.Signal _root arg ->
104104 _Port "inboundSignal" `call`
105105 [ string name
106− , string (show (pretty arg))
106+ , string (show (P.pretty False arg))
107107 , toTypeFunction arg
108108 ]
109109
110110
111−toTypeFunction :: CanonicalType -> Expression ()
111+toTypeFunction :: T.Canonical -> Expression ()
112112toTypeFunction tipe =
113113 ["v"] ==> toType tipe (ref "v")
114114
115115
116−toType :: CanonicalType -> Expression () -> Expression ()
116+toType :: T.Canonical -> Expression () -> Expression ()
117117toType tipe x =
118118 case tipe of
119− Lambda _ _ ->
119+ T.Lambda _ _ ->
120120 error "functions should not be allowed through input ports"
121121
122− Var _ ->
122+ T.Var _ ->
123123 error "type variables should not be allowed through input ports"
124124
125− Aliased _ args t ->
126− toType (dealias args t) x
125+ T.Aliased _ args t ->
126+ toType (T.dealias args t) x
127127
128− Type (Var.Canonical Var.BuiltIn name)
128+ T.Type (Var.Canonical Var.BuiltIn name)
129129 | name == "Int" -> from JSNumber
130130 | name == "Float" -> from JSNumber
131131 | name == "Bool" -> from JSBoolean
@@ -133,7 +133,7 @@ toType tipe x =
133133 where
134134 from checks = check x checks x
135135
136− Type name
136+ T.Type name
137137 | Var.isJson name ->
138138 x
139139
@@ -143,9 +143,9 @@ toType tipe x =
143143 | otherwise ->
144144 error "bad type got to foreign input conversion"
145145
146− App f args ->
146+ T.App f args ->
147147 case f : args of
148− Type name : [t]
148+ T.Type name : [t]
149149 | Var.isMaybe name ->
150150 CondExpr ()
151151 (equal x (NullLit ()))
@@ -160,16 +160,16 @@ toType tipe x =
160160 where
161161 array = DotRef () x (var "map") <| toTypeFunction t
162162
163− Type name : ts
163+ T.Type name : ts
164164 | Var.isTuple name ->
165165 toTuple ts x
166166
167167 _ -> error "bad ADT got to foreign input conversion"
168168
169− Record _ (Just _) ->
169+ T.Record _ (Just _) ->
170170 error "bad record got to foreign input conversion"
171171
172− Record fields Nothing ->
172+ T.Record fields Nothing ->
173173 check x (JSObject (map fst fields)) object
174174 where
175175 object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
@@ -177,7 +177,7 @@ toType tipe x =
177177 convert (f,t) = (prop f, toType t (DotRef () x (var f)))
178178
179179
180−toTuple :: [CanonicalType] -> Expression () -> Expression ()
180+toTuple :: [T.Canonical] -> Expression () -> Expression ()
181181toTuple types x =
182182 check x JSArray (ObjectLit () fields)
183183 where
@@ -195,7 +195,7 @@ toTuple types x =
195195
196196-- OUTBOUND
197197
198−outbound :: String -> Expression () -> T.PortType Var.Canonical -> Expression ()
198+outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()
199199outbound name expr portType =
200200 case portType of
201201 T.Normal tipe ->
@@ -205,18 +205,18 @@ outbound name expr portType =
205205 _Port "outboundSignal" `call` [ string name, fromTypeFunction arg, expr ]
206206
207207
208−fromTypeFunction :: CanonicalType -> Expression ()
208+fromTypeFunction :: T.Canonical -> Expression ()
209209fromTypeFunction tipe =
210210 ["v"] ==> fromType tipe (ref "v")
211211
212212
213−fromType :: CanonicalType -> Expression () -> Expression ()
213+fromType :: T.Canonical -> Expression () -> Expression ()
214214fromType tipe x =
215215 case tipe of
216− Aliased _ args t ->
217− fromType (dealias args t) x
216+ T.Aliased _ args t ->
217+ fromType (T.dealias args t) x
218218
219− Lambda _ _
219+ T.Lambda _ _
220220 | numArgs > 1 && numArgs < 10 ->
221221 func (ref ('A':show numArgs) `call` (x:values))
222222 | otherwise ->
@@ -232,21 +232,21 @@ fromType tipe x =
232232 , ret (fromType (last ts) (ref "_r"))
233233 ]
234234
235− Var _ ->
235+ T.Var _ ->
236236 error "type variables should not be allowed through outputs"
237237
238− Type (Var.Canonical Var.BuiltIn name)
238+ T.Type (Var.Canonical Var.BuiltIn name)
239239 | name `elem` ["Int","Float","Bool","String"] ->
240240 x
241241
242− Type name
242+ T.Type name
243243 | Var.isJson name -> x
244244 | Var.isTuple name -> ArrayLit () []
245245 | otherwise -> error "bad type got to an output"
246246
247− App f args ->
247+ T.App f args ->
248248 case f : args of
249− Type name : [t]
249+ T.Type name : [t]
250250 | Var.isMaybe name ->
251251 CondExpr ()
252252 (equal (DotRef () x (var "ctor")) (string "Nothing"))
@@ -259,17 +259,17 @@ fromType tipe x =
259259 | Var.isList name ->
260260 DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
261261
262− Type name : ts
262+ T.Type name : ts
263263 | Var.isTuple name ->
264264 let convert n t = fromType t $ DotRef () x $ var ('_':show n)
265265 in ArrayLit () $ zipWith convert [0..] ts
266266
267267 _ -> error "bad ADT got to an output"
268268
269− Record _ (Just _) ->
269+ T.Record _ (Just _) ->
270270 error "bad record got to an output"
271271
272− Record fields Nothing ->
272+ T.Record fields Nothing ->
273273 ObjectLit () keys
274274 where
275275 keys = map convert fields
src/Parse/Binop.hs+102−55
@@ -5,81 +5,128 @@ import qualified Data.List as List
55import qualified Data.Map as Map
66import Text.Parsec ((<|>), choice, getState, try)
77
8−import AST.Annotation (merge)
98import AST.Declaration (Assoc(L, N, R))
109import AST.Expression.General (Expr'(Binop))
1110import qualified AST.Expression.Source as Source
1211import qualified AST.Variable as Var
1312import Parse.Helpers (IParser, OpTable, commitIf, failure, whitespace)
13+import qualified Reporting.Annotation as A
14+
1415
1516opLevel :: OpTable -> String -> Int
16−opLevel table op = fst $ Map.findWithDefault (9,L) op table
17+opLevel table op =
18+ fst $ Map.findWithDefault (9,L) op table
19+
1720
1821opAssoc :: OpTable -> String -> Assoc
19−opAssoc table op = snd $ Map.findWithDefault (9,L) op table
22+opAssoc table op =
23+ snd $ Map.findWithDefault (9,L) op table
24+
2025
2126hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool
22−hasLevel table n (op,_) = opLevel table op == n
27+hasLevel table n (op,_) =
28+ opLevel table op == n
29+
2330
24−binops :: IParser Source.Expr
25− -> IParser Source.Expr
26− -> IParser String
27− -> IParser Source.Expr
31+binops
32+ :: IParser Source.Expr
33+ -> IParser Source.Expr
34+ -> IParser String
35+ -> IParser Source.Expr
2836binops term last anyOp =
29− do e <- term
30− table <- getState
31− split table 0 e =<< nextOps
32− where
33− nextOps = choice [ commitIf (whitespace >> anyOp) $ do
34− whitespace ; op <- anyOp ; whitespace
35− expr <- Left <$> try term <|> Right <$> last
36− case expr of
37− Left t -> (:) (op,t) <$> nextOps
38− Right e -> return [(op,e)]
39− , return [] ]
40−
41−split :: OpTable
42− -> Int
43− -> Source.Expr
44− -> [(String, Source.Expr)]
45− -> IParser Source.Expr
46−split _ _ e [] = return e
47−split table n e eops = do
48− assoc <- getAssoc table n eops
49− es <- sequence (splitLevel table n e eops)
50− let ops = map fst (filter (hasLevel table n) eops)
51− case assoc of R -> joinR es ops
52− _ -> joinL es ops
53−
54−splitLevel :: OpTable -> Int -> Source.Expr -> [(String, Source.Expr)]
55− -> [IParser Source.Expr]
37+ do e <- term
38+ table <- getState
39+ split table 0 e =<< nextOps
40+ where
41+ nextOps =
42+ choice
43+ [ commitIf (whitespace >> anyOp) $
44+ do whitespace
45+ op <- anyOp
46+ whitespace
47+ expr <- Left <$> try term <|> Right <$> last
48+ case expr of
49+ Left t -> (:) (op,t) <$> nextOps
50+ Right e -> return [(op,e)]
51+ , return []
52+ ]
53+
54+
55+split
56+ :: OpTable
57+ -> Int
58+ -> Source.Expr
59+ -> [(String, Source.Expr)]
60+ -> IParser Source.Expr
61+split _ _ e [] = return e
62+split table n e eops =
63+ do assoc <- getAssoc table n eops
64+ es <- sequence (splitLevel table n e eops)
65+ let ops = map fst (filter (hasLevel table n) eops)
66+ case assoc of
67+ R -> joinR es ops
68+ _ -> joinL es ops
69+
70+
71+splitLevel
72+ :: OpTable
73+ -> Int
74+ -> Source.Expr
75+ -> [(String, Source.Expr)]
76+ -> [IParser Source.Expr]
5677splitLevel table n e eops =
57− case break (hasLevel table n) eops of
58− (lops, (_op,e'):rops) ->
59− split table (n+1) e lops : splitLevel table n e' rops
60− (lops, []) -> [ split table (n+1) e lops ]
78+ case break (hasLevel table n) eops of
79+ (lops, (_op,e'):rops) ->
80+ split table (n+1) e lops : splitLevel table n e' rops
81+
82+ (lops, []) ->
83+ [ split table (n+1) e lops ]
84+
6185
6286joinL :: [Source.Expr] -> [String] -> IParser Source.Expr
63−joinL [e] [] = return e
64−joinL (a:b:es) (op:ops) = joinL (merge a b (Binop (Var.Raw op) a b) : es) ops
65−joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
87+joinL exprs ops =
88+ case (exprs, ops) of
89+ ([expr], []) ->
90+ return expr
91+
92+ (a:b:remainingExprs, op:remainingOps) ->
93+ let binop = A.merge a b (Binop (Var.Raw op) a b)
94+ in
95+ joinL (binop : remainingExprs) remainingOps
96+
97+ (_, _) ->
98+ failure "Ill-formed binary expression. Report a compiler bug."
99+
66100
67101joinR :: [Source.Expr] -> [String] -> IParser Source.Expr
68−joinR [e] [] = return e
69−joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
70− return (merge a e (Binop (Var.Raw op) a e))
71−joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
102+joinR exprs ops =
103+ case (exprs, ops) of
104+ ([expr], []) ->
105+ return expr
106+
107+ (a:b:remainingExprs, op:remainingOps) ->
108+ do e <- joinR (b:remainingExprs) remainingOps
109+ return (A.merge a e (Binop (Var.Raw op) a e))
110+
111+ (_, _) ->
112+ failure "Ill-formed binary expression. Report a compiler bug."
113+
72114
73115getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc
74116getAssoc table n eops
75117 | all (==L) assocs = return L
76− | all (==R) assocs = return R
77− | all (==N) assocs = case assocs of [_] -> return N
78− _ -> failure (msg "precedence")
118+ | all (==R) assocs = return R
119+ | all (==N) assocs =
120+ case assocs of
121+ [_] -> return N
122+ _ -> failure (msg "precedence")
79123 | otherwise = failure (msg "associativity")
80− where levelOps = filter (hasLevel table n) eops
81− assocs = map (opAssoc table . fst) levelOps
82− msg problem =
83− concat [ "Conflicting " ++ problem ++ " for binary operators ("
84− , List.intercalate ", " (map fst eops), "). "
85− , "Consider adding parentheses to disambiguate." ]
124+ where
125+ levelOps = filter (hasLevel table n) eops
126+ assocs = map (opAssoc table . fst) levelOps
127+ msg problem =
128+ concat
129+ [ "Conflicting " ++ problem ++ " for binary operators ("
130+ , List.intercalate ", " (map fst eops), "). "
131+ , "Consider adding parentheses to disambiguate."
132+ ]
src/Parse/Declaration.hs+5−5
@@ -12,19 +12,19 @@ import qualified Parse.Type as Type
1212
1313declaration :: IParser D.SourceDecl
1414declaration =
15− typeDecl <|> infixDecl <|> port <|> definition
15+ addLocation (typeDecl <|> infixDecl <|> port <|> definition)
1616
1717
1818-- TYPE ANNOTATIONS and DEFINITIONS
1919
20−definition :: IParser D.SourceDecl
20+definition :: IParser D.SourceDecl'
2121definition =
2222 D.Definition <$> (Expr.typeAnnotation <|> Expr.definition)
2323
2424
2525-- TYPE ALIAS and UNION TYPES
2626
27−typeDecl :: IParser D.SourceDecl
27+typeDecl :: IParser D.SourceDecl'
2828typeDecl =
2929 do try (reserved "type") <?> "type declaration"
3030 forcedWS
@@ -46,7 +46,7 @@ typeDecl =
4646
4747-- INFIX
4848
49−infixDecl :: IParser D.SourceDecl
49+infixDecl :: IParser D.SourceDecl'
5050infixDecl =
5151 do assoc <-
5252 choice
@@ -62,7 +62,7 @@ infixDecl =
6262
6363-- PORT
6464
65−port :: IParser D.SourceDecl
65+port :: IParser D.SourceDecl'
6666port =
6767 do try (reserved "port")
6868 whitespace
src/Parse/Expression.hs+115−68
@@ -12,12 +12,12 @@ import qualified Parse.Literal as Literal
1212import qualified Parse.Pattern as Pattern
1313import qualified Parse.Type as Type
1414
15−import qualified AST.Annotation as Annotation
1615import qualified AST.Expression.General as E
1716import qualified AST.Expression.Source as Source
1817import qualified AST.Literal as L
1918import qualified AST.Pattern as P
2019import qualified AST.Variable as Var
20+import qualified Reporting.Annotation as A
2121
2222
2323-------- Basic Terms --------
@@ -30,24 +30,42 @@ varTerm =
3030toVar :: String -> Source.Expr'
3131toVar v =
3232 case v of
33− "True" -> E.Literal (L.Boolean True)
34− "False" -> E.Literal (L.Boolean False)
35− _ -> E.rawVar v
33+ "True" ->
34+ E.Literal (L.Boolean True)
35+
36+ "False" ->
37+ E.Literal (L.Boolean False)
38+
39+ _ ->
40+ E.rawVar v
3641
3742
3843accessor :: IParser Source.Expr'
3944accessor =
4045 do (start, lbl, end) <- located (try (string "." >> rLabel))
41− let loc e = Annotation.at start end e
42− return (E.Lambda (P.Var "_") (loc $ E.Access (loc $ E.rawVar "_") lbl))
46+
47+ let ann value =
48+ A.at start end value
49+
50+ return $
51+ E.Lambda
52+ (ann (P.Var "_"))
53+ (ann (E.Access (ann (E.rawVar "_")) lbl))
4354
4455
4556negative :: IParser Source.Expr'
4657negative =
4758 do (start, nTerm, end) <-
4859 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
49− let loc e = Annotation.at start end e
50− return (E.Binop (Var.Raw "-") (loc $ E.Literal (L.IntNum 0)) nTerm)
60+
61+ let ann e =
62+ A.at start end e
63+
64+ return $
65+ E.Binop
66+ (Var.Raw "-")
67+ (ann (E.Literal (L.IntNum 0)))
68+ nTerm
5169
5270
5371-------- Complex Terms --------
@@ -56,45 +74,65 @@ listTerm :: IParser Source.Expr'
5674listTerm =
5775 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
5876 where
59− range = do
60− lo <- expr
61− padded (string "..")
62− E.Range lo <$> expr
77+ range =
78+ do lo <- expr
79+ padded (string "..")
80+ E.Range lo <$> expr
6381
64− shader' = do
65− pos <- getPosition
66− let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
67− (rawSrc, tipe) <- Help.shader
68− return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
82+ shader' =
83+ do pos <- getPosition
84+ let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
85+ (rawSrc, tipe) <- Help.shader
86+ return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
6987
7088
7189parensTerm :: IParser Source.Expr
7290parensTerm =
73− try (parens opFn) <|> parens (tupleFn <|> parened)
91+ choice
92+ [ try (parens opFn)
93+ , parens (tupleFn <|> parened)
94+ ]
7495 where
75− opFn = do
76− (start, op, end) <- located anyOp
77− let loc = Annotation.at start end
78− return . loc . E.Lambda (P.Var "x") . loc . E.Lambda (P.Var "y") . loc $
79− E.Binop (Var.Raw op) (loc (E.rawVar "x")) (loc (E.rawVar "y"))
80−
81− tupleFn = do
82− let comma = char ',' <?> "comma ','"
83− (start, commas, end) <- located (comma >> many (whitespace >> comma))
84− let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
85− loc = Annotation.at start end
86− return $ foldr (\x e -> loc $ E.Lambda x e)
87− (loc . E.tuple $ map (loc . E.rawVar) vars) (map P.Var vars)
88−
89− parened = do
90− (start, es, end) <- located (commaSep expr)
91− return $ case es of
92− [e] -> e
93− _ -> Annotation.at start end (E.tuple es)
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+
102+ opFn =
103+ do (start, op, end) <- located anyOp
104+ return $
105+ lambda start end "x" $
106+ lambda start end "y" $
107+ A.at start end $
108+ E.Binop (Var.Raw op) (var start end "x") (var start end "y")
109+
110+ tupleFn =
111+ do (start, commas, end) <-
112+ located (comma >> many (whitespace >> comma))
113+
114+ let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
115+
116+ return $
117+ foldr
118+ (lambda start end)
119+ (A.at start end (E.tuple (map (var start end) vars)))
120+ vars
121+
122+ parened =
123+ do (start, expressions, end) <- located (commaSep expr)
124+ return $
125+ case expressions of
126+ [expression] ->
127+ expression
128+ _ ->
129+ A.at start end (E.tuple expressions)
130+
94131
95132recordTerm :: IParser Source.Expr
96133recordTerm =
97− brackets $ choice [ misc, addLocation record ]
134+ addLocation $
135+ brackets $ choice [ misc, record ]
98136 where
99137 field =
100138 do label <- rLabel
@@ -112,23 +150,29 @@ recordTerm =
112150 (,) lbl <$> expr
113151
114152 remove r =
115− addLocation (string "-" >> whitespace >> E.Remove r <$> rLabel)
153+ do string "-"
154+ whitespace
155+ E.Remove r <$> rLabel
116156
117157 insert r =
118− addLocation $
119− do string "|" >> whitespace
120− E.Insert r <$> rLabel <*> (padded equals >> expr)
158+ do string "|"
159+ whitespace
160+ E.Insert r <$> rLabel <*> (padded equals >> expr)
121161
122162 modify r =
123− addLocation (string "|" >> whitespace >> E.Modify r <$> commaSep1 change)
163+ do string "|"
164+ whitespace
165+ E.Modify r <$> commaSep1 change
124166
125167 misc =
126168 try $ do
127169 record <- addLocation (E.rawVar <$> rLabel)
128− opt <- padded (optionMaybe (remove record))
170+ opt <- padded (optionMaybe (addLocation (remove record)))
129171 case opt of
130− Just e -> try (insert e) <|> return e
131− Nothing -> try (insert record) <|> try (modify record)
172+ Just e@(A.A _ e') ->
173+ try (insert e) <|> return e'
174+ Nothing ->
175+ try (insert record) <|> try (modify record)
132176
133177
134178term :: IParser Source.Expr
@@ -148,7 +192,7 @@ appExpr =
148192 return $
149193 case ts of
150194 [] -> 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
152196
153197
154198-------- Normal Expressions --------
@@ -185,7 +229,7 @@ ifExpr =
185229 elseBranch <- expr
186230 return $ E.MultiIf
187231 [ (bool, thenBranch)
188− , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
232+ , (A.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
189233 ]
190234
191235 multiIf =
@@ -246,7 +290,7 @@ letExpr =
246290
247291typeAnnotation :: IParser Source.Def
248292typeAnnotation =
249− Source.TypeAnnotation <$> try start <*> Type.expr
293+ addLocation (Source.TypeAnnotation <$> try start <*> Type.expr)
250294 where
251295 start =
252296 do v <- lowVar <|> parens symOp
@@ -258,6 +302,7 @@ typeAnnotation =
258302
259303definition :: IParser Source.Def
260304definition =
305+ addLocation $
261306 withPos $
262307 do (name:args) <- defStart
263308 padded equals
@@ -266,29 +311,31 @@ definition =
266311
267312
268313makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
269−makeFunction args body@(Annotation.A ann _) =
270− foldr (\arg body' -> Annotation.A ann $ E.Lambda arg body') body args
314+makeFunction args body@(A.A ann _) =
315+ foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args
271316
272317
273318defStart :: IParser [P.RawPattern]
274319defStart =
275320 choice
276− [ do p1 <- try Pattern.term
277− infics p1 <|> func p1
278− , func =<< (P.Var <$> parens symOp)
321+ [ do pattern <- try Pattern.term
322+ infics pattern <|> func pattern
323+ , do opPattern <- addLocation (P.Var <$> parens symOp)
324+ func opPattern
279325 ]
280326 <?> "the definition of a variable (x = ...)"
281− where
282− func pattern =
283− case pattern of
284− P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
285− _ -> do try (lookAhead (whitespace >> string "="))
286− return [pattern]
287−
288− infics p1 =
289− do o:p <- try (whitespace >> anyOp)
290− p2 <- (whitespace >> Pattern.term)
291− return $
292− if o == '`'
293− then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
294− else [ P.Var (o:p), p1, p2 ]
327+ where
328+ func pattern =
329+ case pattern of
330+ A.A _ (P.Var _) ->
331+ (pattern:) <$> spacePrefix Pattern.term
332+
333+ _ ->
334+ return [pattern]
335+
336+ infics p1 =
337+ do (start, o:p, end) <- try (whitespace >> located anyOp)
338+ p2 <- (whitespace >> Pattern.term)
339+ let opName =
340+ if o == '`' then takeWhile (/='`') p else o:p
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)
88import qualified Data.Map as Map
99import qualified Language.GLSL.Parser as GLP
1010import qualified Language.GLSL.Syntax as GLS
11−import Text.Parsec hiding (newline,spaces,State)
11+import Text.Parsec hiding (newline, spaces, State)
1212import Text.Parsec.Indent (indented, runIndent)
1313import qualified Text.Parsec.Token as T
1414
15−import qualified AST.Annotation as Annotation
1615import qualified AST.Declaration as Decl
1716import qualified AST.Expression.General as E
1817import qualified AST.Expression.Source as Source
1918import qualified AST.Helpers as Help
2019import qualified AST.Literal as L
21−import qualified AST.PrettyPrint as P
2220import qualified AST.Variable as Variable
2321import Elm.Utils ((|>))
22+import qualified Reporting.Annotation as A
23+import qualified Reporting.Region as R
2424
2525
2626reserveds :: [String]
@@ -148,9 +148,14 @@ spaceySepBy1 sep p =
148148 (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))
149149
150150
151+comma :: IParser Char
152+comma =
153+ char ',' <?> "comma ','"
154+
155+
151156commaSep1 :: IParser a -> IParser [a]
152157commaSep1 =
153− spaceySepBy1 (char ',' <?> "comma ','")
158+ spaceySepBy1 comma
154159
155160
156161commaSep :: IParser a -> IParser [a]
@@ -238,25 +243,30 @@ brackets =
238243
239244-- HELPERS FOR EXPRESSIONS
240245
241−addLocation :: (P.Pretty a) => IParser a -> IParser (Annotation.Located a)
246+getMyPosition :: IParser R.Position
247+getMyPosition =
248+ R.fromSourcePos <$> getPosition
249+
250+
251+addLocation :: IParser a -> IParser (A.Located a)
242252addLocation expr =
243253 do (start, e, end) <- located expr
244− return (Annotation.at start end e)
254+ return (A.at start end e)
245255
246256
247−located :: IParser a -> IParser (SourcePos, a, SourcePos)
248−located p =
249− do start <- getPosition
250− e <- p
251− end <- getPosition
252− return (start, e, end)
257+located :: IParser a -> IParser (R.Position, a, R.Position)
258+located parser =
259+ do start <- getMyPosition
260+ value <- parser
261+ end <- getMyPosition
262+ return (start, value, end)
253263
254264
255265accessible :: IParser Source.Expr -> IParser Source.Expr
256266accessible exprParser =
257− do start <- getPosition
267+ do start <- getMyPosition
258268
259− annotatedRootExpr@(Annotation.A _ rootExpr) <- exprParser
269+ annotatedRootExpr@(A.A _ rootExpr) <- exprParser
260270
261271 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
262272
@@ -267,8 +277,8 @@ accessible exprParser =
267277 Just _ ->
268278 accessible $
269279 do v <- var <?> "field access (e.g. List.map)"
270− end <- getPosition
271− return . Annotation.at start end $
280+ end <- getMyPosition
281+ return . A.at start end $
272282 case rootExpr of
273283 E.Var (Variable.Raw name@(c:_))
274284 | isUpper c ->
@@ -427,12 +437,10 @@ withSource p =
427437
428438anyUntilPos :: SourcePos -> IParser String
429439anyUntilPos pos =
430− go
431− where
432− go = do currentPos <- getPosition
433− case currentPos == pos of
434− True -> return []
435− False -> (:) <$> anyChar <*> go
440+ do currentPos <- getPosition
441+ if currentPos == pos
442+ then return []
443+ else (:) <$> anyChar <*> anyUntilPos pos
436444
437445
438446-- 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
22
33import Control.Applicative ((<$>), (<*>))
44import Text.Parsec hiding (newline, spaces)
@@ -16,21 +16,21 @@ getModuleName source =
1616 where
1717 getModuleName =
1818 do optional freshLine
19− (names, _) <- header
19+ (names, _) <- moduleDecl
2020 return (Module.nameToString names)
2121
2222
23−headerAndImports :: IParser Module.HeaderAndImports
24−headerAndImports =
23+header :: IParser (Module.Header [Module.UserImport])
24+header =
2525 do optional freshLine
2626 (names, exports) <-
27− option (["Main"], Var.openListing) (header `followedBy` freshLine)
27+ option (["Main"], Var.openListing) (moduleDecl `followedBy` freshLine)
2828 imports' <- imports
29− return $ Module.HeaderAndImports names exports imports'
29+ return (Module.Header names exports imports')
3030
3131
32−header :: IParser ([String], Var.Listing Var.Value)
33−header =
32+moduleDecl :: IParser ([String], Var.Listing Var.Value)
33+moduleDecl =
3434 do try (reserved "module")
3535 whitespace
3636 names <- dotSep1 capVar <?> "name of module"
@@ -41,13 +41,14 @@ header =
4141 return (names, exports)
4242
4343
44−imports :: IParser [(Module.Name, Module.ImportMethod)]
44+imports :: IParser [Module.UserImport]
4545imports =
4646 many (import' `followedBy` freshLine)
4747
4848
49−import' :: IParser (Module.Name, Module.ImportMethod)
49+import' :: IParser Module.UserImport
5050import' =
51+ addLocation $
5152 do try (reserved "import")
5253 whitespace
5354 names <- dotSep1 capVar
src/Parse/Parse.hs+111−52
@@ -1,79 +1,138 @@
1+{-# OPTIONS_GHC -Wall #-}
12module Parse.Parse (program) where
23
3−import Control.Applicative ((<$>))
4−import qualified Data.List as List
4+import Control.Applicative ((<$>), (<*>))
55import qualified Data.Map as Map
6−import Text.Parsec hiding (newline, spaces)
7−import qualified Text.PrettyPrint as P
6+import qualified Data.Traversable as T
7+import Text.Parsec (char, eof, letter, many, optional, putState, (<|>), (<?>))
8+import qualified Text.Parsec.Error as Parsec
89
910import qualified AST.Declaration as D
1011import qualified AST.Module as M
1112import Parse.Helpers
12−import Parse.Declaration (infixDecl)
1313import qualified Parse.Module as Module
1414import 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
1620
1721
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
1858freshDef =
1959 commitIf (freshLine >> (letter <|> char '_')) $
20− do freshLine
60+ do _ <- freshLine
2161 Decl.declaration <?> "another datatype or variable definition"
2262
2363
24−decls =
25− do d <- Decl.declaration <?> "at least one datatype or variable definition"
26− (d:) <$> many freshDef
64+-- RUN PARSERS
2765
66+parse :: String -> IParser a -> Task.Task wrn Error.Error a
67+parse source parser =
68+ case iParse parser source of
69+ Right result ->
70+ return result
2871
29−program :: OpTable -> String -> Either [P.Doc] M.ValidModule
30−program table src =
31− do (M.Module names filePath exs ims sourceDecls) <-
32− setupParserWithTable table programParser src
72+ Left err ->
73+ let pos = R.fromSourcePos (Parsec.errorPos err)
74+ msgs = Parsec.errorMessages err
75+ in
76+ Task.throw (R.Region pos pos) (Error.Parse msgs)
3377
34− decls <-
35− either (\err -> Left [P.text err]) Right (combineAnnotations sourceDecls)
3678
37− return $ M.Module names filePath exs ims decls
79+parseWithTable
80+ :: OpTable
81+ -> String
82+ -> IParser a
83+ -> Task.Task wrn Error.Error a
84+parseWithTable table source parser =
85+ do infixInfoList <- parse source parseFixities
3886
87+ infixTable <- makeInfixTable table infixInfoList
3988
40−programParser :: IParser M.SourceModule
41−programParser =
42− do (M.HeaderAndImports names exports imports) <- Module.headerAndImports
43− declarations <- decls
44− optional freshLine ; optional spaces ; eof
45− return $ M.Module names "" exports imports declarations
46−
47−
48−setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a
49−setupParserWithTable table p source =
50− do localTable <- setupParser parseFixities source
51− case Map.intersection table localTable of
52− overlap | not (Map.null overlap) -> Left [ msg overlap ]
53− | otherwise ->
54− flip setupParser source $
55− do putState (Map.union table localTable)
56− p
57− where
58− msg overlap =
59− P.vcat
60− [ P.text "Parse error:"
61− , P.text $
62− "Overlapping definitions for infix operators: "
63− ++ List.intercalate " " (Map.keys overlap)
64− ]
89+ parse source $
90+ do putState infixTable
91+ parser
6592
6693
67−parseFixities =
68− do decls <- onFreshLines (:) [] infixDecl
69− return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
7094
95+-- INFIX INFO
96+
97+makeInfixTable
98+ :: Map.Map String (Int, D.Assoc)
99+ -> [(String, InfixInfo)]
100+ -> 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))
71133
72−setupParser :: IParser a -> String -> Either [P.Doc] a
73−setupParser p source =
74− case iParse p source of
75− Right result ->
76− Right result
77134
78− Left err ->
79− Left [ P.text $ "Parse error at " ++ show err ]
135+data InfixInfo = InfixInfo
136+ { _region :: R.Region
137+ , _info :: (Int, D.Assoc)
138+ }
src/Parse/Pattern.hs+76−37
@@ -5,64 +5,103 @@ import Data.Char (isUpper)
55import qualified Data.List as List
66import Text.Parsec ((<|>), (<?>), char, choice, optionMaybe, try)
77
8−import Parse.Helpers
9−import qualified Parse.Literal as Literal
108import qualified AST.Literal as L
119import qualified AST.Pattern as P
1210import qualified AST.Variable as Var
11+import Parse.Helpers
12+import qualified Parse.Literal as Literal
13+import qualified Reporting.Annotation as A
14+import qualified Reporting.Region as R
15+
1316
1417basic :: IParser P.RawPattern
15−basic = choice
16− [ char '_' >> return P.Anything
17− , stringToPattern <$> var
18− , P.Literal <$> Literal.literal
19− ]
18+basic =
19+ addLocation $
20+ choice
21+ [ char '_' >> return P.Anything
22+ , stringToPattern <$> var
23+ , P.Literal <$> Literal.literal
24+ ]
2025 where
21− stringToPattern v =
22− case v of
23− "True" -> P.Literal (L.Boolean True)
24− "False" -> P.Literal (L.Boolean False)
25− c:_ | isUpper c -> P.Data (Var.Raw v) []
26− _ -> P.Var v
26+ stringToPattern str =
27+ case str of
28+ "True" ->
29+ P.Literal (L.Boolean True)
30+
31+ "False" ->
32+ P.Literal (L.Boolean False)
33+
34+ c:_ | isUpper c ->
35+ P.Data (Var.Raw str) []
36+
37+ _ ->
38+ P.Var str
39+
40+
41+asPattern :: IParser P.RawPattern -> IParser P.RawPattern
42+asPattern patternParser =
43+ do pattern <- patternParser
2744
45+ let (A.A (R.Region start _) _) = pattern
2846
29−asPattern :: P.RawPattern -> IParser P.RawPattern
30−asPattern pattern =
31− do var <- optionMaybe (try (whitespace >> reserved "as") >> whitespace >> lowVar)
32− case var of
33− Just v ->
34− return (P.Alias v pattern)
47+ maybeAlias <- optionMaybe asAlias
48+
49+ case maybeAlias of
50+ Just alias ->
51+ do end <- getMyPosition
52+ return (A.at start end (P.Alias alias pattern))
3553
3654 Nothing ->
37− return pattern
55+ return pattern
56+ where
57+ asAlias =
58+ do try (whitespace >> reserved "as")
59+ whitespace
60+ lowVar
3861
3962
4063record :: IParser P.RawPattern
41−record = P.Record <$> brackets (commaSep1 lowVar)
64+record =
65+ addLocation
66+ (P.Record <$> brackets (commaSep1 lowVar))
67+
4268
4369tuple :: IParser P.RawPattern
44−tuple = do
45− ps <- parens (commaSep expr)
46− return $ case ps of
47− [p] -> p
48− _ -> P.tuple ps
70+tuple =
71+ do (start, patterns, end) <-
72+ located (parens (commaSep expr))
73+
74+ case patterns of
75+ [pattern] ->
76+ return pattern
77+
78+ _ ->
79+ return (A.at start end (P.tuple patterns))
80+
4981
5082list :: IParser P.RawPattern
51−list = P.list <$> braces (commaSep expr)
83+list =
84+ braces $
85+ do (_, patterns, end) <- located (commaSep expr)
86+ return (P.list end patterns)
87+
5288
5389term :: IParser P.RawPattern
5490term =
55− (choice [ record, tuple, list, basic ]) <?> "pattern"
91+ choice [ record, tuple, list, basic ]
92+ <?> "pattern"
93+
5694
5795patternConstructor :: IParser P.RawPattern
58−patternConstructor = do
59− v <- List.intercalate "." <$> dotSep1 capVar
60− case v of
61− "True" -> return $ P.Literal (L.Boolean True)
62− "False" -> return $ P.Literal (L.Boolean False)
63− _ -> P.Data (Var.Raw v) <$> spacePrefix term
96+patternConstructor =
97+ addLocation $
98+ do v <- List.intercalate "." <$> dotSep1 capVar
99+ case v of
100+ "True" -> return $ P.Literal (L.Boolean True)
101+ "False" -> return $ P.Literal (L.Boolean False)
102+ _ -> P.Data (Var.Raw v) <$> spacePrefix term
103+
64104
65105expr :: IParser P.RawPattern
66−expr = do
67− patterns <- consSep1 (patternConstructor <|> term)
68− asPattern (foldr1 P.cons patterns) <?> "pattern"
106+expr =
107+ asPattern (patternConstructor <|> term) <?> "pattern"
src/Parse/Type.hs+47−32
@@ -5,26 +5,30 @@ import Control.Applicative ((<$>),(<*>),(<*))
55import Data.List (intercalate)
66import Text.Parsec ((<|>), (<?>), char, many, optionMaybe, string, try)
77
8−import qualified AST.Type as T
8+import qualified AST.Type as Type
99import qualified AST.Variable as Var
1010import Parse.Helpers
11+import qualified Reporting.Annotation as A
12+import qualified Reporting.Region as R
1113
1214
13−tvar :: IParser T.RawType
15+tvar :: IParser Type.Raw
1416tvar =
15− T.Var <$> lowVar <?> "type variable"
17+ addLocation
18+ (Type.RVar <$> lowVar <?> "type variable")
1619
1720
18−tuple :: IParser T.RawType
21+tuple :: IParser Type.Raw
1922tuple =
20− do ts <- parens (commaSep expr)
21− case ts of
23+ do (start, types, end) <- located (parens (commaSep expr))
24+ case types of
2225 [t] -> return t
23− _ -> return (T.tupleOf ts)
26+ _ -> return (Type.tuple (R.Region start end) types)
2427
2528
26−record :: IParser T.RawType
29+record :: IParser Type.Raw
2730record =
31+ addLocation $
2832 do char '{'
2933 whitespace
3034 rcrd <- extended <|> normal
@@ -32,18 +36,19 @@ record =
3236 char '}'
3337 return rcrd
3438 where
35− normal = flip T.Record Nothing <$> commaSep field
39+ normal = flip Type.RRecord Nothing <$> commaSep field
3640
3741 -- extended record types require at least one field
38− extended = do
39− ext <- try (lowVar <* (whitespace >> string "|"))
40− whitespace
41− flip T.Record (Just (T.Var ext)) <$> commaSep1 field
42+ extended =
43+ do ext <- try (addLocation lowVar <* (whitespace >> string "|"))
44+ whitespace
45+ fields <- commaSep1 field
46+ return (Type.RRecord fields (Just (A.map Type.RVar ext)))
4247
43− field = do
44− lbl <- rLabel
45− whitespace >> hasType >> whitespace
46− (,) lbl <$> expr
48+ field =
49+ do lbl <- rLabel
50+ whitespace >> hasType >> whitespace
51+ (,) lbl <$> expr
4752
4853
4954capTypeVar :: IParser String
@@ -51,41 +56,51 @@ capTypeVar =
5156 intercalate "." <$> dotSep1 capVar
5257
5358
54−constructor0 :: IParser T.RawType
59+constructor0 :: IParser Type.Raw
5560constructor0 =
61+ addLocation $
5662 do name <- capTypeVar
57− return (T.Type (Var.Raw name))
63+ return (Type.RType (Var.Raw name))
5864
5965
60−term :: IParser T.RawType
66+term :: IParser Type.Raw
6167term =
6268 tuple <|> record <|> tvar <|> constructor0
6369
6470
65−app :: IParser T.RawType
71+app :: IParser Type.Raw
6672app =
67− do f <- constructor0 <|> try tupleCtor <?> "type constructor"
73+ do start <- getMyPosition
74+ f <- constructor0 <|> try tupleCtor <?> "type constructor"
6875 args <- spacePrefix term
76+ end <- getMyPosition
6977 case args of
7078 [] -> return f
71− _ -> return (T.App f args)
79+ _ -> return (A.A (R.Region start end) (Type.RApp f args))
7280 where
73− tupleCtor = do
74− n <- length <$> parens (many (char ','))
75− let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)
76− return (T.Type (Var.Raw ctor))
81+ tupleCtor =
82+ addLocation $
83+ do n <- length <$> parens (many (char ','))
84+ let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)
85+ return (Type.RType (Var.Raw ctor))
7786
7887
79−expr :: IParser T.RawType
88+expr :: IParser Type.Raw
8089expr =
81− do t1 <- app <|> term
90+ do start <- getMyPosition
91+ t1 <- app <|> term
8292 arr <- optionMaybe $ try (whitespace >> arrow)
8393 case arr of
84− Just _ -> T.Lambda t1 <$> (whitespace >> expr)
85− Nothing -> return t1
94+ Nothing ->
95+ return t1
96+ Just _ ->
97+ do whitespace
98+ t2 <- expr
99+ end <- getMyPosition
100+ return (A.A (R.Region start end) (Type.RLambda t1 t2))
86101
87102
88−constructor :: IParser (String, [T.RawType])
103+constructor :: IParser (String, [Type.Raw])
89104constructor =
90105 (,) <$> (capTypeVar <?> "another type constructor")
91106 <*> spacePrefix term
src/Reporting/Annotation.hsnew file+52
@@ -0,0 +1,52 @@
1+module Reporting.Annotation where
2+
3+import Prelude hiding (map)
4+import qualified Reporting.PrettyPrint as P
5+import qualified Reporting.Region as R
6+
7+
8+-- ANNOTATION
9+
10+data Annotated annotation a
11+ = A annotation a
12+ deriving (Show)
13+
14+
15+type Located a =
16+ Annotated R.Region a
17+
18+
19+-- CREATE
20+
21+at :: R.Position -> R.Position -> a -> Located a
22+at start end value =
23+ A (R.Region start end) value
24+
25+
26+merge :: Located a -> Located b -> value -> Located value
27+merge (A region1 _) (A region2 _) value =
28+ A (R.merge region1 region2) value
29+
30+
31+sameAs :: Annotated info a -> b -> Annotated info b
32+sameAs (A annotation _) value =
33+ A annotation value
34+
35+
36+-- MANIPULATE
37+
38+map :: (a -> b) -> Annotated info a -> Annotated info b
39+map f (A annotation value) =
40+ A annotation (f value)
41+
42+
43+drop :: Annotated info a -> a
44+drop (A _ value) =
45+ value
46+
47+
48+-- PRETTY PRINT
49+
50+instance (P.Pretty a) => P.Pretty (Annotated info a) where
51+ pretty parens (A _ value) =
52+ P.pretty parens value
src/Reporting/Error.hsnew file+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 @@
11{-# OPTIONS_GHC -Wall #-}
2−module Transform.Canonicalize.Error where
2+{-# LANGUAGE OverloadedStrings #-}
3+module Reporting.Error.Canonicalize where
34
4−import Data.Aeson ((.=))
5+--import Data.Aeson ((.=))
56import qualified Data.Aeson as Json
7+--import qualified Data.Aeson.Types as Json
68import Data.Function (on)
79import qualified Data.List as List
810import qualified Text.EditDistance as Dist
911
1012import qualified AST.Module as Module
11−import qualified AST.Type as T
13+import qualified AST.Type as Type
1214import qualified AST.Variable as Var
1315import Elm.Utils ((|>))
16+import qualified Reporting.Region as R
1417
1518
1619data Error
1720 = Var VarError
21+ | Pattern PatternError
1822 | Alias AliasError
1923 | Import Module.Name ImportError
2024 | Export String [String]
@@ -42,6 +46,17 @@ var kind name problem =
4246 Var (VarError kind name problem)
4347
4448
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+
4560-- IMPORTS
4661
4762data ImportError
@@ -62,18 +77,14 @@ valueNotFound name value possibilities =
6277-- ALIASES
6378
6479data AliasError
65− = ArgMissmatch Var.Canonical Int Int
66− | Recursive [(String, [String], T.RawType)]
80+ = ArgMismatch Var.Canonical Int Int
81+ | SelfRecursive String [String] Type.Raw
82+ | MutuallyRecursive [(R.Region, String, [String], Type.Raw)]
6783
6884
6985alias :: Var.Canonical -> Int -> Int -> Error
7086alias name expected actual =
71− Alias (ArgMissmatch name expected actual)
72−
73−
74−recursiveAlias :: [(String, [String], T.RawType)] -> Error
75−recursiveAlias aliases =
76− Alias (Recursive aliases)
87+ Alias (ArgMismatch name expected actual)
7788
7889
7990-- PORTS
@@ -81,8 +92,8 @@ recursiveAlias aliases =
8192data PortError = PortError
8293 { portName :: String
8394 , portIsInbound :: Bool
84− , portRootType :: T.CanonicalType
85− , portLocalType :: T.CanonicalType
95+ , portRootType :: Type.Canonical
96+ , portLocalType :: Type.Canonical
8697 , portMessage :: String
8798 }
8899
@@ -90,8 +101,8 @@ data PortError = PortError
90101port
91102 :: String
92103 -> Bool
93− -> T.CanonicalType
94− -> T.CanonicalType
104+ -> Type.Canonical
105+ -> Type.Canonical
95106 -> String
96107 -> Error
97108port name isInbound rootType localType message =
@@ -117,13 +128,32 @@ distance x y =
117128 Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y
118129
119130
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
121137
122−errorToJson err =
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
152+errorToJson (A.A region err) =
123153 Json.object (generals ++ specifics)
124154 where
125155 generals =
126− [ "category" .= "canonicalization"
156+ [ "category" .=. "canonicalization"
127157 , "region" .= region
128158 ]
129159
@@ -137,25 +167,25 @@ errorToJson err =
137167
138168 Alias aliasError ->
139169 case aliasError of
140− ArgMissmatch name expected actual ->
141− [ "tag" .= "alias-args"
142− , "name" .= name
170+ ArgMismatch name expected actual ->
171+ [ "tag" .=. "alias-args"
172+ , "name" .= Var.toString name
143173 , "expected-args" .= expected
144174 , "actual-args" .= actual
145175 ]
146176
147177 Recursive [(name, tvars, tipe)] ->
148− [ "tag" .= "recursive-alias"
178+ [ "tag" .=. "recursive-alias"
149179 ]
150180
151181 Recursive aliases ->
152− [ "tag" .= "mutually-recursive-aliases"
182+ [ "tag" .=. "mutually-recursive-aliases"
153183 ]
154184
155185 Import moduleName importError ->
156186 case importError of
157187 ModuleNotFound suggestions ->
158− [ "tag" .= "unknown-import"
188+ [ "tag" .=. "unknown-import"
159189 , "name" .= moduleName
160190 , "suggestions" .= suggestions
161191 ]
@@ -169,10 +199,10 @@ errorToJson err =
169199 []
170200
171201
172−varProblemToJson :: VarProblem -> Json.Value
202+varProblemToJson :: VarProblem -> [Json.Pair]
173203varProblemToJson varProblem =
174204 let details tag suggestions =
175− [ "tag" .= tag
205+ [ "tag" .=. tag
176206 , "suggestions" .= suggestions
177207 ]
178208 in
@@ -181,14 +211,16 @@ varProblemToJson varProblem =
181211 details "ambiguous" possibilities
182212
183213 UnknownQualifier possibleModules ->
184− details "unknown-qualifier" possibleModules
214+ details
215+ "unknown-qualifier"
216+ (map Module.nameToString possibleModules)
185217
186218 QualifiedUnknown possibilities ->
187219 details "qualified-unknown" possibilities
188220
189221 ExposedUnknown closeExposed closeQualified ->
190222 details "exposed-unknown" (closeExposed ++ closeQualified)
191−
223+--}
192224
193225{-- TO STRING
194226
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 @@
11{-# LANGUAGE FlexibleInstances #-}
2−module AST.PrettyPrint where
2+module Reporting.PrettyPrint where
33
4−import Control.Monad.Trans.Error
54import Text.PrettyPrint as P
65import qualified AST.Helpers as Help
76
87
98class Pretty a where
10− pretty :: a -> Doc
11−
12−
13−instance Pretty Doc where
14− pretty doc = doc
9+ pretty :: Bool -> a -> Doc
1510
1611
1712instance Pretty String where
18− pretty = P.text
19−
20−
21−renderPretty :: (Pretty a) => a -> String
22−renderPretty e =
23− render (pretty e)
13+ pretty _ str =
14+ P.text str
2415
2516
2617commaCat :: [Doc] -> Doc
@@ -53,12 +44,3 @@ eightyCharLines indent message = answer
5344 step (sentence, slen, space) (word, wlen)
5445 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
5546 | 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
1010(==>) = (,)
1111
1212
13−defaultImports :: [(Module.Name, Module.ImportMethod)]
13+defaultImports :: [Module.DefaultImport]
1414defaultImports =
1515 [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing
1616 , ["List"] ==> exposing [Var.Value "::"]
@@ -27,11 +27,14 @@ exposing vars =
2727
2828-- ADDING DEFAULT IMPORTS TO A MODULE
2929
30−add :: Bool -> Module.Module exs body -> Module.Module exs body
31−add needsDefaults (Module.Module moduleName path exports imports decls) =
32− Module.Module moduleName path exports ammendedImports decls
30+add
31+ :: Bool
32+ -> [Module.UserImport]
33+ -> ([Module.DefaultImport], [Module.UserImport])
34+add needsDefaults imports =
35+ (defaults, imports)
3336 where
34− ammendedImports =
37+ defaults =
3538 if needsDefaults
36− then defaultImports ++ imports
37− else imports
39+ then defaultImports
40+ else []
src/Transform/Canonicalize.hs+83−57
@@ -1,26 +1,30 @@
11module Transform.Canonicalize (module') where
22
33import Control.Applicative ((<$>),(<*>))
4+import Control.Monad.Except (throwError)
45import qualified Data.List as List
56import qualified Data.Map as Map
7+import qualified Data.Maybe as Maybe
68import qualified Data.Set as Set
79import qualified Data.Traversable as T
810
911import AST.Expression.General (Expr'(..), dummyLet)
12+import AST.Module (CanonicalBody(..))
13+
14+import qualified AST.Declaration as D
1015import qualified AST.Expression.General as E
1116import qualified AST.Expression.Valid as Valid
1217import 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
1718import qualified AST.Module as Module
1819import qualified AST.Pattern as P
1920import qualified AST.Type as Type
2021import 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
2227import qualified Transform.Canonicalize.Environment as Env
23−import qualified Transform.Canonicalize.Error as Error
2428import qualified Transform.Canonicalize.Port as Port
2529import qualified Transform.Canonicalize.Result as Result
2630import qualified Transform.Canonicalize.Setup as Setup
@@ -30,33 +34,31 @@ import qualified Transform.SortDefinitions as Transform
3034import qualified Transform.Declaration as Transform
3135
3236
37+-- MODULES
38+
3339module'
3440 :: Module.Interfaces
3541 -> Module.ValidModule
36− -> ([Module.Name], Either [Error.Error] Module.CanonicalModule)
37−module' interfaces modul@(Module.Module _ _ _ imports _) =
42+ -> Task.Task Warning.Warning Error.Error Module.CanonicalModule
43+module' interfaces modul@(Module.Module _ _ _ (_, imports) _) =
3844 let (Result.Result uses rawResults) =
3945 moduleHelp interfaces modul
4046
41− unusedImports =
42− filter (\name -> not (Set.member name uses)) (map fst imports)
43−
44− either =
47+ in
48+ do Task.addWarnings (Maybe.mapMaybe (warnUnusedImport uses) imports)
4549 case rawResults of
4650 Result.Ok canonicalModule ->
47− Right canonicalModule
51+ return canonicalModule
4852
4953 Result.Err msgs ->
50− Left msgs
51− in
52− (unusedImports, either)
54+ throwError (map (A.map Error.Canonicalize) msgs)
5355
5456
5557moduleHelp
5658 :: Module.Interfaces
5759 -> Module.ValidModule
58− -> Result.Result Module.CanonicalModule
59−moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
60+ -> Result.ResultErr Module.CanonicalModule
61+moduleHelp interfaces modul@(Module.Module _ _ exports (defaults, imports) decls) =
6062 canonicalModule
6163 <$> canonicalDeclsResult
6264 <*> resolveExports locals exports
@@ -64,6 +66,7 @@ moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
6466 canonicalModule canonicalDecls canonicalExports =
6567 modul
6668 { Module.exports = canonicalExports
69+ , Module.imports = map fst defaults ++ map (fst . A.drop) imports
6770 , Module.body = body canonicalDecls
6871 }
6972
@@ -77,26 +80,47 @@ moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
7780
7881 body :: [D.CanonicalDecl] -> Module.CanonicalBody
7982 body decls =
83+ let nakedDecls = map A.drop decls
84+ in
8085 Module.CanonicalBody
8186 { program =
82− let expr = Transform.toExpr (Module.names modul) decls
83− in Transform.sortDefs (dummyLet expr)
84− , types = Map.empty
87+ let expr = Transform.toExpr (Module.names modul) decls
88+ in
89+ Transform.sortDefs (dummyLet expr)
90+
91+ , types =
92+ Map.empty
93+
8594 , 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+
8797 , fixities =
88− [ (assoc,level,op) | D.Fixity assoc level op <- decls ]
98+ [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]
99+
89100 , 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+
91103 , ports =
92− [ E.portName impl | D.Port (D.CanonicalPort impl) <- decls ]
104+ [ E.portName impl | D.Port (D.CanonicalPort impl) <- nakedDecls ]
93105 }
94106
95107
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+
96120resolveExports
97121 :: [Var.Value]
98122 -> Var.Listing Var.Value
99− -> Result.Result [Var.Value]
123+ -> Result.ResultErr [Var.Value]
100124resolveExports fullList (Var.Listing partialList open) =
101125 if open
102126 then Result.ok fullList
@@ -148,12 +172,10 @@ resolveExports fullList (Var.Listing partialList open) =
148172 Result.errors (map (notFound possibilities) nameList)
149173
150174 notFound possibilities name =
151− Error.Export name (Error.nearbyNames id name possibilities)
175+ A.A undefined $ CError.Export name $
176+ CError.nearbyNames id name possibilities
152177
153178
154−{-| Split a list of values into categories so we can work with them
155−independently.
156−-}
157179splitValues
158180 :: [Var.Value]
159181 -> ([String], [String], [(String, Var.Listing String)])
@@ -173,8 +195,10 @@ splitValues mixedValues =
173195 (values, aliases, (name, listing) : adts)
174196
175197
198+-- DECLARATIONS
199+
176200declToValue :: D.ValidDecl -> [Var.Value]
177−declToValue decl =
201+declToValue (A.A _ decl) =
178202 case decl of
179203 D.Definition (Valid.Definition pattern _ _) ->
180204 map Var.Value (P.boundVarList pattern)
@@ -184,7 +208,7 @@ declToValue decl =
184208
185209 D.TypeAlias name _ tipe ->
186210 case tipe of
187− Type.Record _ _ ->
211+ A.A _ (Type.RRecord _ _) ->
188212 [ Var.Alias name, Var.Value name ]
189213 _ -> [ Var.Alias name ]
190214
@@ -194,11 +218,12 @@ declToValue decl =
194218declaration
195219 :: Env.Environment
196220 -> D.ValidDecl
197− -> Result.Result D.CanonicalDecl
198−declaration env decl =
221+ -> Result.ResultErr D.CanonicalDecl
222+declaration env (A.A region decl) =
199223 let canonicalize kind _context _pattern env v =
200224 kind env v
201225 in
226+ A.A region <$>
202227 case decl of
203228 D.Definition (Valid.Definition p e t) ->
204229 D.Definition <$> (
@@ -244,14 +269,11 @@ declaration env decl =
244269expression
245270 :: Env.Environment
246271 -> Valid.Expr
247− -> Result.Result Canonical.Expr
248−expression env (A.A ann validExpr) =
272+ -> Result.ResultErr Canonical.Expr
273+expression env (A.A region validExpr) =
249274 let go = expression env
250− tipe' environ =
251− format . Canonicalize.tipe environ
252− format = id
253275 in
254− A.A ann <$>
276+ A.A region <$>
255277 case validExpr of
256278 Literal lit ->
257279 Result.ok (Literal lit)
@@ -279,14 +301,14 @@ expression env (A.A ann validExpr) =
279301
280302 Binop (Var.Raw op) leftExpr rightExpr ->
281303 Binop
282− <$> format (Canonicalize.variable env op)
304+ <$> Canonicalize.variable region env op
283305 <*> go leftExpr
284306 <*> go rightExpr
285307
286308 Lambda arg body ->
287309 let env' = Env.addPattern arg env
288310 in
289− Lambda <$> format (pattern env' arg) <*> expression env' body
311+ Lambda <$> pattern env' arg <*> expression env' body
290312
291313 App func arg ->
292314 App <$> go func <*> go arg
@@ -305,12 +327,12 @@ expression env (A.A ann validExpr) =
305327
306328 rename' (Valid.Definition p body mtipe) =
307329 Canonical.Definition
308− <$> format (pattern env' p)
330+ <$> pattern env' p
309331 <*> expression env' body
310− <*> T.traverse (tipe' env') mtipe
332+ <*> T.traverse (Canonicalize.tipe env') mtipe
311333
312334 Var (Var.Raw x) ->
313− Var <$> format (Canonicalize.variable env x)
335+ Var <$> Canonicalize.variable region env x
314336
315337 Data name exprs ->
316338 Data name <$> T.traverse go exprs
@@ -321,18 +343,21 @@ expression env (A.A ann validExpr) =
321343 Case expr cases ->
322344 Case <$> go expr <*> T.traverse branch cases
323345 where
324− branch (p,b) =
325− (,) <$> format (pattern env p)
326− <*> expression (Env.addPattern p env) b
346+ branch (ptrn, brnch) =
347+ (,) <$> pattern env ptrn
348+ <*> expression (Env.addPattern ptrn env) brnch
327349
328350 Port impl ->
329351 let portType pt =
330352 case pt of
331353 Type.Normal t ->
332− Type.Normal <$> tipe' env t
354+ Type.Normal
355+ <$> Canonicalize.tipe env t
333356
334357 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
336361 in
337362 Port <$>
338363 case impl of
@@ -352,8 +377,9 @@ expression env (A.A ann validExpr) =
352377pattern
353378 :: Env.Environment
354379 -> P.RawPattern
355− -> Result.Result P.CanonicalPattern
356−pattern env ptrn =
380+ -> Result.ResultErr P.CanonicalPattern
381+pattern env (A.A region ptrn) =
382+ A.A region <$>
357383 case ptrn of
358384 P.Var x ->
359385 Result.ok (P.Var x)
@@ -361,8 +387,8 @@ pattern env ptrn =
361387 P.Literal lit ->
362388 Result.ok (P.Literal lit)
363389
364− P.Record fs ->
365− Result.ok (P.Record fs)
390+ P.Record fields ->
391+ Result.ok (P.Record fields)
366392
367393 P.Anything ->
368394 Result.ok P.Anything
@@ -370,7 +396,7 @@ pattern env ptrn =
370396 P.Alias x p ->
371397 P.Alias x <$> pattern env p
372398
373− P.Data (Var.Raw name) ps ->
399+ P.Data (Var.Raw name) patterns ->
374400 P.Data
375− <$> Canonicalize.pvar env name
376− <*> T.traverse (pattern env) ps
401+ <$> Canonicalize.pvar region env name (length patterns)
402+ <*> T.traverse (pattern env) patterns
src/Transform/Canonicalize/Environment.hs+21−11
@@ -18,8 +18,8 @@ data Environment = Env
1818 { _home :: Module.Name
1919 , _values :: Dict Var.Canonical
2020 , _adts :: Dict Var.Canonical
21− , _aliases :: Dict (Var.Canonical, [String], Type.CanonicalType)
22− , _patterns :: Dict Var.Canonical
21+ , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)
22+ , _patterns :: Dict (Var.Canonical, Int)
2323 }
2424
2525
@@ -34,7 +34,7 @@ fromPatches moduleName patches =
3434 (Env moduleName Map.empty Map.empty Map.empty Map.empty)
3535
3636
37−addPattern :: P.Pattern var -> Environment -> Environment
37+addPattern :: P.Pattern ann var -> Environment -> Environment
3838addPattern pattern env =
3939 let patches =
4040 map (\x -> Value x (Var.local x)) (P.boundVarList pattern)
@@ -47,8 +47,8 @@ addPattern pattern env =
4747data Patch
4848 = Value String Var.Canonical
4949 | Union String Var.Canonical
50− | Alias String (Var.Canonical, [String], Type.CanonicalType)
51− | Pattern String Var.Canonical
50+ | Alias String (Var.Canonical, [String], Type.Canonical)
51+ | Pattern String (Var.Canonical, Int)
5252
5353
5454-- ADD PATCH TO ENVIRONMENT
@@ -84,13 +84,23 @@ insert key value =
8484builtinPatches :: [Patch]
8585builtinPatches =
8686 concat
87− [ builtIn Value (tuples ++ [saveEnvName])
88− , builtIn Union (tuples ++ ["List","Int","Float","Char","Bool","String"])
89− , builtIn Pattern (tuples ++ ["::","[]"])
87+ [ map (patch Value) (tupleNames ++ [saveEnvName])
88+ , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])
89+ , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])
9090 ]
9191 where
92− builtIn patch xs =
93− map (\x -> patch x (Var.Canonical Var.BuiltIn x)) xs
92+ patch mkPatch name =
93+ mkPatch name (Var.builtin name)
94+
95+ patternPatch (name, args) =
96+ Pattern name (Var.builtin name, args)
97+
98+ tupleNames =
99+ map fst tuples
94100
95101 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
88import qualified AST.Expression.Canonical as Canonical
99import qualified AST.Type as T
1010import 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
1213import qualified Transform.Canonicalize.Result as Result
1314
1415
@@ -17,8 +18,8 @@ import qualified Transform.Canonicalize.Result as Result
1718check
1819 :: String
1920 -> Maybe Canonical.Expr
20− -> T.CanonicalType
21− -> Result.Result D.CanonicalPort
21+ -> T.Canonical
22+ -> Result.ResultErr D.CanonicalPort
2223check name maybeExpr rootType =
2324 D.CanonicalPort <$> checkHelp name maybeExpr rootType rootType
2425
@@ -26,9 +27,9 @@ check name maybeExpr rootType =
2627checkHelp
2728 :: String
2829 -> Maybe Canonical.Expr
29− -> T.CanonicalType
30− -> T.CanonicalType
31− -> Result.Result (E.PortImpl Canonical.Expr Var.Canonical)
30+ -> T.Canonical
31+ -> T.Canonical
32+ -> Result.ResultErr (E.PortImpl Canonical.Expr T.Canonical)
3233checkHelp name maybeExpr rootType tipe =
3334 case (maybeExpr, tipe) of
3435 (_, T.Aliased _ args t) ->
@@ -71,15 +72,16 @@ checkHelp name maybeExpr rootType tipe =
7172validForeignType
7273 :: String
7374 -> Bool
74− -> T.CanonicalType
75− -> T.CanonicalType
76− -> Result.Result ()
75+ -> T.Canonical
76+ -> T.Canonical
77+ -> Result.ResultErr ()
7778validForeignType name isInbound rootType tipe =
7879 let valid localType =
7980 validForeignType name isInbound rootType localType
8081
8182 err problem =
82− Result.err (Error.port name isInbound rootType tipe problem)
83+ Result.err $ A.A undefined $
84+ Error.port name isInbound rootType tipe problem
8385 in
8486 case tipe of
8587 T.Aliased _ args t ->
src/Transform/Canonicalize/Result.hs+17−13
@@ -8,11 +8,15 @@ import qualified Data.Set as Set
88
99import qualified AST.Module as Module
1010import 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
1213
1314
14−data Result a =
15− Result (Set.Set Module.Name) (RawResult Error.Error a)
15+type ResultErr a = Result (A.Located Error.Error) a
16+
17+
18+data Result err a =
19+ Result (Set.Set Module.Name) (RawResult err a)
1620
1721
1822data RawResult err a
@@ -22,22 +26,22 @@ data RawResult err a
2226
2327-- RESULT HELPERS
2428
25−ok :: a -> Result a
29+ok :: a -> Result e a
2630ok value =
2731 Result Set.empty (Ok value)
2832
2933
30−err :: Error.Error -> Result a
34+err :: e -> Result e a
3135err msg =
3236 errors [msg]
3337
3438
35−errors :: [Error.Error] -> Result a
39+errors :: [e] -> Result e a
3640errors msgs =
3741 Result Set.empty (Err msgs)
3842
3943
40−foldl :: (a -> b -> Result b) -> b -> [a] -> Result b
44+foldl :: (a -> b -> Result e b) -> b -> [a] -> Result e b
4145foldl f acc list =
4246 case list of
4347 [] ->
@@ -47,7 +51,7 @@ foldl f acc list =
4751 f x acc `andThen` (\acc' -> foldl f acc' xs)
4852
4953
50−andThen :: Result a -> (a -> Result b) -> Result b
54+andThen :: Result e a -> (a -> Result e b) -> Result e b
5155andThen (Result uses rawResult) callback =
5256 case rawResult of
5357 Err msg ->
@@ -57,7 +61,7 @@ andThen (Result uses rawResult) callback =
5761 callback value
5862
5963
60−instance F.Functor Result where
64+instance F.Functor (Result e) where
6165 fmap func (Result uses result) =
6266 case result of
6367 Ok a ->
@@ -67,7 +71,7 @@ instance F.Functor Result where
6771 Result uses (Err msgs)
6872
6973
70−instance A.Applicative Result where
74+instance A.Applicative (Result e) where
7175 pure value =
7276 ok value
7377
@@ -89,12 +93,12 @@ instance A.Applicative Result where
8993
9094-- TRACK USES OF IMPORTS
9195
92−addModule :: Module.Name -> Result a -> Result a
96+addModule :: Module.Name -> Result e a -> Result e a
9397addModule home (Result uses result) =
9498 Result (Set.insert home uses) result
9599
96100
97−var' :: (a -> Var.Canonical) -> a -> Result a
101+var' :: (a -> Var.Canonical) -> a -> Result e a
98102var' toVar value =
99103 case toVar value of
100104 Var.Canonical (Var.Module moduleName) _name ->
@@ -104,7 +108,7 @@ var' toVar value =
104108 ok value
105109
106110
107−var :: Var.Canonical -> Result Var.Canonical
111+var :: Var.Canonical -> Result e Var.Canonical
108112var variable =
109113 var' id variable
110114
src/Transform/Canonicalize/Setup.hs+75−50
@@ -2,6 +2,7 @@
22module Transform.Canonicalize.Setup (environment) where
33
44import Control.Applicative ((<$>))
5+import Control.Arrow (second)
56import qualified Data.Graph as Graph
67import qualified Data.Map as Map
78import qualified Data.Maybe as Maybe
@@ -14,8 +15,10 @@ import qualified AST.Pattern as P
1415import qualified AST.Type as Type
1516import qualified AST.Variable as Var
1617import Elm.Utils ((|>))
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.Error.Canonicalize as Error
20+import qualified Reporting.Region as R
1721import qualified Transform.Canonicalize.Environment as Env
18−import qualified Transform.Canonicalize.Error as Error
1922import qualified Transform.Canonicalize.Result as Result
2023import qualified Transform.Canonicalize.Type as Canonicalize
2124import qualified Transform.Interface as Interface
@@ -24,14 +27,16 @@ import qualified Transform.Interface as Interface
2427environment
2528 :: Module.Interfaces
2629 -> Module.ValidModule
27− -> Result.Result Env.Environment
28−environment interfaces modul@(Module.Module _ _ _ imports decls) =
30+ -> Result.ResultErr Env.Environment
31+environment interfaces modul@(Module.Module _ _ _ (defaults, imports) decls) =
2932 let moduleName =
3033 Module.names modul
3134
35+ allImports =
36+ imports ++ map (A.A (error "default import not found")) defaults
37+
3238 importPatchesResult =
33− concat <$>
34− Trav.traverse (importPatches interfaces) imports
39+ concat <$> Trav.traverse (importPatches interfaces) allImports
3540
3641 (typeAliasNodes, declPatches) =
3742 declarationsToPatches moduleName decls
@@ -47,9 +52,9 @@ environment interfaces modul@(Module.Module _ _ _ imports decls) =
4752
4853importPatches
4954 :: Module.Interfaces
50− -> (Module.Name, Module.ImportMethod)
51− -> Result.Result [Env.Patch]
52−importPatches allInterfaces (importName, method) =
55+ -> A.Located (Module.Name, Module.ImportMethod)
56+ -> Result.ResultErr [Env.Patch]
57+importPatches allInterfaces (A.A region (importName, method)) =
5358 case Interface.filterExports <$> Map.lookup importName allInterfaces of
5459 Nothing
5560 | Module.nameIsNative importName ->
@@ -60,6 +65,7 @@ importPatches allInterfaces (importName, method) =
6065 |> Map.keys
6166 |> Error.nearbyNames Module.nameToString importName
6267 |> Error.moduleNotFound importName
68+ |> A.A region
6369 |> Result.err
6470
6571 Just interface ->
@@ -78,7 +84,7 @@ importPatches allInterfaces (importName, method) =
7884 unqualifiedPatches =
7985 if open
8086 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
8288 in
8389 (++) qualifiedPatches <$> unqualifiedPatches
8490
@@ -95,34 +101,46 @@ interfacePatches moduleName prefix interface =
95101 genericPatch Env.Alias name
96102 (Var.fromModule moduleName name, tvars, tipe)
97103
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+
98111 ctorNames =
99− concatMap (map fst . snd) (Map.elems (Module.iAdts interface))
112+ map fst ctors
100113 in
101114 concat
102115 [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
103116 , map (patch Env.Value) ctorNames
104117 , map (patch Env.Union) (Map.keys (Module.iAdts interface))
105118 , map aliasPatch (Map.toList (Module.iAliases interface))
106− , map (patch Env.Pattern) ctorNames
119+ , map patternPatch ctors
107120 ]
108121
109122
110123-- PATCHES FOR INDIVIDUAL VALUES
111124
112125valueToPatches
113− :: Module.Name
126+ :: R.Region
127+ -> Module.Name
114128 -> Module.Interface
115129 -> Var.Value
116− -> Result.Result [Env.Patch]
117−valueToPatches moduleName interface value =
130+ -> Result.ResultErr [Env.Patch]
131+valueToPatches region moduleName interface value =
118132 let patch mkPatch x =
119133 mkPatch x (Var.fromModule moduleName x)
120134
135+ patternPatch (x, numArgs) =
136+ Env.Pattern x (Var.fromModule moduleName x, numArgs)
137+
121138 notFound getNames x =
122139 Module.iExports interface
123140 |> getNames
124141 |> Error.nearbyNames id x
125142 |> Error.valueNotFound moduleName x
143+ |> A.A region
126144 |> Result.err
127145 in
128146 case value of
@@ -164,62 +182,60 @@ valueToPatches moduleName interface value =
164182 Just (_tvars, realCtors) ->
165183 patches <$>
166184 if open
167− then Result.ok realCtorNames
185+ then Result.ok realCtorList
168186 else Trav.traverse ctorExists givenCtorNames
169187 where
170− realCtorNames =
171− map fst realCtors
188+ realCtorList =
189+ map (second length) realCtors
190+
191+ realCtorDict =
192+ Map.fromList realCtorList
172193
173194 ctorExists givenCtorName =
174− if givenCtorName `elem` realCtorNames
175− then Result.ok givenCtorName
176− else notFound (const realCtorNames) givenCtorName
195+ case Map.lookup givenCtorName realCtorDict of
196+ Just numArgs ->
197+ Result.ok (givenCtorName, numArgs)
198+ Nothing ->
199+ notFound (const (map fst realCtors)) givenCtorName
177200
178− patches ctorNames =
201+ patches ctors =
179202 patch Env.Union givenName
180− : map (patch Env.Value) ctorNames
181− ++ map (patch Env.Pattern) ctorNames
203+ : map (patch Env.Value . fst) ctors
204+ ++ map patternPatch ctors
182205
183206
184207-- PATCHES FOR TYPE ALIASES
185208
186−type Node = ((String, [String], Type.RawType), String, [String])
209+type Node = ((R.Region, String, [String], Type.Raw), String, [String])
187210
188211
189−node :: String -> [String] -> Type.RawType -> Node
190−node name tvars alias =
191− ((name, tvars, alias), name, edges alias)
212+node :: R.Region -> String -> [String] -> Type.Raw -> Node
213+node region name tvars alias =
214+ ((region, name, tvars, alias), name, edges alias)
192215 where
193− edges tipe =
216+ edges (A.A _ tipe) =
194217 case tipe of
195− Type.Lambda t1 t2 ->
218+ Type.RLambda t1 t2 ->
196219 edges t1 ++ edges t2
197220
198− Type.Var _ ->
221+ Type.RVar _ ->
199222 []
200223
201− Type.Type (Var.Raw x) ->
224+ Type.RType (Var.Raw x) ->
202225 [x]
203226
204− Type.App t ts ->
227+ Type.RApp t ts ->
205228 edges t ++ concatMap edges ts
206229
207− Type.Record fs ext ->
230+ Type.RRecord fs ext ->
208231 maybe [] edges ext ++ concatMap (edges . snd) fs
209232
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−
217233
218234addTypeAliases
219235 :: Module.Name
220236 -> [Node]
221237 -> Env.Environment
222− -> Result.Result Env.Environment
238+ -> Result.ResultErr Env.Environment
223239addTypeAliases moduleName typeAliasNodes initialEnv =
224240 Result.foldl
225241 (addTypeAlias moduleName)
@@ -229,12 +245,12 @@ addTypeAliases moduleName typeAliasNodes initialEnv =
229245
230246addTypeAlias
231247 :: Module.Name
232− -> Graph.SCC (String, [String], Type.RawType)
248+ -> Graph.SCC (R.Region, String, [String], Type.Raw)
233249 -> Env.Environment
234− -> Result.Result Env.Environment
250+ -> Result.ResultErr Env.Environment
235251addTypeAlias moduleName scc env =
236252 case scc of
237− Graph.AcyclicSCC (name, tvars, alias) ->
253+ Graph.AcyclicSCC (_, name, tvars, alias) ->
238254 addToEnv <$> Canonicalize.tipe env alias
239255 where
240256 addToEnv alias' =
@@ -243,8 +259,14 @@ addTypeAlias moduleName scc env =
243259 in
244260 env { Env._aliases = Env.insert name value (Env._aliases env) }
245261
246− Graph.CyclicSCC aliases ->
247− Result.err (Error.recursiveAlias 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, _, _, _) : _) ->
269+ Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))
248270
249271
250272-- DECLARATIONS TO PATCHES
@@ -267,12 +289,15 @@ declToPatches
267289 :: Module.Name
268290 -> D.ValidDecl
269291 -> (Maybe Node, [Env.Patch])
270−declToPatches moduleName decl =
292+declToPatches moduleName (A.A region decl) =
271293 let local mkPatch x =
272294 mkPatch x (Var.local x)
273295
274296 namespaced mkPatch x =
275297 mkPatch x (Var.fromModule moduleName x)
298+
299+ patternPatch (name, args) =
300+ Env.Pattern name (Var.fromModule moduleName name, length args)
276301 in
277302 case decl of
278303 D.Definition (Valid.Definition pattern _ _) ->
@@ -286,13 +311,13 @@ declToPatches moduleName decl =
286311 ( Nothing
287312 , namespaced Env.Union name
288313 : map (local Env.Value) ctorNames
289− ++ map (namespaced Env.Pattern) ctorNames
314+ ++ map patternPatch ctors
290315 )
291316
292317 D.TypeAlias name tvars alias ->
293− ( Just (node name tvars alias)
318+ ( Just (node region name tvars alias)
294319 , case alias of
295− Type.Record _ _ ->
320+ A.A _ (Type.RRecord _ _) ->
296321 [local Env.Value name]
297322 _ ->
298323 []
src/Transform/Canonicalize/Type.hs+30−29
@@ -7,50 +7,50 @@ import qualified Data.Traversable as Trav
77import qualified AST.Type as T
88import qualified AST.Variable as Var
99
10+import qualified Reporting.Annotation as A
11+import qualified Reporting.Error.Canonicalize as Error
12+import qualified Reporting.Region as R
1013import qualified Transform.Canonicalize.Environment as Env
11−import qualified Transform.Canonicalize.Error as Error
1214import qualified Transform.Canonicalize.Result as Result
1315import qualified Transform.Canonicalize.Variable as Canonicalize
1416
1517
1618tipe
1719 :: Env.Environment
18− -> T.RawType
19− -> Result.Result T.CanonicalType
20−tipe env typ =
20+ -> T.Raw
21+ -> Result.ResultErr T.Canonical
22+tipe env typ@(A.A region typ') =
2123 let go = tipe env
2224 goSnd (name,t) =
2325 (,) name <$> go t
2426 in
25− case typ of
26− T.Var x ->
27+ case typ' of
28+ T.RVar x ->
2729 Result.ok (T.Var x)
2830
29− T.Type _ ->
30− canonicalizeApp env typ []
31+ T.RType _ ->
32+ canonicalizeApp region env typ []
3133
32− T.App t ts ->
33− canonicalizeApp env t ts
34+ T.RApp t ts ->
35+ canonicalizeApp region env t ts
3436
35− T.Lambda a b ->
37+ T.RLambda a b ->
3638 T.Lambda <$> go a <*> go b
3739
38− T.Record fields ext ->
40+ T.RRecord fields ext ->
3941 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext
4042
41− T.Aliased _ _ _ ->
42− error "a RawType should never have an alias in it"
43−
4443
4544canonicalizeApp
46− :: Env.Environment
47− -> T.RawType
48− -> [T.RawType]
49− -> Result.Result T.CanonicalType
50−canonicalizeApp env f args =
45+ :: R.Region
46+ -> Env.Environment
47+ -> T.Raw
48+ -> [T.Raw]
49+ -> Result.ResultErr T.Canonical
50+canonicalizeApp region env f args =
5151 case f of
52− T.Type (Var.Raw rawName) ->
53− Canonicalize.tvar env rawName
52+ A.A _ (T.RType (Var.Raw rawName)) ->
53+ Canonicalize.tvar region env rawName
5454 `Result.andThen` canonicalizeWithTvar
5555
5656 _ ->
@@ -60,7 +60,7 @@ canonicalizeApp env f args =
6060 canonicalizeWithTvar tvar =
6161 case tvar of
6262 Right alias ->
63− canonicalizeAlias env alias args
63+ canonicalizeAlias region env alias args
6464
6565 Left name ->
6666 case args of
@@ -71,13 +71,14 @@ canonicalizeApp env f args =
7171
7272
7373canonicalizeAlias
74− :: Env.Environment
75− -> (Var.Canonical, [String], T.CanonicalType)
76− -> [T.RawType]
77− -> Result.Result T.CanonicalType
78−canonicalizeAlias env (name, tvars, dealiasedTipe) types =
74+ :: R.Region
75+ -> Env.Environment
76+ -> (Var.Canonical, [String], T.Canonical)
77+ -> [T.Raw]
78+ -> Result.ResultErr T.Canonical
79+canonicalizeAlias region env (name, tvars, dealiasedTipe) types =
7980 if typesLen /= tvarsLen
80− then Result.err (Error.alias name tvarsLen typesLen)
81+ then Result.err (A.A region (Error.alias name tvarsLen typesLen))
8182 else toAlias <$> Trav.traverse (tipe env) types
8283 where
8384 typesLen = length types
src/Transform/Canonicalize/Variable.hs+50−34
@@ -9,50 +9,53 @@ import qualified AST.Helpers as Help
99import qualified AST.Module as Module
1010import qualified AST.Type as Type
1111import qualified AST.Variable as Var
12−import Transform.Canonicalize.Environment as Env
13−import qualified Transform.Canonicalize.Error as Error
12+import qualified Reporting.Annotation as A
13+import qualified Reporting.Error.Canonicalize as Error
14+import qualified Reporting.Region as R
15+import qualified Transform.Canonicalize.Environment as Env
1416import qualified Transform.Canonicalize.Result as Result
1517import Elm.Utils ((|>))
1618
1719
18−variable :: Environment -> String -> Result.Result Var.Canonical
19−variable env var =
20+variable :: R.Region -> Env.Environment -> String -> Result.ResultErr Var.Canonical
21+variable region env var =
2022 case toVarName var of
2123 Right (name, varName)
2224 | Module.nameIsNative name ->
2325 Result.var (Var.Canonical (Var.Module name) varName)
2426
2527 _ ->
26− case Set.toList `fmap` Map.lookup var (_values env) of
28+ case Set.toList `fmap` Map.lookup var (Env._values env) of
2729 Just [v] ->
2830 Result.var v
2931
3032 Just vs ->
31− preferLocals env "variable" vs var
33+ preferLocals region env "variable" vs var
3234
3335 Nothing ->
34− notFound "variable" (Map.keys (_values env)) var
36+ notFound region "variable" (Map.keys (Env._values env)) var
3537
3638
3739tvar
38− :: Environment
40+ :: R.Region
41+ -> Env.Environment
3942 -> String
40− -> Result.Result
43+ -> Result.ResultErr
4144 (Either
4245 Var.Canonical
43− (Var.Canonical, [String], Type.CanonicalType)
46+ (Var.Canonical, [String], Type.Canonical)
4447 )
45−tvar env var =
48+tvar region env var =
4649 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
4851 [v] -> Result.var' extract v
49− vs -> preferLocals' env extract "type" vs var
52+ vs -> preferLocals' region env extract "type" vs var
5053 where
5154 adts =
52− map Left (maybe [] Set.toList (Map.lookup var (_adts env)))
55+ map Left (maybe [] Set.toList (Map.lookup var (Env._adts env)))
5356
5457 aliases =
55− map Right (maybe [] Set.toList (Map.lookup var (_aliases env)))
58+ map Right (maybe [] Set.toList (Map.lookup var (Env._aliases env)))
5659
5760 extract value =
5861 case value of
@@ -60,39 +63,52 @@ tvar env var =
6063 Right (v,_,_) -> v
6164
6265
63−pvar :: Environment -> String -> Result.Result Var.Canonical
64−pvar env var =
65− case Set.toList `fmap` Map.lookup var (_patterns env) of
66− Just [v] ->
67− Result.var v
66+pvar
67+ :: R.Region
68+ -> Env.Environment
69+ -> String
70+ -> Int
71+ -> Result.ResultErr Var.Canonical
72+pvar region env var actualArgs =
73+ case Set.toList `fmap` Map.lookup var (Env._patterns env) of
74+ Just [value] ->
75+ foundArgCheck value
6876
69− Just vs ->
70− preferLocals env "pattern" vs var
77+ Just values ->
78+ preferLocals' region env fst "pattern" values var
79+ `Result.andThen` foundArgCheck
7180
7281 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))
7488
7589
7690-- FOUND
7791
7892preferLocals
79− :: Environment
93+ :: R.Region
94+ -> Env.Environment
8095 -> String
8196 -> [Var.Canonical]
8297 -> String
83− -> Result.Result Var.Canonical
84−preferLocals env =
85− preferLocals' env id
98+ -> Result.ResultErr Var.Canonical
99+preferLocals region env =
100+ preferLocals' region env id
86101
87102
88103preferLocals'
89− :: Environment
104+ :: R.Region
105+ -> Env.Environment
90106 -> (a -> Var.Canonical)
91107 -> String
92108 -> [a]
93109 -> String
94− -> Result.Result a
95−preferLocals' env extract kind possibilities var =
110+ -> Result.ResultErr a
111+preferLocals' region env extract kind possibilities var =
96112 case filter (isLocal . extract) possibilities of
97113 [] ->
98114 ambiguous possibilities
@@ -112,7 +128,7 @@ preferLocals' env extract kind possibilities var =
112128 name == Env._home env
113129
114130 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)))
116132 where
117133 vars = map (Var.toString . extract) possibleVars
118134
@@ -149,8 +165,8 @@ isOp name =
149165
150166-- NOT FOUND
151167
152−notFound :: String -> [String] -> String -> Result.Result a
153−notFound kind possibilities var =
168+notFound :: R.Region -> String -> [String] -> String -> Result.ResultErr a
169+notFound region kind possibilities var =
154170 let name =
155171 toVarName var
156172
@@ -165,7 +181,7 @@ notFound kind possibilities var =
165181 Right (modul, varName) ->
166182 qualifiedProblem modul varName (Either.rights possibleNames)
167183 in
168− Result.err (Error.var kind var problem)
184+ Result.err (A.A region (Error.var kind var problem))
169185
170186
171187exposedProblem :: 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 @@
11{-# OPTIONS_GHC -Wall #-}
2−module Transform.Declaration (combineAnnotations, toExpr) where
2+module Transform.Declaration (toExpr) where
33
4−import Control.Applicative ((<$>))
5−
6−import qualified AST.Annotation as A
74import qualified AST.Declaration as D
85import qualified AST.Expression.General as E
9−import qualified AST.Expression.Source as Source
10−import qualified AST.Expression.Valid as Valid
116import qualified AST.Expression.Canonical as Canonical
127import qualified AST.Module as Module
138import qualified AST.Pattern as P
149import qualified AST.Type as T
1510import qualified AST.Variable as Var
16−
17−import qualified Transform.Expression as Expr
18−import qualified Transform.Definition as Def
19−
20−
21−combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]
22−combineAnnotations =
23− go
24− where
25− errorMessage kind name =
26− "Syntax Error: The type annotation for " ++ kind ++ " '" ++
27− name ++ "' must be directly above its definition."
28−
29− exprCombineAnnotations =
30− Expr.crawlLet Def.combineAnnotations
31−
32− go decls =
33− case decls of
34− -- simple cases, pass them through with no changes
35− [] ->
36− return []
37−
38− D.Datatype name tvars ctors : rest ->
39− (:) (D.Datatype name tvars ctors) <$> go rest
40−
41− D.TypeAlias name tvars alias : rest ->
42− (:) (D.TypeAlias name tvars alias) <$> go rest
43−
44− D.Fixity assoc prec op : rest ->
45− (:) (D.Fixity assoc prec op) <$> go rest
46−
47− -- combine definitions
48− D.Definition def : defRest ->
49− case def of
50− Source.Definition pat expr ->
51− do expr' <- exprCombineAnnotations expr
52− let def' = Valid.Definition pat expr' Nothing
53− (:) (D.Definition def') <$> go defRest
54−
55− Source.TypeAnnotation name tipe ->
56− case defRest of
57− D.Definition (Source.Definition pat@(P.Var name') expr) : rest
58− | name == name' ->
59− do expr' <- exprCombineAnnotations expr
60− let def' = Valid.Definition pat expr' (Just tipe)
61− (:) (D.Definition def') <$> go rest
62−
63− _ -> Left (errorMessage "value" name)
64−
65− D.Port port : rest ->
66− case port of
67− D.PortAnnotation name tipe ->
68− case rest of
69− D.Port (D.PortDefinition name' expr) : restRest
70− | name == name' ->
71− do expr' <- exprCombineAnnotations expr
72− let port' = D.Out name expr' tipe
73− (:) (D.Port port') <$> go restRest
74−
75− _ ->
76− (:) (D.Port (D.In name tipe)) <$> go rest
77−
78− D.PortDefinition name _ ->
79− Left (errorMessage "port" name)
11+import qualified Reporting.Annotation as A
8012
8113
8214toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]
83−toExpr moduleName =
84− concatMap (toDefs moduleName)
15+toExpr moduleName decls =
16+ concatMap (toDefs moduleName) decls
8517
8618
8719toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]
88−toDefs moduleName decl =
89− let typeVar = Var.Canonical (Var.Module moduleName) in
20+toDefs moduleName (A.A region decl) =
21+ let typeVar = Var.fromModule moduleName
22+
23+ loc expr =
24+ A.A region expr
25+ in
9026 case decl of
9127 D.Definition def ->
9228 [def]
@@ -95,9 +31,9 @@ toDefs moduleName decl =
9531 concatMap toDefs' constructors
9632 where
9733 toDefs' (ctor, tipes) =
98− let vars = take (length tipes) arguments
34+ let vars = take (length tipes) infiniteArgs
9935 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
10137 in
10238 [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
10339
@@ -110,15 +46,19 @@ toDefs moduleName decl =
11046 args =
11147 map snd fields ++ maybe [] (:[]) ext
11248
113− var = A.none . E.localVar
114− vars = take (length args) arguments
49+ var = loc . E.localVar
50+ vars = take (length args) infiniteArgs
51+
52+ efields =
53+ zip (map fst fields) (map var vars)
11554
116− efields = zip (map fst fields) (map var vars)
11755 record =
11856 case ext of
119− Nothing -> A.none $ E.Record efields
57+ Nothing ->
58+ loc (E.Record efields)
59+
12060 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
12262
12363 -- Type aliases must be added to an extended equality dictionary,
12464 -- but they do not require any basic constraints.
@@ -126,7 +66,7 @@ toDefs moduleName decl =
12666 []
12767
12868 D.Port (D.CanonicalPort impl) ->
129− let body = A.none (E.Port impl)
69+ let body = loc (E.Port impl)
13070 in
13171 case impl of
13272 E.In name tipe ->
@@ -143,16 +83,19 @@ toDefs moduleName decl =
14383 []
14484
14585
146−arguments :: [String]
147−arguments =
86+infiniteArgs :: [String]
87+infiniteArgs =
14888 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
14989
15090
15191buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
152−buildFunction body@(A.A s _) vars =
153− foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
92+buildFunction body@(A.A ann _) vars =
93+ foldr
94+ (\pattern expr -> A.A ann (E.Lambda pattern expr))
95+ body
96+ (map (A.A ann . P.Var) vars)
15497
15598
156−definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
157−definition name expr tipe =
158− Canonical.Definition (P.Var name) expr (Just tipe)
99+definition :: String -> Canonical.Expr -> T.Canonical -> Canonical.Def
100+definition name expr@(A.A ann _) tipe =
101+ Canonical.Definition (A.A ann (P.Var name)) expr (Just tipe)
src/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
88import qualified Data.Maybe as Maybe
99import qualified Data.Set as Set
1010
11−import AST.Annotation
1211import AST.Expression.General (Expr'(..), PortImpl(..))
1312import qualified AST.Expression.Canonical as Canonical
1413import qualified AST.Pattern as P
1514import qualified AST.Variable as V
15+import qualified Reporting.Annotation as A
1616
1717
1818ctors :: P.CanonicalPattern -> [String]
19−ctors pattern =
19+ctors (A.A _ pattern) =
2020 case pattern of
21− P.Var _ -> []
22− P.Alias _ p -> ctors p
23− P.Record _ -> []
24− P.Anything -> []
25− P.Literal _ -> []
21+ P.Var _ ->
22+ []
23+
24+ P.Alias _ p ->
25+ ctors p
26+
27+ P.Record _ ->
28+ []
29+
30+ P.Anything ->
31+ []
32+
33+ P.Literal _ ->
34+ []
35+
2636 P.Data (V.Canonical home name) ps ->
2737 case home of
2838 V.Local -> name : rest
@@ -45,9 +55,11 @@ freeIfLocal (V.Canonical home name) =
4555 V.Module _ -> return ()
4656
4757
48−bound :: Set.Set String -> State (Set.Set String) ()
49−bound boundVars =
50− modify (\freeVars -> Set.difference freeVars boundVars)
58+bound :: P.CanonicalPattern -> State (Set.Set String) ()
59+bound pattern =
60+ let boundVars = P.boundVarSet pattern
61+ in
62+ modify (\freeVars -> Set.difference freeVars boundVars)
5163
5264
5365sortDefs :: Canonical.Expr -> Canonical.Expr
@@ -56,8 +68,8 @@ sortDefs expression =
5668
5769
5870reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
59−reorder (A ann expression) =
60− A ann <$>
71+reorder (A.A ann expression) =
72+ A.A ann <$>
6173 case expression of
6274 -- Be careful adding and restricting freeVars
6375 Var var ->
@@ -140,11 +152,11 @@ reorder (A ann expression) =
140152
141153 -- remove let-bound variables from the context
142154 forM_ defs $ \(Canonical.Definition pattern _ _) -> do
143− bound (P.boundVars pattern)
155+ bound pattern
144156 mapM free (ctors pattern)
145157
146− let A _ let' =
147− foldr (\ds bod -> A ann (Let ds bod)) body' defss
158+ let (A.A _ let') =
159+ foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
148160
149161 return let'
150162
@@ -154,7 +166,7 @@ bindingReorder
154166 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
155167bindingReorder (pattern,expr) =
156168 do expr' <- reorder expr
157− bound (P.boundVars pattern)
169+ bound pattern
158170 mapM_ free (ctors pattern)
159171 return (pattern, expr')
160172
@@ -187,7 +199,7 @@ buildDefDict defs =
187199
188200 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
189201 variableToKey (Canonical.Definition pattern _ _, key, _) =
190− [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
202+ [ (var, key) | var <- P.boundVarList pattern ]
191203
192204 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
193205 variableToKeyMap pdefsDeps =
src/Transform/Substitute.hs+22−15
@@ -2,18 +2,18 @@
22module Transform.Substitute (subst) where
33
44import Control.Arrow (second, (***))
5−import qualified Data.Set as Set
65
7−import AST.Annotation
86import AST.Expression.General (Expr'(..), PortImpl(..))
97import qualified AST.Expression.Canonical as Canonical
108import qualified AST.Pattern as Pattern
119import qualified AST.Variable as V
10+import Elm.Utils ((|>))
11+import qualified Reporting.Annotation as A
1212
1313
1414subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'
1515subst old new expression =
16− let f (A a e) = A a (subst old new e) in
16+ let f (A.A a e) = A.A a (subst old new e) in
1717 case expression of
1818 Range e1 e2 ->
1919 Range (f e1) (f e2)
@@ -24,9 +24,10 @@ subst old new expression =
2424 Binop op e1 e2 ->
2525 Binop op (f e1) (f e2)
2626
27− Lambda pattern body
28− | Set.member old (Pattern.boundVars pattern) -> expression
29− | otherwise -> Lambda pattern (f body)
27+ Lambda pattern body ->
28+ if Pattern.member old pattern
29+ then expression
30+ else Lambda pattern (f body)
3031
3132 App e1 e2 ->
3233 App (f e1) (f e2)
@@ -34,28 +35,34 @@ subst old new expression =
3435 MultiIf branches ->
3536 MultiIf (map (f *** f) branches)
3637
37− Let defs body
38− | anyShadow -> expression
39− | otherwise -> Let (map substDef defs) (f body)
38+ Let defs body ->
39+ if anyShadow
40+ then expression
41+ else Let (map substDef defs) (f body)
4042 where
4143 substDef (Canonical.Definition p e t) =
4244 Canonical.Definition p (f e) t
4345
4446 anyShadow =
45− any (Set.member old . Pattern.boundVars)
46− [ pattern | Canonical.Definition pattern _ _ <- defs ]
47+ map (\(Canonical.Definition p _ _) -> p) defs
48+ |> any (Pattern.member old)
4749
4850 Var (V.Canonical home x) ->
4951 case home of
50− V.Module _ -> expression
51− V.BuiltIn -> expression
52− V.Local -> if x == old then new else expression
52+ V.Module _ ->
53+ expression
54+
55+ V.BuiltIn ->
56+ expression
57+
58+ V.Local ->
59+ if x == old then new else expression
5360
5461 Case e cases ->
5562 Case (f e) (map substCase cases)
5663 where
5764 substCase (pattern, expr) =
58− if Set.member old (Pattern.boundVars pattern)
65+ if Pattern.member old pattern
5966 then (pattern, expr)
6067 else (pattern, f expr)
6168
src/Type/Constrain/Expression.hs+113−105
@@ -3,103 +3,102 @@ module Type.Constrain.Expression where
33
44import Control.Applicative ((<$>))
55import qualified Control.Monad as Monad
6−import Control.Monad.Error
76import qualified Data.List as List
87import qualified Data.Map as Map
9−import Prelude hiding (and)
10−import qualified Text.PrettyPrint as PP
118
12−import qualified AST.Literal as Lit
13−import AST.Annotation as Ann
14−import AST.Expression.General
9+import qualified AST.Expression.General as E
1510import qualified AST.Expression.Canonical as Canonical
11+import qualified AST.Literal as Lit
1612import qualified AST.Pattern as P
1713import qualified AST.Type as ST
1814import qualified AST.Variable as V
19−import Type.Type hiding (Descriptor(..))
20−import qualified Type.Fragment as Fragment
21−import qualified Type.Environment as Env
15+import qualified Reporting.Annotation as A
2216import qualified Type.Constrain.Literal as Literal
2317import 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(..))
2421
2522
2623constrain
2724 :: Env.Environment
2825 -> Canonical.Expr
2926 -> Type
30− -> ErrorT [PP.Doc] IO TypeConstraint
31−constrain env (A region expression) tipe =
27+ -> IO TypeConstraint
28+constrain env (A.A region expression) tipe =
3229 let list t = Env.get env Env.types "List" <| t
33− and = A region . CAnd
34− true = A region CTrue
35− t1 === t2 = A region (CEqual t1 t2)
36− x <? t = A region (CInstance x t)
37− clet schemes c = A region (CLet schemes c)
30+ (===) = CEqual region
31+ (<?) = CInstance region
3832 in
3933 case expression of
40− Literal lit ->
41− liftIO $ Literal.constrain env region lit tipe
34+ E.Literal lit ->
35+ Literal.constrain env region lit tipe
4236
43− GLShader _uid _src gltipe ->
37+ E.GLShader _uid _src gltipe ->
4438 exists $ \attr ->
4539 exists $ \unif ->
4640 let
47− shaderTipe a u v = Env.get env Env.types "WebGL.Shader" <| a <| u <| v
48− glTipe = Env.get env Env.types . Lit.glTipeName
49− makeRec accessor baseRec =
50− let decls = accessor gltipe
51− in if Map.size decls == 0
52− then baseRec
53− else record (Map.map (\t -> [glTipe t]) decls) baseRec
54− attribute = makeRec Lit.attribute attr
55− uniform = makeRec Lit.uniform unif
56− varying = makeRec Lit.varying (termN EmptyRecord1)
41+ shaderTipe a u v =
42+ Env.get env Env.types "WebGL.Shader" <| a <| u <| v
43+
44+ glTipe =
45+ Env.get env Env.types . Lit.glTipeName
46+
47+ makeRec accessor baseRec =
48+ let decls = accessor gltipe
49+ in
50+ if Map.size decls == 0
51+ then baseRec
52+ else record (Map.map (\t -> [glTipe t]) decls) baseRec
53+
54+ attribute = makeRec Lit.attribute attr
55+ uniform = makeRec Lit.uniform unif
56+ varying = makeRec Lit.varying (termN EmptyRecord1)
5757 in
58− return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
58+ return (tipe === shaderTipe attribute uniform varying)
5959
60− Var var
61− | name == saveEnvName -> return (A region CSaveEnv)
62− | otherwise -> return (name <? tipe)
63− where
64− name = V.toString var
60+ E.Var var ->
61+ let name = V.toString var
62+ in
63+ return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
6564
66− Range lo hi ->
65+ E.Range lo hi ->
6766 existsNumber $ \n ->
6867 do clo <- constrain env lo n
6968 chi <- constrain env hi n
70− return $ and [clo, chi, list n === tipe]
69+ return $ CAnd [clo, chi, list n === tipe]
7170
72− ExplicitList exprs ->
71+ E.ExplicitList exprs ->
7372 exists $ \x ->
7473 do constraints <- mapM (\e -> constrain env e x) exprs
75− return . and $ list x === tipe : constraints
74+ return $ CAnd (list x === tipe : constraints)
7675
77− Binop op e1 e2 ->
76+ E.Binop op e1 e2 ->
7877 exists $ \t1 ->
7978 exists $ \t2 ->
8079 do c1 <- constrain env e1 t1
8180 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) ]
8382
84− Lambda p e ->
83+ E.Lambda pattern body ->
8584 exists $ \t1 ->
8685 exists $ \t2 ->
87− do fragment <- try region $ Pattern.constrain env p t1
88− c2 <- constrain env e t2
86+ do fragment <- Pattern.constrain env pattern t1
87+ c2 <- constrain env body t2
8988 let c = ex (Fragment.vars fragment)
90− (clet [monoscheme (Fragment.typeEnv fragment)]
89+ (CLet [monoscheme (Fragment.typeEnv fragment)]
9190 (Fragment.typeConstraint fragment /\ c2)
9291 )
9392 return $ c /\ tipe === (t1 ==> t2)
9493
95− App e1 e2 ->
94+ E.App e1 e2 ->
9695 exists $ \t ->
9796 do c1 <- constrain env e1 (t ==> tipe)
9897 c2 <- constrain env e2 t
9998 return $ c1 /\ c2
10099
101− MultiIf branches ->
102− and <$> mapM constrain' branches
100+ E.MultiIf branches ->
101+ CAnd <$> mapM constrain' branches
103102 where
104103 bool = Env.get env Env.types "Bool"
105104
@@ -108,107 +107,116 @@ constrain env (A region expression) tipe =
108107 ce <- constrain env expr tipe
109108 return (cb /\ ce)
110109
111− Case expr branches ->
110+ E.Case expr branches ->
112111 exists $ \t ->
113− do ce <- constrain env expr t
114− and . (:) ce <$> mapM (branch t) branches
112+ do exprConstraint <- constrain env expr t
113+ branchConstraints <- mapM (branch t) branches
114+ return (CAnd (exprConstraint : branchConstraints))
115115 where
116116 branch t (pattern, branchExpr) =
117− do fragment <- try region $ Pattern.constrain env pattern t
118− clet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe
117+ do fragment <- Pattern.constrain env pattern t
118+ CLet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe
119119
120− Data name exprs ->
121− do vars <- forM exprs $ \_ -> liftIO (variable Flexible)
120+ E.Data name exprs ->
121+ do vars <- Monad.forM exprs $ \_ -> variable Flexible
122122 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)
124124 return $ ex vars (cs /\ name <? ctipe)
125125 where
126126 step (t,c) (e,x) =
127127 do c' <- constrain env e x
128128 return (x ==> t, c /\ c')
129129
130− Access expr label ->
130+ E.Access expr label ->
131131 exists $ \t ->
132132 constrain env expr (record (Map.singleton label [tipe]) t)
133133
134− Remove expr label ->
134+ E.Remove expr label ->
135135 exists $ \t ->
136136 constrain env expr (record (Map.singleton label [t]) tipe)
137137
138− Insert expr label value ->
138+ E.Insert expr label value ->
139139 exists $ \tVal ->
140140 exists $ \tRec ->
141141 do cVal <- constrain env value tVal
142142 cRec <- constrain env expr tRec
143143 let c = tipe === record (Map.singleton label [tVal]) tRec
144− return (and [cVal, cRec, c])
144+ return (CAnd [cVal, cRec, c])
145145
146− Modify expr fields ->
146+ E.Modify expr fields ->
147147 exists $ \t ->
148− do oldVars <- forM fields $ \_ -> liftIO (variable Flexible)
148+ do oldVars <- Monad.forM fields $ \_ -> variable Flexible
149149 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))
150150 cOld <- ex oldVars <$> constrain env expr (record oldFields t)
151151
152− newVars <- forM fields $ \_ -> liftIO (variable Flexible)
152+ newVars <- Monad.forM fields $ \_ -> variable Flexible
153153 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))
154154 let cNew = tipe === record newFields t
155155
156− cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)
156+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)
157157
158− return $ cOld /\ ex newVars (and (cNew : cs))
158+ return $ cOld /\ ex newVars (CAnd (cNew : cs))
159159
160− Record fields ->
161− do vars <- forM fields $ \_ -> liftIO (variable Flexible)
162− cs <- zipWithM (constrain env) (map snd fields) (map varN vars)
160+ E.Record fields ->
161+ do vars <- Monad.forM fields $ \_ -> variable Flexible
162+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN vars)
163163 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
164164 let recordType = record fields' (termN EmptyRecord1)
165− return . ex vars . and $ tipe === recordType : cs
165+ return . ex vars . CAnd $ tipe === recordType : cs
166166
167− Let defs body ->
167+ E.Let defs body ->
168168 do c <- constrain env body tipe
169169
170170 (Info schemes rqs fqs headers c2 c1) <-
171171 Monad.foldM
172172 (constrainDef env)
173− (Info [] [] [] Map.empty true true)
173+ (Info [] [] [] Map.empty CTrue CTrue)
174174 (concatMap expandPattern defs)
175175
176− let letScheme = [ Scheme rqs fqs (clet [monoscheme headers] c2) headers ]
176+ let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
177177
178− return $ clet schemes (clet letScheme (c1 /\ c))
178+ return $ CLet schemes (CLet letScheme (c1 /\ c))
179179
180− Port impl ->
180+ E.Port impl ->
181181 case impl of
182− In _ _ ->
183− return true
182+ E.In _ _ ->
183+ return CTrue
184184
185− Out _ expr _ ->
185+ E.Out _ expr _ ->
186186 constrain env expr tipe
187187
188− Task _ expr _ ->
188+ E.Task _ expr _ ->
189189 constrain env expr tipe
190190
191191
192192expandPattern :: Canonical.Def -> [Canonical.Def]
193−expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =
194− case pattern of
195− P.Var _ ->
196− [def]
197− _ ->
198− Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars
199− where
200− vars = P.boundVarList pattern
201− x = "$" ++ concat vars
202− mkVar = A r . localVar
203− toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
193+expandPattern def@(Canonical.Definition lpattern expr maybeType) =
194+ let (A.A patternRegion pattern) = lpattern
195+ in
196+ case pattern of
197+ P.Var _ ->
198+ [def]
199+
200+ _ ->
201+ mainDef : map toDef vars
202+ where
203+ vars = P.boundVarList lpattern
204204
205+ combinedName = "$" ++ concat vars
205206
206−try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
207−try region computation =
208− do result <- liftIO $ runErrorT computation
209− case result of
210− Left err -> throwError [err region]
211− Right value -> return value
207+ pvar name =
208+ A.A patternRegion (P.Var name)
209+
210+ localVar name =
211+ A.A patternRegion (E.localVar name)
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
212220
213221
214222-- CONSTRAIN DEFINITIONS
@@ -223,8 +231,8 @@ data Info = Info
223231 }
224232
225233
226−constrainDef :: Env.Environment -> Info -> Canonical.Def -> ErrorT [PP.Doc] IO Info
227−constrainDef env info (Canonical.Definition pattern expr maybeTipe) =
234+constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
235+constrainDef env info (Canonical.Definition (A.A _ pattern) expr maybeTipe) =
228236 let qs = [] -- should come from the def, but I'm not sure what would live there...
229237 in
230238 case (pattern, maybeTipe) of
@@ -243,13 +251,13 @@ constrainAnnotatedDef
243251 -> [String]
244252 -> String
245253 -> Canonical.Expr
246− -> ST.CanonicalType
247− -> ErrorT [PP.Doc] IO Info
254+ -> ST.Canonical
255+ -> IO Info
248256constrainAnnotatedDef env info qs name expr tipe =
249257 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)
251259
252− flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)
260+ flexiVars <- Monad.forM qs (\_ -> variable Flexible)
253261
254262 let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars
255263
@@ -261,7 +269,7 @@ constrainAnnotatedDef env info qs name expr tipe =
261269 Scheme
262270 { rigidQuantifiers = []
263271 , flexibleQuantifiers = flexiVars ++ vars
264− , constraint = Ann.noneNoDocs CTrue
272+ , constraint = CTrue
265273 , header = Map.singleton name typ
266274 }
267275
@@ -279,12 +287,12 @@ constrainUnannotatedDef
279287 -> [String]
280288 -> String
281289 -> Canonical.Expr
282− -> ErrorT [PP.Doc] IO Info
290+ -> IO Info
283291constrainUnannotatedDef env info qs name expr =
284292 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)
286294
287− v <- liftIO $ variable Flexible
295+ v <- variable Flexible
288296
289297 let tipe = varN v
290298
src/Type/Constrain/Literal.hs+23−16
@@ -1,21 +1,28 @@
11module Type.Constrain.Literal where
22
3−import AST.Annotation
4−import AST.Literal
5−import Type.Type
6−import Type.Environment as Env
3+import qualified AST.Literal as L
4+import qualified Reporting.Region as R
5+import qualified Type.Type as T
6+import qualified Type.Environment as Env
77
8−constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
8+
9+constrain
10+ :: Env.Environment
11+ -> R.Region
12+ -> L.Literal
13+ -> T.Type
14+ -> IO T.TypeConstraint
915constrain env region literal tipe =
10− do tipe' <- litType
11− return . A region $ CEqual tipe tipe'
12− where
13− prim name = return (Env.get env Env.types name)
16+ do tipe' <- litType
17+ return (T.CEqual region tipe tipe')
18+ where
19+ prim name =
20+ return (Env.get env Env.types name)
1421
15− litType =
16− case literal of
17− IntNum _ -> varN `fmap` variable (Is Number)
18− FloatNum _ -> prim "Float"
19− Chr _ -> prim "Char"
20− Str _ -> prim "String"
21− Boolean _ -> prim "Bool"
22+ litType =
23+ case literal of
24+ L.IntNum _ -> T.varN `fmap` T.variable (T.Is T.Number)
25+ L.FloatNum _ -> prim "Float"
26+ L.Chr _ -> prim "Char"
27+ L.Str _ -> prim "String"
28+ L.Boolean _ -> prim "Bool"
src/Type/Constrain/Pattern.hs+51−62
@@ -4,78 +4,67 @@ module Type.Constrain.Pattern where
44import Control.Arrow (second)
55import Control.Applicative ((<$>))
66import qualified Control.Monad as Monad
7−import Control.Monad.Error
87import qualified Data.Map as Map
9−import qualified Text.PrettyPrint as PP
108
11−import qualified AST.Annotation as A
129import qualified AST.Pattern as P
1310import qualified AST.Variable as V
14−import AST.PrettyPrint (pretty)
15−import Type.Type
16−import Type.Fragment
17−import Type.Environment as Env
11+import qualified Reporting.Annotation as A
1812import qualified Type.Constrain.Literal as Literal
13+import qualified Type.Environment as Env
14+import Type.Fragment
15+import Type.Type
1916
2017
21−constrain :: Environment -> P.CanonicalPattern -> Type
22− -> ErrorT (A.Region -> PP.Doc) IO Fragment
23−constrain env pattern tipe =
24− let region = A.None (pretty pattern)
25− t1 === t2 = A.A region (CEqual t1 t2)
26− in
27− case pattern of
28− P.Anything -> return emptyFragment
29−
30− P.Literal lit -> do
31− c <- liftIO $ Literal.constrain env region lit tipe
32− return $ emptyFragment { typeConstraint = c }
18+constrain
19+ :: Env.Environment
20+ -> P.CanonicalPattern
21+ -> Type
22+ -> IO Fragment
23+constrain env (A.A region pattern) tipe =
24+ let (===) = CEqual region
25+ in
26+ case pattern of
27+ P.Anything ->
28+ return emptyFragment
3329
34− P.Var name -> do
35− v <- liftIO $ variable Flexible
36− return $ Fragment {
37− typeEnv = Map.singleton name (varN v),
38− vars = [v],
39− typeConstraint = varN v === tipe
40− }
30+ P.Literal lit ->
31+ do c <- Literal.constrain env region lit tipe
32+ return $ emptyFragment { typeConstraint = c }
4133
42− P.Alias name p -> do
43− v <- liftIO $ variable Flexible
44− fragment <- constrain env p tipe
45− return $ fragment
46− { typeEnv = Map.insert name (varN v) (typeEnv fragment)
47− , vars = v : vars fragment
48− , typeConstraint = varN v === tipe /\ typeConstraint fragment
49− }
34+ P.Var name ->
35+ do v <- variable Flexible
36+ return $ Fragment
37+ { typeEnv = Map.singleton name (varN v)
38+ , vars = [v]
39+ , typeConstraint = varN v === tipe
40+ }
5041
51− P.Data name patterns -> do
52− (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)
53− let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind
54− , " argument", if kind == 1 then "" else "s"
55− , " but was given ", show (length patterns), "." ]
56− err span = PP.vcat [ PP.text $ "Type error " ++ show span
57− , PP.text msg ]
58− case length patterns == kind of
59− False -> throwError err
60− True -> do
61− fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
62− return $ fragment {
63− typeConstraint = typeConstraint fragment /\ tipe === result,
64− vars = cvars ++ vars fragment
42+ P.Alias name p ->
43+ do v <- variable Flexible
44+ fragment <- constrain env p tipe
45+ return $ fragment
46+ { typeEnv = Map.insert name (varN v) (typeEnv fragment)
47+ , vars = v : vars fragment
48+ , typeConstraint = varN v === tipe /\ typeConstraint fragment
6549 }
6650
67− P.Record fields -> do
68− pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields
69− let tenv = Map.fromList (map (second varN) pairs)
70− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
71− return $ Fragment {
72− typeEnv = tenv,
73− vars = map snd pairs,
74− typeConstraint = c
75− }
51+ P.Data name patterns ->
52+ do (_kind, cvars, args, result) <-
53+ Env.freshDataScheme env (V.toString name)
54+
55+ fragList <- Monad.zipWithM (constrain env) patterns args
56+ let fragment = joinFragments fragList
57+ return $ fragment
58+ { typeConstraint = typeConstraint fragment /\ tipe === result
59+ , vars = cvars ++ vars fragment
60+ }
7661
77−instance Error (A.Region -> PP.Doc) where
78− noMsg _ = PP.empty
79− strMsg str span =
80− PP.vcat [ PP.text $ "Type error " ++ show span
81− , PP.text str ]
62+ P.Record fields ->
63+ do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields
64+ let tenv = Map.fromList (map (second varN) pairs)
65+ c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
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 @@
11module Type.Environment where
22
33import Control.Applicative ((<$>), (<*>))
4−import Control.Exception (try, SomeException)
5−import Control.Monad
6−import Control.Monad.Error (ErrorT, throwError, liftIO)
4+import Control.Monad (forM)
75import qualified Control.Monad.State as State
86import qualified Data.Traversable as Traverse
97import qualified Data.Map as Map
108import qualified Data.Set as Set
119import Data.List (isPrefixOf)
12−import qualified Text.PrettyPrint as PP
1310
1411import qualified AST.Type as T
1512import qualified AST.Variable as V
16−import AST.Module (CanonicalAdt, AdtInfo)
13+import qualified AST.Module as Module
1714import Type.Type
1815
1916
@@ -28,7 +25,7 @@ data Environment = Environment
2825 }
2926
3027
31−initialEnvironment :: [CanonicalAdt] -> IO Environment
28+initialEnvironment :: [Module.CanonicalAdt] -> IO Environment
3229initialEnvironment datatypes =
3330 do types <- makeTypes datatypes
3431 let env =
@@ -40,13 +37,13 @@ initialEnvironment datatypes =
4037 return $ env { constructor = makeConstructors env datatypes }
4138
4239
43−makeTypes :: [CanonicalAdt] -> IO TypeDict
40+makeTypes :: [Module.CanonicalAdt] -> IO TypeDict
4441makeTypes datatypes =
4542 do adts <- mapM makeImported datatypes
4643 bs <- mapM makeBuiltin builtins
4744 return (Map.fromList (adts ++ bs))
4845 where
49− makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
46+ makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)
5047 makeImported (var, _) =
5148 do tvar <- namedVar Constant var
5249 return (V.toString var, varN tvar)
@@ -70,7 +67,7 @@ makeTypes datatypes =
7067
7168makeConstructors
7269 :: Environment
73− -> [CanonicalAdt]
70+ -> [Module.CanonicalAdt]
7471 -> Map.Map String (IO (Int, [Variable], [Type], Type))
7572makeConstructors env datatypes =
7673 Map.fromList builtins
@@ -98,18 +95,18 @@ makeConstructors env datatypes =
9895
9996ctorToType
10097 :: Environment
101− -> (V.Canonical, AdtInfo V.Canonical)
98+ -> (V.Canonical, Module.AdtInfo V.Canonical)
10299 -> [(String, IO (Int, [Variable], [Type], Type))]
103100ctorToType env (name, (tvars, ctors)) =
104101 zip (map (V.toString . fst) ctors) (map inst ctors)
105102 where
106− inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
103+ inst :: (V.Canonical, [T.Canonical]) -> IO (Int, [Variable], [Type], Type)
107104 inst ctor =
108105 do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
109106 return (length args, Map.elems dict, args, tipe)
110107
111108
112− go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
109+ go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)
113110 go (_, args) =
114111 do types <- mapM (instantiator env) args
115112 returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
@@ -133,22 +130,17 @@ freshDataScheme env name =
133130
134131instantiateType
135132 :: Environment
136− -> T.CanonicalType
133+ -> T.Canonical
137134 -> VarDict
138− -> ErrorT [PP.Doc] IO ([Variable], Type)
135+ -> IO ([Variable], Type)
139136instantiateType env sourceType dict =
140− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
141− case result :: Either SomeException (Type, VarDict) of
142− Left someError ->
143− throwError [ PP.text $ show someError ]
144−
145− Right (tipe, dict') ->
146− return (Map.elems dict', tipe)
137+ do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict
138+ return (Map.elems dict', tipe)
147139
148140
149141instantiator
150142 :: Environment
151− -> T.CanonicalType
143+ -> T.Canonical
152144 -> State.StateT VarDict IO Type
153145instantiator env sourceType =
154146 instantiatorHelp env Set.empty sourceType
@@ -157,7 +149,7 @@ instantiator env sourceType =
157149instantiatorHelp
158150 :: Environment
159151 -> Set.Set String
160− -> T.CanonicalType
152+ -> T.Canonical
161153 -> State.StateT VarDict IO Type
162154instantiatorHelp env aliasVars sourceType =
163155 let go = instantiatorHelp env aliasVars
src/Type/ExtraChecks.hs+11−93
@@ -1,45 +1,26 @@
11{-# OPTIONS_GHC -Wall #-}
22
33{-| This module contains checks to be run *after* type inference has completed
4−successfully. At that point we still need to do occurs checks and ensure that
5−`main` has an acceptable type.
4+successfully. At that point we still need to ensure that `main` has an
5+acceptable type.
66-}
7−module Type.ExtraChecks (effectTypes, occurs) where
7+module Type.ExtraChecks (mainType) where
88
99import Prelude hiding (maybe)
10−import Control.Applicative ((<$>),(<*>))
11−import Control.Monad.Error
12−import Control.Monad.State
10+import Control.Monad.Except (ExceptT, throwError)
1311import 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
1712
18−import qualified AST.Annotation as A
19−import qualified AST.PrettyPrint as PP
2013import qualified AST.Type as ST
2114import 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'
3415
3516
3617-- MAIN TYPE
3718
38−mainCheck
19+mainType
3920 :: (Monad m)
40− => Map.Map String ST.CanonicalType
41− -> ErrorT [P.Doc] m ()
42−mainCheck env =
21+ => Map.Map String ST.Canonical
22+ -> ExceptT ST.Canonical m ()
23+mainType env =
4324 case Map.lookup "main" env of
4425 Nothing ->
4526 return ()
@@ -49,10 +30,10 @@ mainCheck env =
4930 in
5031 if tipe `elem` validMainTypes
5132 then return ()
52− else throwError [ badMainMessage typeOfMain ]
33+ else throwError typeOfMain
5334
5435
55−validMainTypes :: [ST.CanonicalType]
36+validMainTypes :: [ST.Canonical]
5637validMainTypes =
5738 [ element
5839 , html
@@ -60,7 +41,7 @@ validMainTypes =
6041 , signal html
6142 ]
6243 where
63− fromModule :: [String] -> String -> ST.CanonicalType
44+ fromModule :: [String] -> String -> ST.Canonical
6445 fromModule home name =
6546 ST.Type (Var.fromModule home name)
6647
@@ -95,66 +76,3 @@ validMainTypes =
9576 )
9677 ]
9778 Nothing
98−
99−
100−badMainMessage :: ST.CanonicalType -> P.Doc
101−badMainMessage typeOfMain =
102− P.vcat
103− [ P.text "Type Error: 'main' must have one of the following types:"
104− , P.text " "
105− , P.text " Element, Html, Signal Element, Signal Html"
106− , P.text " "
107− , P.text "Instead 'main' has type:\n"
108− , P.nest 4 (PP.pretty typeOfMain)
109− , P.text " "
110− ]
111−
112−
113−-- INFINITE TYPES
114−
115−occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
116−occurs (name, variable) =
117− do vars <- liftIO $ infiniteVars [] variable
118− case vars of
119− [] ->
120− return ()
121−
122− var : _ ->
123− do desc <- liftIO $ UF.descriptor var
124− case TT.structure desc of
125− Nothing ->
126− TS.addHint (P.text msg)
127−
128− Just _ ->
129− do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
130− var' <- liftIO $ UF.fresh desc
131− hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
132− TS.addHint hint
133− where
134− msg = "Infinite types are not allowed"
135−
136− infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
137− infiniteVars seen var =
138− let go = infiniteVars (var:seen) in
139− if var `elem` seen
140− then return [var]
141− else do
142− desc <- UF.descriptor var
143− case TT.structure desc of
144− Nothing -> return []
145− Just struct ->
146− case struct of
147− TT.App1 a b ->
148− (++) <$> go a <*> go b
149−
150− TT.Fun1 a b ->
151− (++) <$> go a <*> go b
152−
153− TT.Var1 a ->
154− go a
155−
156− TT.EmptyRecord1 ->
157− return []
158−
159− TT.Record1 fields ext ->
160− concat <$> mapM go (ext : concat (Map.elems fields))
src/Type/Fragment.hs+11−11
@@ -5,32 +5,32 @@ import qualified Data.List as List
55import qualified Data.Map as Map
66
77import Type.Type
8−import AST.Annotation (noneNoDocs)
8+
99
1010data Fragment = Fragment
11− { typeEnv :: Map.Map String Type
12− , vars :: [Variable]
11+ { typeEnv :: Map.Map String Type
12+ , vars :: [Variable]
1313 , typeConstraint :: TypeConstraint
1414 }
1515
1616
1717emptyFragment :: Fragment
1818emptyFragment =
19− Fragment Map.empty [] (noneNoDocs CTrue)
19+ Fragment Map.empty [] CTrue
2020
2121
2222joinFragment :: Fragment -> Fragment -> Fragment
2323joinFragment f1 f2 =
2424 Fragment
25− { typeEnv =
26− Map.union (typeEnv f1) (typeEnv f2)
25+ { typeEnv =
26+ Map.union (typeEnv f1) (typeEnv f2)
2727
28− , vars =
29− vars f1 ++ vars f2
28+ , vars =
29+ vars f1 ++ vars f2
3030
31− , typeConstraint =
32− typeConstraint f1 /\ typeConstraint f2
33− }
31+ , typeConstraint =
32+ typeConstraint f1 /\ typeConstraint f2
33+ }
3434
3535
3636joinFragments :: [Fragment] -> Fragment
src/Type/Hint.hsdeleted−35
@@ -1,35 +0,0 @@
1−module Type.Hint where
2−
3−import Control.Applicative ( (<$>) )
4−import qualified Data.UnionFind.IO as UF
5−import Text.PrettyPrint as P
6−
7−import qualified AST.Annotation as A
8−import AST.PrettyPrint (pretty)
9−import Type.Type (Descriptor, toSrcType)
10−
11−
12−type Hint = Doc
13−
14−
15−create
16− :: A.Region
17− -> Maybe String
18− -> UF.Point Descriptor
19− -> UF.Point Descriptor
20− -> IO Hint
21−create region hint t1 t2 =
22− do t1' <- pretty <$> toSrcType t1
23− t2' <- pretty <$> toSrcType t2
24− return . foldr ($+$) P.empty $
25− [ P.text "Type mismatch between the following types" <+> pretty region <> P.text ":"
26− , P.text ""
27− , P.nest 8 t1'
28− , P.text ""
29− , P.nest 8 t2'
30− , P.text ""
31− , maybe P.empty (P.nest 4 . P.text) hint
32− , P.text " It is related to the following expression:"
33− , P.text ""
34− , P.nest 8 $ A.getRegionDocs region
35− ]
src/Type/Inference.hs+41−28
@@ -1,15 +1,15 @@
11module Type.Inference where
22
33import Control.Arrow (first, second)
4−import Control.Monad.State (execStateT, forM)
5−import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)
4+import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError, withExceptT)
65import qualified Data.Map as Map
7−import Text.PrettyPrint
6+import qualified Data.Traversable as Traverse
87
9−import qualified AST.Annotation as A
108import AST.Module as Module
11−import AST.Type (CanonicalType)
9+import qualified AST.Type as Type
1210import qualified AST.Variable as Var
11+import qualified Reporting.Annotation as A
12+import qualified Reporting.Error.Type as Error
1313import qualified Type.Constrain.Expression as TcExpr
1414import qualified Type.Environment as Env
1515import qualified Type.ExtraChecks as Check
@@ -22,50 +22,63 @@ import System.IO.Unsafe
2222 -- I don't think that'd be worthwhile though.
2323
2424
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)
2629infer interfaces modul =
27− unsafePerformIO $ runErrorT $
28− do (header, constraint) <- genConstraints interfaces modul
30+ either throwError return $ unsafePerformIO $ runExceptT $
31+ do (header, constraint) <-
32+ liftIO (genConstraints interfaces modul)
2933
30− state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
31−
32− () <- case TS.sHint state of
33− hints@(_:_) -> throwError hints
34− [] -> return ()
34+ state <- Solve.solve constraint
3535
3636 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)
3841
39− Check.effectTypes types
42+ withExceptT
43+ (\tipe -> [A.A (error "TODO:infer") (Error.BadMain tipe)])
44+ (Check.mainType srcTypes)
45+
46+ return srcTypes
4047
4148
4249genConstraints
4350 :: Interfaces
4451 -> CanonicalModule
45− -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)
52+ -> IO (Env.TypeDict, T.TypeConstraint)
4653genConstraints interfaces modul =
47− do env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
54+ do env <-
55+ Env.initialEnvironment (canonicalizeAdts interfaces modul)
4856
49− ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
50− (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
51− return (name, (vars, foldr (T.==>) result args))
57+ ctors <-
58+ forM (Map.keys (Env.constructor env)) $ \name ->
59+ do (_, vars, args, result) <- Env.freshDataScheme env name
60+ return (name, (vars, foldr (T.==>) result args))
5261
53− importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
62+ importedVars <-
63+ mapM (canonicalizeValues env) (Map.toList interfaces)
5464
5565 let allTypes = concat (ctors : importedVars)
56− vars = concatMap (fst . snd) allTypes
57− header = Map.map snd (Map.fromList allTypes)
58− environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
66+ let vars = concatMap (fst . snd) allTypes
67+ let header = Map.map snd (Map.fromList allTypes)
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)
5974
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)
6376
6477
6578canonicalizeValues
6679 :: Env.Environment
6780 -> (Module.Name, Interface)
68− -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
81+ -> IO [(String, ([T.Variable], T.Type))]
6982canonicalizeValues env (moduleName, iface) =
7083 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
7184 do tipe' <- Env.instantiateType env tipe Map.empty
src/Type/Solve.hs+146−89
@@ -1,29 +1,32 @@
11module Type.Solve (solve) where
22
3+import Control.Applicative ((<$>), (<*>))
34import Control.Monad
4−import Control.Monad.State
5+import Control.Monad.State (StateT, execStateT, liftIO)
6+import Control.Monad.Except (ExceptT, throwError)
57import qualified Data.List as List
68import qualified Data.Map as Map
79import qualified Data.Traversable as Traversable
810import qualified Data.UnionFind.IO as UF
11+
12+import qualified Reporting.Annotation as A
13+import qualified Reporting.Error.Type as Error
14+import qualified Type.State as TS
915import Type.Type
1016import Type.Unify
11−import qualified Type.ExtraChecks as Check
12−import qualified Type.Hint as Hint
13−import qualified Type.State as TS
14−import qualified AST.Annotation as A
1517
1618
17−-- | Every variable has rank less than or equal to the maxRank of the pool.
18−-- This sorts variables into the young and old pools accordingly.
19+{-| Every variable has rank less than or equal to the maxRank of the pool.
20+This sorts variables into the young and old pools accordingly.
21+-}
1922generalize :: TS.Pool -> StateT TS.SolverState IO ()
2023generalize youngPool =
21− do youngMark <- TS.uniqueMark
24+ do youngMark <- TS.uniqueMark
2225 let youngRank = TS.maxRank youngPool
23− insert dict var = do
24− descriptor <- liftIO $ UF.descriptor var
25− liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
26− return $ Map.insertWith (++) (rank descriptor) [var] dict
26+ let insert dict var =
27+ do descriptor <- liftIO $ UF.descriptor var
28+ liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
29+ return $ Map.insertWith (++) (rank descriptor) [var] dict
2730
2831 -- Sort the youngPool variables by rank.
2932 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)
@@ -37,9 +40,9 @@ generalize youngPool =
3740
3841 -- For variables that have rank lowerer than youngRank, register them in
3942 -- the old pool if they are not redundant.
40− let registerIfNotRedundant var = do
41− isRedundant <- liftIO $ UF.redundant var
42− if isRedundant then return var else TS.register var
43+ let registerIfNotRedundant var =
44+ do isRedundant <- liftIO $ UF.redundant var
45+ if isRedundant then return var else TS.register var
4346
4447 let rankDict' = Map.delete youngRank rankDict
4548 Traversable.traverse (mapM registerIfNotRedundant) rankDict'
@@ -58,7 +61,7 @@ generalize youngPool =
5861 False -> do
5962 let flex' = case flex desc of { Flexible -> Rigid ; other -> other }
6063 liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
61−
64+
6265 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
6366
6467
@@ -85,73 +88,96 @@ adjustRank youngMark visitedMark groupRank var =
8588 | otherwise ->
8689 return (rank descriptor)
8790 where
88− adjust = adjustRank youngMark visitedMark groupRank
91+ adjust =
92+ adjustRank youngMark visitedMark groupRank
8993
9094 adjustTerm term =
9195 case term of
92− App1 a b -> max `liftM` adjust a `ap` adjust b
93− Fun1 a b -> max `liftM` adjust a `ap` adjust b
94− Var1 x -> adjust x
95− EmptyRecord1 -> return outermostRank
96+ App1 a b ->
97+ max `liftM` adjust a `ap` adjust b
98+
99+ Fun1 a b ->
100+ max `liftM` adjust a `ap` adjust b
101+
102+ Var1 x ->
103+ adjust x
104+
105+ EmptyRecord1 ->
106+ return outermostRank
107+
96108 Record1 fields extension ->
97− do ranks <- mapM adjust (concat (Map.elems fields))
98− rnk <- adjust extension
99− return . maximum $ rnk : ranks
109+ do ranks <- mapM adjust (concat (Map.elems fields))
110+ rnk <- adjust extension
111+ return . maximum $ rnk : ranks
100112
101113
102−solve :: TypeConstraint -> StateT TS.SolverState IO ()
103−solve (A.A region constraint) =
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+
127+actuallySolve :: TypeConstraint -> StateT TS.SolverState IO ()
128+actuallySolve constraint =
104129 case constraint of
105130 CTrue ->
106− return ()
131+ return ()
107132
108133 CSaveEnv ->
109− TS.saveLocalEnv
134+ TS.saveLocalEnv
110135
111− CEqual term1 term2 ->
112− do t1 <- TS.flatten term1
113− t2 <- TS.flatten term2
114− unify region t1 t2
136+ CEqual region term1 term2 ->
137+ do t1 <- TS.flatten term1
138+ t2 <- TS.flatten term2
139+ unify region t1 t2
115140
116141 CAnd cs ->
117− mapM_ solve cs
142+ mapM_ actuallySolve cs
118143
119− CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) ->
120− do oldEnv <- TS.getEnv
121− mapM TS.introduce fqs
122− solve constraint'
123− TS.modifyEnv (\_ -> oldEnv)
144+ CLet [Scheme [] fqs constraint' _] CTrue ->
145+ do oldEnv <- TS.getEnv
146+ mapM TS.introduce fqs
147+ actuallySolve constraint'
148+ TS.modifyEnv (\_ -> oldEnv)
124149
125150 CLet schemes constraint' ->
126− do oldEnv <- TS.getEnv
127− headers <- Map.unions `fmap` mapM (solveScheme region) schemes
128− TS.modifyEnv $ \env -> Map.union headers env
129− solve constraint'
130− mapM Check.occurs $ Map.toList headers
131− TS.modifyEnv (\_ -> oldEnv)
132−
133− CInstance name term ->
134− do env <- TS.getEnv
135− freshCopy <-
136− case Map.lookup name env of
137− Just tipe -> TS.makeInstance tipe
138− Nothing
139− | List.isPrefixOf "Native." name -> liftIO (variable Flexible)
140− | otherwise ->
141− error ("Could not find '" ++ name ++ "' when solving type constraints.")
142−
143− t <- TS.flatten term
144− unify region freshCopy t
145−
146−
147−solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
148−solveScheme region scheme =
149− case scheme of
150− Scheme [] [] constraint header ->
151− do solve constraint
151+ do oldEnv <- TS.getEnv
152+ headers <- Map.unions `fmap` mapM solveScheme schemes
153+ TS.modifyEnv $ \env -> Map.union headers env
154+ actuallySolve constraint'
155+ mapM occurs $ Map.toList headers
156+ TS.modifyEnv (\_ -> oldEnv)
157+
158+ CInstance region name term ->
159+ do env <- TS.getEnv
160+ freshCopy <-
161+ case Map.lookup name env of
162+ Just tipe ->
163+ TS.makeInstance tipe
164+ Nothing ->
165+ if List.isPrefixOf "Native." name
166+ then liftIO (variable Flexible)
167+ else error ("Could not find '" ++ name ++ "' when solving type constraints.")
168+
169+ t <- TS.flatten term
170+ unify region freshCopy t
171+
172+
173+solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
174+solveScheme scheme =
175+ case scheme of
176+ Scheme [] [] constraint header ->
177+ do actuallySolve constraint
152178 Traversable.traverse TS.flatten header
153179
154− Scheme rigidQuantifiers flexibleQuantifiers constraint header ->
180+ Scheme rigidQuantifiers flexibleQuantifiers constraint header ->
155181 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
156182 oldPool <- TS.getPool
157183
@@ -160,54 +186,85 @@ solveScheme region scheme =
160186 TS.switchToPool freshPool
161187 mapM TS.introduce quantifiers
162188 header' <- Traversable.traverse TS.flatten header
163− solve constraint
189+ actuallySolve constraint
164190
165− allDistinct region rigidQuantifiers
191+ allDistinct rigidQuantifiers
166192 youngPool <- TS.getPool
167193 TS.switchToPool oldPool
168194 generalize youngPool
169− mapM (isGeneric region) rigidQuantifiers
195+ mapM isGeneric rigidQuantifiers
170196 return header'
171197
172198
173−addHint
174− :: A.Region
175− -> Maybe String
176− -> UF.Point Descriptor
177− -> UF.Point Descriptor
178− -> StateT TS.SolverState IO ()
179−addHint region hint t1 t2 =
180− do msg <- liftIO (Hint.create region hint t1 t2)
181− TS.addHint msg
182−
199+-- ADDITIONAL CHECKS
183200
184201-- Checks that all of the given variables belong to distinct equivalence classes.
185202-- Also checks that their structure is Nothing, so they represent a variable, not
186203-- a more complex term.
187−allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
188−allDistinct region vars =
204+allDistinct :: [Variable] -> StateT TS.SolverState IO ()
205+allDistinct vars =
189206 do seen <- TS.uniqueMark
190207 forM_ vars $ \var ->
191208 do desc <- liftIO $ UF.descriptor var
192209 case structure desc of
193210 Just _ ->
194− let msg = "Cannot generalize something that is not a type variable."
195− in
196− addHint region (Just msg) var var
211+ TS.addError (error "Cannot generalize something that is not a type variable.") undefined
197212
198213 Nothing ->
199214 do when (mark desc == seen) $
200− do let msg = "Duplicate variable during generalization."
201− addHint region (Just msg) var var
215+ TS.addError (error "Duplicate variable during generalization.") undefined
202216 liftIO $ UF.setDescriptor var (desc { mark = seen })
203217
204218
205219-- Check that a variable has rank == noRank, meaning that it can be generalized.
206−isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
207−isGeneric region var =
220+isGeneric :: Variable -> StateT TS.SolverState IO ()
221+isGeneric var =
208222 do desc <- liftIO $ UF.descriptor var
209223 if rank desc == noRank
210224 then return ()
211225 else
212− let msg = "Unable to generalize a type variable. It is not unranked."
213− in addHint region (Just msg) var var
226+ TS.addError (error "Unable to generalize a type variable. It is not unranked.") undefined
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
88import qualified Data.Traversable as Traversable
99import qualified Data.UnionFind.IO as UF
1010
11−import qualified Type.Hint as Hint
11+import qualified Reporting.Annotation as A
12+import qualified Reporting.Error.Type as Error
13+import qualified Reporting.Region as R
1214import Type.Type
1315
1416
@@ -40,7 +42,7 @@ data SolverState = SS
4042 , sSavedEnv :: Env
4143 , sPool :: Pool
4244 , sMark :: Int
43− , sHint :: [Hint.Hint]
45+ , sError :: [A.Located Error.Error]
4446 }
4547
4648
@@ -51,7 +53,7 @@ initialState =
5153 , sSavedEnv = Map.empty
5254 , sPool = emptyPool
5355 , sMark = noMark + 1 -- The mark must never be equal to noMark!
54− , sHint = []
56+ , sError = []
5557 }
5658
5759
@@ -65,9 +67,9 @@ modifyPool f =
6567 modify $ \state -> state { sPool = f (sPool state) }
6668
6769
68−addHint :: Hint.Hint -> StateT SolverState IO ()
69−addHint hint =
70− modify $ \state -> state { sHint = hint : sHint state }
70+addError :: R.Region -> Error.Error -> StateT SolverState IO ()
71+addError region err =
72+ modify $ \state -> state { sError = A.A region err : sError state }
7173
7274
7375switchToPool :: (MonadState SolverState m) => Pool -> m ()
src/Type/Type.hs+83−63
@@ -3,7 +3,6 @@ module Type.Type where
33import Control.Applicative ((<$>),(<*>))
44import Control.Monad.State (StateT)
55import qualified Control.Monad.State as State
6−import Control.Monad.Error (ErrorT, Error, liftIO)
76import qualified Data.Char as Char
87import qualified Data.Map as Map
98import qualified Data.Set as Set
@@ -12,10 +11,9 @@ import qualified Data.UnionFind.IO as UF
1211import Text.PrettyPrint as P
1312import System.IO.Unsafe
1413
15−import AST.Annotation
16−import qualified AST.PrettyPrint as PP
1714import qualified AST.Type as T
1815import qualified AST.Variable as Var
16+import qualified Reporting.Region as R
1917import Type.PrettyPrint
2018
2119
@@ -103,16 +101,13 @@ data SuperType
103101
104102-- CONSTRAINTS
105103
106−type Constraint a b =
107− Located (BasicConstraint a b)
108−
109−data BasicConstraint a b
104+data Constraint a b
110105 = CTrue
111106 | CSaveEnv
112− | CEqual a a
107+ | CEqual R.Region a a
113108 | CAnd [Constraint a b]
114109 | CLet [Scheme a b] (Constraint a b)
115− | CInstance SchemeName a
110+ | CInstance R.Region SchemeName a
116111
117112type SchemeName = String
118113
@@ -170,40 +165,40 @@ variable flex = UF.fresh $ Descriptor
170165
171166monoscheme :: Map.Map String a -> Scheme a b
172167monoscheme headers =
173− Scheme [] [] (noneNoDocs CTrue) headers
168+ Scheme [] [] CTrue headers
174169
175170
176171infixl 8 /\
177172
178173(/\) :: Constraint a b -> Constraint a b -> Constraint a b
179−(/\) a@(A _ c1) b@(A _ c2) =
174+(/\) c1 c2 =
180175 case (c1, c2) of
181− (CTrue, _) -> b
182− (_, CTrue) -> a
183− _ -> mergeOldDocs a b (CAnd [a,b])
176+ (CTrue, _) -> c2
177+ (_, CTrue) -> c1
178+ _ -> CAnd [c1,c2]
184179
185180
186181-- ex qs constraint == exists qs. constraint
187182ex :: [Variable] -> TypeConstraint -> TypeConstraint
188−ex fqs constraint@(A ann _) =
189− A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
183+ex fqs constraint =
184+ CLet [Scheme [] fqs constraint Map.empty] CTrue
190185
191186
192187-- fl qs constraint == forall qs. constraint
193188fl :: [Variable] -> TypeConstraint -> TypeConstraint
194−fl rqs constraint@(A ann _) =
195− A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
189+fl rqs constraint =
190+ CLet [Scheme rqs [] constraint Map.empty] CTrue
196191
197192
198−exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
193+exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint
199194exists f =
200− do v <- liftIO $ variable Flexible
195+ do v <- variable Flexible
201196 ex [v] <$> f (varN v)
202197
203198
204−existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
199+existsNumber :: (Type -> IO TypeConstraint) -> IO TypeConstraint
205200existsNumber f =
206− do v <- liftIO $ variable (Is Number)
201+ do v <- variable (Is Number)
207202 ex [v] <$> f (varN v)
208203
209204
@@ -214,11 +209,6 @@ instance PrettyType a => PrettyType (UF.Point a) where
214209 unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
215210
216211
217−instance PrettyType t => PrettyType (Annotated a t) where
218− pretty when (A _ e) =
219− pretty when e
220−
221−
222212instance PrettyType a => PrettyType (Term1 a) where
223213 pretty when term =
224214 let prty = pretty Never in
@@ -280,14 +270,20 @@ instance PrettyType a => PrettyType (TermN a) where
280270 case maybeAlias of
281271 Nothing -> doc
282272 Just (name, args) ->
283− P.hang (PP.pretty name) 2 (P.sep (map (pretty App . snd) args))
273+ P.hang
274+ (P.text (Var.toString name))
275+ 2
276+ (P.sep (map (pretty App . snd) args))
284277
285278
286279instance PrettyType Descriptor where
287280 pretty when desc =
288281 case (alias desc, structure desc, name desc) of
289282 (Just (name, args), _, _) ->
290− P.hang (PP.pretty name) 4 (P.sep (map (pretty App . snd) args))
283+ P.hang
284+ (P.text (Var.toString name))
285+ 4
286+ (P.sep (map (pretty App . snd) args))
291287
292288 (_, Just term, _) ->
293289 pretty when term
@@ -301,72 +297,96 @@ instance PrettyType Descriptor where
301297 _ -> P.text "?"
302298
303299
304−instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
300+instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where
305301 pretty _ constraint =
306302 let prty = pretty Never in
307303 case constraint of
308− CTrue -> P.text "True"
309− CSaveEnv -> P.text "SaveTheEnvironment!!!"
310− CEqual a b -> prty a <+> P.text "=" <+> prty b
311− CAnd [] -> P.text "True"
304+ CTrue ->
305+ P.text "True"
306+
307+ CSaveEnv ->
308+ P.text "SaveTheEnvironment!!!"
309+
310+ CEqual _region a b ->
311+ prty a <+> P.text "=" <+> prty b
312+
313+ CAnd [] ->
314+ P.text "True"
312315
313316 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)
315318
316− CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->
319+ CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->
317320 P.sep [ binder, pretty Never c ]
318321 where
319− mergeExists vs (A _ c) =
322+ mergeExists vs c =
320323 case c of
321− CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'
324+ CLet [Scheme [] fqs' c' _] CTrue -> mergeExists (vs ++ fqs') c'
322325 _ -> (vs, c)
323326
324327 (fqs', c) = mergeExists fqs constraint
325328
326− binder = if null fqs' then P.empty else
327− P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."
329+ binder =
330+ if null fqs'
331+ then P.empty
332+ else
333+ P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."
328334
329335 CLet schemes constraint ->
330− P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
331− , P.text "in", pretty Never constraint ]
336+ P.fsep
337+ [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
338+ , P.text "in", pretty Never constraint
339+ ]
332340
333− CInstance name tipe ->
334− P.text name <+> P.text "<" <+> prty tipe
341+ CInstance _region name tipe ->
342+ P.text name <+> P.text "<" <+> prty tipe
335343
336344
337345instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
338− pretty _ (Scheme rqs fqs (A _ constraint) headers) =
346+ pretty _ (Scheme rqs fqs constraint headers) =
339347 P.sep [ forall, cs, headers' ]
340348 where
341349 prty = pretty Never
342350
343− forall = if null rqs && null fqs then P.empty else
344− P.text "\x2200" <+> frees <+> rigids
351+ forall =
352+ if null rqs && null fqs
353+ then P.empty
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)
345368
346− frees = P.hsep $ map prty fqs
347− rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs
369+ headers' =
370+ if Map.size headers > 0 then dict else P.empty
348371
349− cs = case constraint of
350− CTrue -> P.empty
351− CAnd [] -> P.empty
352− _ -> P.brackets (pretty Never constraint)
372+ dict =
373+ P.parens . commaSep . map prettyPair $ Map.toList headers
353374
354− headers' = if Map.size headers > 0 then dict else P.empty
355− dict = P.parens . commaSep . map prettyPair $ Map.toList headers
356− prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t
375+ prettyPair (n,t) =
376+ P.text n <+> P.text ":" <+> pretty Never t
357377
358378
359379-- CONVERT TO SOURCE TYPES
360380
361381-- TODO: Attach resulting type to the descriptor so that you
362382-- never have to do extra work, particularly nice for aliased types
363−toSrcType :: Variable -> IO T.CanonicalType
383+toSrcType :: Variable -> IO T.Canonical
364384toSrcType variable =
365385 do addNames variable
366386 variableToSrcType variable variable
367387
368388
369−variableToSrcType :: Variable -> Variable -> IO T.CanonicalType
389+variableToSrcType :: Variable -> Variable -> IO T.Canonical
370390variableToSrcType rootVariable variable =
371391 do desc <- UF.descriptor variable
372392 srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)
@@ -383,7 +403,7 @@ variableToSrcType rootVariable variable =
383403 do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args
384404 return (T.Aliased name args' (T.Filled srcType))
385405 where
386− backupSrcType :: Descriptor -> IO T.CanonicalType
406+ backupSrcType :: Descriptor -> IO T.Canonical
387407 backupSrcType desc =
388408 case name desc of
389409 Just v@(Var.Canonical _ x@(c:_))
@@ -401,7 +421,7 @@ variableToSrcType rootVariable variable =
401421 ]
402422
403423
404−termToSrcType :: Variable -> Term1 Variable -> IO T.CanonicalType
424+termToSrcType :: Variable -> Term1 Variable -> IO T.Canonical
405425termToSrcType rootVariable term =
406426 let go = variableToSrcType rootVariable in
407427 case term of
@@ -433,7 +453,7 @@ termToSrcType rootVariable term =
433453 T.Var _ -> T.Record fields (Just ext')
434454 _ -> error "Used toSrcType on a type that is not well-formed"
435455 where
436− dealias :: T.CanonicalType -> T.CanonicalType
456+ dealias :: T.Canonical -> T.Canonical
437457 dealias tipe =
438458 case tipe of
439459 T.Aliased _ args tipe' ->
@@ -473,7 +493,7 @@ data NameState = NameState
473493
474494varAddNames :: Variable -> StateT NameState IO ()
475495varAddNames var =
476− do desc <- liftIO (UF.descriptor var)
496+ do desc <- State.liftIO (UF.descriptor var)
477497 case alias desc of
478498 Nothing ->
479499 return ()
@@ -490,7 +510,7 @@ varAddNames var =
490510 Just _ -> return ()
491511 Nothing ->
492512 do name' <- createName desc
493− liftIO $ UF.modifyDescriptor var $ \desc ->
513+ State.liftIO $ UF.modifyDescriptor var $ \desc ->
494514 desc { name = Just (Var.local name') }
495515
496516
src/Type/Unify.hs+61−60
@@ -1,7 +1,7 @@
11module Type.Unify (unify) where
22
33import Control.Applicative ((<|>))
4−import Control.Monad.Error (ErrorT, throwError, runErrorT)
4+import Control.Monad.Except (ExceptT, throwError, runExceptT)
55import Control.Monad.State as State
66import qualified Data.List as List
77import qualified Data.Map as Map
@@ -9,52 +9,55 @@ import qualified Data.Maybe as Maybe
99import qualified Data.UnionFind.IO as UF
1010import Text.PrettyPrint (render)
1111
12−import qualified AST.Annotation as A
1312import qualified AST.Variable as Var
13+import qualified Reporting.Region as R
14+import qualified Reporting.Error.Type as Error
1415import qualified Type.State as TS
1516import Type.Type
1617import Type.PrettyPrint
17−import qualified Type.Hint as Hint
1818import Elm.Utils ((|>))
1919
2020
21−unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
21+unify :: R.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
2222unify region variable1 variable2 =
23− do result <- runErrorT (unifyHelp region variable1 variable2)
24− either TS.addHint return result
23+ do result <- runExceptT (unifyHelp variable1 variable2)
24+ case result of
25+ Right state ->
26+ return state
27+
28+ Left mismatch ->
29+ TS.addError region (Error.Mismatch mismatch)
2530
2631
2732-- ACTUALLY UNIFY STUFF
2833
29−type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)
34+type Unify = ExceptT Error.Mismatch (StateT TS.SolverState IO)
3035
3136
3237typeError
33− :: A.Region
34− -> Maybe String
38+ :: Maybe String
3539 -> UF.Point Descriptor
3640 -> UF.Point Descriptor
3741 -> Unify a
38−typeError region hint t1 t2 =
39− do msg <- liftIO (Hint.create region hint t1 t2)
40− throwError msg
42+typeError hint leftType rightType =
43+ do leftSrcType <- liftIO (toSrcType leftType)
44+ rightSrcType <- liftIO (toSrcType rightType)
45+ throwError (Error.MismatchInfo hint leftSrcType rightSrcType)
4146
4247
43−unifyHelp :: A.Region -> Variable -> Variable -> Unify ()
44−unifyHelp region variable1 variable2 = do
45− equivalent <- liftIO $ UF.equivalent variable1 variable2
46− if equivalent
47− then return ()
48− else actuallyUnify region variable1 variable2
48+unifyHelp :: Variable -> Variable -> Unify ()
49+unifyHelp variable1 variable2 =
50+ do equivalent <- liftIO $ UF.equivalent variable1 variable2
51+ if equivalent
52+ then return ()
53+ else actuallyUnify variable1 variable2
4954
5055
51−actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()
52−actuallyUnify region variable1 variable2 = do
56+actuallyUnify :: Variable -> Variable -> Unify ()
57+actuallyUnify variable1 variable2 = do
5358 desc1 <- liftIO $ UF.descriptor variable1
5459 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
5861
5962 merge1 :: Unify ()
6063 merge1 =
@@ -100,7 +103,7 @@ actuallyUnify region variable1 variable2 = do
100103
101104 flexAndUnify v =
102105 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
103− unifyHelp' variable1 variable2
106+ unifyHelp variable1 variable2
104107
105108 unifyNumber svar (Var.Canonical home name) =
106109 case home of
@@ -109,17 +112,17 @@ actuallyUnify region variable1 variable2 = do
109112 _ ->
110113 let hint = "Looks like something besides an Int or Float is being used as a number."
111114 in
112− typeError region (Just hint) variable1 variable2
115+ typeError (Just hint) variable1 variable2
113116
114117 comparableError maybe =
115− typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
118+ typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
116119 where
117120 msg =
118121 "Looks like you want something comparable, but the only valid comparable\n\
119122 \types are Int, Float, Char, String, lists, or tuples."
120123
121124 appendableError maybe =
122− typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
125+ typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
123126 where
124127 msg =
125128 "Looks like you want something appendable, but the only Strings, Lists,\n\
@@ -139,7 +142,7 @@ actuallyUnify region variable1 variable2 = do
139142
140143 List v ->
141144 do flexAndUnify varSuper
142− unifyHelp' v =<< liftIO (variable $ Is Comparable)
145+ unifyHelp v =<< liftIO (variable $ Is Comparable)
143146
144147 Tuple vs
145148 | length vs > 6 ->
@@ -147,7 +150,7 @@ actuallyUnify region variable1 variable2 = do
147150 | otherwise ->
148151 do flexAndUnify varSuper
149152 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
150− zipWithM_ unifyHelp' vs cmpVars
153+ zipWithM_ unifyHelp vs cmpVars
151154
152155 unifyAppendable varSuper varFlex =
153156 do struct <- liftIO $ collectApps varFlex
@@ -156,7 +159,7 @@ actuallyUnify region variable1 variable2 = do
156159 _ -> appendableError Nothing
157160
158161 rigidError var =
159− typeError region (Just hint) variable1 variable2
162+ typeError (Just hint) variable1 variable2
160163 where
161164 hint =
162165 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
@@ -187,7 +190,7 @@ actuallyUnify region variable1 variable2 = do
187190
188191 (Rigid, _, _, _) -> rigidError variable1
189192 (_, Rigid, _, _) -> rigidError variable2
190− _ -> typeError region Nothing variable1 variable2
193+ _ -> typeError Nothing variable1 variable2
191194
192195 case (structure desc1, structure desc2) of
193196 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
@@ -200,10 +203,10 @@ actuallyUnify region variable1 variable2 = do
200203 merge1
201204
202205 (Just (Var1 v), _) ->
203− unifyHelp' v variable2
206+ unifyHelp v variable2
204207
205208 (_, Just (Var1 v)) ->
206− unifyHelp' variable1 v
209+ unifyHelp variable1 v
207210
208211 (Nothing, _) ->
209212 superUnify
@@ -215,38 +218,37 @@ actuallyUnify region variable1 variable2 = do
215218 case (type1,type2) of
216219 (App1 term1 term2, App1 term1' term2') ->
217220 do merge
218− unifyHelp' term1 term1'
219− unifyHelp' term2 term2'
221+ unifyHelp term1 term1'
222+ unifyHelp term2 term2'
220223 (Fun1 term1 term2, Fun1 term1' term2') ->
221224 do merge
222− unifyHelp' term1 term1'
223− unifyHelp' term2 term2'
225+ unifyHelp term1 term1'
226+ unifyHelp term2 term2'
224227
225228 (EmptyRecord1, EmptyRecord1) ->
226229 return ()
227230
228− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2
229− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' variable1 ext
231+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
232+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
230233
231234 (Record1 _ _, Record1 _ _) ->
232− recordUnify region fresh variable1 variable2
235+ recordUnify fresh variable1 variable2
233236
234− _ -> typeError region Nothing variable1 variable2
237+ _ -> typeError Nothing variable1 variable2
235238
236239
237240-- RECORD UNIFICATION
238241
239242recordUnify
240− :: A.Region
241− -> (Maybe (Term1 Variable) -> Unify Variable)
243+ :: (Maybe (Term1 Variable) -> Unify Variable)
242244 -> Variable
243245 -> Variable
244246 -> Unify ()
245−recordUnify region fresh variable1 variable2 =
247+recordUnify fresh variable1 variable2 =
246248 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
247249 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
248250
249− unifyOverlappingFields region fields1 fields2
251+ unifyOverlappingFields fields1 fields2
250252
251253 let freshRecord fields ext =
252254 fresh (Just (Record1 fields ext))
@@ -257,57 +259,56 @@ recordUnify region fresh variable1 variable2 =
257259 let addFieldMismatchError missingFields =
258260 let msg = fieldMismatchError missingFields
259261 in
260− typeError region (Just msg) variable1 variable2
262+ typeError (Just msg) variable1 variable2
261263
262264 case (ext1, ext2) of
263265 (Empty _, Empty _) ->
264266 case Map.null uniqueFields1 && Map.null uniqueFields2 of
265267 True -> return ()
266− False -> typeError region Nothing variable1 variable2
268+ False -> typeError Nothing variable1 variable2
267269
268270 (Empty var1, Extension var2) ->
269271 case (Map.null uniqueFields1, Map.null uniqueFields2) of
270272 (_, False) -> addFieldMismatchError uniqueFields2
271− (True, True) -> unifyHelp region var1 var2
273+ (True, True) -> unifyHelp var1 var2
272274 (False, True) ->
273275 do subRecord <- freshRecord uniqueFields1 var1
274− unifyHelp region subRecord var2
276+ unifyHelp subRecord var2
275277
276278 (Extension var1, Empty var2) ->
277279 case (Map.null uniqueFields1, Map.null uniqueFields2) of
278280 (False, _) -> addFieldMismatchError uniqueFields1
279− (True, True) -> unifyHelp region var1 var2
281+ (True, True) -> unifyHelp var1 var2
280282 (True, False) ->
281283 do subRecord <- freshRecord uniqueFields2 var2
282− unifyHelp region var1 subRecord
284+ unifyHelp var1 subRecord
283285
284286 (Extension var1, Extension var2) ->
285287 case (Map.null uniqueFields1, Map.null uniqueFields2) of
286288 (True, True) ->
287− unifyHelp region var1 var2
289+ unifyHelp var1 var2
288290
289291 (True, False) ->
290292 do subRecord <- freshRecord uniqueFields2 var2
291− unifyHelp region var1 subRecord
293+ unifyHelp var1 subRecord
292294
293295 (False, True) ->
294296 do subRecord <- freshRecord uniqueFields1 var1
295− unifyHelp region subRecord var2
297+ unifyHelp subRecord var2
296298
297299 (False, False) ->
298300 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
299301 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
300− unifyHelp region record1' var2
301− unifyHelp region var1 record2'
302+ unifyHelp record1' var2
303+ unifyHelp var1 record2'
302304
303305
304306unifyOverlappingFields
305− :: A.Region
306− -> Map.Map String [Variable]
307+ :: Map.Map String [Variable]
307308 -> Map.Map String [Variable]
308309 -> Unify ()
309−unifyOverlappingFields region fields1 fields2 =
310− Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2
310+unifyOverlappingFields fields1 fields2 =
311+ Map.intersectionWith (zipWith unifyHelp) fields1 fields2
311312 |> Map.elems
312313 |> concat
313314 |> 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+