git.iko.soy/elk
on master help sign in
Merge pull request #1351 from elm-lang/dev
967c895Evan Czaplicki
.travis.yml−1
compare with master
unifiedsplit
@@ -22,5 +22,4 @@ install:
22
22
23script:
23script:
24 - cabal configure --enable-tests
24 - cabal configure --enable-tests
25− - cabal build
26 - cabal test
25 - cabal test
elm-compiler.cabal+25−13
@@ -1,6 +1,6 @@
1
1
2Name: elm-compiler
2Name: elm-compiler
3−Version: 0.16
3+Version: 0.17
4
4
5Synopsis:
5Synopsis:
6 Values to help with elm-package, elm-make, and elm-lang.org.
6 Values to help with elm-package, elm-make, and elm-lang.org.
@@ -18,7 +18,7 @@ License-file: LICENSE
18
18
19Author: Evan Czaplicki
19Author: Evan Czaplicki
20Maintainer: info@elm-lang.org
20Maintainer: info@elm-lang.org
21−Copyright: Copyright (c) 2011-2014 Evan Czaplicki
21+Copyright: Copyright (c) 2011-2016 Evan Czaplicki
22
22
23Category: Compiler, Language
23Category: Compiler, Language
24
24
@@ -31,9 +31,18 @@ source-repository head
31 type: git
31 type: git
32 location: git://github.com/elm-lang/elm-compiler.git
32 location: git://github.com/elm-lang/elm-compiler.git
33
33
34+
35+Flag dev {
36+ Description: Turn off optimization and make warnings errors
37+ Default: False
38+}
39+
40+
34Library
41Library
42+ if flag(dev)
35− ghc-options:
43+ ghc-options: -O0 -W -Werror
36− -O2 -W
44+ else
45+ ghc-options: -O2
37
46
38 Hs-Source-Dirs:
47 Hs-Source-Dirs:
39 src
48 src
@@ -48,6 +57,7 @@ Library
48
57
49 other-modules:
58 other-modules:
50 AST.Declaration,
59 AST.Declaration,
60+ AST.Effects,
51 AST.Expression.Canonical,
61 AST.Expression.Canonical,
52 AST.Expression.General,
62 AST.Expression.General,
53 AST.Expression.Optimized,
63 AST.Expression.Optimized,
@@ -61,10 +71,9 @@ Library
61 AST.Type,
71 AST.Type,
62 AST.Variable,
72 AST.Variable,
63 Canonicalize,
73 Canonicalize,
64− Canonicalize.Declaration,
74+ Canonicalize.Body,
75+ Canonicalize.Effects,
65 Canonicalize.Environment,
76 Canonicalize.Environment,
66− Canonicalize.Port,
67− Canonicalize.Result,
68 Canonicalize.Setup,
77 Canonicalize.Setup,
69 Canonicalize.Sort,
78 Canonicalize.Sort,
70 Canonicalize.Type,
79 Canonicalize.Type,
@@ -77,11 +86,12 @@ Library
77 Elm.Compiler.Type.Extract,
86 Elm.Compiler.Type.Extract,
78 Elm.Compiler.Version,
87 Elm.Compiler.Version,
79 Generate.JavaScript,
88 Generate.JavaScript,
89+ Generate.JavaScript.Builder,
80 Generate.JavaScript.BuiltIn,
90 Generate.JavaScript.BuiltIn,
81 Generate.JavaScript.Expression,
91 Generate.JavaScript.Expression,
92+ Generate.JavaScript.Foreign,
82 Generate.JavaScript.Helpers,
93 Generate.JavaScript.Helpers,
83 Generate.JavaScript.Literal,
94 Generate.JavaScript.Literal,
84− Generate.JavaScript.Port,
85 Generate.JavaScript.Variable,
95 Generate.JavaScript.Variable,
86 Nitpick.Pattern,
96 Nitpick.Pattern,
87 Nitpick.PatternMatches,
97 Nitpick.PatternMatches,
@@ -101,6 +111,7 @@ Library
101 Parse.Pattern,
111 Parse.Pattern,
102 Parse.Type,
112 Parse.Type,
103 Reporting.Annotation,
113 Reporting.Annotation,
114+ Reporting.Bag,
104 Reporting.Error,
115 Reporting.Error,
105 Reporting.Error.Canonicalize,
116 Reporting.Error.Canonicalize,
106 Reporting.Error.Docs,
117 Reporting.Error.Docs,
@@ -114,6 +125,7 @@ Library
114 Reporting.Report,
125 Reporting.Report,
115 Reporting.Result,
126 Reporting.Result,
116 Reporting.Warning,
127 Reporting.Warning,
128+ Type.Constrain.Effects,
117 Type.Constrain.Expression,
129 Type.Constrain.Expression,
118 Type.Constrain.Literal,
130 Type.Constrain.Literal,
119 Type.Constrain.Pattern,
131 Type.Constrain.Pattern,
@@ -147,8 +159,7 @@ Library
147 pretty >= 1.0 && < 2.0,
159 pretty >= 1.0 && < 2.0,
148 process,
160 process,
149 text >= 1 && < 2,
161 text >= 1 && < 2,
150− union-find >= 0.2 && < 0.3,
162+ union-find >= 0.2 && < 0.3
151− wl-pprint
152
163
153
164
154Executable elm
165Executable elm
@@ -176,6 +187,9 @@ Executable elm
176
187
177
188
178Test-Suite compiler-tests
189Test-Suite compiler-tests
190+ ghc-options:
191+ -O0
192+
179 Type:
193 Type:
180 exitcode-stdio-1.0
194 exitcode-stdio-1.0
181
195
@@ -208,7 +222,6 @@ Test-Suite compiler-tests
208 containers >= 0.3 && < 0.6,
222 containers >= 0.3 && < 0.6,
209 directory >= 1.0 && < 2.0,
223 directory >= 1.0 && < 2.0,
210 edit-distance >= 0.2 && < 0.3,
224 edit-distance >= 0.2 && < 0.3,
211− elm-compiler,
212 filemanip >= 0.3.5 && < 0.4,
225 filemanip >= 0.3.5 && < 0.4,
213 filepath >= 1 && < 2.0,
226 filepath >= 1 && < 2.0,
214 indents >= 0.3 && < 0.4,
227 indents >= 0.3 && < 0.4,
@@ -219,5 +232,4 @@ Test-Suite compiler-tests
219 pretty >= 1.0 && < 2.0,
232 pretty >= 1.0 && < 2.0,
220 process,
233 process,
221 text >= 1 && < 2,
234 text >= 1 && < 2,
222− union-find >= 0.2 && < 0.3,
235+ union-find >= 0.2 && < 0.3
223− wl-pprint
src/AST/Declaration.hs+111−55
@@ -3,7 +3,6 @@ module AST.Declaration where
3
3
4import Data.Binary
4import Data.Binary
5
5
6−import qualified AST.Expression.General as General
7import qualified AST.Expression.Source as Source
6import qualified AST.Expression.Source as Source
8import qualified AST.Expression.Valid as Valid
7import qualified AST.Expression.Valid as Valid
9import qualified AST.Expression.Canonical as Canonical
8import qualified AST.Expression.Canonical as Canonical
@@ -11,86 +10,143 @@ import qualified AST.Type as Type
11import qualified Reporting.Annotation as A
10import qualified Reporting.Annotation as A
12
11
13
12
14−-- DECLARATIONS
15
13
16−data Declaration' port def tipe expr
14+-- SOURCE DECLARATIONS
17− = Definition def
18− | Datatype String [String] [(String, [tipe])]
19− | TypeAlias String [String] tipe
20− | Port port
21− | Fixity Assoc Int String
22
15
23
16
24−-- INFIX STUFF
17+type Source =
18+ CommentOr (A.Located Raw)
25
19
26−data Assoc = L | N | R
27− deriving (Eq)
28
20
21+data CommentOr a
22+ = Comment (A.Located String)
23+ | Whatever a
29
24
30−assocToString :: Assoc -> String
25+
31−assocToString assoc =
26+data Raw
32− case assoc of
27+ = Def Source.Def
33− L -> "left"
28+ | Union (Union Type.Raw)
34− N -> "non"
29+ | Alias (Alias Type.Raw)
35− R -> "right"
30+ | Fixity Infix
31+ | Port String Type.Raw
32+
33+
34+
35+-- STRUCTURED DECLARATIONS
36
36
37
37
38−-- DECLARATION PHASES
38+data Decls def tipe =
39+ Decls
40+ { _defs :: [A.Commented def]
41+ , _unions :: [A.Commented (Union tipe)]
42+ , _aliases :: [A.Commented (Alias tipe)]
43+ , _infixes :: [Infix]
44+ }
39
45
40−type SourceDecl' =
41− Declaration' SourcePort Source.Def Type.Raw Source.Expr
42
46
47+type Valid =
48+ Decls Valid.Def Type.Raw
43
49
44−data SourceDecl
45− = Comment String
46− | Decl (A.Located SourceDecl')
47
50
51+type Canonical =
52+ Decls Canonical.Def Type.Canonical
48
53
49−type ValidDecl =
50− A.Commented (Declaration' ValidPort Valid.Def Type.Raw Valid.Expr)
51
54
55+addDef :: A.Commented d -> Decls d t -> Decls d t
56+addDef def decls =
57+ decls { _defs = def : _defs decls }
52
58
53−type CanonicalDecl =
54− A.Commented (Declaration' CanonicalPort Canonical.Def Type.Canonical Canonical.Expr)
55
59
60+addUnion :: A.Commented (Union t) -> Decls d t -> Decls d t
61+addUnion union decls =
62+ decls { _unions = union : _unions decls }
56
63
57−-- PORTS
58
64
59−data SourcePort
65+addAlias :: A.Commented (Alias t) -> Decls d t -> Decls d t
60− = PortAnnotation String Type.Raw
66+addAlias alias decls =
61− | PortDefinition String Source.Expr
67+ decls { _aliases = alias : _aliases decls }
62
68
63
69
64−data ValidPort
70+addInfix :: Infix -> Decls d t -> Decls d t
65− = In String Type.Raw
71+addInfix fixity decls =
66− | Out String Valid.Expr Type.Raw
72+ decls { _infixes = fixity : _infixes decls }
67
73
68
74
69−newtype CanonicalPort
70− = CanonicalPort (General.PortImpl Canonical.Expr Type.Canonical)
71
75
76+-- TYPE DECLARATIONS
77+
78+
79+data Type body =
80+ Type
81+ { _name :: String
82+ , _args :: [String]
83+ , _body :: body
84+ }
85+
86+
87+type Union tipe =
88+ Type [(String, [tipe])]
89+
90+
91+type Alias tipe =
92+ Type tipe
93+
94+
95+
96+-- INFIX STUFF
97+
98+
99+data Infix =
100+ Infix
101+ { _op :: String
102+ , _associativity :: Assoc
103+ , _precedence :: Int
104+ }
105+
106+
107+data Assoc = L | N | R
108+ deriving (Eq)
109+
110+
111+assocToString :: Assoc -> String
112+assocToString assoc =
113+ case assoc of
114+ L ->
115+ "left"
116+
117+ N ->
118+ "non"
119+
120+ R ->
121+ "right"
72
122
73−validPortName :: ValidPort -> String
74−validPortName port =
75− case port of
76− In name _ -> name
77− Out name _ _ -> name
78
123
79
124
80-- BINARY CONVERSION
125-- BINARY CONVERSION
81
126
127+
128+instance Binary Infix where
129+ get =
130+ Infix <$> get <*> get <*> get
131+
132+ put (Infix op assoc prec) =
133+ do put op
134+ put assoc
135+ put prec
136+
137+
82instance Binary Assoc where
138instance Binary Assoc where
83− get =
139+ get =
84− do n <- getWord8
140+ do n <- getWord8
85− return $ case n of
141+ return $ case n of
86− 0 -> L
142+ 0 -> L
87− 1 -> N
143+ 1 -> N
88− 2 -> R
144+ 2 -> R
89− _ -> error "Error reading valid associativity from serialized string"
145+ _ -> error "Error reading valid associativity from serialized string"
90−
146+
91− put assoc =
147+ put assoc =
92− putWord8 $
148+ putWord8 $
93− case assoc of
149+ case assoc of
94− L -> 0
150+ L -> 0
95− N -> 1
151+ N -> 1
96− R -> 2
152+ R -> 2
src/AST/Effects.hsnew file+68
@@ -0,0 +1,68 @@
1+module AST.Effects where
2+
3+import qualified AST.Type as Type
4+import qualified Elm.Package as Pkg
5+import qualified Reporting.Annotation as A
6+import qualified Reporting.Region as R
7+
8+
9+
10+-- EFFECTS
11+
12+
13+data Effects pkg ports
14+ = None
15+ | Manager pkg Info
16+ | Port ports
17+
18+
19+type Raw =
20+ Effects () [A.Commented PortRaw]
21+
22+
23+type Canonical =
24+ Effects Pkg.Name [A.Commented PortCanonical]
25+
26+
27+
28+-- EFFECT MANAGERS
29+
30+
31+data Info =
32+ Info
33+ { _tag :: R.Region
34+ , _init :: R.Region
35+ , _onEffects :: R.Region
36+ , _onSelfMsg :: R.Region
37+ , _managerType :: ManagerType
38+ }
39+
40+
41+data ManagerType
42+ = CmdManager (A.Located String)
43+ | SubManager (A.Located String)
44+ | FxManager (A.Located String) (A.Located String)
45+
46+
47+
48+-- FOREIGN EFFECTS
49+
50+
51+data PortRaw =
52+ PortRaw
53+ { _rawName :: String
54+ , _rawType :: Type.Raw
55+ }
56+
57+
58+data PortCanonical =
59+ PortCanonical
60+ { _name :: String
61+ , _kind :: Kind
62+ , _type :: Type.Canonical
63+ }
64+
65+
66+data Kind
67+ = Outgoing Type.Canonical
68+ | Incoming Type.Canonical
src/AST/Expression/Canonical.hs+39−2
@@ -1,5 +1,11 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module AST.Expression.Canonical where
2+module AST.Expression.Canonical
3+ ( Expr, Expr'
4+ , Def(..)
5+ , Facts(..), dummyFacts
6+ , SortedDefs(..), toSortedDefs
7+ )
8+ where
3
9
4import qualified AST.Expression.General as General
10import qualified AST.Expression.General as General
5import qualified AST.Pattern as Pattern
11import qualified AST.Pattern as Pattern
@@ -21,7 +27,7 @@ type Expr' =
21
27
22
28
23data Def
29data Def
24− = Definition Facts Pattern.CanonicalPattern Expr (Maybe (A.Located Type.Canonical))
30+ = Def Facts Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))
25
31
26
32
27data Facts = Facts
33data Facts = Facts
@@ -33,3 +39,34 @@ dummyFacts :: Facts
33dummyFacts =
39dummyFacts =
34 Facts (error "This should be set by Canonicalize.Sort")
40 Facts (error "This should be set by Canonicalize.Sort")
35
41
42+
43+
44+-- SORTED DEFS
45+
46+
47+data SortedDefs
48+ = NoMain [Def]
49+ | YesMain [Def] Def [Def]
50+
51+
52+toSortedDefs :: Expr -> SortedDefs
53+toSortedDefs (A.A _ expr) =
54+ case expr of
55+ General.Let defs body ->
56+ foldr defCons (toSortedDefs body) defs
57+
58+ _ ->
59+ NoMain []
60+
61+
62+defCons :: Def -> SortedDefs -> SortedDefs
63+defCons def@(Def _ (A.A _ pattern) _ _) sortedDefs =
64+ case (pattern, sortedDefs) of
65+ (Pattern.Var "main", NoMain defs) ->
66+ YesMain [] def defs
67+
68+ (_, NoMain defs) ->
69+ NoMain (def : defs)
70+
71+ (_, YesMain defs main rest) ->
72+ YesMain (def : defs) main rest
src/AST/Expression/General.hs+27−39
@@ -8,15 +8,18 @@ enrich the AST with more information.
8-}
8-}
9module AST.Expression.General where
9module AST.Expression.General where
10
10
11+import qualified AST.Effects as Effects
11import qualified AST.Literal as Literal
12import qualified AST.Literal as Literal
13+import qualified AST.Module.Name as ModuleName
12import qualified AST.Pattern as Pattern
14import qualified AST.Pattern as Pattern
13−import qualified AST.Type as Type
14import qualified AST.Variable as Var
15import qualified AST.Variable as Var
15import qualified Reporting.Annotation as A
16import qualified Reporting.Annotation as A
16
17
17
18
19+
18---- GENERAL AST ----
20---- GENERAL AST ----
19
21
22+
20{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
23{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
21"type holes" that allow us to enrich the AST with additional information as we
24"type holes" that allow us to enrich the AST with additional information as we
22move through the compilation process. The type holes are used to represent:
25move through the compilation process. The type holes are used to represent:
@@ -52,29 +55,25 @@ data Expr' ann def var typ
52 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]
55 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]
53 | Record [(String, Expr ann def var typ)]
56 | Record [(String, Expr ann def var typ)]
54 -- for type checking and code gen only
57 -- for type checking and code gen only
58+ | Cmd ModuleName.Canonical
59+ | Sub ModuleName.Canonical
60+ | OutgoingPort String typ
61+ | IncomingPort String typ
55− | Port (PortImpl (Expr ann def var typ) typ)
62+ | Program (Main typ) (Expr ann def var typ)
63+ | SaveEnv ModuleName.Canonical Effects.Canonical
56 | GLShader String String Literal.GLShaderTipe
64 | GLShader String String Literal.GLShaderTipe
57
65
58
66
59−-- PORTS
67+data Main typ
60−
68+ = VDom
61−data PortImpl expr tipe
69+ | NoFlags
62− = In String (Type.Port tipe)
70+ | Flags typ
63− | Out String expr (Type.Port tipe)
64− | Task String expr (Type.Port tipe)
65− deriving (Eq)
66
71
67
72
68−portName :: PortImpl expr tipe -> String
69−portName impl =
70− case impl of
71− In name _ -> name
72− Out name _ _ -> name
73− Task name _ _ -> name
74−
75
73
76---- UTILITIES ----
74---- UTILITIES ----
77
75
76+
78rawVar :: String -> Expr' ann def Var.Raw typ
77rawVar :: String -> Expr' ann def Var.Raw typ
79rawVar x =
78rawVar x =
80 Var (Var.Raw x)
79 Var (Var.Raw x)
@@ -90,35 +89,24 @@ tuple expressions =
90 Data ("_Tuple" ++ show (length expressions)) expressions
89 Data ("_Tuple" ++ show (length expressions)) expressions
91
90
92
91
93−saveEnvName :: String
94−saveEnvName =
95− "_save_the_environment!!!"
96−
97−
98−dummyLet :: [def] -> Expr ann def Var.Canonical typ
99−dummyLet defs =
100− let body =
101− A.A undefined (Var (Var.builtin saveEnvName))
102− in
103− A.A undefined (Let defs body)
104−
105−
106collectApps :: Expr ann def var typ -> [Expr ann def var typ]
92collectApps :: Expr ann def var typ -> [Expr ann def var typ]
107collectApps annExpr@(A.A _ expr) =
93collectApps annExpr@(A.A _ expr) =
108 case expr of
94 case expr of
95+ App a b ->
109− App a b -> collectApps a ++ [b]
96+ collectApps a ++ [b]
97+
98+ _ ->
110− _ -> [annExpr]
99+ [annExpr]
111
100
112
101
113−collectLambdas
114− :: Expr ann def var typ
115− -> ([Pattern.Pattern ann var], Expr ann def var typ)
102+collectLambdas :: Expr ann def var typ -> ([Pattern.Pattern ann var], Expr ann def var typ)
116collectLambdas lexpr@(A.A _ expr) =
103collectLambdas lexpr@(A.A _ expr) =
117 case expr of
104 case expr of
118 Lambda pattern body ->
105 Lambda pattern body ->
119− let
106+ let
120− (ps, body') = collectLambdas body
107+ (ps, body') = collectLambdas body
121− in
108+ in
122− (pattern : ps, body')
109+ (pattern : ps, body')
123
110
111+ _ ->
124− _ -> ([], lexpr)
112+ ([], lexpr)
src/AST/Expression/Optimized.hs+6−2
@@ -5,7 +5,7 @@ module AST.Expression.Optimized
5 , Decider(..), Choice(..)
5 , Decider(..), Choice(..)
6 ) where
6 ) where
7
7
8−import qualified AST.Expression.General as General
8+import qualified AST.Expression.General as Expr
9import qualified AST.Literal as Literal
9import qualified AST.Literal as Literal
10import qualified AST.Module.Name as ModuleName
10import qualified AST.Module.Name as ModuleName
11import qualified AST.Type as Type
11import qualified AST.Type as Type
@@ -52,7 +52,11 @@ data Expr
52 | Access Expr String
52 | Access Expr String
53 | Update Expr [(String, Expr)]
53 | Update Expr [(String, Expr)]
54 | Record [(String, Expr)]
54 | Record [(String, Expr)]
55− | Port (General.PortImpl Expr Type.Canonical)
55+ | Cmd ModuleName.Canonical
56+ | Sub ModuleName.Canonical
57+ | OutgoingPort String Type.Canonical
58+ | IncomingPort String Type.Canonical
59+ | Program (Expr.Main Type.Canonical) Expr
56 | GLShader String String Literal.GLShaderTipe
60 | GLShader String String Literal.GLShaderTipe
57 | Crash ModuleName.Canonical R.Region (Maybe Expr)
61 | Crash ModuleName.Canonical R.Region (Maybe Expr)
58
62
src/AST/Expression/Source.hs+2−2
@@ -26,6 +26,6 @@ type Def =
26
26
27
27
28data Def'
28data Def'
29− = Definition Pattern.RawPattern Expr
29+ = Definition Pattern.Raw Expr
30− | TypeAnnotation String Type.Raw
30+ | Annotation String Type.Raw
31
31
src/AST/Expression/Valid.hs+7−2
@@ -20,6 +20,11 @@ type Expr' =
20 General.Expr' R.Region Def Var.Raw Type.Raw
20 General.Expr' R.Region Def Var.Raw Type.Raw
21
21
22
22
23−data Def
23+data Def =
24− = Definition Pattern.RawPattern Expr (Maybe Type.Raw)
24+ Def Pattern.Raw Expr (Maybe Type.Raw)
25+
26+
27+getPattern :: Def -> Pattern.Raw
28+getPattern (Def pattern _ _) =
29+ pattern
25
30
src/AST/Module.hs+152−83
@@ -1,18 +1,25 @@
1module AST.Module
1module AST.Module
2− ( Interfaces
3− , Types, Aliases, ADTs
4− , AdtInfo, CanonicalAdt
5− , SourceModule, ValidModule, CanonicalModule, Optimized
6− , Module(..), Body(..)
7− , Header(..)
2+ ( Header(..), Module(..)
8− , Interface(..), toInterface
3+
4+ , Source, SourceInfo(..), SourceTag(..), SourceSettings, emptySettings
5+ , Valid, ValidInfo(..)
6+ , Canonical, Optimized, Info(..)
7+
9 , UserImport, DefaultImport, ImportMethod(..)
8 , UserImport, DefaultImport, ImportMethod(..)
9+
10+ , Types
11+ , Aliases
12+ , Unions, UnionInfo, CanonicalUnion
13+
14+ , Interfaces, Interface(..), toInterface
15+ )
10− ) where
16+ where
11
17
12import Data.Binary
18import Data.Binary
13import qualified Data.Map as Map
19import qualified Data.Map as Map
14
20
15import qualified AST.Declaration as Decl
21import qualified AST.Declaration as Decl
22+import qualified AST.Effects as Effects
16import qualified AST.Expression.Canonical as Canonical
23import qualified AST.Expression.Canonical as Canonical
17import qualified AST.Expression.Optimized as Optimized
24import qualified AST.Expression.Optimized as Optimized
18import qualified AST.Module.Name as Name
25import qualified AST.Module.Name as Name
@@ -22,78 +29,92 @@ import qualified Docs.AST as Docs
22import qualified Elm.Package as Package
29import qualified Elm.Package as Package
23import qualified Elm.Compiler.Version as Compiler
30import qualified Elm.Compiler.Version as Compiler
24import qualified Reporting.Annotation as A
31import qualified Reporting.Annotation as A
32+import qualified Reporting.Region as R
25
33
26
34
27−-- HELPFUL TYPE ALIASES
28
35
29−type Interfaces = Map.Map Name.Canonical Interface
36+-- HEADERS FOR PARSING
30
37
31−type Types = Map.Map String Type.Canonical
32−type Aliases = Map.Map String ([String], Type.Canonical)
33−type ADTs = Map.Map String (AdtInfo String)
34
38
35−type AdtInfo v = ( [String], [(v, [Type.Canonical])] )
39+{-| Basic info needed to identify modules and determine dependencies. -}
36−type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)
40+data Header imports =
41+ Header
42+ { _tag :: SourceTag
43+ , _name :: Name.Raw
44+ , _exports :: Var.Listing (A.Located Var.Value)
45+ , _settings :: SourceSettings
46+ , _docs :: A.Located (Maybe String)
47+ , _imports :: imports
48+ }
49+
37
50
38
51
39-- MODULES
52-- MODULES
40
53
41−type SourceModule =
42− Module
43− String
44− [UserImport]
45− (Var.Listing (A.Located Var.Value))
46− [Decl.SourceDecl]
47
54
55+data Module phase =
56+ Module
57+ { name :: Name.Canonical
58+ , path :: FilePath
59+ , info :: phase
60+ }
48
61
49−type ValidModule =
50− Module
51− String
52− ([DefaultImport], [UserImport])
53− (Var.Listing (A.Located Var.Value))
54− [Decl.ValidDecl]
55
62
63+type Source =
64+ Module SourceInfo
56
65
57−type CanonicalModule =
58− Module Docs.Centralized [Name.Raw] [Var.Value] (Body Canonical.Expr)
59
66
67+data SourceInfo =
68+ Source
69+ { srcTag :: SourceTag
70+ , srcSettings :: SourceSettings
71+ , srcDocs :: A.Located (Maybe String)
72+ , srcExports :: Var.Listing (A.Located Var.Value)
73+ , srcImports :: [UserImport]
74+ , srcDecls :: [Decl.Source]
75+ }
60
76
61−type Optimized =
62− Module Docs.Centralized [Name.Raw] [Var.Value] (Body [Optimized.Def])
63
77
78+data SourceTag
79+ = Normal
80+ | Effect R.Region
81+ | Port R.Region
64
82
65−data Module docs imports exports body = Module
66− { name :: Name.Canonical
67− , path :: FilePath
68− , docs :: A.Located (Maybe docs)
69− , exports :: exports
70− , imports :: imports
71− , body :: body
72− }
73
83
84+type SourceSettings =
85+ A.Located [(A.Located String, A.Located String)]
74
86
75−data Body expr = Body
76− { program :: expr
77− , types :: Types
78− , fixities :: [(Decl.Assoc, Int, String)]
79− , aliases :: Aliases
80− , datatypes :: ADTs
81− , ports :: [String]
82− }
83
87
88+emptySettings :: SourceSettings
89+emptySettings =
90+ A.A (error "region of empty settings should not be needed") []
84
91
85−-- HEADERS
86
92
87−{-| Basic info needed to identify modules and determine dependencies. -}
93+type Valid =
88−data Header imports = Header
94+ Module ValidInfo
89− { _name :: Name.Raw
95+
96+
97+data ValidInfo =
98+ Valid
90− , _docs :: A.Located (Maybe String)
99+ { validDocs :: A.Located (Maybe String)
91− , _exports :: Var.Listing (A.Located Var.Value)
100+ , validExports :: Var.Listing (A.Located Var.Value)
92− , _imports :: imports
101+ , validImports :: ([DefaultImport], [UserImport])
102+ , validDecls :: Decl.Valid
103+ , validEffects :: Effects.Raw
93 }
104 }
94
105
95
106
96−-- IMPORTs
107+type Canonical =
108+ Module (Info Canonical.Expr)
109+
110+
111+type Optimized =
112+ Module (Info [Optimized.Def])
113+
114+
115+
116+-- IMPORTS
117+
97
118
98type UserImport = A.Located (Name.Raw, ImportMethod)
119type UserImport = A.Located (Name.Raw, ImportMethod)
99
120
@@ -101,53 +122,101 @@ type UserImport = A.Located (Name.Raw, ImportMethod)
101type DefaultImport = (Name.Raw, ImportMethod)
122type DefaultImport = (Name.Raw, ImportMethod)
102
123
103
124
104−data ImportMethod = ImportMethod
125+data ImportMethod =
126+ ImportMethod
105 { alias :: Maybe String
127 { alias :: Maybe String
106 , exposedVars :: !(Var.Listing Var.Value)
128 , exposedVars :: !(Var.Listing Var.Value)
107 }
129 }
108
130
109
131
132+
133+-- LATE PHASE MODULE INFORMATION
134+
135+
136+data Info program =
137+ Info
138+ { docs :: A.Located (Maybe Docs.Centralized)
139+ , exports :: [Var.Value]
140+ , imports :: [Name.Raw]
141+ , program :: program
142+ , types :: Types
143+ , fixities :: [Decl.Infix]
144+ , aliases :: Aliases
145+ , unions :: Unions
146+ , effects :: Effects.Canonical
147+ }
148+
149+
150+type Types =
151+ Map.Map String Type.Canonical
152+
153+
154+type Aliases =
155+ Map.Map String ([String], Type.Canonical)
156+
157+
158+type Unions =
159+ Map.Map String (UnionInfo String)
160+
161+
162+type UnionInfo v =
163+ ( [String], [(v, [Type.Canonical])] )
164+
165+
166+type CanonicalUnion =
167+ ( Var.Canonical, UnionInfo Var.Canonical )
168+
169+
170+
110-- INTERFACES
171-- INTERFACES
111
172
173+
174+type Interfaces =
175+ Map.Map Name.Canonical Interface
176+
177+
112{-| Key facts about a module, used when reading info from .elmi files. -}
178{-| Key facts about a module, used when reading info from .elmi files. -}
113−data Interface = Interface
179+data Interface =
180+ Interface
114 { iVersion :: Package.Version
181 { iVersion :: Package.Version
115 , iPackage :: Package.Name
182 , iPackage :: Package.Name
116 , iExports :: [Var.Value]
183 , iExports :: [Var.Value]
117− , iTypes :: Types
118 , iImports :: [Name.Raw]
184 , iImports :: [Name.Raw]
119− , iAdts :: ADTs
185+ , iTypes :: Types
186+ , iUnions :: Unions
120 , iAliases :: Aliases
187 , iAliases :: Aliases
121− , iFixities :: [(Decl.Assoc, Int, String)]
188+ , iFixities :: [Decl.Infix]
122− , iPorts :: [String]
123 }
189 }
124
190
125
191
126toInterface :: Package.Name -> Optimized -> Interface
192toInterface :: Package.Name -> Optimized -> Interface
127toInterface pkgName modul =
193toInterface pkgName modul =
128− let body' = body modul in
194+ let
195+ myInfo =
196+ info modul
197+ in
129 Interface
198 Interface
130− { iVersion = Compiler.version
199+ { iVersion = Compiler.version
131− , iPackage = pkgName
200+ , iPackage = pkgName
132− , iExports = exports modul
201+ , iExports = exports myInfo
133− , iTypes = types body'
134− , iImports = imports modul
202+ , iImports = imports myInfo
135− , iAdts = datatypes body'
203+ , iTypes = types myInfo
204+ , iUnions = unions myInfo
136− , iAliases = aliases body'
205+ , iAliases = aliases myInfo
137− , iFixities = fixities body'
206+ , iFixities = fixities myInfo
138− , iPorts = ports body'
139− }
207+ }
140
208
141
209
142instance Binary Interface where
210instance Binary Interface where
211+ get =
143− get = Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
212+ Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
213+
144− put modul = do
214+ put modul =
145− put (iVersion modul)
215+ do put (iVersion modul)
146− put (iPackage modul)
216+ put (iPackage modul)
147− put (iExports modul)
217+ put (iExports modul)
148− put (iTypes modul)
149− put (iImports modul)
218+ put (iImports modul)
150− put (iAdts modul)
219+ put (iTypes modul)
220+ put (iUnions modul)
151− put (iAliases modul)
221+ put (iAliases modul)
152− put (iFixities modul)
222+ put (iFixities modul)
153− put (iPorts modul)
src/AST/Module/Name.hs+6−1
@@ -18,7 +18,12 @@ data Canonical = Canonical
18
18
19inCore :: Raw -> Canonical
19inCore :: Raw -> Canonical
20inCore raw =
20inCore raw =
21− Canonical Package.coreName raw
21+ Canonical Package.core raw
22+
23+
24+inHtml :: Raw -> Canonical
25+inHtml raw =
26+ Canonical Package.html raw
22
27
23
28
24toString :: Raw -> String
29toString :: Raw -> String
src/AST/Pattern.hs+16−6
@@ -22,19 +22,29 @@ data Pattern' ann var
22 | Literal L.Literal
22 | Literal L.Literal
23
23
24
24
25−type RawPattern =
25+type Raw =
26 Pattern R.Region Var.Raw
26 Pattern R.Region Var.Raw
27
27
28
28
29−type RawPattern' =
29+type Raw' =
30 Pattern' R.Region Var.Raw
30 Pattern' R.Region Var.Raw
31
31
32
32
33−type CanonicalPattern =
33+type Canonical =
34 Pattern R.Region Var.Canonical
34 Pattern R.Region Var.Canonical
35
35
36
36
37+isVar :: String -> Pattern ann var -> Bool
38+isVar name (A.A _ pattern) =
39+ case pattern of
40+ Var pName ->
41+ name == pName
42+
43+ _ ->
44+ False
45+
46+
37−list :: R.Position -> [RawPattern] -> RawPattern
47+list :: R.Position -> [Raw] -> Raw
38list end patterns =
48list end patterns =
39 case patterns of
49 case patterns of
40 [] ->
50 [] ->
@@ -44,7 +54,7 @@ list end patterns =
44 A.at start end (Data (Var.Raw "::") [pattern, list end rest])
54 A.at start end (Data (Var.Raw "::") [pattern, list end rest])
45
55
46
56
47−consMany :: R.Position -> [RawPattern] -> RawPattern
57+consMany :: R.Position -> [Raw] -> Raw
48consMany end patterns =
58consMany end patterns =
49 let cons hd@(A.A (R.Region start _) _) tl =
59 let cons hd@(A.A (R.Region start _) _) tl =
50 A.at start end (Data (Var.Raw "::") [hd, tl])
60 A.at start end (Data (Var.Raw "::") [hd, tl])
@@ -52,7 +62,7 @@ consMany end patterns =
52 foldr1 cons patterns
62 foldr1 cons patterns
53
63
54
64
55−tuple :: [RawPattern] -> RawPattern'
65+tuple :: [Raw] -> Raw'
56tuple patterns =
66tuple patterns =
57 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns
67 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns
58
68
src/AST/Type.hs+91−77
@@ -1,16 +1,17 @@
1module AST.Type
1module AST.Type
2 ( Raw, Raw'(..)
2 ( Raw, Raw'(..)
3 , Canonical(..), Aliased(..)
3 , Canonical(..), Aliased(..)
4− , Port(..), getPortType
5 , deepDealias, iteratedDealias, dealias
4 , deepDealias, iteratedDealias, dealias
6 , collectLambdas
5 , collectLambdas
7− , tuple
6+ , tuple, cmd, sub
7+ )
8− ) where
8+ where
9
9
10import Control.Arrow (second)
10import Control.Arrow (second)
11import Data.Binary
11import Data.Binary
12import qualified Data.Map as Map
12import qualified Data.Map as Map
13
13
14+import qualified AST.Module.Name as ModuleName
14import qualified AST.Variable as Var
15import qualified AST.Variable as Var
15import qualified Reporting.Annotation as A
16import qualified Reporting.Annotation as A
16import qualified Reporting.Region as R
17import qualified Reporting.Region as R
@@ -48,24 +49,34 @@ data Aliased t
48 deriving (Eq, Ord)
49 deriving (Eq, Ord)
49
50
50
51
51−data Port t
52− = Normal t
53− | Signal { root :: t, arg :: t }
54− deriving (Eq)
55
52
56−
53+-- CONSTRUCT USEFUL TYPES
57−getPortType :: Port tipe -> tipe
58−getPortType portType =
59− case portType of
60− Normal tipe -> tipe
61− Signal tipe _ -> tipe
62
54
63
55
64tuple :: R.Region -> [Raw] -> Raw
56tuple :: R.Region -> [Raw] -> Raw
65tuple region types =
57tuple region types =
58+ let
59+ name =
66− let name = Var.Raw ("_Tuple" ++ show (length types))
60+ Var.Raw ("_Tuple" ++ show (length types))
67 in
61 in
68− A.A region (RApp (A.A region (RType name)) types)
62+ A.A region (RApp (A.A region (RType name)) types)
63+
64+
65+cmd :: ModuleName.Canonical -> String -> Canonical
66+cmd =
67+ effect Var.cmd
68+
69+
70+sub :: ModuleName.Canonical -> String -> Canonical
71+sub =
72+ effect Var.sub
73+
74+
75+effect :: Var.Canonical -> ModuleName.Canonical -> String -> Canonical
76+effect effectName moduleName tipe =
77+ Lambda
78+ (App (Type (Var.fromModule moduleName tipe)) [Var "msg"])
79+ (App (Type effectName) [Var "msg"])
69
80
70
81
71
82
@@ -76,65 +87,68 @@ deepDealias :: Canonical -> Canonical
76deepDealias tipe =
87deepDealias tipe =
77 case tipe of
88 case tipe of
78 Lambda a b ->
89 Lambda a b ->
79− Lambda (deepDealias a) (deepDealias b)
90+ Lambda (deepDealias a) (deepDealias b)
80
91
81 Var _ ->
92 Var _ ->
82− tipe
93+ tipe
83
94
84 Record fields ext ->
95 Record fields ext ->
85− Record (map (second deepDealias) fields) (fmap deepDealias ext)
96+ Record (map (second deepDealias) fields) (fmap deepDealias ext)
86
97
87 Aliased _name args tipe' ->
98 Aliased _name args tipe' ->
88− deepDealias (dealias args tipe')
99+ deepDealias (dealias args tipe')
89
100
90 Type _ ->
101 Type _ ->
91− tipe
102+ tipe
92
103
93 App f args ->
104 App f args ->
94− App (deepDealias f) (map deepDealias args)
105+ App (deepDealias f) (map deepDealias args)
95
106
96
107
97iteratedDealias :: Canonical -> Canonical
108iteratedDealias :: Canonical -> Canonical
98iteratedDealias tipe =
109iteratedDealias tipe =
99 case tipe of
110 case tipe of
100 Aliased _ args realType ->
111 Aliased _ args realType ->
101− iteratedDealias (dealias args realType)
112+ iteratedDealias (dealias args realType)
102
113
103 _ ->
114 _ ->
104− tipe
115+ tipe
105
116
106
117
107dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
118dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
108dealias args aliasType =
119dealias args aliasType =
109 case aliasType of
120 case aliasType of
110 Holey tipe ->
121 Holey tipe ->
111− dealiasHelp (Map.fromList args) tipe
122+ dealiasHelp (Map.fromList args) tipe
112
123
113 Filled tipe ->
124 Filled tipe ->
114− tipe
125+ tipe
115
126
116
127
117dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
128dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
118dealiasHelp typeTable tipe =
129dealiasHelp typeTable tipe =
130+ let
131+ go =
119− let go = dealiasHelp typeTable in
132+ dealiasHelp typeTable
133+ in
120− case tipe of
134+ case tipe of
121− Lambda a b ->
135+ Lambda a b ->
122− Lambda (go a) (go b)
136+ Lambda (go a) (go b)
123
137
124− Var x ->
138+ Var x ->
125− Map.findWithDefault tipe x typeTable
139+ Map.findWithDefault tipe x typeTable
126
140
127− Record fields ext ->
141+ Record fields ext ->
128− Record (map (second go) fields) (fmap go ext)
142+ Record (map (second go) fields) (fmap go ext)
129
143
130− Aliased original args t' ->
144+ Aliased original args t' ->
131− Aliased original (map (second go) args) t'
145+ Aliased original (map (second go) args) t'
132
146
133− Type _ ->
147+ Type _ ->
134− tipe
148+ tipe
135
149
136− App f args ->
150+ App f args ->
137− App (go f) (map go args)
151+ App (go f) (map go args)
138
152
139
153
140
154
@@ -145,10 +159,10 @@ collectLambdas :: Canonical -> [Canonical]
145collectLambdas tipe =
159collectLambdas tipe =
146 case tipe of
160 case tipe of
147 Lambda arg result ->
161 Lambda arg result ->
148− arg : collectLambdas result
162+ arg : collectLambdas result
149
163
150 _ ->
164 _ ->
151− [tipe]
165+ [tipe]
152
166
153
167
154
168
@@ -157,49 +171,49 @@ collectLambdas tipe =
157
171
158instance Binary Canonical where
172instance Binary Canonical where
159 put tipe =
173 put tipe =
160− case tipe of
174+ case tipe of
161− Lambda t1 t2 ->
175+ Lambda t1 t2 ->
162− putWord8 0 >> put t1 >> put t2
176+ putWord8 0 >> put t1 >> put t2
163
177
164− Var x ->
178+ Var x ->
165− putWord8 1 >> put x
179+ putWord8 1 >> put x
166
180
167− Type name ->
181+ Type name ->
168− putWord8 2 >> put name
182+ putWord8 2 >> put name
169
183
170− App t1 t2 ->
184+ App t1 t2 ->
171− putWord8 3 >> put t1 >> put t2
185+ putWord8 3 >> put t1 >> put t2
172
186
173− Record fs ext ->
187+ Record fs ext ->
174− putWord8 4 >> put fs >> put ext
188+ putWord8 4 >> put fs >> put ext
175
189
176− Aliased var args t ->
190+ Aliased var args t ->
177− putWord8 5 >> put var >> put args >> put t
191+ putWord8 5 >> put var >> put args >> put t
178
192
179− get = do
193+ get =
180− n <- getWord8
194+ do n <- getWord8
181− case n of
195+ case n of
182− 0 -> Lambda <$> get <*> get
196+ 0 -> Lambda <$> get <*> get
183− 1 -> Var <$> get
197+ 1 -> Var <$> get
184− 2 -> Type <$> get
198+ 2 -> Type <$> get
185− 3 -> App <$> get <*> get
199+ 3 -> App <$> get <*> get
186− 4 -> Record <$> get <*> get
200+ 4 -> Record <$> get <*> get
187− 5 -> Aliased <$> get <*> get <*> get
201+ 5 -> Aliased <$> get <*> get <*> get
188− _ -> error "Error reading a valid type from serialized string"
202+ _ -> error "Error reading a valid type from serialized string"
189
203
190
204
191instance Binary t => Binary (Aliased t) where
205instance Binary t => Binary (Aliased t) where
192 put aliasType =
206 put aliasType =
193− case aliasType of
207+ case aliasType of
194− Holey tipe ->
208+ Holey tipe ->
195− putWord8 0 >> put tipe
209+ putWord8 0 >> put tipe
196−
210+
197− Filled tipe ->
211+ Filled tipe ->
198− putWord8 1 >> put tipe
212+ putWord8 1 >> put tipe
199−
213+
200− get = do
214+ get =
201− n <- getWord8
215+ do n <- getWord8
202− case n of
216+ case n of
203− 0 -> Holey <$> get
217+ 0 -> Holey <$> get
204− 1 -> Filled <$> get
218+ 1 -> Filled <$> get
205− _ -> error "Error reading a valid type from serialized string"
219+ _ -> error "Error reading a valid type from serialized string"
src/AST/Variable.hs+15−10
@@ -70,6 +70,21 @@ inCore home name =
70 Canonical (Module (ModuleName.inCore home)) name
70 Canonical (Module (ModuleName.inCore home)) name
71
71
72
72
73+inHtml :: ModuleName.Raw -> String -> Canonical
74+inHtml home name =
75+ Canonical (Module (ModuleName.inHtml home)) name
76+
77+
78+cmd :: Canonical
79+cmd =
80+ inCore ["Platform","Cmd"] "Cmd"
81+
82+
83+sub :: Canonical
84+sub =
85+ inCore ["Platform","Sub"] "Sub"
86+
87+
73
88
74-- VARIABLE RECOGNIZERS
89-- VARIABLE RECOGNIZERS
75
90
@@ -114,16 +129,6 @@ isTask =
114 is ["Task"] "Task"
129 is ["Task"] "Task"
115
130
116
131
117−isSignal :: Canonical -> Bool
118−isSignal =
119− is ["Signal"] "Signal"
120−
121−
122−isText :: Canonical -> Bool
123−isText =
124− is ["Text"] "Text"
125−
126−
127isList :: Canonical -> Bool
132isList :: Canonical -> Bool
128isList v =
133isList v =
129 v == Canonical BuiltIn "List"
134 v == Canonical BuiltIn "List"
src/Canonicalize.hs+203−239
@@ -1,18 +1,16 @@
1+{-# OPTIONS_GHC -Wall #-}
1module Canonicalize (module') where
2module Canonicalize (module') where
2
3
3import qualified Data.List as List
4import qualified Data.List as List
4import qualified Data.Map as Map
5import qualified Data.Map as Map
5import qualified Data.Maybe as Maybe
6import qualified Data.Maybe as Maybe
6import qualified Data.Set as Set
7import qualified Data.Set as Set
7−import qualified Data.Traversable as T
8import qualified Data.Foldable as T
8import qualified Data.Foldable as T
9
9
10−import AST.Expression.General (Expr'(..), dummyLet)
10+import AST.Expression.General (Expr'(..))
11−import AST.Module (Body(..))
12import Elm.Utils ((|>))
11import Elm.Utils ((|>))
13
12
14import qualified AST.Declaration as D
13import qualified AST.Declaration as D
15−import qualified AST.Expression.General as E
16import qualified AST.Expression.Valid as Valid
14import qualified AST.Expression.Valid as Valid
17import qualified AST.Expression.Canonical as Canonical
15import qualified AST.Expression.Canonical as Canonical
18import qualified AST.Module as Module
16import qualified AST.Module as Module
@@ -20,144 +18,132 @@ import qualified AST.Module.Name as ModuleName
20import qualified AST.Pattern as P
18import qualified AST.Pattern as P
21import qualified AST.Type as Type
19import qualified AST.Type as Type
22import qualified AST.Variable as Var
20import qualified AST.Variable as Var
23−import qualified Docs.AST as Docs
21+import qualified Canonicalize.Body as Body
22+import qualified Canonicalize.Effects as Effects
23+import qualified Canonicalize.Environment as Env
24+import qualified Canonicalize.Setup as Setup
25+import qualified Canonicalize.Type as Canon
26+import qualified Canonicalize.Variable as Canon
24import qualified Docs.Centralize as Docs
27import qualified Docs.Centralize as Docs
25import qualified Reporting.Annotation as A
28import qualified Reporting.Annotation as A
26import qualified Reporting.Error as Error
29import qualified Reporting.Error as Error
27import qualified Reporting.Error.Canonicalize as CError
30import qualified Reporting.Error.Canonicalize as CError
28import qualified Reporting.Error.Helpers as ErrorHelp
31import qualified Reporting.Error.Helpers as ErrorHelp
29import qualified Reporting.Region as Region
32import qualified Reporting.Region as Region
30−import qualified Reporting.Result as R
33+import qualified Reporting.Render.Type as RenderType
34+import qualified Reporting.Result as Result
31import qualified Reporting.Warning as Warning
35import qualified Reporting.Warning as Warning
32−import qualified Canonicalize.Declaration as Decls
36+
33−import qualified Canonicalize.Environment as Env
37+
34−import qualified Canonicalize.Port as Port
38+
35−import qualified Canonicalize.Result as Result
39+type Result a =
36−import qualified Canonicalize.Setup as Setup
40+ Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error a
37−import qualified Canonicalize.Sort as Sort
38−import qualified Canonicalize.Type as Canonicalize
39−import qualified Canonicalize.Variable as Canonicalize
40
41
41
42
42-- MODULES
43-- MODULES
43
44
45+
44module'
46module'
45 :: [ModuleName.Canonical]
47 :: [ModuleName.Canonical]
46 -> Module.Interfaces
48 -> Module.Interfaces
47− -> Module.ValidModule
49+ -> Module.Valid
48− -> R.Result Warning.Warning Error.Error Module.CanonicalModule
50+ -> Result Module.Canonical
49−module' canonicalImports interfaces modul =
51+module' allCanonicalImports interfaces modul =
50 let
52 let
53+ (Module.Valid docs exports imports decls effects) =
54+ Module.info modul
55+
51 importDict =
56 importDict =
52− canonicalImports
57+ allCanonicalImports
53 |> map (\cName -> (ModuleName._module cName, cName))
58 |> map (\cName -> (ModuleName._module cName, cName))
54 |> Map.fromList
59 |> Map.fromList
55
60
56− (Result.Result uses rawResults) =
61+ (Result.Result uses warnings rawResults) =
57− moduleHelp importDict interfaces modul
62+ do env <- Setup.environment importDict interfaces modul
58− in
59− case rawResults of
60− Result.Ok (env, almostCanonicalModule) ->
61− R.addDealiaser (Env.toDealiaser env) $
62− filterImports uses almostCanonicalModule
63
63
64+ (,,,) env
65+ <$> resolveExports (Effects.toValues effects ++ declsToValues decls) exports
66+ <*> canonicalizeDecls env decls
67+ <*> Effects.canonicalize env effects
68+ in
69+ case rawResults of
64− Result.Err msgs ->
70+ Result.Err errors ->
65− R.throwMany (map (A.map Error.Canonicalize) msgs)
71+ Result.mapError Error.Canonicalize $
72+ Result.Result Result.None warnings (Result.Err errors)
66
73
74+ Result.Ok (env, canonicalExports, canonicalDecls, canonicalEffects) ->
75+ let
76+ (D.Decls _ unions aliases infixes) =
77+ canonicalDecls
67
78
68−type AlmostCanonicalModule =
79+ centralizedDocs =
69− Module.Module
80+ A.map (fmap (Docs.centralize canonicalDecls)) docs
70− Docs.Centralized
71− ([Module.DefaultImport], [Module.UserImport])
72− [Var.Value]
73− (Module.Body Canonical.Expr)
74
81
82+ typeToPair (A.A _ (D.Type name args body)) =
83+ ( name, (args, body) )
75
84
76−moduleHelp
85+ program =
77− :: Map.Map ModuleName.Raw ModuleName.Canonical
86+ Body.flatten (Module.name modul) canonicalDecls canonicalEffects
78− -> Module.Interfaces
79− -> Module.ValidModule
80− -> Result.ResultErr (Env.Environment, AlmostCanonicalModule)
81−moduleHelp importDict interfaces modul@(Module.Module _ _ comment exports _ decls) =
82− canonicalModule
83− <$> canonicalDeclsResult
84− <*> resolveExports locals exports
85− where
86− canonicalModule (env, canonicalDecls) canonicalExports =
87− (,) env $
88− modul
89− { Module.docs = A.map (fmap (Docs.centralize canonicalDecls)) comment
90− , Module.exports = canonicalExports
91− , Module.body = body canonicalDecls
92− }
93−
94− locals :: [Var.Value]
95− locals =
96− concatMap declToValue decls
97−
98− canonicalDeclsResult =
99− Setup.environment importDict interfaces modul
100− `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls
101−
102− body :: [D.CanonicalDecl] -> Module.Body Canonical.Expr
103− body decls =
104− let nakedDecls = map A.drop decls
105 in
87 in
106− Module.Body
88+ do canonicalImports <- filterImports uses imports
107− { program =
89+ Result.accumulate (Result.One (Env.toDealiaser env)) $
108− let expr = Decls.toExpr (Module.name modul) decls
90+ modul {
109− in
91+ Module.info =
110− Sort.definitions (dummyLet expr)
92+ Module.Info
111−
93+ { Module.docs = centralizedDocs
112− , types =
94+ , Module.exports = canonicalExports
95+ , Module.imports = canonicalImports
96+ , Module.program = program
113− Map.empty
97+ , Module.types = Map.empty
114−
98+ , Module.fixities = infixes
115− , datatypes =
99+ , Module.aliases = Map.fromList (map typeToPair aliases)
116− Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- nakedDecls ]
100+ , Module.unions = Map.fromList (map typeToPair unions)
101+ , Module.effects = canonicalEffects
102+ }
103+ }
117
104
118− , fixities =
119− [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]
120−
121− , aliases =
122− Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- nakedDecls ]
123−
124− , ports =
125− [ E.portName impl | D.Port (D.CanonicalPort impl) <- nakedDecls ]
126− }
127
105
128
106
129-- IMPORTS
107-- IMPORTS
130
108
109+
131filterImports
110filterImports
132 :: Set.Set ModuleName.Raw
111 :: Set.Set ModuleName.Raw
133− -> AlmostCanonicalModule
112+ -> ([Module.DefaultImport], [Module.UserImport])
134− -> R.Result Warning.Warning e Module.CanonicalModule
113+ -> Result [ModuleName.Raw]
135−filterImports uses modul@(Module.Module _ _ _ _ (defaults, imports) _) =
114+filterImports uses (defaults, imports) =
136− do reducedImports <-
115+ let
137− Maybe.catMaybes <$> T.traverse checkImport imports
138−
139− return $ modul
140− { Module.imports =
141− Set.toList (Set.fromList (map fst defaults ++ reducedImports))
142− }
143− where
144 checkImport (A.A region (name, _method)) =
116 checkImport (A.A region (name, _method)) =
145 if Set.member name uses then
117 if Set.member name uses then
146− return (Just name)
118+ return (Just name)
119+
147 else
120 else
148− do R.warn region (Warning.UnusedImport name)
121+ Result.warn region (Warning.UnusedImport name) Nothing
122+ in
123+ do reducedImports <-
124+ Maybe.catMaybes <$> traverse checkImport imports
125+
149− return Nothing
126+ return $
127+ Set.toList (Set.fromList (map fst defaults ++ reducedImports))
128+
129+
130+
131+-------- CANONICALIZATION --------
132+
133+
134+type CResult a =
135+ Canon.Result a
136+
150
137
151
138
152-- EXPORTS
139-- EXPORTS
153
140
154−resolveExports
141+
155− :: [Var.Value]
156− -> Var.Listing (A.Located Var.Value)
142+resolveExports :: [Var.Value] -> Var.Listing (A.Located Var.Value) -> CResult [Var.Value]
157− -> Result.ResultErr [Var.Value]
158resolveExports fullList (Var.Listing partialList open) =
143resolveExports fullList (Var.Listing partialList open) =
159 if open then
144 if open then
160 Result.ok fullList
145 Result.ok fullList
146+
161 else
147 else
162 let
148 let
163 (allValues, allAliases, allAdts) =
149 (allValues, allAliases, allAdts) =
@@ -170,17 +156,13 @@ resolveExports fullList (Var.Listing partialList open) =
170 map fst allAdts
156 map fst allAdts
171 in
157 in
172 (\xs ys zs _ -> xs ++ ys ++ zs)
158 (\xs ys zs _ -> xs ++ ys ++ zs)
173− <$> T.traverse (getValueExport allValues (Set.fromList allValues)) values
159+ <$> traverse (getValueExport allValues (Set.fromList allValues)) values
174− <*> (concat <$> T.traverse (getAliasExport allValues allAliases adtTypes) aliases)
160+ <*> (concat <$> traverse (getAliasExport allValues allAliases adtTypes) aliases)
175− <*> T.traverse (getAdtExport allAdts adtTypes) adts
161+ <*> traverse (getAdtExport allAdts adtTypes) adts
176 <*> allUnique partialList
162 <*> allUnique partialList
177
163
178
164
179−getValueExport
165+getValueExport :: [String] -> Set.Set String -> A.Located String -> CResult Var.Value
180− :: [String]
181− -> Set.Set String
182− -> A.Located String
183− -> Result.ResultErr Var.Value
184getValueExport allValues allValuesSet (A.A region name) =
166getValueExport allValues allValuesSet (A.A region name) =
185 if Set.member name allValuesSet then
167 if Set.member name allValuesSet then
186 Result.ok (Var.Value name)
168 Result.ok (Var.Value name)
@@ -188,12 +170,7 @@ getValueExport allValues allValuesSet (A.A region name) =
188 manyNotFound region [name] allValues
170 manyNotFound region [name] allValues
189
171
190
172
191−getAliasExport
173+getAliasExport :: [String] -> [String] -> [String] -> A.Located String -> CResult [Var.Value]
192− :: [String]
193− -> [String]
194− -> [String]
195− -> A.Located String
196− -> Result.ResultErr [Var.Value]
197getAliasExport allValues allAliases adtTypes (A.A region alias) =
174getAliasExport allValues allAliases adtTypes (A.A region alias) =
198 if alias `elem` allAliases then
175 if alias `elem` allAliases then
199
176
@@ -213,7 +190,7 @@ getAdtExport
213 :: [(String, Var.Listing String)]
190 :: [(String, Var.Listing String)]
214 -> [String]
191 -> [String]
215 -> A.Located (String, Var.Listing String)
192 -> A.Located (String, Var.Listing String)
216− -> Result.ResultErr Var.Value
193+ -> CResult Var.Value
217getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =
194getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =
218 case List.lookup name allAdts of
195 case List.lookup name allAdts of
219 Nothing ->
196 Nothing ->
@@ -230,9 +207,9 @@ getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =
230 manyNotFound region unfoundCtors allCtors
207 manyNotFound region unfoundCtors allCtors
231
208
232
209
233−manyNotFound :: Region.Region -> [String] -> [String] -> Result.ResultErr a
210+manyNotFound :: Region.Region -> [String] -> [String] -> CResult a
234manyNotFound region nameList possibilities =
211manyNotFound region nameList possibilities =
235− Result.errors (map (notFound region possibilities) nameList)
212+ Result.throwMany (map (notFound region possibilities) nameList)
236
213
237
214
238notFound :: Region.Region -> [String] -> String -> A.Located CError.Error
215notFound :: Region.Region -> [String] -> String -> A.Located CError.Error
@@ -241,7 +218,7 @@ notFound region possibilities name =
241 ErrorHelp.nearbyNames id name possibilities
218 ErrorHelp.nearbyNames id name possibilities
242
219
243
220
244−allUnique :: [A.Located Var.Value] -> Result.ResultErr ()
221+allUnique :: [A.Located Var.Value] -> CResult ()
245allUnique statedExports =
222allUnique statedExports =
246 let
223 let
247 valueToString value =
224 valueToString value =
@@ -256,16 +233,46 @@ allUnique statedExports =
256 isUnique value allRegions =
233 isUnique value allRegions =
257 case allRegions of
234 case allRegions of
258 region : _ : _ ->
235 region : _ : _ ->
259− Result.err (A.A region (CError.DuplicateExport (valueToString value)))
236+ Result.throw region (CError.DuplicateExport (valueToString value))
260
237
261 _ ->
238 _ ->
262 Result.ok ()
239 Result.ok ()
263 in
240 in
264− T.traverse_ id (Map.mapWithKey isUnique locations)
241+ T.sequenceA_ (Map.mapWithKey isUnique locations)
242+
243+
244+
245+-- CONVERSIONS
246+
247+
248+declsToValues :: D.Valid -> [Var.Value]
249+declsToValues (D.Decls defs unions aliases _) =
250+ let
251+ fromDef (A.A _ def) =
252+ map Var.Value (P.boundVarList (Valid.getPattern def))
253+
254+ fromUnion (A.A _ (D.Type name _ ctors)) =
255+ Var.Union name (Var.Listing (map fst ctors) False)
256+
257+ fromAlias (A.A _ (D.Type name _ tipe)) =
258+ case tipe of
259+ A.A _ (Type.RRecord _ Nothing) ->
260+ [ Var.Alias name, Var.Value name ]
261+
262+ _ ->
263+ [ Var.Alias name ]
264+ in
265+ concat
266+ [ map fromUnion unions
267+ , concatMap fromAlias aliases
268+ , concatMap fromDef defs
269+ ]
270+
265
271
266
272
267-- GROUPING VALUES
273-- GROUPING VALUES
268
274
275+
269maybeUnzip3 :: [(Maybe a, Maybe b, Maybe c)] -> ([a],[b],[c])
276maybeUnzip3 :: [(Maybe a, Maybe b, Maybe c)] -> ([a],[b],[c])
270maybeUnzip3 tuples =
277maybeUnzip3 tuples =
271 let (as, bs, cs) = unzip3 tuples
278 let (as, bs, cs) = unzip3 tuples
@@ -307,90 +314,52 @@ splitLocatedValue (A.A region value) =
307 (Nothing, Nothing, Just (A.A region (name, listing)))
314 (Nothing, Nothing, Just (A.A region (name, listing)))
308
315
309
316
317+
310-- DECLARATIONS
318-- DECLARATIONS
311
319
312−declToValue :: D.ValidDecl -> [Var.Value]
313−declToValue (A.A _ decl) =
314− case decl of
315− D.Definition (Valid.Definition pattern _ _) ->
316− map Var.Value (P.boundVarList pattern)
317
320
318− D.Datatype name _tvs ctors ->
321+canonicalizeDecls :: Env.Environment -> D.Valid -> CResult D.Canonical
319− [ Var.Union name (Var.Listing (map fst ctors) False) ]
322+canonicalizeDecls env (D.Decls defs unions aliases infixes) =
323+ let
324+ annTraverse canEntry entries =
325+ traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries
320
326
321− D.TypeAlias name _ tipe ->
327+ canonicalizeDef (Valid.Def pat expr typ) =
322− case tipe of
328+ Canonical.Def Canonical.dummyFacts
323− A.A _ (Type.RRecord _ Nothing) ->
329+ <$> canonicalizePattern env pat
324− [ Var.Alias name, Var.Value name ]
330+ <*> canonicalizeExpr env expr
331+ <*> traverse (canonicalizeRegionType env) typ
325
332
326− _ ->
333+ canonicalizeArgs (ctor, args) =
327− [ Var.Alias name ]
334+ (,) ctor <$> traverse (Canon.tipe env) args
328
335
329− _ -> []
336+ canonicalizeUnion (D.Type name tvars ctors) =
337+ D.Type name tvars <$> traverse canonicalizeArgs ctors
330
338
339+ canonicalizeAlias (D.Type name tvars alias) =
340+ D.Type name tvars <$> Canon.tipe env alias
341+ in
342+ D.Decls
343+ <$> annTraverse canonicalizeDef defs
344+ <*> annTraverse canonicalizeUnion unions
345+ <*> annTraverse canonicalizeAlias aliases
346+ <*> pure infixes
331
347
332−declaration
348+
333− :: Env.Environment
349+canonicalizeRegionType
334− -> D.ValidDecl
335− -> Result.ResultErr D.CanonicalDecl
336−declaration env (A.A ann@(region,_) decl) =
337− A.A ann <$>
338− case decl of
339− D.Definition (Valid.Definition pat expr typ) ->
340− D.Definition <$> (
341− Canonical.Definition Canonical.dummyFacts
342− <$> pattern env pat
343− <*> expression env expr
344− <*> T.traverse (regionType env) typ
345− )
346−
347− D.Datatype name tvars ctors ->
348− D.Datatype name tvars <$> T.traverse canonicalize' ctors
349− where
350− canonicalize' (ctor,args) =
351− (,) ctor <$> T.traverse (Canonicalize.tipe env) args
352−
353− D.TypeAlias name tvars expanded ->
354− D.TypeAlias name tvars
355− <$> Canonicalize.tipe env expanded
356−
357− D.Port validPort ->
358− Result.addModule ["Native","Port"] $
359− Result.addModule ["Native","Json"] $
360− case validPort of
361− D.In name tipe ->
362− Canonicalize.tipe env tipe
363− `Result.andThen` \canonicalType ->
364− D.Port <$> Port.check region name Nothing canonicalType
365−
366− D.Out name expr tipe ->
367− let exprTypeResult =
368− (,)
369− <$> expression env expr
370− <*> Canonicalize.tipe env tipe
371− in
372− exprTypeResult
373− `Result.andThen` \(expr', tipe') ->
374− D.Port <$> Port.check region name (Just expr') tipe'
375−
376− D.Fixity assoc prec op ->
377− Result.ok (D.Fixity assoc prec op)
378−
379−
380−regionType
381 :: Env.Environment
350 :: Env.Environment
382 -> Type.Raw
351 -> Type.Raw
383− -> Result.ResultErr (A.Located Type.Canonical)
352+ -> CResult (A.Located Type.Canonical)
384−regionType env typ@(A.A region _) =
353+canonicalizeRegionType env typ@(A.A region _) =
385− A.A region <$> Canonicalize.tipe env typ
354+ A.A region <$> Canon.tipe env typ
386
355
387
356
388−expression
357+canonicalizeExpr
389 :: Env.Environment
358 :: Env.Environment
390 -> Valid.Expr
359 -> Valid.Expr
391− -> Result.ResultErr Canonical.Expr
360+ -> CResult Canonical.Expr
392−expression env (A.A region validExpr) =
361+canonicalizeExpr env (A.A region validExpr) =
393− let go = expression env
362+ let go = canonicalizeExpr env
394 in
363 in
395 A.A region <$>
364 A.A region <$>
396 case validExpr of
365 case validExpr of
@@ -406,94 +375,89 @@ expression env (A.A region validExpr) =
406 Update record fields ->
375 Update record fields ->
407 Update
376 Update
408 <$> go record
377 <$> go record
409− <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
378+ <*> traverse (\(field,expr) -> (,) field <$> go expr) fields
410
379
411 Record fields ->
380 Record fields ->
412 Record
381 Record
413− <$> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
382+ <$> traverse (\(field,expr) -> (,) field <$> go expr) fields
414
383
415 Binop (Var.Raw op) leftExpr rightExpr ->
384 Binop (Var.Raw op) leftExpr rightExpr ->
416 Binop
385 Binop
417− <$> Canonicalize.variable region env op
386+ <$> Canon.variable region env op
418 <*> go leftExpr
387 <*> go leftExpr
419 <*> go rightExpr
388 <*> go rightExpr
420
389
421 Lambda arg body ->
390 Lambda arg body ->
391+ let
392+ env' =
422− let env' = Env.addPattern arg env
393+ Env.addPattern arg env
423 in
394 in
424− Lambda <$> pattern env' arg <*> expression env' body
395+ Lambda <$> canonicalizePattern env' arg <*> canonicalizeExpr env' body
425
396
426 App func arg ->
397 App func arg ->
427 App <$> go func <*> go arg
398 App <$> go func <*> go arg
428
399
429 If branches finally ->
400 If branches finally ->
430 If
401 If
431− <$> T.traverse go' branches
402+ <$> traverse go' branches
432 <*> go finally
403 <*> go finally
433 where
404 where
434 go' (condition, branch) =
405 go' (condition, branch) =
435 (,) <$> go condition <*> go branch
406 (,) <$> go condition <*> go branch
436
407
437− Let defs body ->
408+ Let defs expr ->
438− Let <$> T.traverse rename' defs <*> expression env' body
409+ Let <$> traverse rename' defs <*> canonicalizeExpr env' expr
439 where
410 where
440 env' =
411 env' =
441− foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs
412+ foldr Env.addPattern env (map Valid.getPattern defs)
442
413
443− rename' (Valid.Definition p body mtipe) =
414+ rename' (Valid.Def p body mtipe) =
444− Canonical.Definition Canonical.dummyFacts
415+ Canonical.Def Canonical.dummyFacts
445− <$> pattern env' p
416+ <$> canonicalizePattern env' p
446− <*> expression env' body
417+ <*> canonicalizeExpr env' body
447− <*> T.traverse (regionType env') mtipe
418+ <*> traverse (canonicalizeRegionType env') mtipe
448
419
449 Var (Var.Raw x) ->
420 Var (Var.Raw x) ->
450− Var <$> Canonicalize.variable region env x
421+ Var <$> Canon.variable region env x
451
422
452 Data name exprs ->
423 Data name exprs ->
453− Data name <$> T.traverse go exprs
424+ Data name <$> traverse go exprs
454
425
455 ExplicitList exprs ->
426 ExplicitList exprs ->
456− ExplicitList <$> T.traverse go exprs
427+ ExplicitList <$> traverse go exprs
457
428
458 Case expr cases ->
429 Case expr cases ->
459− Case <$> go expr <*> T.traverse branch cases
430+ Case <$> go expr <*> traverse branch cases
460 where
431 where
461 branch (ptrn, brnch) =
432 branch (ptrn, brnch) =
462− (,) <$> pattern env ptrn
433+ (,)
434+ <$> canonicalizePattern env ptrn
463− <*> expression (Env.addPattern ptrn env) brnch
435+ <*> canonicalizeExpr (Env.addPattern ptrn env) brnch
464−
436+
465− Port impl ->
437+ Cmd moduleName ->
466− let portType pt =
438+ Result.ok (Cmd moduleName)
467− case pt of
439+
468− Type.Normal t ->
440+ Sub moduleName ->
469− Type.Normal
441+ Result.ok (Sub moduleName)
470− <$> Canonicalize.tipe env t
471−
472− Type.Signal root arg ->
473− Type.Signal
474− <$> Canonicalize.tipe env root
475− <*> Canonicalize.tipe env arg
476− in
477− Port <$>
478− case impl of
479− E.In name tipe ->
480− E.In name <$> portType tipe
481
442
482− E.Out name expr tipe ->
443+ OutgoingPort name tipe ->
483− E.Out name <$> go expr <*> portType tipe
444+ OutgoingPort name <$> Canon.tipe env tipe
484
445
485− E.Task name expr tipe ->
446+ IncomingPort name tipe ->
486− E.Task name <$> go expr <*> portType tipe
447+ IncomingPort name <$> Canon.tipe env tipe
448+
449+ Program _ _ ->
450+ error "DANGER - Program AST nodes should not be in canonicalization."
451+
452+ SaveEnv moduleName effects ->
453+ Result.ok (SaveEnv moduleName effects)
487
454
488 GLShader uid src tipe ->
455 GLShader uid src tipe ->
489 Result.ok (GLShader uid src tipe)
456 Result.ok (GLShader uid src tipe)
490
457
491
458
492−pattern
493− :: Env.Environment
459+canonicalizePattern :: Env.Environment -> P.Raw -> CResult P.Canonical
494− -> P.RawPattern
495− -> Result.ResultErr P.CanonicalPattern
496−pattern env (A.A region ptrn) =
460+canonicalizePattern env (A.A region ptrn) =
497 A.A region <$>
461 A.A region <$>
498 case ptrn of
462 case ptrn of
499 P.Var x ->
463 P.Var x ->
@@ -509,9 +473,9 @@ pattern env (A.A region ptrn) =
509 Result.ok P.Anything
473 Result.ok P.Anything
510
474
511 P.Alias x p ->
475 P.Alias x p ->
512− P.Alias x <$> pattern env p
476+ P.Alias x <$> canonicalizePattern env p
513
477
514 P.Data (Var.Raw name) patterns ->
478 P.Data (Var.Raw name) patterns ->
515 P.Data
479 P.Data
516− <$> Canonicalize.pvar region env name (length patterns)
480+ <$> Canon.pvar region env name (length patterns)
517− <*> T.traverse (pattern env) patterns
481+ <*> traverse (canonicalizePattern env) patterns
src/Canonicalize/Body.hsnew file+170
@@ -0,0 +1,170 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Canonicalize.Body (flatten) where
3+
4+import qualified Data.Maybe as Maybe
5+
6+import qualified AST.Declaration as Decl
7+import qualified AST.Effects as Effects
8+import qualified AST.Expression.General as E
9+import qualified AST.Expression.Canonical as Canonical
10+import qualified AST.Module.Name as ModuleName
11+import qualified AST.Pattern as P
12+import qualified AST.Type as Type
13+import qualified AST.Variable as Var
14+import qualified Canonicalize.Sort as Sort
15+import qualified Reporting.Annotation as A
16+import qualified Reporting.Region as R
17+
18+
19+
20+flatten :: ModuleName.Canonical -> Decl.Canonical -> Effects.Canonical -> Canonical.Expr
21+flatten moduleName (Decl.Decls defs unions aliases _) effects =
22+ let
23+ allDefs =
24+ concat
25+ [ concatMap (unionToDefs moduleName) unions
26+ , Maybe.mapMaybe (aliasToDefs moduleName) aliases
27+ , effectsToDefs moduleName effects
28+ , map A.drop defs
29+ ]
30+
31+ loc =
32+ A.A (error "this annotation should never be needed")
33+ in
34+ Sort.definitions $ loc $
35+ E.Let allDefs (loc $ E.SaveEnv moduleName effects)
36+
37+
38+
39+-- TYPES TO DEFS
40+
41+
42+unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [Canonical.Def]
43+unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =
44+ let
45+ tagToDef (tag, tipes) =
46+ let
47+ vars =
48+ take (length tipes) infiniteArgs
49+
50+ tbody =
51+ Type.App
52+ (Type.Type (Var.fromModule moduleName name))
53+ (map Type.Var tvars)
54+
55+ body =
56+ A.A region $
57+ E.Data tag (map (A.A region . E.localVar) vars)
58+ in
59+ definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)
60+ in
61+ map tagToDef constructors
62+
63+
64+aliasToDefs :: ModuleName.Canonical -> A.Commented (Decl.Alias Type.Canonical) -> Maybe Canonical.Def
65+aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =
66+ case tipe of
67+ Type.Record fields Nothing ->
68+ let
69+ resultType =
70+ Type.Aliased
71+ (Var.fromModule moduleName name)
72+ (zip tvars (map Type.Var tvars))
73+ (Type.Holey tipe)
74+
75+ args =
76+ map snd fields
77+
78+ vars =
79+ take (length args) infiniteArgs
80+
81+ record =
82+ A.A region $
83+ E.Record (zip (map fst fields) (map (A.A region . E.localVar) vars))
84+ in
85+ Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)
86+
87+ _ ->
88+ Nothing
89+
90+
91+infiniteArgs :: [String]
92+infiniteArgs =
93+ map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
94+
95+
96+buildFunction :: [String] -> Canonical.Expr -> Canonical.Expr
97+buildFunction vars body@(A.A ann _) =
98+ foldr
99+ (\pattern expr -> A.A ann (E.Lambda pattern expr))
100+ body
101+ (map (A.A ann . P.Var) vars)
102+
103+
104+definition :: String -> Canonical.Expr -> R.Region -> Type.Canonical -> Canonical.Def
105+definition name expr@(A.A ann _) region tipe =
106+ Canonical.Def
107+ Canonical.dummyFacts
108+ (A.A ann (P.Var name))
109+ expr
110+ (Just (A.A region tipe))
111+
112+
113+
114+-- EFFECTS
115+
116+
117+effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [Canonical.Def]
118+effectsToDefs moduleName effects =
119+ case effects of
120+ Effects.None ->
121+ []
122+
123+ Effects.Port ports ->
124+ map portToDef ports
125+
126+ Effects.Manager _ info ->
127+ let
128+ cmdToDef (A.A region name) =
129+ definition
130+ "command"
131+ (A.A region (E.Cmd moduleName))
132+ region
133+ (Type.cmd moduleName name)
134+
135+ subToDef (A.A region name) =
136+ definition
137+ "subscription"
138+ (A.A region (E.Sub moduleName))
139+ region
140+ (Type.sub moduleName name)
141+ in
142+ case Effects._managerType info of
143+ Effects.CmdManager cmd ->
144+ [ cmdToDef cmd
145+ ]
146+
147+ Effects.SubManager sub ->
148+ [ subToDef sub
149+ ]
150+
151+ Effects.FxManager cmd sub ->
152+ [ cmdToDef cmd
153+ , subToDef sub
154+ ]
155+
156+
157+portToDef :: A.Commented Effects.PortCanonical -> Canonical.Def
158+portToDef (A.A (region, _) (Effects.PortCanonical name kind tipe)) =
159+ definition name (A.A region (toPortExpr name kind)) region tipe
160+
161+
162+toPortExpr :: String -> Effects.Kind -> Canonical.Expr'
163+toPortExpr name kind =
164+ case kind of
165+ Effects.Outgoing tipe ->
166+ E.OutgoingPort name tipe
167+
168+ Effects.Incoming tipe ->
169+ E.IncomingPort name tipe
170+
src/Canonicalize/Declaration.hsdeleted−100
@@ -1,100 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Canonicalize.Declaration (toExpr) where
3−
4−import qualified AST.Declaration as D
5−import qualified AST.Expression.General as E
6−import qualified AST.Expression.Canonical as Canonical
7−import qualified AST.Module.Name as ModuleName
8−import qualified AST.Pattern as P
9−import qualified AST.Type as T
10−import qualified AST.Variable as Var
11−import qualified Reporting.Annotation as A
12−import qualified Reporting.Region as R
13−
14−
15−toExpr :: ModuleName.Canonical -> [D.CanonicalDecl] -> [Canonical.Def]
16−toExpr moduleName decls =
17− concatMap (toDefs moduleName) decls
18−
19−
20−toDefs :: ModuleName.Canonical -> D.CanonicalDecl -> [Canonical.Def]
21−toDefs moduleName (A.A (region,_) decl) =
22− let
23− typeVar =
24− Var.fromModule moduleName
25−
26− loc expr =
27− A.A region expr
28− in
29− case decl of
30− D.Definition def ->
31− [def]
32−
33− D.Datatype name tvars constructors ->
34− concatMap toDefs' constructors
35− where
36− toDefs' (ctor, tipes) =
37− let vars = take (length tipes) infiniteArgs
38− tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
39− body = loc . E.Data ctor $ map (loc . E.localVar) vars
40− in
41− [ definition ctor (buildFunction body vars) region (foldr T.Lambda tbody tipes) ]
42−
43− D.TypeAlias name tvars tipe@(T.Record fields Nothing) ->
44− [ definition name (buildFunction record vars) region (foldr T.Lambda result args) ]
45− where
46− result =
47− T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)
48−
49− args =
50− map snd fields
51−
52− vars =
53− take (length args) infiniteArgs
54−
55− record =
56− loc (E.Record (zip (map fst fields) (map (loc . E.localVar) vars)))
57−
58− -- Type aliases must be added to an extended equality dictionary,
59− -- but they do not require any basic constraints.
60− D.TypeAlias _ _ _ ->
61− []
62−
63− D.Port (D.CanonicalPort impl) ->
64− let body = loc (E.Port impl)
65− in
66− case impl of
67− E.In name tipe ->
68− [ definition name body region (T.getPortType tipe) ]
69−
70− E.Out name _expr tipe ->
71− [ definition name body region (T.getPortType tipe) ]
72−
73− E.Task name _expr tipe ->
74− [ definition name body region (T.getPortType tipe) ]
75−
76− -- no constraints are needed for fixity declarations
77− D.Fixity _ _ _ ->
78− []
79−
80−
81−infiniteArgs :: [String]
82−infiniteArgs =
83− map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
84−
85−
86−buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
87−buildFunction body@(A.A ann _) vars =
88− foldr
89− (\pattern expr -> A.A ann (E.Lambda pattern expr))
90− body
91− (map (A.A ann . P.Var) vars)
92−
93−
94−definition :: String -> Canonical.Expr -> R.Region -> T.Canonical -> Canonical.Def
95−definition name expr@(A.A ann _) region tipe =
96− Canonical.Definition
97− Canonical.dummyFacts
98− (A.A ann (P.Var name))
99− expr
100− (Just (A.A region tipe))
src/Canonicalize/Effects.hsnew file+137
@@ -0,0 +1,137 @@
1+module Canonicalize.Effects (canonicalize, toValues, checkPortType) where
2+
3+import qualified Data.Foldable as F
4+import qualified Data.Traversable as T
5+
6+import qualified AST.Effects as Effects
7+import qualified AST.Type as T
8+import qualified AST.Variable as Var
9+import qualified Reporting.Annotation as A
10+import qualified Reporting.Error.Canonicalize as Error
11+import qualified Reporting.Region as R
12+import qualified Reporting.Result as Result
13+import qualified Canonicalize.Environment as Env
14+import qualified Canonicalize.Type as Canonicalize
15+import Canonicalize.Variable (Result)
16+
17+
18+
19+-- TO EXPORT VALUES
20+
21+
22+toValues :: Effects.Raw -> [Var.Value]
23+toValues effects =
24+ case effects of
25+ Effects.None ->
26+ []
27+
28+ Effects.Manager _ _ ->
29+ []
30+
31+ Effects.Port ports ->
32+ map (Var.Value . Effects._rawName . A.drop) ports
33+
34+
35+
36+-- CANONICALIZE
37+
38+
39+canonicalize :: Env.Environment -> Effects.Raw -> Result Effects.Canonical
40+canonicalize env effects =
41+ case effects of
42+ Effects.None ->
43+ Result.ok Effects.None
44+
45+ Effects.Manager _ info ->
46+ Result.ok (Effects.Manager (Env.getPackage env) info)
47+
48+ Effects.Port rawPorts ->
49+ Effects.Port <$> T.traverse (canonicalizeRawPort env) rawPorts
50+
51+
52+canonicalizeRawPort
53+ :: Env.Environment
54+ -> A.Commented Effects.PortRaw
55+ -> Result (A.Commented Effects.PortCanonical)
56+canonicalizeRawPort env (A.A ann (Effects.PortRaw name rawType)) =
57+ do tipe <- Canonicalize.tipe env rawType
58+ kind <- figureOutKind (fst ann) name tipe
59+ Result.ok (A.A ann (Effects.PortCanonical name kind tipe))
60+
61+
62+figureOutKind :: R.Region -> String -> T.Canonical -> Result Effects.Kind
63+figureOutKind region name rootType =
64+ case T.deepDealias rootType of
65+ T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])
66+ | effect == Var.cmd ->
67+ pure (Effects.Outgoing outgoingType)
68+ <* checkPortType (makeError region name) outgoingType
69+
70+ T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.App (T.Type effect) [T.Var msg2])
71+ | effect == Var.sub && msg1 == msg2 ->
72+ pure (Effects.Incoming incomingType)
73+ <* checkPortType (makeError region name) incomingType
74+
75+ _ ->
76+ Result.throw region (error "TODO - bad overall type")
77+
78+
79+makeError :: R.Region -> String -> T.Canonical -> Maybe String -> A.Located Error.Error
80+makeError region name tipe maybeMessage =
81+ A.A region (Error.port name tipe maybeMessage)
82+
83+
84+
85+-- CHECK INCOMING AND OUTGOING TYPES
86+
87+
88+checkPortType
89+ :: (Monoid i)
90+ => (T.Canonical -> Maybe String -> A.Located e)
91+ -> T.Canonical
92+ -> Result.Result i w e ()
93+checkPortType makeError tipe =
94+ let
95+ check =
96+ checkPortType makeError
97+
98+ throw maybeMsg =
99+ Result.throwMany [makeError tipe maybeMsg]
100+ in
101+ case tipe of
102+ T.Aliased _ args aliasedType ->
103+ check (T.dealias args aliasedType)
104+
105+ T.Type name ->
106+ if Var.isJson name || Var.isPrimitive name || Var.isTuple name then
107+ return ()
108+
109+ else
110+ throw Nothing
111+
112+ T.App name [] ->
113+ check name
114+
115+ T.App (T.Type name) [arg]
116+ | Var.isMaybe name -> check arg
117+ | Var.isArray name -> check arg
118+ | Var.isList name -> check arg
119+
120+ T.App (T.Type name) args
121+ | Var.isTuple name ->
122+ F.traverse_ check args
123+
124+ T.App _ _ ->
125+ throw Nothing
126+
127+ T.Var _ ->
128+ throw (Just "free type variable")
129+
130+ T.Lambda _ _ ->
131+ throw (Just "function")
132+
133+ T.Record _ (Just _) ->
134+ throw (Just "extended record")
135+
136+ T.Record fields Nothing ->
137+ F.traverse_ (\(k,v) -> (,) k <$> check v) fields
src/Canonicalize/Environment.hs+38−18
@@ -1,25 +1,34 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Canonicalize.Environment where
2+module Canonicalize.Environment
3+ ( Environment(..)
4+ , getPackage
5+ , insert
6+ , Patch(..), fromPatches, addPattern
7+ , builtinPatches
8+ , toDealiaser
9+ )
10+ where
3
11
4import qualified Data.List as List
12import qualified Data.List as List
5import qualified Data.Map as Map
13import qualified Data.Map as Map
6import qualified Data.Maybe as Maybe
14import qualified Data.Maybe as Maybe
7import qualified Data.Set as Set
15import qualified Data.Set as Set
8
16
9−import AST.Expression.General (saveEnvName)
10import qualified AST.Module.Name as ModuleName
17import qualified AST.Module.Name as ModuleName
11import qualified AST.Pattern as P
18import qualified AST.Pattern as P
12import qualified AST.Type as Type
19import qualified AST.Type as Type
13import qualified AST.Variable as Var
20import qualified AST.Variable as Var
14−import Elm.Utils ((|>))
21+import qualified Elm.Package as Pkg
22+
15
23
16
24
17-- ENVIRONMENT
25-- ENVIRONMENT
18
26
27+
19data Environment = Env
28data Environment = Env
20 { _home :: ModuleName.Canonical
29 { _home :: ModuleName.Canonical
21 , _values :: Dict Var.Canonical
30 , _values :: Dict Var.Canonical
22− , _adts :: Dict Var.Canonical
31+ , _unions :: Dict Var.Canonical
23 , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)
32 , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)
24 , _patterns :: Dict (Var.Canonical, Int)
33 , _patterns :: Dict (Var.Canonical, Int)
25 }
34 }
@@ -31,21 +40,27 @@ type Dict a =
31
40
32fromPatches :: ModuleName.Canonical -> [Patch] -> Environment
41fromPatches :: ModuleName.Canonical -> [Patch] -> Environment
33fromPatches moduleName patches =
42fromPatches moduleName patches =
34− addPatches
35− patches
36− (Env moduleName Map.empty Map.empty Map.empty Map.empty)
43+ addPatches patches (Env moduleName Map.empty Map.empty Map.empty Map.empty)
37
44
38
45
39addPattern :: P.Pattern ann var -> Environment -> Environment
46addPattern :: P.Pattern ann var -> Environment -> Environment
40addPattern pattern env =
47addPattern pattern env =
48+ let
41− let patches =
49+ patches =
42− map (\x -> Value x (Var.local x)) (P.boundVarList pattern)
50+ map (\x -> Value x (Var.local x)) (P.boundVarList pattern)
43 in
51 in
44− addPatches patches env
52+ addPatches patches env
53+
54+
55+getPackage :: Environment -> Pkg.Name
56+getPackage env =
57+ ModuleName._package (_home env)
58+
45
59
46
60
47-- PATCHES
61-- PATCHES
48
62
63+
49data Patch
64data Patch
50 = Value String Var.Canonical
65 = Value String Var.Canonical
51 | Union String Var.Canonical
66 | Union String Var.Canonical
@@ -53,8 +68,10 @@ data Patch
53 | Pattern String (Var.Canonical, Int)
68 | Pattern String (Var.Canonical, Int)
54
69
55
70
71+
56-- ADD PATCH TO ENVIRONMENT
72-- ADD PATCH TO ENVIRONMENT
57
73
74+
58addPatches :: [Patch] -> Environment -> Environment
75addPatches :: [Patch] -> Environment -> Environment
59addPatches patches env =
76addPatches patches env =
60 List.foldl' (flip addPatch) env patches
77 List.foldl' (flip addPatch) env patches
@@ -67,7 +84,7 @@ addPatch patch env =
67 env { _values = insert name var (_values env) }
84 env { _values = insert name var (_values env) }
68
85
69 Union name var ->
86 Union name var ->
70− env { _adts = insert name var (_adts env) }
87+ env { _unions = insert name var (_unions env) }
71
88
72 Alias name var ->
89 Alias name var ->
73 env { _aliases = insert name var (_aliases env) }
90 env { _aliases = insert name var (_aliases env) }
@@ -81,12 +98,14 @@ insert key value =
81 Map.insertWith Set.union key (Set.singleton value)
98 Map.insertWith Set.union key (Set.singleton value)
82
99
83
100
101+
84-- PATCH HELPERS
102-- PATCH HELPERS
85
103
104+
86builtinPatches :: [Patch]
105builtinPatches :: [Patch]
87builtinPatches =
106builtinPatches =
88 concat
107 concat
89− [ map (patch Value) (tupleNames ++ [saveEnvName])
108+ [ map (patch Value) tupleNames
90 , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])
109 , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])
91 , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])
110 , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])
92 ]
111 ]
@@ -108,12 +127,14 @@ builtinPatches =
108 ("_Tuple" ++ show n, n)
127 ("_Tuple" ++ show n, n)
109
128
110
129
130+
111-- TO TYPE DEALIASER
131-- TO TYPE DEALIASER
112
132
133+
113toDealiaser :: Environment -> Map.Map String String
134toDealiaser :: Environment -> Map.Map String String
114−toDealiaser (Env _ _ adts aliases _) =
135+toDealiaser (Env _ _ unions aliases _) =
115 let
136 let
116− dealiasAdt (localName, canonicalSet) =
137+ dealiasUnion (localName, canonicalSet) =
117 case Set.toList canonicalSet of
138 case Set.toList canonicalSet of
118 [canonicalName] ->
139 [canonicalName] ->
119 Just (Var.toString canonicalName, localName)
140 Just (Var.toString canonicalName, localName)
@@ -127,8 +148,8 @@ toDealiaser (Env _ _ adts aliases _) =
127 _ ->
148 _ ->
128 Nothing
149 Nothing
129
150
130− adtPairs =
151+ unionPairs =
131− Maybe.mapMaybe dealiasAdt (Map.toList adts)
152+ Maybe.mapMaybe dealiasUnion (Map.toList unions)
132
153
133 aliasPairs =
154 aliasPairs =
134 Maybe.mapMaybe dealiasAlias (Map.toList aliases)
155 Maybe.mapMaybe dealiasAlias (Map.toList aliases)
@@ -136,5 +157,4 @@ toDealiaser (Env _ _ adts aliases _) =
136 add (key,value) dict =
157 add (key,value) dict =
137 Map.insertWith (\v v' -> if length v < length v' then v else v') key value dict
158 Map.insertWith (\v v' -> if length v < length v' then v else v') key value dict
138 in
159 in
139− adtPairs ++ aliasPairs
140− |> foldr add Map.empty
160+ foldr add Map.empty (unionPairs ++ aliasPairs)
src/Canonicalize/Port.hsdeleted−123
@@ -1,123 +0,0 @@
1−module Canonicalize.Port (check) where
2−
3−import qualified Data.Foldable as Foldable
4−
5−import qualified AST.Declaration as D
6−import qualified AST.Expression.General as E
7−import qualified AST.Expression.Canonical as Canonical
8−import qualified AST.Type as T
9−import qualified AST.Variable as Var
10−import qualified Reporting.Annotation as A
11−import qualified Reporting.Error.Canonicalize as Error
12−import qualified Reporting.Region as R
13−import qualified Canonicalize.Result as Result
14−
15−
16−-- CHECK FOR PORT
17−
18−check
19− :: R.Region
20− -> String
21− -> Maybe Canonical.Expr
22− -> T.Canonical
23− -> Result.ResultErr D.CanonicalPort
24−check region name maybeExpr rootType =
25− D.CanonicalPort <$> checkHelp region name maybeExpr rootType rootType
26−
27−
28−checkHelp
29− :: R.Region
30− -> String
31− -> Maybe Canonical.Expr
32− -> T.Canonical
33− -> T.Canonical
34− -> Result.ResultErr (E.PortImpl Canonical.Expr T.Canonical)
35−checkHelp region name maybeExpr rootType tipe =
36− case (maybeExpr, tipe) of
37− (_, T.Aliased _ args t) ->
38− checkHelp region name maybeExpr rootType (T.dealias args t)
39−
40− (Just expr, T.App (T.Type task) [ _x, _a ])
41− | Var.isTask task ->
42− Result.ok (E.Task name expr (T.Normal tipe))
43−
44−
45− (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])
46− | Var.isSignal signal && Var.isTask task ->
47− Result.ok (E.Task name expr (T.Signal tipe arg))
48−
49−
50− (_, T.App (T.Type signal) [arg])
51− | Var.isSignal signal ->
52− case maybeExpr of
53− Nothing ->
54− const (E.In name (T.Signal rootType arg))
55− <$> validForeignType region name True arg arg
56−
57− Just expr ->
58− const (E.Out name expr (T.Signal rootType arg))
59− <$> validForeignType region name False arg arg
60−
61− _ ->
62− case maybeExpr of
63− Nothing ->
64− const (E.In name (T.Normal rootType))
65− <$> validForeignType region name True rootType tipe
66−
67− Just expr ->
68− const (E.Out name expr (T.Normal rootType))
69− <$> validForeignType region name False rootType tipe
70−
71−
72−-- CHECK INBOUND AND OUTBOUND TYPES
73−
74−validForeignType
75− :: R.Region
76− -> String
77− -> Bool
78− -> T.Canonical
79− -> T.Canonical
80− -> Result.ResultErr ()
81−validForeignType region name isInbound rootType tipe =
82− let valid localType =
83− validForeignType region name isInbound rootType localType
84−
85− err problem =
86− Result.err $ A.A region $
87− Error.port name isInbound rootType tipe problem
88− in
89− case tipe of
90− T.Aliased _ args t ->
91− valid (T.dealias args t)
92−
93− T.Type v ->
94− case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
95− True -> Result.ok ()
96− False -> err Nothing
97−
98− T.App t [] ->
99− valid t
100−
101− T.App (T.Type v) [t]
102− | Var.isMaybe v -> valid t
103− | Var.isArray v -> valid t
104− | Var.isList v -> valid t
105−
106− T.App (T.Type v) ts
107− | Var.isTuple v ->
108− Foldable.traverse_ valid ts
109−
110− T.App _ _ ->
111− err Nothing
112−
113− T.Var _ ->
114− err (Just "a free type variable")
115−
116− T.Lambda _ _ ->
117− err (Just "a function")
118−
119− T.Record _ (Just _) ->
120− err (Just "an extended record")
121−
122− T.Record fields Nothing ->
123− Foldable.traverse_ (\(k,v) -> (,) k <$> valid v) fields
src/Canonicalize/Result.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Canonicalize.Result where
3−
4−import Prelude hiding (foldl)
5−import qualified Control.Applicative as A
6−import qualified Data.Functor as F
7−import qualified Data.Set as Set
8−
9−import qualified AST.Module.Name as ModuleName
10−import qualified AST.Variable as Var
11−import qualified Reporting.Annotation as A
12−import qualified Reporting.Error.Canonicalize as Error
13−
14−
15−type ResultErr a = Result (A.Located Error.Error) a
16−
17−
18−data Result err a =
19− Result (Set.Set ModuleName.Raw) (RawResult err a)
20−
21−
22−data RawResult err a
23− = Ok a
24− | Err [err]
25−
26−
27−-- RESULT HELPERS
28−
29−ok :: a -> Result e a
30−ok value =
31− Result Set.empty (Ok value)
32−
33−
34−err :: e -> Result e a
35−err msg =
36− errors [msg]
37−
38−
39−errors :: [e] -> Result e a
40−errors msgs =
41− Result Set.empty (Err msgs)
42−
43−
44−foldl :: (a -> b -> Result e b) -> b -> [a] -> Result e b
45−foldl f acc list =
46− case list of
47− [] ->
48− ok acc
49−
50− x:xs ->
51− f x acc `andThen` (\acc' -> foldl f acc' xs)
52−
53−
54−andThen :: Result e a -> (a -> Result e b) -> Result e b
55−andThen (Result uses rawResult) callback =
56− case rawResult of
57− Err msg ->
58− Result uses (Err msg)
59−
60− Ok value ->
61− let (Result uses' rawResult') = callback value
62− in
63− Result (Set.union uses uses') rawResult'
64−
65−
66−instance F.Functor (Result e) where
67− fmap func (Result uses result) =
68− case result of
69− Ok a ->
70− Result uses (Ok (func a))
71−
72− Err msgs ->
73− Result uses (Err msgs)
74−
75−
76−instance A.Applicative (Result e) where
77− pure value =
78− ok value
79−
80− (<*>) (Result uses resultFunc) (Result uses' resultVal) =
81− Result (Set.union uses uses') $
82− case (resultFunc, resultVal) of
83− (Ok func, Ok val) ->
84− Ok (func val)
85−
86− (Err msgs, Err msgs') ->
87− Err (msgs ++ msgs')
88−
89− (Err msgs, _) ->
90− Err msgs
91−
92− (_, Err msgs) ->
93− Err msgs
94−
95−
96−-- TRACK USES OF IMPORTS
97−
98−addModule :: ModuleName.Raw -> Result e a -> Result e a
99−addModule home (Result uses result) =
100− Result (Set.insert home uses) result
101−
102−
103−var' :: (a -> Var.Canonical) -> a -> Result e a
104−var' toVar value =
105− case toVar value of
106− Var.Canonical (Var.Module (ModuleName.Canonical _ moduleName)) _name ->
107− Result (Set.singleton moduleName) (Ok value)
108−
109− Var.Canonical _ _ ->
110− ok value
111−
112−
113−var :: Var.Canonical -> Result e Var.Canonical
114−var variable =
115− var' id variable
116−
117−
src/Canonicalize/Setup.hs+276−223
@@ -2,12 +2,14 @@
2module Canonicalize.Setup (environment) where
2module Canonicalize.Setup (environment) where
3
3
4import Control.Arrow (second)
4import Control.Arrow (second)
5+import Control.Monad (foldM)
5import qualified Data.Graph as Graph
6import qualified Data.Graph as Graph
6import qualified Data.Map as Map
7import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.Maybe as Maybe
8import qualified Data.Traversable as Trav
9import qualified Data.Traversable as Trav
9
10
10import qualified AST.Declaration as D
11import qualified AST.Declaration as D
12+import qualified AST.Effects as Effects
11import qualified AST.Expression.Valid as Valid
13import qualified AST.Expression.Valid as Valid
12import qualified AST.Module as Module
14import qualified AST.Module as Module
13import qualified AST.Module.Name as ModuleName
15import qualified AST.Module.Name as ModuleName
@@ -19,42 +21,54 @@ import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Canonicalize as Error
21import qualified Reporting.Error.Canonicalize as Error
20import qualified Reporting.Error.Helpers as Error
22import qualified Reporting.Error.Helpers as Error
21import qualified Reporting.Region as R
23import qualified Reporting.Region as R
24+import qualified Reporting.Result as Result
22import qualified Canonicalize.Environment as Env
25import qualified Canonicalize.Environment as Env
23−import qualified Canonicalize.Result as Result
24import qualified Canonicalize.Type as Canonicalize
26import qualified Canonicalize.Type as Canonicalize
27+import Canonicalize.Variable (Result)
28+
25
29
26
30
27environment
31environment
28 :: Map.Map ModuleName.Raw ModuleName.Canonical
32 :: Map.Map ModuleName.Raw ModuleName.Canonical
29 -> Module.Interfaces
33 -> Module.Interfaces
30− -> Module.ValidModule
34+ -> Module.Valid
31− -> Result.ResultErr Env.Environment
35+ -> Result Env.Environment
32−environment importDict interfaces (Module.Module name _ _ _ (defaults, imports) decls) =
36+environment importDict interfaces (Module.Module name _ info) =
33 let
37 let
38+ (Module.Valid _ _ (defaults, imports) decls effects) =
39+ info
40+
34 allImports =
41 allImports =
35 imports ++ map (A.A (error "default import not found")) defaults
42 imports ++ map (A.A (error "default import not found")) defaults
36
43
37− importPatchesResult =
44+ getImportPatches =
38− concat <$> Trav.traverse (importPatches importDict interfaces) allImports
45+ Trav.traverse (importToPatches importDict interfaces) allImports
39
46
40 (typeAliasNodes, declPatches) =
47 (typeAliasNodes, declPatches) =
41− declarationsToPatches name decls
48+ declsToPatches name decls
42
49
43− patches =
50+ effectPatches =
51+ effectsToPatches name effects
52+
53+ createEnv importPatches =
54+ Env.fromPatches
55+ name
44− (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult
56+ (concat (Env.builtinPatches : declPatches : effectPatches : importPatches))
45 in
57 in
46− (Env.fromPatches name <$> patches)
58+ do env <- createEnv <$> getImportPatches
47− `Result.andThen` addTypeAliases name typeAliasNodes
59+ addTypeAliases name typeAliasNodes env
60+
48
61
49
62
50-- PATCHES FOR IMPORTS
63-- PATCHES FOR IMPORTS
51
64
52−importPatches
65+
66+importToPatches
53 :: Map.Map ModuleName.Raw ModuleName.Canonical
67 :: Map.Map ModuleName.Raw ModuleName.Canonical
54 -> Module.Interfaces
68 -> Module.Interfaces
55 -> A.Located (ModuleName.Raw, Module.ImportMethod)
69 -> A.Located (ModuleName.Raw, Module.ImportMethod)
56− -> Result.ResultErr [Env.Patch]
70+ -> Result [Env.Patch]
57−importPatches importDict allInterfaces (A.A region (rawImportName, method)) =
71+importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =
58 let
72 let
59 maybeInterface =
73 maybeInterface =
60 do canonicalName <- Map.lookup rawImportName importDict
74 do canonicalName <- Map.lookup rawImportName importDict
@@ -63,157 +77,175 @@ importPatches importDict allInterfaces (A.A region (rawImportName, method)) =
63 in
77 in
64 case maybeInterface of
78 case maybeInterface of
65 Nothing ->
79 Nothing ->
66− if ModuleName.isNative rawImportName then
80+ if ModuleName.isNative rawImportName then
67− Result.ok []
81+ Result.ok []
68−
82+
69− else
83+ else
70− allInterfaces
84+ allInterfaces
71− |> Map.keys
85+ |> Map.keys
72− |> map ModuleName._module
86+ |> map ModuleName._module
73− |> Error.nearbyNames ModuleName.toString rawImportName
87+ |> Error.nearbyNames ModuleName.toString rawImportName
74− |> Error.moduleNotFound rawImportName
88+ |> Error.moduleNotFound rawImportName
75− |> A.A region
89+ |> Result.throw region
76− |> Result.err
77
90
78 Just (importName, interface) ->
91 Just (importName, interface) ->
92+ let
79− let (Module.ImportMethod maybeAlias listing) =
93+ (Module.ImportMethod maybeAlias listing) =
80− method
94+ method
95+
96+ (Var.Listing exposedValues open) =
97+ listing
81
98
82− (Var.Listing exposedValues open) =
99+ qualifier =
83− listing
100+ maybe (ModuleName.toString rawImportName) id maybeAlias
84
101
85− qualifier =
102+ qualifiedPatches =
86− maybe (ModuleName.toString rawImportName) id maybeAlias
103+ interfaceToPatches importName (qualifier ++ ".") interface
87
104
88− qualifiedPatches =
105+ unqualifiedPatches =
89− interfacePatches importName (qualifier ++ ".") interface
106+ if open then
107+ Result.ok (interfaceToPatches importName "" interface)
90
108
91− unqualifiedPatches =
109+ else
92− if open
93− then Result.ok (interfacePatches importName "" interface)
94− else concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
110+ concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
95− in
111+ in
96− (++) qualifiedPatches <$> unqualifiedPatches
112+ (++) qualifiedPatches <$> unqualifiedPatches
97
113
98
114
99−interfacePatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]
115+interfaceToPatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]
100−interfacePatches moduleName prefix interface =
116+interfaceToPatches moduleName prefix interface =
117+ let
101− let genericPatch mkPatch name value =
118+ genericPatch mkPatch name value =
102− mkPatch (prefix ++ name) value
119+ mkPatch (prefix ++ name) value
103
120
104− patch mkPatch name =
121+ patch mkPatch name =
105− genericPatch mkPatch name (Var.fromModule moduleName name)
122+ genericPatch mkPatch name (Var.fromModule moduleName name)
106
123
107− aliasPatch (name, (tvars, tipe)) =
124+ aliasPatch (name, (tvars, tipe)) =
108− genericPatch Env.Alias name
125+ genericPatch
126+ Env.Alias
127+ name
109− (Var.fromModule moduleName name, tvars, tipe)
128+ (Var.fromModule moduleName name, tvars, tipe)
110
129
111− patternPatch (name, args) =
130+ patternPatch (name, args) =
112− genericPatch Env.Pattern name
131+ genericPatch
132+ Env.Pattern
133+ name
113− (Var.fromModule moduleName name, length args)
134+ (Var.fromModule moduleName name, length args)
114
135
115− ctors =
136+ ctors =
116− concatMap snd (Map.elems (Module.iAdts interface))
137+ concatMap snd (Map.elems (Module.iUnions interface))
138+
139+ ctorNames =
140+ map fst ctors
141+ in
142+ concat
143+ [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
144+ , map (patch Env.Value) ctorNames
145+ , map (patch Env.Union) (Map.keys (Module.iUnions interface))
146+ , map aliasPatch (Map.toList (Module.iAliases interface))
147+ , map patternPatch ctors
148+ ]
117
149
118− ctorNames =
119− map fst ctors
120− in
121− concat
122− [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
123− , map (patch Env.Value) ctorNames
124− , map (patch Env.Union) (Map.keys (Module.iAdts interface))
125− , map aliasPatch (Map.toList (Module.iAliases interface))
126− , map patternPatch ctors
127− ]
128
150
129
151
130-- PATCHES FOR INDIVIDUAL VALUES
152-- PATCHES FOR INDIVIDUAL VALUES
131
153
154+
132valueToPatches
155valueToPatches
133 :: R.Region
156 :: R.Region
134 -> ModuleName.Canonical
157 -> ModuleName.Canonical
135 -> Module.Interface
158 -> Module.Interface
136 -> Var.Value
159 -> Var.Value
137− -> Result.ResultErr [Env.Patch]
160+ -> Result [Env.Patch]
138valueToPatches region moduleName interface value =
161valueToPatches region moduleName interface value =
162+ let
139− let patch mkPatch x =
163+ patch mkPatch x =
140− mkPatch x (Var.fromModule moduleName x)
164+ mkPatch x (Var.fromModule moduleName x)
141−
165+
142− patternPatch (x, numArgs) =
166+ patternPatch (x, numArgs) =
143− Env.Pattern x (Var.fromModule moduleName x, numArgs)
167+ Env.Pattern x (Var.fromModule moduleName x, numArgs)
144−
168+
145− notFound getNames x =
169+ notFound getNames x =
146− Module.iExports interface
170+ Module.iExports interface
147− |> getNames
171+ |> getNames
148− |> Error.nearbyNames id x
172+ |> Error.nearbyNames id x
149− |> Error.valueNotFound (ModuleName._module moduleName) x
173+ |> Error.valueNotFound (ModuleName._module moduleName) x
150− |> A.A region
174+ |> Result.throw region
151− |> Result.err
152 in
175 in
153 case value of
176 case value of
154 Var.Value x ->
177 Var.Value x ->
155− if Map.notMember x (Module.iTypes interface) then
178+ if Map.notMember x (Module.iTypes interface) then
156− notFound Var.getValues x
179+ notFound Var.getValues x
157
180
158− else
181+ else
159− Result.ok [patch Env.Value x]
182+ Result.ok [patch Env.Value x]
160
183
161 Var.Alias x ->
184 Var.Alias x ->
162− case Map.lookup x (Module.iAliases interface) of
185+ case Map.lookup x (Module.iAliases interface) of
163− Just (tvars, t) ->
186+ Just (tvars, t) ->
187+ let
164− let alias =
188+ alias =
165− Env.Alias x (Var.fromModule moduleName x, tvars, t)
189+ Env.Alias x (Var.fromModule moduleName x, tvars, t)
166− in
190+ in
167− Result.ok $
191+ Result.ok $
168− if Map.member x (Module.iTypes interface)
192+ if Map.member x (Module.iTypes interface) then
169− then [alias, patch Env.Value x]
193+ [alias, patch Env.Value x]
194+
195+ else
170− else [alias]
196+ [alias]
171−
197+
172− Nothing ->
198+ Nothing ->
173− case Map.lookup x (Module.iAdts interface) of
199+ case Map.lookup x (Module.iUnions interface) of
174− Just (_,_) ->
200+ Just (_,_) ->
175− Result.ok [patch Env.Union x]
201+ Result.ok [patch Env.Union x]
176−
202+
177− Nothing ->
203+ Nothing ->
178− let getNames values =
204+ let getNames values =
179− Var.getAliases values
205+ Var.getAliases values
180− ++ map fst (Var.getUnions values)
206+ ++ map fst (Var.getUnions values)
181− in
207+ in
182− notFound getNames x
208+ notFound getNames x
183
209
184 Var.Union givenName (Var.Listing givenCtorNames open) ->
210 Var.Union givenName (Var.Listing givenCtorNames open) ->
185− case Map.lookup givenName (Module.iAdts interface) of
211+ case Map.lookup givenName (Module.iUnions interface) of
186− Nothing ->
212+ Nothing ->
187− notFound (map fst . Var.getUnions) givenName
213+ notFound (map fst . Var.getUnions) givenName
188−
214+
189− Just (_tvars, realCtors) ->
215+ Just (_tvars, realCtors) ->
190− patches <$>
216+ patches <$>
191− if open
217+ if open then
192− then Result.ok realCtorList
218+ Result.ok realCtorList
219+
220+ else
193− else Trav.traverse ctorExists givenCtorNames
221+ Trav.traverse ctorExists givenCtorNames
194− where
222+ where
195− realCtorList =
223+ realCtorList =
196− map (second length) realCtors
224+ map (second length) realCtors
197−
225+
198− realCtorDict =
226+ realCtorDict =
199− Map.fromList realCtorList
227+ Map.fromList realCtorList
200−
228+
201− ctorExists givenCtorName =
229+ ctorExists givenCtorName =
202− case Map.lookup givenCtorName realCtorDict of
230+ case Map.lookup givenCtorName realCtorDict of
203− Just numArgs ->
231+ Just numArgs ->
204− Result.ok (givenCtorName, numArgs)
232+ Result.ok (givenCtorName, numArgs)
233+
205− Nothing ->
234+ Nothing ->
206− notFound (const (map fst realCtors)) givenCtorName
235+ notFound (const (map fst realCtors)) givenCtorName
207−
236+
208− patches ctors =
237+ patches ctors =
209− patch Env.Union givenName
238+ patch Env.Union givenName
210− : map (patch Env.Value . fst) ctors
239+ : map (patch Env.Value . fst) ctors
211− ++ map patternPatch ctors
240+ ++ map patternPatch ctors
241+
212
242
213
243
214-- PATCHES FOR TYPE ALIASES
244-- PATCHES FOR TYPE ALIASES
215
245
246+
247+type Node =
216−type Node = ((R.Region, String, [String], Type.Raw), String, [String])
248+ ( (R.Region, String, [String], Type.Raw), String, [String] )
217
249
218
250
219node :: R.Region -> String -> [String] -> Type.Raw -> Node
251node :: R.Region -> String -> [String] -> Type.Raw -> Node
@@ -221,41 +253,34 @@ node region name tvars alias =
221 ((region, name, tvars, alias), name, edges alias)
253 ((region, name, tvars, alias), name, edges alias)
222 where
254 where
223 edges (A.A _ tipe) =
255 edges (A.A _ tipe) =
224− case tipe of
256+ case tipe of
225− Type.RLambda t1 t2 ->
257+ Type.RLambda t1 t2 ->
226− edges t1 ++ edges t2
258+ edges t1 ++ edges t2
227
259
228− Type.RVar _ ->
260+ Type.RVar _ ->
229− []
261+ []
230
262
231− Type.RType (Var.Raw x) ->
263+ Type.RType (Var.Raw x) ->
232− [x]
264+ [x]
233
265
234− Type.RApp t ts ->
266+ Type.RApp t ts ->
235− edges t ++ concatMap edges ts
267+ edges t ++ concatMap edges ts
236
268
237− Type.RRecord fs ext ->
269+ Type.RRecord fs ext ->
238− maybe [] edges ext ++ concatMap (edges . snd) fs
270+ maybe [] edges ext ++ concatMap (edges . snd) fs
239
271
240
272
241−addTypeAliases
242− :: ModuleName.Canonical
273+addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Environment -> Result Env.Environment
243− -> [Node]
244− -> Env.Environment
245− -> Result.ResultErr Env.Environment
246addTypeAliases moduleName typeAliasNodes initialEnv =
274addTypeAliases moduleName typeAliasNodes initialEnv =
247− Result.foldl
248− (addTypeAlias moduleName)
249− initialEnv
250− (Graph.stronglyConnComp typeAliasNodes)
275+ foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)
251
276
252
277
253addTypeAlias
278addTypeAlias
254 :: ModuleName.Canonical
279 :: ModuleName.Canonical
255− -> Graph.SCC (R.Region, String, [String], Type.Raw)
256 -> Env.Environment
280 -> Env.Environment
281+ -> Graph.SCC (R.Region, String, [String], Type.Raw)
257− -> Result.ResultErr Env.Environment
282+ -> Result Env.Environment
258−addTypeAlias moduleName scc env =
283+addTypeAlias moduleName env scc =
259 case scc of
284 case scc of
260 Graph.AcyclicSCC (_, name, tvars, alias) ->
285 Graph.AcyclicSCC (_, name, tvars, alias) ->
261 addToEnv <$> Canonicalize.tipe env alias
286 addToEnv <$> Canonicalize.tipe env alias
@@ -267,84 +292,106 @@ addTypeAlias moduleName scc env =
267 env { Env._aliases = Env.insert name value (Env._aliases env) }
292 env { Env._aliases = Env.insert name value (Env._aliases env) }
268
293
269 Graph.CyclicSCC [] ->
294 Graph.CyclicSCC [] ->
270− Result.ok env
295+ Result.ok env
271
296
272 Graph.CyclicSCC [(region, name, tvars, alias)] ->
297 Graph.CyclicSCC [(region, name, tvars, alias)] ->
273− Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))
298+ Result.throw region (Error.Alias (Error.SelfRecursive name tvars alias))
274
299
275 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
300 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
276− Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))
301+ Result.throw region (Error.Alias (Error.MutuallyRecursive aliases))
302+
277
303
278
304
279-- DECLARATIONS TO PATCHES
305-- DECLARATIONS TO PATCHES
280
306
281−declarationsToPatches
282− :: ModuleName.Canonical
283− -> [D.ValidDecl]
284− -> ([Node], [Env.Patch])
285−declarationsToPatches moduleName decls =
286− let (maybeNodes, patchLists) =
287− unzip (map (declToPatches moduleName) decls)
288− in
289− (Maybe.catMaybes maybeNodes, concat patchLists)
290
307
308+{- When canonicalizing, it is important that:
291
309
292−-- When canonicalizing, it is important that:
293−-- _adts are fully namespaced (Var.Module ...)
310+ _adts are fully namespaced (Var.Module ...)
294−-- _patterns are fully namespaced (Var.Module ...)
311+ _patterns are fully namespaced (Var.Module ...)
295−-- _values that are defined as top-level declarations are (Var.TopLevel ...)
312+ _values that are defined as top-level declarations are (Var.TopLevel ...)
296−-- all other _values are local (Var.Local)
313+ all other _values are local (Var.Local)
297−declToPatches
314+
315+-}
298− :: ModuleName.Canonical
316+declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])
299− -> D.ValidDecl
317+declsToPatches moduleName (D.Decls defs unions aliases _) =
300− -> (Maybe Node, [Env.Patch])
318+ let
301−declToPatches moduleName (A.A (region,_) decl) =
319+
302− let topLevel mkPatch x =
320+ -- HELPERS
321+
322+ topLevelValue x =
303− mkPatch x (Var.topLevel moduleName x )
323+ Env.Value x (Var.topLevel moduleName x)
324+
325+ patternPatch (name, args) =
326+ Env.Pattern name (Var.fromModule moduleName name, length args)
327+
328+ -- TO PATCHES
329+
330+ defToPatches (A.A _ (Valid.Def pattern _ _)) =
331+ map topLevelValue (P.boundVarList pattern)
304
332
305− namespaced mkPatch x =
333+ unionToPatches (A.A _ (D.Type name _ ctors)) =
306− mkPatch x (Var.fromModule moduleName x)
334+ Env.Union name (Var.fromModule moduleName name)
335+ : map topLevelValue (map fst ctors)
336+ ++ map patternPatch ctors
307
337
308− patternPatch (name, args) =
338+ aliasToPatches (A.A _ (D.Type name _ alias)) =
309− Env.Pattern name (Var.fromModule moduleName name, length args)
339+ case A.drop alias of
340+ Type.RRecord _ Nothing ->
341+ Just (topLevelValue name)
342+
343+ _ ->
344+ Nothing
345+
346+ -- TO NODES
347+
348+ aliasToNode (A.A (region, _) (D.Type name tvars alias)) =
349+ node region name tvars alias
310 in
350 in
351+ (
352+ map aliasToNode aliases
353+ ,
354+ concat
355+ [ Maybe.mapMaybe aliasToPatches aliases
356+ , concatMap unionToPatches unions
357+ , concatMap defToPatches defs
358+ ]
359+ )
360+
361+
362+-- EFFECTS TO PATCHES
363+
364+
365+effectsToPatches :: ModuleName.Canonical -> Effects.Raw -> [Env.Patch]
366+effectsToPatches moduleName effects =
311− case decl of
367+ case effects of
312− D.Definition (Valid.Definition pattern _ _) ->
368+ Effects.None ->
313− ( Nothing
369+ []
314− , map (topLevel Env.Value) (P.boundVarList pattern)
370+
315− )
371+ Effects.Port ports ->
316−
372+ let
317− D.Datatype name _ ctors ->
373+ toPatch (A.A _ (Effects.PortRaw name _)) =
318− let ctorNames = map fst ctors
374+ Env.Value name (Var.topLevel moduleName name)
319− in
375+ in
320− ( Nothing
376+ map toPatch ports
321− , namespaced Env.Union name
377+
322− : map (topLevel Env.Value) ctorNames
378+ Effects.Manager _ info ->
323− ++ map patternPatch ctors
379+ map (\name -> Env.Value name (Var.topLevel moduleName name)) $
324− )
380+ case Effects._managerType info of
325−
381+ Effects.CmdManager _ ->
326− D.TypeAlias name tvars alias ->
382+ [ "command" ]
327− ( Just (node region name tvars alias)
383+
328− , case alias of
384+ Effects.SubManager _ ->
329− A.A _ (Type.RRecord _ Nothing) ->
385+ [ "subscription" ]
330− [topLevel Env.Value name]
386+
331− _ ->
387+ Effects.FxManager _ _ ->
332− []
388+ [ "command", "subscription" ]
333− )
389+
334−
335− D.Port port ->
336− ( Nothing
337− , [topLevel Env.Value (D.validPortName port)]
338− )
339−
340− D.Fixity _ _ _ ->
341− ( Nothing
342− , []
343− )
344
390
345
391
346-- RESTRICT VISIBLE API OF INTERFACES
392-- RESTRICT VISIBLE API OF INTERFACES
347
393
394+
348restrictToPublicApi :: Module.Interface -> Module.Interface
395restrictToPublicApi :: Module.Interface -> Module.Interface
349restrictToPublicApi interface =
396restrictToPublicApi interface =
350 interface
397 interface
@@ -360,7 +407,7 @@ restrictToPublicApi interface =
360 (get (Module.iAliases interface))
407 (get (Module.iAliases interface))
361 (Var.getAliases exports)
408 (Var.getAliases exports)
362
409
363− , Module.iAdts =
410+ , Module.iUnions =
364 Map.fromList
411 Map.fromList
365 (Maybe.mapMaybe (trimUnions interface) unions)
412 (Maybe.mapMaybe (trimUnions interface) unions)
366 }
413 }
@@ -381,19 +428,25 @@ restrictToPublicApi interface =
381get :: Map.Map String a -> String -> Maybe (String, a)
428get :: Map.Map String a -> String -> Maybe (String, a)
382get dict key =
429get dict key =
383 case Map.lookup key dict of
430 case Map.lookup key dict of
384− Nothing -> Nothing
431+ Nothing ->
432+ Nothing
433+
434+ Just value ->
385− Just value -> Just (key, value)
435+ Just (key, value)
386
436
387
437
388trimUnions
438trimUnions
389 :: Module.Interface
439 :: Module.Interface
390 -> (String, Var.Listing String)
440 -> (String, Var.Listing String)
391− -> Maybe (String, Module.AdtInfo String)
441+ -> Maybe (String, Module.UnionInfo String)
392trimUnions interface (name, Var.Listing exportedCtors _) =
442trimUnions interface (name, Var.Listing exportedCtors _) =
393− case Map.lookup name (Module.iAdts interface) of
443+ case Map.lookup name (Module.iUnions interface) of
394− Nothing -> Nothing
444+ Nothing ->
445+ Nothing
446+
395 Just (tvars, ctors) ->
447 Just (tvars, ctors) ->
448+ let
396− let isExported (ctor, _) =
449+ isExported (ctor, _) =
397− ctor `elem` exportedCtors
450+ ctor `elem` exportedCtors
398 in
451 in
399− Just (name, (tvars, filter isExported ctors))
452+ Just (name, (tvars, filter isExported ctors))
src/Canonicalize/Sort.hs+116−100
@@ -7,15 +7,17 @@ import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
7import qualified Data.Maybe as Maybe
8import qualified Data.Set as Set
8import qualified Data.Set as Set
9
9
10−import AST.Expression.General (Expr'(..), PortImpl(..))
10+import AST.Expression.General (Expr'(..))
11import qualified AST.Expression.Canonical as Canonical
11import qualified AST.Expression.Canonical as Canonical
12import qualified AST.Pattern as P
12import qualified AST.Pattern as P
13import qualified AST.Variable as V
13import qualified AST.Variable as V
14import qualified Reporting.Annotation as A
14import qualified Reporting.Annotation as A
15
15
16
16
17+
17-- STARTING POINT
18-- STARTING POINT
18
19
20+
19definitions :: Canonical.Expr -> Canonical.Expr
21definitions :: Canonical.Expr -> Canonical.Expr
20definitions expression =
22definitions expression =
21 evalState (reorder expression) Set.empty
23 evalState (reorder expression) Set.empty
@@ -35,138 +37,148 @@ freeIfLocal (V.Canonical home name) =
35 V.Module _ -> return ()
37 V.Module _ -> return ()
36
38
37
39
40+
38-- REORDER EXPRESSIONS
41-- REORDER EXPRESSIONS
39
42
43+
40reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
44reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
41reorder (A.A ann expression) =
45reorder (A.A ann expression) =
42− A.A ann <$>
46+ A.A ann <$>
43− case expression of
47+ case expression of
44− -- Be careful adding and restricting freeVars
48+ -- Be careful adding and restricting freeVars
45− Var var ->
49+ Var var ->
46− do freeIfLocal var
50+ do freeIfLocal var
47− return expression
51+ return expression
48
52
49− Lambda pattern body ->
53+ Lambda pattern body ->
50− uncurry Lambda <$> bindingReorder (pattern,body)
54+ uncurry Lambda <$> bindingReorder (pattern,body)
51
55
52− Binop op leftExpr rightExpr ->
56+ Binop op leftExpr rightExpr ->
53− do freeIfLocal op
57+ do freeIfLocal op
54− Binop op <$> reorder leftExpr <*> reorder rightExpr
58+ Binop op <$> reorder leftExpr <*> reorder rightExpr
55
59
56− Case expr cases ->
60+ Case expr cases ->
57− Case <$> reorder expr <*> mapM bindingReorder cases
61+ Case <$> reorder expr <*> mapM bindingReorder cases
58
62
59− Data name exprs ->
63+ Data name exprs ->
60− do free name
64+ do free name
61− Data name <$> mapM reorder exprs
65+ Data name <$> mapM reorder exprs
62
66
63− -- Just pipe the reorder though
67+ -- Just pipe the reorder though
64− Literal _ ->
68+ Literal _ ->
65− return expression
69+ return expression
66
70
67− Range lowExpr highExpr ->
71+ Range lowExpr highExpr ->
68− Range <$> reorder lowExpr <*> reorder highExpr
72+ Range <$> reorder lowExpr <*> reorder highExpr
69
73
70− ExplicitList es ->
74+ ExplicitList es ->
71− ExplicitList <$> mapM reorder es
75+ ExplicitList <$> mapM reorder es
72
76
73− App func arg ->
77+ App func arg ->
74− App <$> reorder func <*> reorder arg
78+ App <$> reorder func <*> reorder arg
75
79
76− If branches finally ->
80+ If branches finally ->
77− If
81+ If
78− <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
82+ <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
79− <*> reorder finally
83+ <*> reorder finally
80
84
85+ Access record field ->
81− Access record field ->
86+ Access
82− Access
83− <$> reorder record
87+ <$> reorder record
84− <*> return field
88+ <*> return field
85
89
90+ Update record fields ->
86− Update record fields ->
91+ Update
87− Update
88− <$> reorder record
92+ <$> reorder record
89− <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
93+ <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
90
94
95+ Record fields ->
91− Record fields ->
96+ Record
92− Record
93− <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
97+ <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
94
98
95− GLShader _ _ _ ->
99+ Cmd _ ->
96− return expression
100+ return expression
97
101
98− Port impl ->
102+ Sub _ ->
99− Port <$>
100− case impl of
101− In _ _ ->
102− return impl
103+ return expression
103
104
104− Out name expr tipe ->
105+ OutgoingPort _ _ ->
105− (\e -> Out name e tipe) <$> reorder expr
106+ return expression
106
107
107− Task name expr tipe ->
108+ IncomingPort _ _ ->
108− (\e -> Task name e tipe) <$> reorder expr
109+ return expression
109
110
110− -- Actually do some reordering
111+ Program _ _ ->
111− Let defs body ->
112+ error "DANGER - Program AST nodes should not be in def sorting."
112− do body' <- reorder body
113
113
114− -- Sort defs into strongly connected components.This
114+ SaveEnv _ _ ->
115− -- allows the programmer to write definitions in whatever
115+ return expression
116− -- order they please, we can still define things in order
117− -- and generalize polymorphic functions when appropriate.
118− sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
119− let defss = map Graph.flattenSCC sccs
120
116
121− -- remove let-bound variables from the context
117+ GLShader _ _ _ ->
122− forM_ defs $ \(Canonical.Definition _ pattern _ _) -> do
118+ return expression
123− bound pattern
124− mapM free (ctors pattern)
125
119
126− let (A.A _ let') =
120+ -- Actually do some reordering
127− foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
121+ Let defs body ->
122+ do body' <- reorder body
128
123
129− return let'
124+ -- Sort defs into strongly connected components.This
125+ -- allows the programmer to write definitions in whatever
126+ -- order they please, we can still define things in order
127+ -- and generalize polymorphic functions when appropriate.
128+ sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
129+ let defss = map Graph.flattenSCC sccs
130
130
131+ -- remove let-bound variables from the context
132+ forM_ defs $ \(Canonical.Def _ pattern _ _) -> do
133+ bound pattern
134+ mapM free (ctors pattern)
131
135
136+ let (A.A _ let') =
137+ foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
138+
139+ return let'
140+
141+
132−ctors :: P.CanonicalPattern -> [String]
142+ctors :: P.Canonical -> [String]
133ctors (A.A _ pattern) =
143ctors (A.A _ pattern) =
134− case pattern of
144+ case pattern of
135− P.Var _ ->
145+ P.Var _ ->
136− []
146+ []
137
147
138− P.Alias _ p ->
148+ P.Alias _ p ->
139− ctors p
149+ ctors p
140
150
141− P.Record _ ->
151+ P.Record _ ->
142− []
152+ []
143
153
144− P.Anything ->
154+ P.Anything ->
145− []
155+ []
146
156
147− P.Literal _ ->
157+ P.Literal _ ->
148− []
158+ []
149
159
150− P.Data (V.Canonical home name) ps ->
160+ P.Data (V.Canonical home name) ps ->
151− case home of
161+ case home of
152− V.Local -> name : rest
162+ V.Local -> name : rest
153− V.TopLevel _ -> name : rest
163+ V.TopLevel _ -> name : rest
154− V.BuiltIn -> rest
164+ V.BuiltIn -> rest
155− V.Module _ -> rest
165+ V.Module _ -> rest
156− where
166+ where
157− rest = concatMap ctors ps
167+ rest = concatMap ctors ps
158
168
159
169
160−bound :: P.CanonicalPattern -> State (Set.Set String) ()
170+bound :: P.Canonical -> State (Set.Set String) ()
161bound pattern =
171bound pattern =
172+ let
173+ boundVars =
162− let boundVars = P.boundVarSet pattern
174+ P.boundVarSet pattern
163 in
175 in
164− modify (\freeVars -> Set.difference freeVars boundVars)
176+ modify (\freeVars -> Set.difference freeVars boundVars)
165
177
166
178
167bindingReorder
179bindingReorder
168− :: (P.CanonicalPattern, Canonical.Expr)
180+ :: (P.Canonical, Canonical.Expr)
169− -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
181+ -> State (Set.Set String) (P.Canonical, Canonical.Expr)
170bindingReorder (pattern, expr) =
182bindingReorder (pattern, expr) =
171 do expr' <- reorder expr
183 do expr' <- reorder expr
172 bound pattern
184 bound pattern
@@ -174,8 +186,10 @@ bindingReorder (pattern, expr) =
174 return (pattern, expr')
186 return (pattern, expr')
175
187
176
188
189+
177-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
190-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
178
191
192+
179-- This also reorders the all of the sub-expressions in the Def list.
193-- This also reorders the all of the sub-expressions in the Def list.
180buildDefGraph
194buildDefGraph
181 :: [Canonical.Def]
195 :: [Canonical.Def]
@@ -186,21 +200,23 @@ buildDefGraph defs =
186 where
200 where
187 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
201 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
188 addKey =
202 addKey =
189− zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
203+ zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
190
204
191 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
205 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
192− variableToKey (Canonical.Definition _ pattern _ _, key, _) =
206+ variableToKey (Canonical.Def _ pattern _ _, key, _) =
193− [ (var, key) | var <- P.boundVarList pattern ]
207+ [ (var, key) | var <- P.boundVarList pattern ]
194
208
195 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
209 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
196 variableToKeyMap pdefsDeps =
210 variableToKeyMap pdefsDeps =
197− Map.fromList (concatMap variableToKey pdefsDeps)
211+ Map.fromList (concatMap variableToKey pdefsDeps)
198
212
199 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
213 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
200 realDeps pdefsDeps =
214 realDeps pdefsDeps =
201 map convert pdefsDeps
215 map convert pdefsDeps
202 where
216 where
217+ varDict =
203− varDict = variableToKeyMap pdefsDeps
218+ variableToKeyMap pdefsDeps
219+
204 convert (pdef, key, deps) =
220 convert (pdef, key, deps) =
205 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
221 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
206
222
@@ -208,7 +224,7 @@ buildDefGraph defs =
208reorderAndGetDependencies
224reorderAndGetDependencies
209 :: Canonical.Def
225 :: Canonical.Def
210 -> State (Set.Set String) (Canonical.Def, [String])
226 -> State (Set.Set String) (Canonical.Def, [String])
211−reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =
227+reorderAndGetDependencies (Canonical.Def facts pattern expr mType) =
212 do globalFrees <- get
228 do globalFrees <- get
213 -- work in a fresh environment
229 -- work in a fresh environment
214 put Set.empty
230 put Set.empty
@@ -216,4 +232,4 @@ reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =
216 localFrees <- get
232 localFrees <- get
217 -- merge with global frees
233 -- merge with global frees
218 modify (Set.union globalFrees)
234 modify (Set.union globalFrees)
219− return (Canonical.Definition facts pattern expr' mType, Set.toList localFrees)
235+ return (Canonical.Def facts pattern expr' mType, Set.toList localFrees)
src/Canonicalize/Type.hs+38−33
@@ -9,29 +9,30 @@ import qualified AST.Variable as Var
9import qualified Reporting.Annotation as A
9import qualified Reporting.Annotation as A
10import qualified Reporting.Error.Canonicalize as Error
10import qualified Reporting.Error.Canonicalize as Error
11import qualified Reporting.Region as R
11import qualified Reporting.Region as R
12+import qualified Reporting.Result as Result
12import qualified Canonicalize.Environment as Env
13import qualified Canonicalize.Environment as Env
13−import qualified Canonicalize.Result as Result
14import qualified Canonicalize.Variable as Canonicalize
14import qualified Canonicalize.Variable as Canonicalize
15+import Canonicalize.Variable (Result)
15
16
16
17
17−tipe
18− :: Env.Environment
18+tipe :: Env.Environment -> T.Raw -> Result T.Canonical
19− -> T.Raw
20− -> Result.ResultErr T.Canonical
21−tipe env typ@(A.A region typ') =
19+tipe env annType@(A.A _ typ) =
20+ let
21+ go =
22− let go = tipe env
22+ tipe env
23+
23− goSnd (name,t) =
24+ goSnd (name,t) =
24− (,) name <$> go t
25+ (,) name <$> go t
25− in
26+ in
26− case typ' of
27+ case typ of
27 T.RVar x ->
28 T.RVar x ->
28 Result.ok (T.Var x)
29 Result.ok (T.Var x)
29
30
30 T.RType _ ->
31 T.RType _ ->
31− canonicalizeApp region env typ []
32+ canonicalizeApp env annType []
32
33
33 T.RApp t ts ->
34 T.RApp t ts ->
34− canonicalizeApp region env t ts
35+ canonicalizeApp env t ts
35
36
36 T.RLambda a b ->
37 T.RLambda a b ->
37 T.Lambda <$> go a <*> go b
38 T.Lambda <$> go a <*> go b
@@ -40,20 +41,16 @@ tipe env typ@(A.A region typ') =
40 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext
41 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext
41
42
42
43
43−canonicalizeApp
44+canonicalizeApp :: Env.Environment -> T.Raw -> [T.Raw] -> Result T.Canonical
44− :: R.Region
45− -> Env.Environment
46− -> T.Raw
47− -> [T.Raw]
48− -> Result.ResultErr T.Canonical
49−canonicalizeApp region env f args =
45+canonicalizeApp env annFunc@(A.A region func) args =
50− case f of
46+ case func of
51− A.A _ (T.RType (Var.Raw rawName)) ->
47+ T.RType (Var.Raw rawName) ->
52− Canonicalize.tvar region env rawName
48+ canonicalizeWithTvar =<< Canonicalize.tvar region env rawName
53− `Result.andThen` canonicalizeWithTvar
54
49
55 _ ->
50 _ ->
51+ T.App
52+ <$> tipe env annFunc
56− T.App <$> tipe env f <*> Trav.traverse (tipe env) args
53+ <*> Trav.traverse (tipe env) args
57
54
58 where
55 where
59 canonicalizeWithTvar tvar =
56 canonicalizeWithTvar tvar =
@@ -65,6 +62,7 @@ canonicalizeApp region env f args =
65 case args of
62 case args of
66 [] ->
63 [] ->
67 Result.ok (T.Type name)
64 Result.ok (T.Type name)
65+
68 _ ->
66 _ ->
69 T.App (T.Type name) <$> Trav.traverse (tipe env) args
67 T.App (T.Type name) <$> Trav.traverse (tipe env) args
70
68
@@ -74,14 +72,21 @@ canonicalizeAlias
74 -> Env.Environment
72 -> Env.Environment
75 -> (Var.Canonical, [String], T.Canonical)
73 -> (Var.Canonical, [String], T.Canonical)
76 -> [T.Raw]
74 -> [T.Raw]
77− -> Result.ResultErr T.Canonical
75+ -> Result T.Canonical
78canonicalizeAlias region env (name, tvars, dealiasedTipe) types =
76canonicalizeAlias region env (name, tvars, dealiasedTipe) types =
79− if typesLen /= tvarsLen
77+ let
80− then Result.err (A.A region (Error.alias name tvarsLen typesLen))
78+ typesLen =
81− else toAlias <$> Trav.traverse (tipe env) types
82− where
83− typesLen = length types
79+ length types
80+
81+ tvarsLen =
84− tvarsLen = length tvars
82+ length tvars
85
83
86 toAlias canonicalTypes =
84 toAlias canonicalTypes =
87− T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)
85+ T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)
86+ in
87+ if typesLen /= tvarsLen then
88+ Result.throw region (Error.alias name tvarsLen typesLen)
89+
90+ else
91+ toAlias <$> Trav.traverse (tipe env) types
92+
src/Canonicalize/Variable.hs+74−38
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Canonicalize.Variable where
2+module Canonicalize.Variable (Result, variable, tvar, pvar) where
3
3
4import qualified Data.Either as Either
4import qualified Data.Either as Either
5import qualified Data.Map as Map
5import qualified Data.Map as Map
@@ -9,55 +9,84 @@ import qualified AST.Helpers as Help
9import qualified AST.Module.Name as ModuleName
9import qualified AST.Module.Name as ModuleName
10import qualified AST.Type as Type
10import qualified AST.Type as Type
11import qualified AST.Variable as Var
11import qualified AST.Variable as Var
12−import qualified Reporting.Annotation as A
12+import qualified Canonicalize.Environment as Env
13import qualified Reporting.Error.Canonicalize as Error
13import qualified Reporting.Error.Canonicalize as Error
14import qualified Reporting.Error.Helpers as Error
14import qualified Reporting.Error.Helpers as Error
15import qualified Reporting.Region as R
15import qualified Reporting.Region as R
16−import qualified Canonicalize.Environment as Env
16+import qualified Reporting.Result as Result
17−import qualified Canonicalize.Result as Result
18−import qualified Elm.Package as Pkg
17+import qualified Reporting.Warning as Warning
19import Elm.Utils ((|>))
18import Elm.Utils ((|>))
20
19
21
20
21+
22+-- RESULT HELPERS
23+
24+
25+type Result a =
26+ Result.Result (Set.Set ModuleName.Raw) Warning.Warning Error.Error a
27+
28+
29+logVarWith :: (a -> Var.Canonical) -> a -> Result a
30+logVarWith toVar value =
31+ case toVar value of
32+ Var.Canonical (Var.Module (ModuleName.Canonical _ moduleName)) _name ->
33+ Result.accumulate (Set.singleton moduleName) value
34+
35+ Var.Canonical _ _ ->
36+ Result.ok value
37+
38+
39+logVar :: Var.Canonical -> Result Var.Canonical
40+logVar var =
41+ logVarWith id var
42+
43+
44+
45+-- FINDERS
46+
47+
22−variable :: R.Region -> Env.Environment -> String -> Result.ResultErr Var.Canonical
48+variable :: R.Region -> Env.Environment -> String -> Result Var.Canonical
23variable region env var =
49variable region env var =
24 case toVarName var of
50 case toVarName var of
25 Right (name, varName) | ModuleName.isNative name ->
51 Right (name, varName) | ModuleName.isNative name ->
26− let
52+ let
53+ localPkg =
54+ ModuleName._package (Env._home env)
55+
27− moduleName =
56+ moduleName =
28− ModuleName.Canonical Pkg.dummyName name
57+ ModuleName.Canonical localPkg name
29− in
58+ in
30− Result.var (Var.Canonical (Var.Module moduleName) varName)
59+ logVar (Var.Canonical (Var.Module moduleName) varName)
31
60
32 _ ->
61 _ ->
33− case Set.toList `fmap` Map.lookup var (Env._values env) of
62+ case Set.toList `fmap` Map.lookup var (Env._values env) of
34− Just [v] ->
63+ Just [v] ->
35− Result.var v
64+ logVar v
36
65
37− Just vs ->
66+ Just vs ->
38− preferLocals region env "variable" vs var
67+ preferLocals region env "variable" vs var
39
68
40− Nothing ->
69+ Nothing ->
41− notFound region "variable" (Map.keys (Env._values env)) var
70+ notFound region "variable" (Map.keys (Env._values env)) var
42
71
43
72
44tvar
73tvar
45 :: R.Region
74 :: R.Region
46 -> Env.Environment
75 -> Env.Environment
47 -> String
76 -> String
48− -> Result.ResultErr
77+ -> Result
49 (Either
78 (Either
50 Var.Canonical
79 Var.Canonical
51 (Var.Canonical, [String], Type.Canonical)
80 (Var.Canonical, [String], Type.Canonical)
52 )
81 )
53tvar region env var =
82tvar region env var =
54− case adts ++ aliases of
83+ case unions ++ aliases of
55− [] -> notFound region "type" (Map.keys (Env._adts env) ++ Map.keys (Env._aliases env)) var
84+ [] -> notFound region "type" (Map.keys (Env._unions env) ++ Map.keys (Env._aliases env)) var
56− [v] -> Result.var' extract v
85+ [v] -> logVarWith extract v
57 vs -> preferLocals' region env extract "type" vs var
86 vs -> preferLocals' region env extract "type" vs var
58 where
87 where
59− adts =
88+ unions =
60− map Left (maybe [] Set.toList (Map.lookup var (Env._adts env)))
89+ map Left (maybe [] Set.toList (Map.lookup var (Env._unions env)))
61
90
62 aliases =
91 aliases =
63 map Right (maybe [] Set.toList (Map.lookup var (Env._aliases env)))
92 map Right (maybe [] Set.toList (Map.lookup var (Env._aliases env)))
@@ -73,34 +102,37 @@ pvar
73 -> Env.Environment
102 -> Env.Environment
74 -> String
103 -> String
75 -> Int
104 -> Int
76− -> Result.ResultErr Var.Canonical
105+ -> Result Var.Canonical
77pvar region env var actualArgs =
106pvar region env var actualArgs =
78 case Set.toList `fmap` Map.lookup var (Env._patterns env) of
107 case Set.toList `fmap` Map.lookup var (Env._patterns env) of
79 Just [value] ->
108 Just [value] ->
80 foundArgCheck value
109 foundArgCheck value
81
110
82 Just values ->
111 Just values ->
83− preferLocals' region env fst "pattern" values var
112+ foundArgCheck =<< preferLocals' region env fst "pattern" values var
84− `Result.andThen` foundArgCheck
85
113
86 Nothing ->
114 Nothing ->
87 notFound region "pattern" (Map.keys (Env._patterns env)) var
115 notFound region "pattern" (Map.keys (Env._patterns env)) var
88 where
116 where
89 foundArgCheck (name, expectedArgs) =
117 foundArgCheck (name, expectedArgs) =
90− if actualArgs == expectedArgs
118+ if actualArgs == expectedArgs then
91− then Result.var name
119+ logVar name
120+
121+ else
92− else Result.err (A.A region (Error.argMismatch name expectedArgs actualArgs))
122+ Result.throw region (Error.argMismatch name expectedArgs actualArgs)
123+
93
124
94
125
95-- FOUND
126-- FOUND
96
127
128+
97preferLocals
129preferLocals
98 :: R.Region
130 :: R.Region
99 -> Env.Environment
131 -> Env.Environment
100 -> String
132 -> String
101 -> [Var.Canonical]
133 -> [Var.Canonical]
102 -> String
134 -> String
103− -> Result.ResultErr Var.Canonical
135+ -> Result Var.Canonical
104preferLocals region env =
136preferLocals region env =
105 preferLocals' region env id
137 preferLocals' region env id
106
138
@@ -112,28 +144,28 @@ preferLocals'
112 -> String
144 -> String
113 -> [a]
145 -> [a]
114 -> String
146 -> String
115− -> Result.ResultErr a
147+ -> Result a
116preferLocals' region env extract kind possibilities var =
148preferLocals' region env extract kind possibilities var =
117 case filter (isLocal (Env._home env) . extract) possibilities of
149 case filter (isLocal (Env._home env) . extract) possibilities of
118 [] ->
150 [] ->
119 ambiguous possibilities
151 ambiguous possibilities
120
152
121 [v] ->
153 [v] ->
122− Result.var' extract v
154+ logVarWith extract v
123
155
124 --Local vars shadow top-level vars
156 --Local vars shadow top-level vars
125 [v1, v2]
157 [v1, v2]
126 | isTopLevel (extract v1) ->
158 | isTopLevel (extract v1) ->
127− Result.var' extract v2
159+ logVarWith extract v2
128
160
129 | isTopLevel (extract v2) ->
161 | isTopLevel (extract v2) ->
130− Result.var' extract v1
162+ logVarWith extract v1
131
163
132 locals ->
164 locals ->
133 ambiguous locals
165 ambiguous locals
134 where
166 where
135 ambiguous possibleVars =
167 ambiguous possibleVars =
136− Result.err (A.A region (Error.variable kind var Error.Ambiguous vars))
168+ Result.throw region (Error.variable kind var Error.Ambiguous vars)
137 where
169 where
138 vars = map (Var.toString . extract) possibleVars
170 vars = map (Var.toString . extract) possibleVars
139
171
@@ -164,8 +196,10 @@ isTopLevel (Var.Canonical home _) =
164 False
196 False
165
197
166
198
199+
167-- NOT FOUND HELPERS
200-- NOT FOUND HELPERS
168
201
202+
169type VarName =
203type VarName =
170 Either String (ModuleName.Raw, String)
204 Either String (ModuleName.Raw, String)
171
205
@@ -194,9 +228,11 @@ isOp name =
194 Help.isOp (noQualifier name)
228 Help.isOp (noQualifier name)
195
229
196
230
231+
197-- NOT FOUND
232-- NOT FOUND
198
233
234+
199−notFound :: R.Region -> String -> [String] -> String -> Result.ResultErr a
235+notFound :: R.Region -> String -> [String] -> String -> Result a
200notFound region kind possibilities var =
236notFound region kind possibilities var =
201 let name =
237 let name =
202 toVarName var
238 toVarName var
@@ -212,7 +248,7 @@ notFound region kind possibilities var =
212 Right (modul, varName) ->
248 Right (modul, varName) ->
213 qualifiedProblem modul varName (Either.rights possibleNames)
249 qualifiedProblem modul varName (Either.rights possibleNames)
214 in
250 in
215− Result.err (A.A region (Error.variable kind var problem suggestions))
251+ Result.throw region (Error.variable kind var problem suggestions)
216
252
217
253
218exposedProblem :: VarName -> [VarName] -> (Error.VarProblem, [String])
254exposedProblem :: VarName -> [VarName] -> (Error.VarProblem, [String])
src/Compile.hs+28−17
@@ -2,6 +2,8 @@ module Compile (compile) where
2
2
3import qualified Data.Map as Map
3import qualified Data.Map as Map
4
4
5+import qualified AST.Declaration as D
6+import qualified AST.Expression.Canonical as Can
5import qualified AST.Module as Module
7import qualified AST.Module as Module
6import qualified AST.Module.Name as ModuleName
8import qualified AST.Module.Name as ModuleName
7import qualified Canonicalize
9import qualified Canonicalize
@@ -13,25 +15,29 @@ import qualified Optimize
13import qualified Parse.Helpers as Parse
15import qualified Parse.Helpers as Parse
14import qualified Parse.Parse as Parse
16import qualified Parse.Parse as Parse
15import qualified Reporting.Error as Error
17import qualified Reporting.Error as Error
18+import qualified Reporting.Render.Type as RenderType
16import qualified Reporting.Result as Result
19import qualified Reporting.Result as Result
17import qualified Reporting.Warning as Warning
20import qualified Reporting.Warning as Warning
18import qualified Type.Inference as TI
21import qualified Type.Inference as TI
19
22
20
23
24+
25+type Result =
26+ Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error
27+
28+
21compile
29compile
22 :: Package.Name
30 :: Package.Name
23− -> Bool
24 -> [ModuleName.Canonical]
31 -> [ModuleName.Canonical]
25 -> Module.Interfaces
32 -> Module.Interfaces
26 -> String
33 -> String
27− -> Result.Result Warning.Warning Error.Error Module.Optimized
34+ -> Result Module.Optimized
28−
29−compile packageName isRoot canonicalImports interfaces source =
35+compile packageName canonicalImports interfaces source =
30 do
36 do
31 -- Parse the source code
37 -- Parse the source code
32 validModule <-
38 validModule <-
33− Result.mapError Error.Syntax $
39+ Result.format Error.Syntax $
34− Parse.program packageName isRoot (getOpTable interfaces) source
40+ Parse.program packageName (getOpTable interfaces) source
35
41
36 -- Canonicalize all variables, pinning down where they came from.
42 -- Canonicalize all variables, pinning down where they came from.
37 canonicalModule <-
43 canonicalModule <-
@@ -43,27 +49,32 @@ compile packageName isRoot canonicalImports interfaces source =
43 TI.infer interfaces canonicalModule
49 TI.infer interfaces canonicalModule
44
50
45 -- One last round of checks
51 -- One last round of checks
52+ canonicalDefs <-
46− Result.mapError Error.Type $
53+ Result.format Error.Type $
47− Nitpick.topLevelTypes types (Module.body validModule)
54+ Nitpick.topLevelTypes types $
55+ Can.toSortedDefs (Module.program (Module.info canonicalModule))
48
56
49 tagDict <-
57 tagDict <-
50− Result.mapError Error.Pattern $
58+ Result.format Error.Pattern $
51 Nitpick.patternMatches interfaces canonicalModule
59 Nitpick.patternMatches interfaces canonicalModule
52
60
53− -- Add the real list of types
54− let body =
55− (Module.body canonicalModule) { Module.types = types }
56−
57 -- Do some basic optimizations
61 -- Do some basic optimizations
58− let optModule =
62+ let optimisedDefs =
59− Optimize.optimize tagDict (canonicalModule { Module.body = body })
63+ Optimize.optimize tagDict (Module.name canonicalModule) canonicalDefs
64+
65+ -- Add the real list of types
66+ let info =
67+ (Module.info canonicalModule)
68+ { Module.types = types
69+ , Module.program = optimisedDefs
70+ }
60
71
61− return optModule
72+ return $ canonicalModule { Module.info = info }
62
73
63
74
64getOpTable :: Module.Interfaces -> Parse.OpTable
75getOpTable :: Module.Interfaces -> Parse.OpTable
65getOpTable interfaces =
76getOpTable interfaces =
66 Map.elems interfaces
77 Map.elems interfaces
67 |> concatMap Module.iFixities
78 |> concatMap Module.iFixities
68− |> map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
79+ |> map (\(D.Infix op assoc lvl) -> ( op, (lvl,assoc) ))
69 |> Map.fromList
80 |> Map.fromList
src/Docs/Centralize.hs+56−76
@@ -2,99 +2,79 @@ module Docs.Centralize (centralize) where
2
2
3import Control.Arrow (second)
3import Control.Arrow (second)
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5+import qualified Data.Maybe as Maybe
5
6
6import qualified AST.Declaration as D
7import qualified AST.Declaration as D
7import qualified AST.Expression.Canonical as Canonical
8import qualified AST.Expression.Canonical as Canonical
8−import qualified AST.Pattern as P
9+import qualified AST.Pattern as Pattern
10+import qualified AST.Type as Type
9import qualified Docs.AST as Docs
11import qualified Docs.AST as Docs
10import qualified Elm.Compiler.Type as Type
12import qualified Elm.Compiler.Type as Type
11import qualified Elm.Compiler.Type.Extract as Extract
13import qualified Elm.Compiler.Type.Extract as Extract
12import qualified Reporting.Annotation as A
14import qualified Reporting.Annotation as A
13
15
14
16
17+
15-- CENTRALIZE DOCUMENTATION
18-- CENTRALIZE DOCUMENTATION
16
19
20+
17−centralize :: [D.CanonicalDecl] -> String -> Docs.Centralized
21+centralize :: D.Canonical -> String -> Docs.Centralized
18−centralize decls comment =
22+centralize (D.Decls defs unions aliases infixes) comment =
19 let
23 let
20− (Raw aliases types valueInfo fixities) =
24+ infixDict =
21− toRawDocs decls
25+ Map.fromList (map infixToEntry infixes)
26+ in
27+ Docs.Docs
28+ comment
29+ (Map.fromList (map aliasToEntry aliases))
30+ (Map.fromList (map unionToEntry unions))
31+ (Map.fromList (Maybe.mapMaybe (defToEntry infixDict) defs))
32+
33+
34+
35+-- CONVERSION TO DOC ENTRIES
36+
22
37
23− values =
38+defToEntry
24− Map.fromList (map (toValue fixities) (Map.toList valueInfo))
39+ :: Map.Map String (String, Int)
40+ -> A.Commented Canonical.Def
41+ -> Maybe (String, A.Located (Docs.Value (Maybe Type.Type)))
42+defToEntry infixDict (A.A (_, maybeComment) (Canonical.Def _ pattern _ maybeType)) =
43+ case pattern of
44+ A.A subregion (Pattern.Var name) ->
45+ let
46+ value =
47+ Docs.Value
48+ maybeComment
49+ (fmap (Extract.toAliasedType . A.drop) maybeType)
50+ (Map.lookup name infixDict)
51+ in
52+ Just (name, A.A subregion value)
53+
54+ _ ->
55+ Nothing
56+
57+
58+unionToEntry :: A.Commented (D.Union Type.Canonical) -> (String, A.Located Docs.Union)
59+unionToEntry (A.A (region, maybeComment) (D.Type name args ctors)) =
60+ let
61+ ctors' =
62+ map (second (map Extract.toAliasedType)) ctors
25 in
63 in
26− Docs.Docs comment aliases types values
64+ (name, A.A region (Docs.Union maybeComment args ctors'))
27
65
28
66
29−toValue
67+aliasToEntry :: A.Commented (D.Alias Type.Canonical) -> (String, A.Located Docs.Alias)
30− :: Map.Map String (String, Int)
31− -> ( String, A.Located (Maybe String, Maybe Type.Type) )
32− -> ( String, A.Located (Docs.Value (Maybe Type.Type)) )
33−toValue fixities (name, A.A region (maybeComment, maybeType)) =
68+aliasToEntry (A.A (region, maybeComment) (D.Type name args tipe)) =
34 ( name
69 ( name
35− , A.A region (Docs.Value maybeComment maybeType (Map.lookup name fixities))
70+ , A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))
36 )
71 )
37
72
38
73
39−-- GATHER INFORMATION
74+infixToEntry :: D.Infix -> (String, (String, Int))
40−
75+infixToEntry (D.Infix name assoc precedence) =
41−data Raw = Raw
42− { rawAliases :: Map.Map String (A.Located Docs.Alias)
43− , rawTypes :: Map.Map String (A.Located Docs.Union)
44− , rawValues :: Map.Map String (A.Located (Maybe String, Maybe Type.Type))
45− , rawFixities :: Map.Map String (String, Int)
46− }
47−
48−
49−toRawDocs :: [D.CanonicalDecl] -> Raw
50−toRawDocs decls =
51− foldr addDeclToDocs (Raw Map.empty Map.empty Map.empty Map.empty) decls
52−
53−
54−addDeclToDocs :: D.CanonicalDecl -> Raw -> Raw
55−addDeclToDocs (A.A (region,maybeComment) decl) docs =
56− case decl of
57− D.Definition (Canonical.Definition _ (A.A subregion (P.Var name)) _ maybeType) ->
58− let
59− info =
60− ( maybeComment
61− , fmap (Extract.toAliasedType . A.drop) maybeType
62− )
63−
64− newValues =
65− Map.insert name (A.A subregion info) (rawValues docs)
66− in
67− docs { rawValues = newValues }
68−
69− D.Definition _ ->
70− docs
71−
72− D.Datatype name args ctors ->
73− let
74− ctors' =
75− map (second (map Extract.toAliasedType)) ctors
76−
77− union =
78− A.A region (Docs.Union maybeComment args ctors')
79− in
80− docs { rawTypes = Map.insert name union (rawTypes docs) }
81−
82− D.TypeAlias name args tipe ->
83− let
76+ let
84− alias =
85− A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))
86− in
87− docs { rawAliases = Map.insert name alias (rawAliases docs) }
88−
89− D.Port _ ->
90− docs
91−
92− D.Fixity assoc precedence name ->
93− let
94− fixity =
77+ fixity =
95− (D.assocToString assoc, precedence)
78+ (D.assocToString assoc, precedence)
96− in
79+ in
97− docs
98− { rawFixities =
99− Map.insert name fixity (rawFixities docs)
80+ ( name, fixity )
100− }
src/Docs/Check.hs+4−2
@@ -1,4 +1,4 @@
1−module Docs.Check (check) where
1+module Docs.Check (Result, check) where
2
2
3import qualified Data.List as List
3import qualified Data.List as List
4import qualified Data.Map as Map
4import qualified Data.Map as Map
@@ -22,7 +22,9 @@ import qualified Reporting.Region as R
22import qualified Reporting.Result as R
22import qualified Reporting.Result as R
23
23
24
24
25+
26+type Result w a =
25−type Result w a = R.Result w Error.Error a
27+ R.Result () w Error.Error a
26
28
27
29
28-- CHECK DOCUMENTATION
30-- CHECK DOCUMENTATION
src/Elm/Compiler.hs+33−35
@@ -11,6 +11,7 @@ module Elm.Compiler
11
11
12import qualified Data.Aeson as Json
12import qualified Data.Aeson as Json
13import qualified Data.Map as Map
13import qualified Data.Map as Map
14+import qualified Data.Text.Lazy as LazyText
14import System.IO (Handle)
15import System.IO (Handle)
15
16
16import qualified AST.Module as Module
17import qualified AST.Module as Module
@@ -25,6 +26,7 @@ import qualified Generate.JavaScript as JS
25import qualified Parse.Module as Parse
26import qualified Parse.Module as Parse
26import qualified Parse.Parse as Parse
27import qualified Parse.Parse as Parse
27import qualified Reporting.Annotation as A
28import qualified Reporting.Annotation as A
29+import qualified Reporting.Bag as Bag
28import qualified Reporting.Error as Error
30import qualified Reporting.Error as Error
29import qualified Reporting.Render.Type as RenderType
31import qualified Reporting.Render.Type as RenderType
30import qualified Reporting.Report as Report
32import qualified Reporting.Report as Report
@@ -32,36 +34,35 @@ import qualified Reporting.Result as Result
32import qualified Reporting.Warning as Warning
34import qualified Reporting.Warning as Warning
33
35
34
36
37+
35-- VERSION
38-- VERSION
36
39
40+
37version :: Package.Version
41version :: Package.Version
38version =
42version =
39 Elm.Compiler.Version.version
43 Elm.Compiler.Version.version
40
44
41
45
46+
42-- DEPENDENCIES
47-- DEPENDENCIES
43
48
44−parseDependencies
49+
45− :: String
46− -> Either [Error] (PublicModule.Name, [PublicModule.Name])
50+parseDependencies :: String -> Either [Error] (PublicModule.Raw, [PublicModule.Raw])
47parseDependencies sourceCode =
51parseDependencies sourceCode =
48 let
52 let
49− (Result.Result _warnings rawResult) =
53+ (Result.Result _ _ answer) =
50 Parse.parse sourceCode Parse.header
54 Parse.parse sourceCode Parse.header
55+
56+ getDeps (Module.Header _ name _ _ _ imports) =
57+ ( name, map (fst . A.drop) imports )
51 in
58 in
52− case rawResult of
53− Result.Err msgs ->
54− Left $ map (Error . A.map Error.Syntax) msgs
59+ Result.answerToEither (Error . A.map Error.Syntax) getDeps answer
55
60
56− Result.Ok (Module.Header name _docs _exports imports) ->
57− Right
58− ( PublicModule.Name name
59− , map (PublicModule.Name . fst . A.drop) imports
60− )
61
61
62
62
63-- COMPILATION
63-- COMPILATION
64
64
65+
65{-| Compiles Elm source code to JavaScript. -}
66{-| Compiles Elm source code to JavaScript. -}
66compile
67compile
67 :: Context
68 :: Context
@@ -71,62 +72,55 @@ compile
71
72
72compile context source interfaces =
73compile context source interfaces =
73 let
74 let
74− (Context packageName isRoot isExposed dependencies) =
75+ (Context packageName isExposed dependencies) =
75 context
76 context
76
77
77− (Result.Result (localizer, warnings) rawResult) =
78+ (Result.Result oneLocalizer warnings answer) =
78− do modul <- Compile.compile packageName isRoot dependencies interfaces source
79+ do modul <- Compile.compile packageName dependencies interfaces source
79− docs <- docsGen isExposed modul
80+ docs <- Result.format Error.Docs (docsGen isExposed modul)
80
81
81 let interface = Module.toInterface packageName modul
82 let interface = Module.toInterface packageName modul
82 let javascript = JS.generate modul
83 let javascript = JS.generate modul
83
84
84 return (Result docs interface javascript)
85 return (Result docs interface javascript)
85 in
86 in
86− ( maybe dummyLocalizer Localizer localizer
87+ ( Result.oneToValue dummyLocalizer Localizer oneLocalizer
87− , map Warning warnings
88+ , Bag.toList Warning warnings
88− , Result.destruct (Left . map Error) Right rawResult
89+ , Result.answerToEither Error id answer
89 )
90 )
90
91
91
92
92data Context = Context
93data Context = Context
93 { _packageName :: Package.Name
94 { _packageName :: Package.Name
94− , _isRoot :: Bool
95 , _isExposed :: Bool
95 , _isExposed :: Bool
96− , _dependencies :: [PublicModule.CanonicalName]
96+ , _dependencies :: [PublicModule.Canonical]
97 }
97 }
98
98
99
99
100data Result = Result
100data Result = Result
101 { _docs :: Maybe Docs.Documentation
101 { _docs :: Maybe Docs.Documentation
102 , _interface :: PublicModule.Interface
102 , _interface :: PublicModule.Interface
103− , _js :: String
103+ , _js :: LazyText.Text
104 }
104 }
105
105
106
106
107−docsGen
108− :: Bool
109− -> Module.Optimized
110− -> Result.Result w Error.Error (Maybe Docs.Documentation)
107+docsGen :: Bool -> Module.Optimized -> Docs.Result w (Maybe Docs.Documentation)
111−docsGen isExposed modul =
108+docsGen isExposed (Module.Module name _ info) =
112 if not isExposed then
109 if not isExposed then
113 Result.ok Nothing
110 Result.ok Nothing
111+
114 else
112 else
115 let
113 let
116− getChecked =
117− Docs.check (Module.exports modul) (Module.docs modul)
118−
119− name =
120− PublicModule.Name (ModuleName._module (Module.name modul))
121−
122 toDocs checked =
114 toDocs checked =
123− Docs.fromCheckedDocs name checked
115+ Just (Docs.fromCheckedDocs (ModuleName._module name) checked)
124 in
116 in
125− (Just . toDocs) `fmap` Result.mapError Error.Docs getChecked
117+ toDocs <$> Docs.check (Module.exports info) (Module.docs info)
118+
126
119
127
120
128-- DEALIASER
121-- DEALIASER
129
122
123+
130newtype Localizer =
124newtype Localizer =
131 Localizer RenderType.Localizer
125 Localizer RenderType.Localizer
132
126
@@ -136,8 +130,10 @@ dummyLocalizer =
136 Localizer Map.empty
130 Localizer Map.empty
137
131
138
132
133+
139-- ERRORS
134-- ERRORS
140
135
136+
141newtype Error =
137newtype Error =
142 Error (A.Located Error.Error)
138 Error (A.Located Error.Error)
143
139
@@ -157,8 +153,10 @@ errorToJson (Localizer localizer) location (Error err) =
157 Error.toJson localizer location err
153 Error.toJson localizer location err
158
154
159
155
156+
160-- WARNINGS
157-- WARNINGS
161
158
159+
162newtype Warning =
160newtype Warning =
163 Warning (A.Located Warning.Warning)
161 Warning (A.Located Warning.Warning)
164
162
src/Elm/Compiler/Imports.hs+14−1
@@ -17,10 +17,23 @@ defaults =
17 , ["List"] ==> exposing [Var.Value "::"]
17 , ["List"] ==> exposing [Var.Value "::"]
18 , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]
18 , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]
19 , ["Result"] ==> exposing [Var.Union "Result" Var.openListing]
19 , ["Result"] ==> exposing [Var.Union "Result" Var.openListing]
20− , ["Signal"] ==> exposing [Var.Alias "Signal"]
20+ , ["Platform"] ==> exposing [closedType "Program"]
21+ , ["Platform","Cmd"] ==> named "Cmd" [closedType "Cmd", Var.Value "!"]
22+ , ["Platform","Sub"] ==> named "Sub" [closedType "Sub"]
21 ]
23 ]
22
24
23
25
24exposing :: [Var.Value] -> Module.ImportMethod
26exposing :: [Var.Value] -> Module.ImportMethod
25exposing vars =
27exposing vars =
26 Module.ImportMethod Nothing (Var.listing vars)
28 Module.ImportMethod Nothing (Var.listing vars)
29+
30+
31+closedType :: String -> Var.Value
32+closedType name =
33+ Var.Union name Var.closedListing
34+
35+
36+named :: String -> [Var.Value] -> Module.ImportMethod
37+named name vars =
38+ Module.ImportMethod (Just name) (Var.listing vars)
39+
src/Elm/Compiler/Module.hs+52−52
@@ -1,19 +1,17 @@
1module Elm.Compiler.Module
1module Elm.Compiler.Module
2 ( Interface, Interfaces
2 ( Interface, Interfaces
3− , Name(Name)
3+ , ModuleName.Raw
4 , nameToPath
4 , nameToPath
5 , nameToString, nameFromString
5 , nameToString, nameFromString
6 , hyphenate, dehyphenate
6 , hyphenate, dehyphenate
7+ , RawForJson(RawForJson), fromJson
7 , defaultImports
8 , defaultImports
8− , interfacePorts
9 , interfaceAliasedTypes
9 , interfaceAliasedTypes
10− , CanonicalName, canonicalName
10+ , ModuleName.Canonical(..), qualifiedVar
11 )
11 )
12 where
12 where
13
13
14−import Control.Monad (mzero)
15import qualified Data.Aeson as Json
14import qualified Data.Aeson as Json
16−import Data.Binary
17import qualified Data.Char as Char
15import qualified Data.Char as Char
18import qualified Data.List as List
16import qualified Data.List as List
19import qualified Data.Map as Map
17import qualified Data.Map as Map
@@ -25,76 +23,78 @@ import qualified AST.Module.Name as ModuleName
25import qualified Elm.Compiler.Imports as Imports
23import qualified Elm.Compiler.Imports as Imports
26import qualified Elm.Compiler.Type as Type
24import qualified Elm.Compiler.Type as Type
27import qualified Elm.Compiler.Type.Extract as Extract
25import qualified Elm.Compiler.Type.Extract as Extract
28−import qualified Elm.Package as Package
26+import qualified Generate.JavaScript.Variable as Gen
27+
29
28
30
29
31-- INTERFACES
30-- INTERFACES
32
31
32+
33type Interface = Module.Interface
33type Interface = Module.Interface
34
34
35
35
36type Interfaces = Module.Interfaces
36type Interfaces = Module.Interfaces
37
37
38
38
39−interfacePorts :: Interface -> [String]
40−interfacePorts interface =
41− Module.iPorts interface
42−
43−
44interfaceAliasedTypes :: Interface -> Map.Map String Type.Type
39interfaceAliasedTypes :: Interface -> Map.Map String Type.Type
45interfaceAliasedTypes interface =
40interfaceAliasedTypes interface =
46 Map.map Extract.toAliasedType (Module.iTypes interface)
41 Map.map Extract.toAliasedType (Module.iTypes interface)
47
42
48
43
44+
49-- NAMES
45-- NAMES
50
46
51−newtype Name = Name ModuleName.Raw
52− deriving (Eq, Ord)
53
47
48+newtype RawForJson = RawForJson ModuleName.Raw
54
49
55−type CanonicalName = ModuleName.Canonical
56
50
51+fromJson :: RawForJson -> ModuleName.Raw
52+fromJson (RawForJson raw) =
53+ raw
57
54
58−canonicalName :: Package.Name -> Name -> CanonicalName
59−canonicalName pkgName (Name name) =
60− ModuleName.Canonical pkgName name
61
55
56+qualifiedVar :: ModuleName.Canonical -> String -> String
57+qualifiedVar =
58+ Gen.qualified
62
59
60+
63−defaultImports :: [Name]
61+defaultImports :: [ModuleName.Raw]
64defaultImports =
62defaultImports =
65− map (Name . fst) Imports.defaults
63+ map fst Imports.defaults
64+
65+
66
66
67+-- STRING CONVERSIONS for RAW NAMES
67
68
68−-- STRING CONVERSIONS for NAMES
69
69
70−nameToPath :: Name -> FilePath
70+nameToPath :: ModuleName.Raw -> FilePath
71−nameToPath (Name names) =
71+nameToPath names =
72− List.foldl1 (</>) names
72+ List.foldl1 (</>) names
73
73
74
74
75−nameToString :: Name -> String
75+nameToString :: ModuleName.Raw -> String
76−nameToString (Name names) =
76+nameToString names =
77− List.intercalate "." names
77+ List.intercalate "." names
78
78
79
79
80−nameFromString :: String -> Maybe Name
80+nameFromString :: String -> Maybe ModuleName.Raw
81nameFromString =
81nameFromString =
82− fromString '.'
82+ fromString '.'
83
83
84
84
85−hyphenate :: Name -> String
85+hyphenate :: ModuleName.Raw -> String
86−hyphenate (Name names) =
86+hyphenate names =
87− List.intercalate "-" names
87+ List.intercalate "-" names
88
88
89
89
90−dehyphenate :: String -> Maybe Name
90+dehyphenate :: String -> Maybe ModuleName.Raw
91dehyphenate =
91dehyphenate =
92− fromString '-'
92+ fromString '-'
93
93
94
94
95−fromString :: Char -> String -> Maybe Name
95+fromString :: Char -> String -> Maybe ModuleName.Raw
96fromString sep raw =
96fromString sep raw =
97− Name `fmap` mapM isLegit names
97+ mapM isLegit names
98 where
98 where
99 names =
99 names =
100 filter (/= [sep]) (List.groupBy (\a b -> a /= sep && b /= sep) raw)
100 filter (/= [sep]) (List.groupBy (\a b -> a /= sep && b /= sep) raw)
@@ -111,28 +111,28 @@ fromString sep raw =
111 Char.isAlphaNum char || char `elem` "_'"
111 Char.isAlphaNum char || char `elem` "_'"
112
112
113
113
114−-- JSON for NAME
115
114
116−instance Json.ToJSON Name where
115+-- JSON for NAME
117− toJSON name =
118− Json.toJSON (nameToString name)
119
116
120
117
121−instance Json.FromJSON Name where
118+instance Json.ToJSON RawForJson where
122− parseJSON (Json.String text) =
119+ toJSON (RawForJson name) =
123− let rawName = Text.unpack text in
120+ Json.toJSON (nameToString name)
124− case nameFromString rawName of
125− Nothing -> fail (rawName ++ " is not a valid module name")
126− Just name -> return name
127
121
128− parseJSON _ = mzero
129
122
123+instance Json.FromJSON RawForJson where
124+ parseJSON (Json.String text) =
125+ let
126+ rawString =
127+ Text.unpack text
128+ in
129+ case nameFromString rawString of
130+ Nothing ->
131+ fail (rawString ++ " is not a valid module name")
130
132
131−-- BINARY for NAME
133+ Just name ->
134+ return (RawForJson name)
132
135
133−instance Binary Name where
136+ parseJSON _ =
134− get =
137+ fail "expecting the module name to be a string"
135− fmap Name get
136
138
137− put (Name names) =
138− put names
src/Elm/Compiler/Type/Extract.hs+2−1
@@ -40,5 +40,6 @@ toType useAliases astType =
40 Type.Aliased name args t ->
40 Type.Aliased name args t ->
41 if useAliases then
41 if useAliases then
42 T.App (T.Type (Var.toString name)) (map (go . snd) args)
42 T.App (T.Type (Var.toString name)) (map (go . snd) args)
43+
43 else
44 else
44− go (Type.dealias args t)
45+ go (Type.dealias args t)
src/Elm/Docs.hs+30−9
@@ -18,8 +18,12 @@ import qualified Elm.Package as Pkg
18import qualified Reporting.Annotation as A
18import qualified Reporting.Annotation as A
19
19
20
20
21+
22+-- DATA STRUCTURES
23+
24+
21data Documentation = Documentation
25data Documentation = Documentation
22− { moduleName :: Module.Name
26+ { moduleName :: Module.Raw
23 , comment :: String
27 , comment :: String
24 , aliases :: [Alias]
28 , aliases :: [Alias]
25 , types :: [Union]
29 , types :: [Union]
@@ -55,9 +59,11 @@ data Value = Value
55data Version = NonCanonicalTypes | Version String
59data Version = NonCanonicalTypes | Version String
56
60
57
61
62+
58-- FROM CHECKED DOCS
63-- FROM CHECKED DOCS
59
64
65+
60−fromCheckedDocs :: Module.Name -> Docs.Checked -> Documentation
66+fromCheckedDocs :: Module.Raw -> Docs.Checked -> Documentation
61fromCheckedDocs name (Docs.Docs comment aliases unions values) =
67fromCheckedDocs name (Docs.Docs comment aliases unions values) =
62 let
68 let
63 unwrap cmnt =
69 unwrap cmnt =
@@ -72,15 +78,19 @@ fromCheckedDocs name (Docs.Docs comment aliases unions values) =
72 toValue (name, (A.A _ (Docs.Value cmnt tipe fix))) =
78 toValue (name, (A.A _ (Docs.Value cmnt tipe fix))) =
73 Value name (unwrap cmnt) tipe fix
79 Value name (unwrap cmnt) tipe fix
74 in
80 in
75− Documentation name comment
81+ Documentation
82+ name
83+ comment
76− (map toAlias (Map.toList aliases))
84+ (map toAlias (Map.toList aliases))
77− (map toUnion (Map.toList unions))
85+ (map toUnion (Map.toList unions))
78− (map toValue (Map.toList values))
86+ (map toValue (Map.toList values))
79− (Version $ (Pkg.versionToString Version.version))
87+ (Version $ (Pkg.versionToString Version.version))
88+
80
89
81
90
82-- PRETTY JSON
91-- PRETTY JSON
83
92
93+
84prettyJson :: (Json.ToJSON a) => a -> BS.ByteString
94prettyJson :: (Json.ToJSON a) => a -> BS.ByteString
85prettyJson value =
95prettyJson value =
86 Json.encodePretty' config value
96 Json.encodePretty' config value
@@ -99,12 +109,14 @@ config =
99 ]
109 ]
100
110
101
111
112+
102-- JSON for DOCUMENTATION
113-- JSON for DOCUMENTATION
103
114
115+
104instance Json.ToJSON Documentation where
116instance Json.ToJSON Documentation where
105 toJSON (Documentation name comment aliases types values version) =
117 toJSON (Documentation name comment aliases types values version) =
106 Json.object
118 Json.object
107− [ "name" .= name
119+ [ "name" .= Module.RawForJson name
108 , "comment" .= comment
120 , "comment" .= comment
109 , "aliases" .= aliases
121 , "aliases" .= aliases
110 , "types" .= types
122 , "types" .= types
@@ -116,7 +128,7 @@ instance Json.ToJSON Documentation where
116instance Json.FromJSON Documentation where
128instance Json.FromJSON Documentation where
117 parseJSON (Json.Object obj) =
129 parseJSON (Json.Object obj) =
118 Documentation
130 Documentation
119− <$> obj .: "name"
131+ <$> fmap Module.fromJson (obj .: "name")
120 <*> obj .: "comment"
132 <*> obj .: "comment"
121 <*> obj .: "aliases"
133 <*> obj .: "aliases"
122 <*> obj .: "types"
134 <*> obj .: "types"
@@ -127,8 +139,11 @@ instance Json.FromJSON Documentation where
127 fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value)
139 fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value)
128
140
129
141
142+
143+
130-- JSON for VERSION
144-- JSON for VERSION
131
145
146+
132instance Json.ToJSON Version where
147instance Json.ToJSON Version where
133 toJSON version =
148 toJSON version =
134 case version of
149 case version of
@@ -149,8 +164,10 @@ instance Json.FromJSON Version where
149 fail $ "Cannot decode version of documentation from: " ++ BS.unpack (Json.encode value)
164 fail $ "Cannot decode version of documentation from: " ++ BS.unpack (Json.encode value)
150
165
151
166
167+
152-- JSON for ALIAS
168-- JSON for ALIAS
153
169
170+
154instance Json.ToJSON Alias where
171instance Json.ToJSON Alias where
155 toJSON (Alias name comment args tipe) =
172 toJSON (Alias name comment args tipe) =
156 Json.object
173 Json.object
@@ -172,8 +189,10 @@ instance Json.FromJSON Alias where
172 fail $ "Cannot decode Alias from: " ++ BS.unpack (Json.encode value)
189 fail $ "Cannot decode Alias from: " ++ BS.unpack (Json.encode value)
173
190
174
191
192+
175-- JSON for UNION
193-- JSON for UNION
176
194
195+
177instance Json.ToJSON Union where
196instance Json.ToJSON Union where
178 toJSON (Union name comment args cases) =
197 toJSON (Union name comment args cases) =
179 Json.object
198 Json.object
@@ -195,8 +214,10 @@ instance Json.FromJSON Union where
195 fail $ "Cannot decode Union from: " ++ BS.unpack (Json.encode value)
214 fail $ "Cannot decode Union from: " ++ BS.unpack (Json.encode value)
196
215
197
216
217+
198-- JSON for VALUE
218-- JSON for VALUE
199
219
220+
200instance Json.ToJSON Value where
221instance Json.ToJSON Value where
201 toJSON (Value name comment tipe assocPrec) =
222 toJSON (Value name comment tipe assocPrec) =
202 Json.object (fields ++ possibleFields)
223 Json.object (fields ++ possibleFields)
src/Elm/Package.hs+12−2
@@ -26,11 +26,21 @@ dummyName =
26 Name "user" "project"
26 Name "user" "project"
27
27
28
28
29−coreName :: Name
29+core :: Name
30−coreName =
30+core =
31 Name "elm-lang" "core"
31 Name "elm-lang" "core"
32
32
33
33
34+virtualDom :: Name
35+virtualDom =
36+ Name "elm-lang" "virtual-dom"
37+
38+
39+html :: Name
40+html =
41+ Name "elm-lang" "html"
42+
43+
34toString :: Name -> String
44toString :: Name -> String
35toString name =
45toString name =
36 user name ++ "/" ++ project name
46 user name ++ "/" ++ project name
src/Elm/Utils.hs+2−3
@@ -18,7 +18,6 @@ import System.FilePath ((</>))
18import System.IO.Error (tryIOError)
18import System.IO.Error (tryIOError)
19import System.Process (readProcessWithExitCode)
19import System.Process (readProcessWithExitCode)
20
20
21−import qualified AST.Expression.Source as Source
22import qualified AST.Pattern as Pattern
21import qualified AST.Pattern as Pattern
23import qualified Elm.Compiler.Version as Version
22import qualified Elm.Compiler.Version as Version
24import qualified Elm.Package as Pkg
23import qualified Elm.Package as Pkg
@@ -154,8 +153,8 @@ errorNotFound name =
154
153
155isDeclaration :: String -> Maybe String
154isDeclaration :: String -> Maybe String
156isDeclaration string =
155isDeclaration string =
157− case Parse.iParse Parse.definition string of
156+ case Parse.iParse (Parse.definition (,)) string of
158− Right (A.A _ (Source.Definition pattern _)) ->
157+ Right (A.A _ (pattern, _)) ->
159 Just (List.intercalate "$" (Pattern.boundVarList pattern))
158 Just (List.intercalate "$" (Pattern.boundVarList pattern))
160
159
161 _ ->
160 _ ->
src/Generate/JavaScript.hs+61−132
@@ -1,162 +1,91 @@
1module Generate.JavaScript (generate) where
1module Generate.JavaScript (generate) where
2
2
3−import Control.Monad.State as State
3+import qualified Control.Monad.State as State
4−import qualified Data.List as List
4+import qualified Data.Text.Lazy as LazyText
5−import Language.ECMAScript3.PrettyPrint as ES
6−import Language.ECMAScript3.Syntax
5+import qualified Language.ECMAScript3.Syntax as JS
7−import qualified Text.PrettyPrint.Leijen as PP
6+
8−
9−import qualified AST.Expression.Optimized as Optimized
7+import qualified AST.Effects as Effects
10−import qualified AST.Helpers as Help
11import qualified AST.Module as Module
8import qualified AST.Module as Module
12import qualified AST.Module.Name as ModuleName
9import qualified AST.Module.Name as ModuleName
13−import qualified AST.Variable as Variable
10+import qualified Elm.Package as Pkg
11+import qualified Generate.JavaScript.Builder as Builder
14import qualified Generate.JavaScript.Expression as JS
12import qualified Generate.JavaScript.Expression as JS
15−import Generate.JavaScript.Helpers (call, function, localRuntime, obj, prop, ref, varDecl)
13+import qualified Generate.JavaScript.Helpers as JS
16import qualified Generate.JavaScript.Variable as Var
14import qualified Generate.JavaScript.Variable as Var
17
15
18
16
19−generate :: Module.Optimized -> String
20−generate module_ =
21− let
22− (ModuleName.Canonical _ name) =
23− Module.name module_
24−
25− body =
26− concat
27− [ useStrict
28− , checkForCachedVersion name
29− , imports (Module.imports module_)
30− , definitions (Module.program (Module.body module_))
31− , exports name (Module.exports module_)
32− ]
33−
34− make =
35− "Elm" : name ++ ["make"]
36−
37− javascript =
38− buildIntermediateObjects make
39− ++
40− [ assign make (function [localRuntime] body)
41− ]
42− in
43− PP.displayS (PP.renderPretty 1 160 (ES.prettyPrint javascript)) ""
44−
45−
46−
47−-- INTRO
48−
49
17
50−useStrict :: [Statement ()]
18+-- GENERATE JAVASCRIPT
51−useStrict =
52− [ ExprStmt () (StringLit () "use strict")
53− ]
54
19
55
20
56−checkForCachedVersion :: ModuleName.Raw -> [Statement ()]
21+generate :: Module.Optimized -> LazyText.Text
57−checkForCachedVersion name =
22+generate (Module.Module moduleName _ info) =
58 let
23 let
59− values =
24+ genBody =
60− localRuntime : name ++ ["values"]
25+ do defsList <- mapM JS.generateDef (Module.program info)
61−
26+ let managerStmts = generateEffectManager moduleName (Module.effects info)
62− valuesObject =
27+ return (concat (defsList ++ [managerStmts]))
63− obj values
64− in
65− buildIntermediateObjects values
66− ++
67− [ IfSingleStmt () valuesObject (ReturnStmt () (Just valuesObject))
68− ]
69−
70−
71−buildIntermediateObjects :: [String] -> [Statement ()]
72−buildIntermediateObjects path =
73− let
74− create name =
75− assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
76−
77− paths =
78− drop 2 (init (List.inits path))
79− in
80− map create paths
81−
82
28
83−assign :: [String] -> Expression () -> Statement ()
29+ body =
84−assign path expr =
30+ State.evalState genBody 0
85− case path of
86− [x] ->
87− VarDeclStmt () [ varDecl x expr ]
88−
89− _ ->
90− ExprStmt () $
91− AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
92−
93−
94−
95−-- IMPORTS
96−
97−
98−imports :: [ModuleName.Raw] -> [Statement ()]
99−imports rawImports =
100− let
101− utils =
102− varDecl "_U" (call (obj ["Elm", "Native", "Utils", "make"]) [ref localRuntime])
103− in
104− [ VarDeclStmt () (utils : map jsImport rawImports) ]
105−
106−
107−jsImport :: ModuleName.Raw -> VarDecl ()
108−jsImport name =
109− let
110− make =
111− obj ("Elm" : name ++ ["make"])
112 in
31 in
113− varDecl (Var.modulePrefix name) (call make [ref localRuntime])
32+ Builder.stmtsToText body
114
33
115
34
116
35
117−-- DEFINITIONS
36+-- GENERATE EFFECT MANAGER
118
37
119
38
120−definitions :: [Optimized.Def] -> [Statement ()]
39+generateEffectManager :: ModuleName.Canonical -> Effects.Canonical -> [JS.Statement ()]
121−definitions defs =
40+generateEffectManager moduleName effects =
122− let
41+ case effects of
123− setup =
42+ Effects.None ->
124− Var.define "_op" (ObjectLit () [])
43+ []
125− in
126− setup : State.evalState (mapM JS.generateDef defs) 0
127
44
45+ Effects.Port _ ->
46+ []
128
47
48+ Effects.Manager pkgName (Effects.Info _ _ _ _ managerType) ->
49+ let
50+ managers =
51+ Var.native (ModuleName.inCore ["Native","Platform"]) "effectManagers"
129
52
130−-- EXPORTS
53+ managerName =
54+ JS.StringLit () (ModuleName.canonicalToString moduleName)
131
55
56+ entry name =
57+ ( JS.PropId () (JS.Id () name)
58+ , JS.ref (Var.qualified moduleName name)
59+ )
132
60
133−exports :: ModuleName.Raw -> [Variable.Value] -> [Statement ()]
61+ managerEntries =
134−exports name exportedValues =
62+ [ "pkg" ==> Pkg.toString pkgName
135− let
63+ , entry "init"
136− exportedFields =
64+ , entry "onEffects"
137− map toField ("_op" : concatMap extract exportedValues)
65+ , entry "onSelfMsg"
66+ ]
138
67
139− toField x =
68+ otherEntries =
140− (prop x, ref x)
69+ case managerType of
70+ Effects.CmdManager _ ->
71+ [ "tag" ==> "cmd", entry "cmdMap" ]
141
72
142− extract value =
73+ Effects.SubManager _ ->
143− case value of
74+ [ "tag" ==> "sub", entry "subMap" ]
144− Variable.Alias _ ->
145− []
146
75
147− Variable.Value x ->
76+ Effects.FxManager _ _ ->
148− if Help.isOp x then
77+ [ "tag" ==> "fx", entry "cmdMap", entry "subMap" ]
149− []
150
78
151− else
79+ addManager =
152− [Var.safe x]
80+ JS.AssignExpr () JS.OpAssign
81+ (JS.LBracket () managers managerName)
82+ (JS.ObjectLit () (managerEntries ++ otherEntries))
83+ in
84+ [ JS.ExprStmt () addManager ]
153
85
154− Variable.Union _ (Variable.Listing ctors _) ->
155− map Var.safe ctors
156
86
157− values =
87+(==>) :: String -> String -> ( JS.Prop (), JS.Expression () )
158− LDot () (obj (localRuntime : name)) "values"
88+(==>) key value =
159− in
89+ ( JS.PropId () (JS.Id () key)
160− [ ReturnStmt () $ Just $
90+ , JS.StringLit () value
161− AssignExpr () OpAssign values (ObjectLit () exportedFields)
91+ )
162− ]
src/Generate/JavaScript/Builder.hsnew file+528
@@ -0,0 +1,528 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Generate.JavaScript.Builder (stmtsToText) where
4+
5+import qualified Data.List as List
6+import Data.Monoid ((<>))
7+import qualified Data.Text.Lazy as LazyText
8+import Data.Text.Lazy.Builder
9+import Data.Text.Lazy.Builder.Int (decimal)
10+import Data.Text.Lazy.Builder.RealFloat (realFloat)
11+import Language.ECMAScript3.Syntax
12+import Prelude hiding (lines)
13+
14+
15+
16+-- CONVERT TO LAZY TEXT
17+
18+
19+stmtsToText :: [Statement a] -> LazyText.Text
20+stmtsToText stmts =
21+ toLazyText (fromStmtBlock "" stmts)
22+
23+
24+
25+-- HELPERS
26+
27+
28+deeper :: Builder -> Builder
29+deeper indent =
30+ "\t" <> indent
31+
32+
33+commaSep :: [Builder] -> Builder
34+commaSep builders =
35+ mconcat (List.intersperse ", " builders)
36+
37+
38+commaNewlineSep :: Builder -> [Builder] -> Builder
39+commaNewlineSep indent builders =
40+ mconcat (List.intersperse (",\n" <> deeper indent) builders)
41+
42+
43+
44+-- STATEMENTS
45+
46+
47+fromStmtBlock :: Builder -> [Statement a] -> Builder
48+fromStmtBlock indent stmts =
49+ mconcat (map (fromStmt indent) stmts)
50+
51+
52+fromStmt :: Builder -> Statement a -> Builder
53+fromStmt indent statement =
54+ case statement of
55+ BlockStmt _ stmts ->
56+ fromStmtBlock indent stmts
57+
58+ EmptyStmt _ ->
59+ mempty
60+
61+ ExprStmt _ expr ->
62+ indent <> snd (fromExpr indent Whatever expr) <> ";\n"
63+
64+ IfStmt _ condition thenStmt elseStmt ->
65+ mconcat
66+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
67+ , fromStmt (deeper indent) thenStmt
68+ , indent, "} else {\n"
69+ , fromStmt (deeper indent) elseStmt
70+ , indent, "}\n"
71+ ]
72+
73+ IfSingleStmt _ condition thenStmt ->
74+ mconcat
75+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
76+ , fromStmt (deeper indent) thenStmt
77+ , indent, "}\n"
78+ ]
79+
80+ SwitchStmt _ expr clauses ->
81+ mconcat
82+ [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
83+ , mconcat (map (fromClause (deeper indent)) clauses)
84+ , indent, "}\n"
85+ ]
86+
87+ WhileStmt _ expr stmt ->
88+ mconcat
89+ [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
90+ , fromStmt (deeper indent) stmt
91+ , indent, "}\n"
92+ ]
93+
94+ DoWhileStmt _ stmt expr ->
95+ mconcat
96+ [ indent, "do {\n"
97+ , fromStmt (deeper indent) stmt
98+ , indent, "} while(", snd (fromExpr indent Whatever expr), ");\n"
99+ ]
100+
101+ BreakStmt _ Nothing ->
102+ indent <> "break;\n"
103+
104+ BreakStmt _ (Just label) ->
105+ indent <> "break " <> fromId label <> ";\n"
106+
107+ ContinueStmt _ Nothing ->
108+ indent <> "continue;\n"
109+
110+ ContinueStmt _ (Just label) ->
111+ indent <> "continue " <> fromId label <> ";\n"
112+
113+ LabelledStmt _ label stmt ->
114+ mconcat
115+ [ indent, fromId label, ":\n"
116+ , fromStmt indent stmt
117+ ]
118+
119+ ForInStmt _ _ _ _ ->
120+ error "TODO"
121+
122+ ForStmt _ _ _ _ _ ->
123+ error "TODO"
124+
125+ TryStmt _ _ _ _ ->
126+ error "TODO"
127+
128+ ThrowStmt _ expr ->
129+ indent <> "throw " <> snd (fromExpr indent Whatever expr) <> ";\n"
130+
131+ ReturnStmt _ Nothing ->
132+ indent <> "return;\n"
133+
134+ ReturnStmt _ (Just expr) ->
135+ indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
136+
137+ WithStmt _ _ _ ->
138+ error "TODO"
139+
140+ VarDeclStmt _ [] ->
141+ mempty
142+
143+ VarDeclStmt _ decls ->
144+ indent <> "var " <> commaNewlineSep indent (map (fromVarDecl indent) decls) <> ";\n"
145+
146+ FunctionStmt _ name args stmts ->
147+ indent <> "function " <> fromId name <> "(" <> commaSep (map fromId args) <> ") {\n"
148+ <>
149+ fromStmtBlock (deeper indent) stmts
150+ <>
151+ indent <> "}\n"
152+
153+
154+
155+-- SWITCH CLAUSES
156+
157+
158+fromClause :: Builder -> CaseClause a -> Builder
159+fromClause indent clause =
160+ case clause of
161+ CaseClause _ expr stmts ->
162+ indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
163+ <> fromStmtBlock (deeper indent) stmts
164+
165+ CaseDefault _ stmts ->
166+ indent <> "default:\n"
167+ <> fromStmtBlock (deeper indent) stmts
168+
169+
170+
171+-- ID
172+
173+
174+fromId :: Id a -> Builder
175+fromId (Id _ name) =
176+ fromString name
177+
178+
179+
180+-- VAR DECLS
181+
182+
183+fromVarDecl :: Builder -> VarDecl a -> Builder
184+fromVarDecl indent (VarDecl _ (Id _ name) maybeExpr) =
185+ case maybeExpr of
186+ Nothing ->
187+ fromString name
188+
189+ Just expr ->
190+ fromString name <> " = " <> snd (fromExpr indent Whatever expr)
191+
192+
193+
194+-- EXPRESSIONS
195+
196+
197+data Lines = One | Many deriving (Eq)
198+
199+
200+merge :: Lines -> Lines -> Lines
201+merge a b =
202+ if a == Many || b == Many then Many else One
203+
204+
205+linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
206+linesMap func xs =
207+ let
208+ pairs =
209+ map func xs
210+ in
211+ ( any ((==) Many . fst) pairs
212+ , map snd pairs
213+ )
214+
215+
216+data Grouping = Atomic | Whatever
217+
218+
219+parensFor :: Grouping -> Builder -> Builder
220+parensFor grouping builder =
221+ case grouping of
222+ Atomic ->
223+ "(" <> builder <> ")"
224+
225+ Whatever ->
226+ builder
227+
228+
229+fromExpr :: Builder -> Grouping -> Expression a -> (Lines, Builder)
230+fromExpr indent grouping expression =
231+ case expression of
232+ StringLit _ string ->
233+ (One, quoted string)
234+
235+ RegexpLit _ _ _ _ ->
236+ error "TODO"
237+
238+ NumLit _ n ->
239+ (One, realFloat n)
240+
241+ IntLit _ n ->
242+ (One, decimal n)
243+
244+ BoolLit _ True ->
245+ (One, "true")
246+
247+ BoolLit _ False ->
248+ (One, "false")
249+
250+ NullLit _ ->
251+ (One, "null")
252+
253+ ArrayLit _ exprs ->
254+ (,) Many $
255+ let
256+ (anyMany, builders) =
257+ linesMap (fromExpr indent Whatever) exprs
258+ in
259+ if anyMany then
260+ "[\n"
261+ <> deeper indent
262+ <> commaNewlineSep indent builders
263+ <> "\n" <> indent <> "]"
264+
265+ else
266+ "[" <> commaSep builders <> "]"
267+
268+ ObjectLit _ fields ->
269+ (,) Many $
270+ let
271+ deeperIndent =
272+ deeper indent
273+
274+ (anyMany, builders) =
275+ linesMap (fromField deeperIndent) fields
276+ in
277+ if anyMany then
278+ "{\n"
279+ <> deeperIndent
280+ <> commaNewlineSep indent builders
281+ <> "\n" <> indent <> "}"
282+
283+ else
284+ "{" <> commaSep builders <> "}"
285+
286+ ThisRef _ ->
287+ (One, "this")
288+
289+ VarRef _ name ->
290+ (One, fromId name)
291+
292+ DotRef _ expr (Id _ name) ->
293+ makeDot indent expr name
294+
295+ BracketRef _ expr bracketedExpr ->
296+ makeBracketed indent expr bracketedExpr
297+
298+ NewExpr _ _ _ ->
299+ error "TODO"
300+
301+ PrefixExpr _ op expr ->
302+ let
303+ (lines, builder) =
304+ fromExpr indent Atomic expr
305+ in
306+ ( lines
307+ , parensFor grouping (fromPrefix op <> builder)
308+ )
309+
310+ UnaryAssignExpr _ _ _ ->
311+ error "TODO"
312+
313+ InfixExpr _ op leftExpr rightExpr ->
314+ let
315+ (leftLines, left) =
316+ fromExpr indent Atomic leftExpr
317+
318+ (rightLines, right) =
319+ fromExpr indent Atomic rightExpr
320+ in
321+ ( merge leftLines rightLines
322+ , parensFor grouping (left <> fromInfix op <> right)
323+ )
324+
325+ CondExpr _ condExpr thenExpr elseExpr ->
326+ let
327+ condB = snd (fromExpr indent Atomic condExpr)
328+ thenB = snd (fromExpr indent Atomic thenExpr)
329+ elseB = snd (fromExpr indent Atomic elseExpr)
330+ in
331+ ( Many
332+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
333+ )
334+
335+ AssignExpr _ op lValue expr ->
336+ let
337+ (leftLines, left) =
338+ fromLValue indent lValue
339+
340+ (rightLines, right) =
341+ fromExpr indent Whatever expr
342+ in
343+ ( merge leftLines rightLines
344+ , parensFor grouping (left <> fromAssign op <> right)
345+ )
346+
347+ ListExpr _ _ ->
348+ error "TODO"
349+
350+ CallExpr _ function args ->
351+ (,) Many $
352+ let
353+ deeperIndent =
354+ deeper indent
355+
356+ funcB =
357+ snd (fromExpr indent Atomic function)
358+
359+ (anyMany, argsB) =
360+ linesMap (fromExpr deeperIndent Whatever) args
361+ in
362+ if anyMany then
363+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
364+
365+ else
366+ funcB <> "(" <> commaSep argsB <> ")"
367+
368+ FuncExpr _ maybeName args stmts ->
369+ (,) Many $
370+ "function " <> maybe mempty fromId maybeName <> "(" <> commaSep (map fromId args) <> ") {\n"
371+ <>
372+ fromStmtBlock (deeper indent) stmts
373+ <>
374+ indent <> "}"
375+
376+
377+
378+-- FIELDS
379+
380+
381+fromField :: Builder -> (Prop a, Expression a) -> (Lines, Builder)
382+fromField indent (prop, expr) =
383+ let
384+ (lines, builder) =
385+ fromExpr indent Whatever expr
386+ in
387+ ( lines
388+ , fromProp prop <> ": " <> builder
389+ )
390+
391+
392+fromProp :: Prop a -> Builder
393+fromProp prop =
394+ case prop of
395+ PropId _ name ->
396+ fromId name
397+
398+ PropString _ string ->
399+ quoted string
400+
401+ PropNum _ n ->
402+ decimal n
403+
404+
405+
406+-- STRINGS
407+
408+
409+quoted :: String -> Builder
410+quoted string =
411+ fromString ('\'' : foldr escapeCons "'" string)
412+
413+
414+-- https://developer.mozilla.org/en-US/docs/Web/JavaScript/Guide/Grammar_and_types#String_literals
415+escapeCons :: Char -> String -> String
416+escapeCons char rest =
417+ case char of
418+ '\b' -> '\\' : 'b' : rest
419+ '\f' -> '\\' : 'f' : rest
420+ '\n' -> '\\' : 'n' : rest
421+ '\r' -> '\\' : 'r' : rest
422+ '\t' -> '\\' : 't' : rest
423+ '\v' -> '\\' : 'v' : rest
424+ '\"' -> '\\' : '"' : rest
425+ '\'' -> '\\' : '\'' : rest
426+ '\\' -> '\\' : '\\' : rest
427+ _ -> char : rest
428+
429+
430+
431+-- VALUES
432+
433+
434+fromLValue :: Builder -> LValue a -> (Lines, Builder)
435+fromLValue indent lValue =
436+ case lValue of
437+ LVar _ name ->
438+ (One, fromString name)
439+
440+ LDot _ expr field ->
441+ makeDot indent expr field
442+
443+ LBracket _ expr bracketedExpr ->
444+ makeBracketed indent expr bracketedExpr
445+
446+
447+makeDot :: Builder -> Expression a -> String -> (Lines, Builder)
448+makeDot indent expr field =
449+ let
450+ (lines, builder) =
451+ fromExpr indent Atomic expr
452+ in
453+ (lines, builder <> "." <> fromString field)
454+
455+
456+makeBracketed :: Builder -> Expression a -> Expression a -> (Lines, Builder)
457+makeBracketed indent expr bracketedExpr =
458+ let
459+ (lines, builder) =
460+ fromExpr indent Atomic expr
461+
462+ (bracketedLines, bracketedBuilder) =
463+ fromExpr indent Whatever bracketedExpr
464+ in
465+ ( merge lines bracketedLines
466+ , builder <> "[" <> bracketedBuilder <> "]"
467+ )
468+
469+
470+
471+-- OPERATORS
472+
473+
474+fromPrefix :: PrefixOp -> Builder
475+fromPrefix op =
476+ case op of
477+ PrefixLNot -> "!"
478+ PrefixBNot -> "~"
479+ PrefixPlus -> "+"
480+ PrefixMinus -> "-"
481+ PrefixTypeof -> "typeof "
482+ PrefixVoid -> "void "
483+ PrefixDelete -> "delete "
484+
485+
486+fromAssign :: AssignOp -> Builder
487+fromAssign op =
488+ case op of
489+ OpAssign -> " = "
490+ OpAssignAdd -> " += "
491+ OpAssignSub -> " -= "
492+ OpAssignMul -> " *= "
493+ OpAssignDiv -> " /= "
494+ OpAssignMod -> " %= "
495+ OpAssignLShift -> " <<= "
496+ OpAssignSpRShift -> " >>= "
497+ OpAssignZfRShift -> " >>>= "
498+ OpAssignBAnd -> " &= "
499+ OpAssignBXor -> " ^= "
500+ OpAssignBOr -> " |= "
501+
502+
503+fromInfix :: InfixOp -> Builder
504+fromInfix op =
505+ case op of
506+ OpLT -> " < "
507+ OpLEq -> " <= "
508+ OpGT -> " > "
509+ OpGEq -> " >= "
510+ OpIn -> " in "
511+ OpInstanceof -> " instanceof "
512+ OpEq -> " == "
513+ OpNEq -> " != "
514+ OpStrictEq -> " === "
515+ OpStrictNEq -> " !=== "
516+ OpLAnd -> " && "
517+ OpLOr -> " || "
518+ OpMul -> " * "
519+ OpDiv -> " / "
520+ OpMod -> " % "
521+ OpSub -> " - "
522+ OpLShift -> " << "
523+ OpSpRShift -> " >> "
524+ OpZfRShift -> " >>> "
525+ OpBAnd -> " & "
526+ OpBXor -> " ^ "
527+ OpBOr -> " | "
528+ OpAdd -> " + "
src/Generate/JavaScript/BuiltIn.hs+45−12
@@ -1,17 +1,30 @@
1−module Generate.JavaScript.BuiltIn where
1+module Generate.JavaScript.BuiltIn
2+ ( character, string
3+ , list, range
4+ , recordUpdate
5+ , eq, cmp
6+ , effect, outgoingPort, incomingPort
7+ , crash
8+ )
9+ where
2
10
3−import Control.Arrow (first)
4import qualified Language.ECMAScript3.Syntax as JS
11import qualified Language.ECMAScript3.Syntax as JS
5
12
6import qualified AST.Module.Name as ModuleName
13import qualified AST.Module.Name as ModuleName
7−import Generate.JavaScript.Helpers
14+import Generate.JavaScript.Helpers ((<|), (==>), call)
15+import qualified Generate.JavaScript.Variable as Var
8import qualified Reporting.Region as R
16import qualified Reporting.Region as R
9
17
10
18
11
19
12utils :: String -> [JS.Expression ()] -> JS.Expression ()
20utils :: String -> [JS.Expression ()] -> JS.Expression ()
13utils func args =
21utils func args =
14− obj ["_U", func] `call` args
22+ Var.coreNative "Utils" func `call` args
23+
24+
25+nativeList :: String -> [JS.Expression ()] -> JS.Expression ()
26+nativeList func args =
27+ Var.coreNative "List" func `call` args
15
28
16
29
17
30
@@ -34,12 +47,12 @@ string str =
34
47
35list :: [JS.Expression ()] -> JS.Expression ()
48list :: [JS.Expression ()] -> JS.Expression ()
36list elements =
49list elements =
37− utils "list" [ JS.ArrayLit () elements ]
50+ nativeList "fromArray" [ JS.ArrayLit () elements ]
38
51
39
52
40range :: JS.Expression () -> JS.Expression () -> JS.Expression ()
53range :: JS.Expression () -> JS.Expression () -> JS.Expression ()
41range low high =
54range low high =
42− utils "range" [ low, high ]
55+ nativeList "range" [ low, high ]
43
56
44
57
45
58
@@ -50,7 +63,7 @@ recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expressio
50recordUpdate record fields =
63recordUpdate record fields =
51 utils "update"
64 utils "update"
52 [ record
65 [ record
53− , JS.ObjectLit () (map (first prop) fields)
66+ , JS.ObjectLit () (map (uncurry (==>)) fields)
54 ]
67 ]
55
68
56
69
@@ -69,6 +82,26 @@ cmp left right =
69
82
70
83
71
84
85+-- EFFECTS
86+
87+
88+effect :: ModuleName.Canonical -> JS.Expression ()
89+effect effectName =
90+ Var.coreNative "Platform" "leaf" <|
91+ JS.StringLit () (ModuleName.canonicalToString effectName)
92+
93+
94+outgoingPort :: String -> JS.Expression () -> JS.Expression ()
95+outgoingPort name converter =
96+ Var.coreNative "Platform" "outgoingPort" `call` [ JS.StringLit () name, converter ]
97+
98+
99+incomingPort :: String -> JS.Expression () -> JS.Expression ()
100+incomingPort name converter =
101+ Var.coreNative "Platform" "incomingPort" `call` [ JS.StringLit () name, converter ]
102+
103+
104+
72-- CRASH
105-- CRASH
73
106
74
107
@@ -89,14 +122,14 @@ crash home region maybeCaseCrashValue =
89regionToJs :: R.Region -> JS.Expression ()
122regionToJs :: R.Region -> JS.Expression ()
90regionToJs (R.Region start end) =
123regionToJs (R.Region start end) =
91 JS.ObjectLit ()
124 JS.ObjectLit ()
92− [ ( prop "start", positionToJs start )
125+ [ "start" ==> positionToJs start
93− , ( prop "end", positionToJs end )
126+ , "end" ==> positionToJs end
94 ]
127 ]
95
128
96
129
97positionToJs :: R.Position -> JS.Expression ()
130positionToJs :: R.Position -> JS.Expression ()
98positionToJs (R.Position line column) =
131positionToJs (R.Position line column) =
99 JS.ObjectLit ()
132 JS.ObjectLit ()
100− [ ( prop "line", JS.IntLit () line )
133+ [ "line" ==> JS.IntLit () line
101− , ( prop "column", JS.IntLit () column )
134+ , "column" ==> JS.IntLit () column
102− ]
135+ ]
src/Generate/JavaScript/Expression.hs+73−23
@@ -6,21 +6,24 @@ import qualified Data.List as List
6import qualified Data.Map as Map
6import qualified Data.Map as Map
7import Language.ECMAScript3.Syntax
7import Language.ECMAScript3.Syntax
8
8
9−import qualified AST.Expression.General as Expr
9+import AST.Expression.General as Expr (Main(..))
10import AST.Expression.Optimized as Opt
10import AST.Expression.Optimized as Opt
11import qualified AST.Literal as L
11import qualified AST.Literal as L
12import qualified AST.Module.Name as ModuleName
12import qualified AST.Module.Name as ModuleName
13+import qualified AST.Type as Type
13import qualified AST.Variable as Var
14import qualified AST.Variable as Var
14import Generate.JavaScript.Helpers as Help
15import Generate.JavaScript.Helpers as Help
15import qualified Generate.JavaScript.BuiltIn as BuiltIn
16import qualified Generate.JavaScript.BuiltIn as BuiltIn
17+import qualified Generate.JavaScript.Foreign as Foreign
16import qualified Generate.JavaScript.Literal as Literal
18import qualified Generate.JavaScript.Literal as Literal
17−import qualified Generate.JavaScript.Port as Port
18import qualified Generate.JavaScript.Variable as Var
19import qualified Generate.JavaScript.Variable as Var
19import qualified Optimize.DecisionTree as DT
20import qualified Optimize.DecisionTree as DT
20
21
21
22
23+
22-- CODE CHUNKS
24-- CODE CHUNKS
23
25
26+
24data Code
27data Code
25 = JsExpr (Expression ())
28 = JsExpr (Expression ())
26 | JsBlock [Statement ()]
29 | JsBlock [Statement ()]
@@ -76,9 +79,11 @@ toExpr code =
76 function [] stmts `call` []
79 function [] stmts `call` []
77
80
78
81
82+
79-- DEFINITIONS
83-- DEFINITIONS
80
84
85+
81−generateDef :: Opt.Def -> State Int (Statement ())
86+generateDef :: Opt.Def -> State Int [Statement ()]
82generateDef def =
87generateDef def =
83 do (home, name, jsBody) <-
88 do (home, name, jsBody) <-
84 case def of
89 case def of
@@ -88,11 +93,13 @@ generateDef def =
88 Opt.Def (Opt.Facts home _) name body ->
93 Opt.Def (Opt.Facts home _) name body ->
89 (,,) home name <$> generateJsExpr body
94 (,,) home name <$> generateJsExpr body
90
95
91− return (Var.define name jsBody)
96+ return (Var.define home name jsBody)
97+
92
98
93
99
94-- EXPRESSIONS
100-- EXPRESSIONS
95
101
102+
96generateJsExpr :: Opt.Expr -> State Int (Expression ())
103generateJsExpr :: Opt.Expr -> State Int (Expression ())
97generateJsExpr optExpr =
104generateJsExpr optExpr =
98 toExpr <$> generateCode optExpr
105 toExpr <$> generateCode optExpr
@@ -130,7 +137,7 @@ generateCode expr =
130 let
137 let
131 toField (field, value) =
138 toField (field, value) =
132 do jsValue <- generateJsExpr value
139 do jsValue <- generateJsExpr value
133− return (prop (Var.safe field), jsValue)
140+ return (Var.safe field ==> jsValue)
134 in
141 in
135 do jsFields <- mapM toField fields
142 do jsFields <- mapM toField fields
136 jsExpr $ ObjectLit () jsFields
143 jsExpr $ ObjectLit () jsFields
@@ -169,7 +176,7 @@ generateCode expr =
169 Let defs body ->
176 Let defs body ->
170 do stmts <- mapM generateDef defs
177 do stmts <- mapM generateDef defs
171 code <- generateCode body
178 code <- generateCode body
172− jsBlock (stmts ++ toStatementList code)
179+ jsBlock (concat stmts ++ toStatementList code)
173
180
174 If branches finally ->
181 If branches finally ->
175 generateIf branches finally
182 generateIf branches finally
@@ -182,40 +189,69 @@ generateCode expr =
182 jsExpr $ BuiltIn.list jsElements
189 jsExpr $ BuiltIn.list jsElements
183
190
184 Data tag members ->
191 Data tag members ->
192+ let
193+ ctor =
194+ "ctor" ==> StringLit () tag
195+
196+ toEntry entry n =
197+ ("_" ++ show n) ==> entry
198+ in
185 do jsMembers <- mapM generateJsExpr members
199 do jsMembers <- mapM generateJsExpr members
186− jsExpr $ ObjectLit () (ctor : fields jsMembers)
200+ jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
187− where
188− ctor = (prop "ctor", StringLit () tag)
189− fields =
190− zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
191
201
192 DataAccess dataExpr index ->
202 DataAccess dataExpr index ->
193 do jsDataExpr <- generateJsExpr dataExpr
203 do jsDataExpr <- generateJsExpr dataExpr
194 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
204 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
195
205
196− GLShader _uid src _tipe ->
206+ Cmd moduleName ->
197− jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
207+ jsExpr $ BuiltIn.effect moduleName
208+
209+ Sub moduleName ->
210+ jsExpr $ BuiltIn.effect moduleName
211+
212+ OutgoingPort name tipe ->
213+ jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)
198
214
199− Port impl ->
215+ IncomingPort name tipe ->
200− case impl of
216+ do jsDecoder <- generateJsExpr (Foreign.decode tipe)
201− Expr.In name portType ->
217+ jsExpr $ BuiltIn.incomingPort name jsDecoder
202− jsExpr (Port.inbound name portType)
203
218
204− Expr.Out name expr portType ->
219+ Program kind body ->
205− do expr' <- generateJsExpr expr
220+ generateProgram kind body
206− jsExpr (Port.outbound name expr' portType)
207
221
208− Expr.Task name expr portType ->
222+ GLShader _uid src _tipe ->
209− do expr' <- generateJsExpr expr
223+ jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
210− jsExpr (Port.task name expr' portType)
211
224
212 Crash home region maybeBranchProblem ->
225 Crash home region maybeBranchProblem ->
213 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
226 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
214 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
227 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
215
228
216
229
230+
231+-- PROGRAMS
232+
233+
234+generateProgram :: Expr.Main Type.Canonical -> Opt.Expr -> State Int Code
235+generateProgram kind body =
236+ let
237+ gen fields =
238+ generateCode $ Record (("main", body) : fields)
239+ in
240+ case kind of
241+ Expr.VDom ->
242+ gen []
243+
244+ Expr.NoFlags ->
245+ gen []
246+
247+ Expr.Flags tipe ->
248+ gen [ ("flags", Foreign.decode tipe) ]
249+
250+
251+
217-- FUNCTIONS
252-- FUNCTIONS
218
253
254+
219generateFunction :: [String] -> Opt.Expr -> State Int Code
255generateFunction :: [String] -> Opt.Expr -> State Int Code
220generateFunction args body =
256generateFunction args body =
221 do code <- generateCode body
257 do code <- generateCode body
@@ -250,8 +286,10 @@ generateFunctionWithArity rawArgs code =
250 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
286 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
251
287
252
288
289+
253-- GENERATE IFS
290-- GENERATE IFS
254
291
292+
255generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
293generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
256generateIf givenBranches givenFinally =
294generateIf givenBranches givenFinally =
257 let
295 let
@@ -307,8 +345,10 @@ crushIfsHelp visitedBranches unvisitedBranches finally =
307 crushIfsHelp (visiting : visitedBranches) unvisited finally
345 crushIfsHelp (visiting : visitedBranches) unvisited finally
308
346
309
347
348+
310-- CASE EXPRESSIONS
349-- CASE EXPRESSIONS
311
350
351+
312generateCase
352generateCase
313 :: String
353 :: String
314 -> Opt.Decider Opt.Choice
354 -> Opt.Decider Opt.Choice
@@ -320,8 +360,10 @@ generateCase exprName decider jumps =
320 foldM (goto labelRoot) decider jumps
360 foldM (goto labelRoot) decider jumps
321
361
322
362
363+
323-- handle any jumps
364-- handle any jumps
324
365
366+
325goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
367goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
326goto labelRoot deciderStmts (target, branch) =
368goto labelRoot deciderStmts (target, branch) =
327 let
369 let
@@ -339,8 +381,10 @@ toLabel root target =
339 Id () (root ++ "_" ++ show target)
381 Id () (root ++ "_" ++ show target)
340
382
341
383
384+
342-- turn deciders into ifs and switches
385-- turn deciders into ifs and switches
343
386
387+
344generateDecider
388generateDecider
345 :: String
389 :: String
346 -> String
390 -> String
@@ -395,8 +439,10 @@ testToExpr test =
395 Literal.literal lit
439 Literal.literal lit
396
440
397
441
442+
398-- work with paths
443-- work with paths
399
444
445+
400pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
446pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
401pathToTestableExpr root path exampleTest =
447pathToTestableExpr root path exampleTest =
402 do accessExpr <- generateJsExpr (pathToExpr root path)
448 do accessExpr <- generateJsExpr (pathToExpr root path)
@@ -430,8 +476,10 @@ pathToExpr root fullPath =
430 expr
476 expr
431
477
432
478
479+
433-- BINARY OPERATORS
480-- BINARY OPERATORS
434
481
482+
435binop
483binop
436 :: Var.Canonical
484 :: Var.Canonical
437 -> Opt.Expr
485 -> Opt.Expr
@@ -443,8 +491,10 @@ binop func left right =
443 jsExpr (makeExpr func jsLeft jsRight)
491 jsExpr (makeExpr func jsLeft jsRight)
444
492
445
493
494+
446-- BINARY OPERATOR HELPERS
495-- BINARY OPERATOR HELPERS
447
496
497+
448makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
498makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
449makeExpr qualifiedOp@(Var.Canonical home op) =
499makeExpr qualifiedOp@(Var.Canonical home op) =
450 let
500 let
src/Generate/JavaScript/Foreign.hsnew file+219
@@ -0,0 +1,219 @@
1+module Generate.JavaScript.Foreign (encode, decode) where
2+
3+import qualified Data.List as List
4+import Language.ECMAScript3.Syntax
5+
6+import qualified AST.Expression.Optimized as Opt
7+import qualified AST.Literal as Literal
8+import qualified AST.Type as T
9+import qualified AST.Variable as Var
10+import Generate.JavaScript.Helpers ((<|), (==>), function, ref, var)
11+import qualified Generate.JavaScript.Variable as Var
12+
13+
14+
15+-- ENCODE
16+
17+
18+encode :: T.Canonical -> Expression ()
19+encode tipe =
20+ function ["v"] [ ReturnStmt () (Just (encodeHelp tipe (ref "v"))) ]
21+
22+
23+encodeHelp :: T.Canonical -> Expression () -> Expression ()
24+encodeHelp tipe expr =
25+ case tipe of
26+ T.Aliased _ args t ->
27+ encodeHelp (T.dealias args t) expr
28+
29+ T.Lambda _ _ ->
30+ error "encodeHelp: function"
31+
32+ T.Var _ ->
33+ error "encodeHelp: type variable"
34+
35+ T.Type name
36+ | Var.isPrim "Float" name -> expr
37+ | Var.isPrim "Int" name -> expr
38+ | Var.isPrim "Bool" name -> expr
39+ | Var.isPrim "String" name -> expr
40+ | Var.isJson name -> expr
41+ | Var.isTuple name -> NullLit ()
42+ | otherwise -> error "encodeHelp: bad type"
43+
44+ T.App (T.Type name) [arg]
45+ | Var.isMaybe name -> fromMaybe arg expr
46+ | Var.isList name -> fromList arg expr
47+ | Var.isArray name -> fromArray arg expr
48+ | otherwise -> error "encodeHelp: bad union type"
49+
50+ T.App (T.Type name) args
51+ | Var.isTuple name -> fromTuple args expr
52+
53+ T.App _ _ ->
54+ error "encodeHelp: bad union type"
55+
56+ T.Record _ (Just _) ->
57+ error "encodeHelp: bad record"
58+
59+ T.Record fields Nothing ->
60+ let
61+ convert (name, tipe) =
62+ name ==> encodeHelp tipe (DotRef () expr (var name))
63+ in
64+ ObjectLit () (map convert fields)
65+
66+
67+fromMaybe :: T.Canonical -> Expression () -> Expression ()
68+fromMaybe tipe expr =
69+ CondExpr ()
70+ (InfixExpr () OpStrictEq (DotRef () expr (var "ctor")) (StringLit () "Nothing"))
71+ (NullLit ())
72+ (encodeHelp tipe (DotRef () expr (var "_0")))
73+
74+
75+fromList :: T.Canonical -> Expression () -> Expression ()
76+fromList tipe expr =
77+ let
78+ array =
79+ Var.coreNative "List" "toArray" <| expr
80+ in
81+ DotRef () array (var "map") <| encode tipe
82+
83+
84+fromArray :: T.Canonical -> Expression () -> Expression ()
85+fromArray tipe expr =
86+ let
87+ array =
88+ Var.coreNative "Array" "toJSArray" <| expr
89+ in
90+ DotRef () array (var "map") <| encode tipe
91+
92+
93+fromTuple :: [T.Canonical] -> Expression () -> Expression ()
94+fromTuple types expr =
95+ let
96+ convert subType n =
97+ encodeHelp subType $ DotRef () expr (var ('_':show n))
98+ in
99+ ArrayLit () (zipWith convert types [0..])
100+
101+
102+
103+-- SUBSCRIPTIONS
104+
105+
106+decode :: T.Canonical -> Opt.Expr
107+decode tipe =
108+ case tipe of
109+ T.Lambda _ _ ->
110+ error "functions should not be allowed through input ports"
111+
112+ T.Var _ ->
113+ error "type variables should not be allowed through input ports"
114+
115+ T.Aliased _ args t ->
116+ decode (T.dealias args t)
117+
118+ T.Type name
119+ | Var.isPrim "Float" name -> to "float"
120+ | Var.isPrim "Int" name -> to "int"
121+ | Var.isPrim "Bool" name -> to "bool"
122+ | Var.isPrim "String" name -> to "string"
123+ | Var.isJson name -> to "value"
124+ | Var.isTuple name -> toTuple0
125+ | otherwise -> error "decode: bad type"
126+
127+ T.App (T.Type name) [arg]
128+ | Var.isMaybe name -> toMaybe arg
129+ | Var.isList name -> to "list" <== [decode arg]
130+ | Var.isArray name -> to "array" <== [decode arg]
131+ | otherwise -> error "decode: bad union type"
132+
133+ T.App (T.Type name) args
134+ | Var.isTuple name -> toTuple args
135+
136+ T.App _ _ ->
137+ error "decode: bad union type"
138+
139+ T.Record _ (Just _) ->
140+ error "decode: bad record"
141+
142+ T.Record fields Nothing ->
143+ toRecord fields
144+
145+
146+-- DECODE HELPERS
147+
148+
149+inJsonDecode :: String -> Var.Canonical
150+inJsonDecode name =
151+ Var.inCore ["Json","Decode"] name
152+
153+
154+to :: String -> Opt.Expr
155+to name =
156+ Opt.Var (inJsonDecode name)
157+
158+
159+(=:) :: String -> Opt.Expr -> Opt.Expr
160+(=:) name decoder =
161+ Opt.Binop (inJsonDecode ":=") (Opt.Literal (Literal.Str name)) decoder
162+
163+
164+(<==) :: Opt.Expr -> [Opt.Expr] -> Opt.Expr
165+(<==) func args =
166+ Opt.Call func args
167+
168+
169+
170+-- COMPLEX DECODE HELPERS
171+
172+
173+toMaybe :: T.Canonical -> Opt.Expr
174+toMaybe tipe =
175+ let
176+ maybe tag =
177+ Opt.Var (Var.inCore ["Maybe"] tag)
178+ in
179+ to "oneOf" <==
180+ [ Opt.ExplicitList
181+ [ to "null" <== [ maybe "Nothing" ]
182+ , to "map" <== [ maybe "Just", decode tipe ]
183+ ]
184+ ]
185+
186+
187+toTuple0 :: Opt.Expr
188+toTuple0 =
189+ to "null" <== [Opt.Var (Var.builtin "_Tuple0")]
190+
191+
192+toTuple :: [T.Canonical] -> Opt.Expr
193+toTuple types =
194+ let
195+ size =
196+ length types
197+
198+ args =
199+ map (\n -> 'x' : show n) [ 1 .. size ]
200+
201+ makeTuple =
202+ Opt.Function args (Opt.Data ("_Tuple" ++ show size) (map (Opt.Var . Var.local) args))
203+ in
204+ to ("tuple" ++ show size) <== (makeTuple : map decode types)
205+
206+
207+toRecord :: [(String, T.Canonical)] -> Opt.Expr
208+toRecord fields =
209+ let
210+ toFieldExpr (key, _) =
211+ (key, Opt.Var (Var.local key))
212+
213+ finalDecoder =
214+ to "succeed" <== [ Opt.Record (map toFieldExpr fields) ]
215+
216+ andThen (key, tipe) decoder =
217+ to "andThen" <== [ key =: decode tipe, Opt.Function [key] decoder ]
218+ in
219+ List.foldr andThen finalDecoder fields
src/Generate/JavaScript/Helpers.hs+10−31
@@ -3,6 +3,7 @@ module Generate.JavaScript.Helpers where
3import Language.ECMAScript3.Syntax
3import Language.ECMAScript3.Syntax
4
4
5
5
6+
6localRuntime :: String
7localRuntime :: String
7localRuntime =
8localRuntime =
8 "_elm"
9 "_elm"
@@ -13,18 +14,15 @@ varDecl x expr =
13 VarDecl () (var x) (Just expr)
14 VarDecl () (var x) (Just expr)
14
15
15
16
16−make :: [String] -> Expression ()
17+refOrObject :: String -> Expression ()
17−make moduleName =
18+refOrObject name =
18− obj (moduleName ++ ["make"]) <| ref localRuntime
19+ InfixExpr () OpLOr (ref name) (ObjectLit () [])
19−
20
20
21−useLazy :: [String] -> String -> Expression ()
22−useLazy moduleName functionName =
23− DotRef () (make moduleName) (var functionName)
24
21
25
22
26-- Creating Variables
23-- Creating Variables
27
24
25+
28var :: String -> Id ()
26var :: String -> Id ()
29var name =
27var name =
30 Id () name
28 Id () name
@@ -35,9 +33,9 @@ ref name =
35 VarRef () (var name)
33 VarRef () (var name)
36
34
37
35
38−prop :: String -> Prop ()
36+(==>) :: String -> Expression () -> (Prop (), Expression ())
39−prop name =
37+(==>) name expr =
40− PropId () (var name)
38+ ( PropId () (var name), expr )
41
39
42
40
43obj :: [String] -> Expression ()
41obj :: [String] -> Expression ()
@@ -50,8 +48,10 @@ obj vars =
50 error "dotSep must be called on a non-empty list of variables"
48 error "dotSep must be called on a non-empty list of variables"
51
49
52
50
51+
53-- Function Calls
52-- Function Calls
54
53
54+
55(<|) :: Expression () -> Expression () -> Expression ()
55(<|) :: Expression () -> Expression () -> Expression ()
56(<|) f x =
56(<|) f x =
57 CallExpr () f [x]
57 CallExpr () f [x]
@@ -66,24 +66,3 @@ call :: Expression () -> [Expression ()] -> Expression ()
66call =
66call =
67 CallExpr ()
67 CallExpr ()
68
68
69−
70−-- Checks
71−
72−equal :: Expression () -> Expression () -> Expression ()
73−equal a b =
74− InfixExpr () OpStrictEq a b
75−
76−
77−instanceof :: String -> Expression () -> Expression ()
78−instanceof tipe x =
79− InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))
80−
81−
82−typeof :: String -> Expression () -> Expression ()
83−typeof tipe x =
84− equal (PrefixExpr () PrefixTypeof x) (StringLit () tipe)
85−
86−
87−member :: String -> Expression () -> Expression ()
88−member field x =
89− InfixExpr () OpIn (StringLit () field) x
src/Generate/JavaScript/Port.hsdeleted−299
@@ -1,299 +0,0 @@
1−module Generate.JavaScript.Port (inbound, outbound, task) where
2−
3−import qualified Data.List as List
4−import qualified Data.Map as Map
5−import Language.ECMAScript3.Syntax
6−
7−import qualified AST.Type as T
8−import qualified AST.Variable as Var
9−import Generate.JavaScript.Helpers
10−import qualified Reporting.Render.Type as RenderType
11−
12−
13−-- TASK
14−
15−task :: String -> Expression () -> T.Port t -> Expression ()
16−task name expr portType =
17− case portType of
18− T.Normal _ ->
19− _Task "perform" `call` [ expr ]
20−
21− T.Signal _ _ ->
22− _Task "performSignal" `call` [ StringLit () name, expr ]
23−
24−
25−
26−-- HELPERS
27−
28−data JSType
29− = JSNumber
30− | JSInt
31− | JSBoolean
32− | JSString
33− | JSArray
34− | JSObject [String]
35−
36−
37−typeToString :: JSType -> String
38−typeToString tipe =
39− case tipe of
40− JSNumber -> "a number"
41− JSInt -> "an integer"
42− JSBoolean -> "a boolean (true or false)"
43− JSString -> "a string"
44− JSArray -> "an array"
45− JSObject fields ->
46− "an object with fields `" ++ List.intercalate "`, `" fields ++ "`"
47−
48−
49−_Array :: String -> Expression ()
50−_Array functionName =
51− useLazy ["Elm","Native","Array"] functionName
52−
53−
54−_List :: String -> Expression ()
55−_List functionName =
56− useLazy ["Elm","Native","List"] functionName
57−
58−
59−_Maybe :: String -> Expression ()
60−_Maybe functionName =
61− useLazy ["Elm","Maybe"] functionName
62−
63−
64−_Port :: String -> Expression ()
65−_Port functionName =
66− useLazy ["Elm","Native","Port"] functionName
67−
68−
69−_Task :: String -> Expression ()
70−_Task functionName =
71− useLazy ["Elm","Native","Task"] functionName
72−
73−
74−check :: Expression () -> JSType -> Expression () -> Expression ()
75−check x jsType continue =
76− CondExpr () (jsFold OpLOr checks x) continue throw
77− where
78− jsFold op checks value =
79− foldl1 (InfixExpr () op) (map ($ value) checks)
80−
81− throw =
82− obj ["_U","badPort"] `call` [ StringLit () (typeToString jsType), x ]
83−
84− checks =
85− case jsType of
86− JSNumber ->
87− [typeof "number"]
88−
89− JSInt ->
90− [jsFold OpLAnd intChecks]
91−
92− JSBoolean ->
93− [typeof "boolean"]
94−
95− JSString ->
96− [typeof "string", instanceof "String"]
97−
98− JSArray ->
99− [instanceof "Array"]
100−
101− JSObject fields ->
102− [jsFold OpLAnd (typeof "object" : map member fields)]
103−
104−
105−intChecks :: [Expression () -> Expression ()]
106−intChecks =
107− [ typeof "number"
108− , \x -> ref "isFinite" <| x
109− , \x -> equal (obj ["Math","floor"] <| x) x
110− ]
111−
112−
113−-- INBOUND
114−
115−inbound :: String -> T.Port T.Canonical -> Expression ()
116−inbound name portType =
117− case portType of
118− T.Normal tipe ->
119− _Port "inbound" `call`
120− [ StringLit () name
121− , StringLit () (show (RenderType.toDoc Map.empty tipe))
122− , toTypeFunction tipe
123− ]
124−
125− T.Signal _root arg ->
126− _Port "inboundSignal" `call`
127− [ StringLit () name
128− , StringLit () (show (RenderType.toDoc Map.empty arg))
129− , toTypeFunction arg
130− ]
131−
132−
133−toTypeFunction :: T.Canonical -> Expression ()
134−toTypeFunction tipe =
135− function ["v"] [ ReturnStmt () (Just (toType tipe (ref "v"))) ]
136−
137−
138−toType :: T.Canonical -> Expression () -> Expression ()
139−toType tipe x =
140− case tipe of
141− T.Lambda _ _ ->
142− error "functions should not be allowed through input ports"
143−
144− T.Var _ ->
145− error "type variables should not be allowed through input ports"
146−
147− T.Aliased _ args t ->
148− toType (T.dealias args t) x
149−
150− T.Type (Var.Canonical Var.BuiltIn name)
151− | name == "Float" -> from JSNumber
152− | name == "Int" -> from JSInt
153− | name == "Bool" -> from JSBoolean
154− | name == "String" -> from JSString
155− where
156− from checks = check x checks x
157−
158− T.Type name
159− | Var.isJson name ->
160− x
161−
162− | Var.isTuple name ->
163− toTuple [] x
164−
165− | otherwise ->
166− error "bad type got to foreign input conversion"
167−
168− T.App f args ->
169− case f : args of
170− T.Type name : [t]
171− | Var.isMaybe name ->
172− CondExpr ()
173− (equal x (NullLit ()))
174− (_Maybe "Nothing")
175− (_Maybe "Just" <| toType t x)
176−
177− | Var.isList name ->
178− check x JSArray (_List "fromArray" <| array)
179−
180− | Var.isArray name ->
181− check x JSArray (_Array "fromJSArray" <| array)
182− where
183− array = DotRef () x (var "map") <| toTypeFunction t
184−
185− T.Type name : ts
186− | Var.isTuple name ->
187− toTuple ts x
188−
189− _ -> error "bad ADT got to foreign input conversion"
190−
191− T.Record _ (Just _) ->
192− error "bad record got to foreign input conversion"
193−
194− T.Record fields Nothing ->
195− check x (JSObject (map fst fields)) object
196− where
197− object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
198− keys = map convert fields
199− convert (f,t) = (prop f, toType t (DotRef () x (var f)))
200−
201−
202−toTuple :: [T.Canonical] -> Expression () -> Expression ()
203−toTuple types x =
204− check x JSArray (ObjectLit () fields)
205− where
206− fields =
207− (prop "ctor", ctor) : zipWith convert [0..] types
208−
209− ctor =
210− StringLit () ("_Tuple" ++ show (length types))
211−
212− convert n t =
213− ( prop ('_':show n)
214− , toType t (BracketRef () x (IntLit () n))
215− )
216−
217−
218−-- OUTBOUND
219−
220−outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()
221−outbound name expr portType =
222− case portType of
223− T.Normal tipe ->
224− _Port "outbound" `call` [ StringLit () name, fromTypeFunction tipe, expr ]
225−
226− T.Signal _ arg ->
227− _Port "outboundSignal" `call` [ StringLit () name, fromTypeFunction arg, expr ]
228−
229−
230−fromTypeFunction :: T.Canonical -> Expression ()
231−fromTypeFunction tipe =
232− function ["v"] [ ReturnStmt () (Just (fromType tipe (ref "v"))) ]
233−
234−
235−fromType :: T.Canonical -> Expression () -> Expression ()
236−fromType tipe x =
237− case tipe of
238− T.Aliased _ args t ->
239− fromType (T.dealias args t) x
240−
241− T.Lambda _ _
242− | numArgs > 1 && numArgs < 10 ->
243− func (ref ('A':show numArgs) `call` (x:values))
244− | otherwise ->
245− func (foldl (<|) x values)
246− where
247− ts = T.collectLambdas tipe
248− numArgs = length ts - 1
249− args = map (\n -> '_' : show n) [0..]
250− values = zipWith toType (init ts) (map ref args)
251− func body =
252− function (take numArgs args)
253− [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
254− , ReturnStmt () (Just (fromType (last ts) (ref "_r")))
255− ]
256−
257− T.Var _ ->
258− error "type variables should not be allowed through outputs"
259−
260− T.Type (Var.Canonical Var.BuiltIn name)
261− | name `elem` ["Int","Float","Bool","String"] ->
262− x
263−
264− T.Type name
265− | Var.isJson name -> x
266− | Var.isTuple name -> ArrayLit () []
267− | otherwise -> error "bad type got to an output"
268−
269− T.App f args ->
270− case f : args of
271− T.Type name : [t]
272− | Var.isMaybe name ->
273− CondExpr ()
274− (equal (DotRef () x (var "ctor")) (StringLit () "Nothing"))
275− (NullLit ())
276− (fromType t (DotRef () x (var "_0")))
277−
278− | Var.isArray name ->
279− DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
280−
281− | Var.isList name ->
282− DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
283−
284− T.Type name : ts
285− | Var.isTuple name ->
286− let convert n t = fromType t $ DotRef () x $ var ('_':show n)
287− in ArrayLit () $ zipWith convert [0..] ts
288−
289− _ -> error "bad ADT got to an output"
290−
291− T.Record _ (Just _) ->
292− error "bad record got to an output"
293−
294− T.Record fields Nothing ->
295− ObjectLit () keys
296− where
297− keys = map convert fields
298− convert (f,t) =
299− (PropId () (var f), fromType t (DotRef () x (var f)))
src/Generate/JavaScript/Variable.hs+99−31
@@ -1,7 +1,10 @@
1+{-# OPTIONS_GHC -Wall #-}
1module Generate.JavaScript.Variable
2module Generate.JavaScript.Variable
2 ( fresh
3 ( fresh
3 , canonical
4 , canonical
4− , modulePrefix
5+ , qualified
6+ , native
7+ , coreNative
5 , define
8 , define
6 , safe
9 , safe
7 )
10 )
@@ -15,11 +18,14 @@ import qualified Language.ECMAScript3.Syntax as JS
15import qualified AST.Helpers as Help
18import qualified AST.Helpers as Help
16import qualified AST.Module.Name as ModuleName
19import qualified AST.Module.Name as ModuleName
17import qualified AST.Variable as Var
20import qualified AST.Variable as Var
21+import qualified Elm.Package as Pkg
18import qualified Generate.JavaScript.Helpers as JS
22import qualified Generate.JavaScript.Helpers as JS
19
23
20
24
25+
21-- FRESH NAMES
26-- FRESH NAMES
22
27
28+
23fresh :: State.State Int String
29fresh :: State.State Int String
24fresh =
30fresh =
25 do n <- State.get
31 do n <- State.get
@@ -27,54 +33,111 @@ fresh =
27 return ("_v" ++ show n)
33 return ("_v" ++ show n)
28
34
29
35
36+
30-- DEF NAMES
37-- DEF NAMES
31
38
32−define :: String -> JS.Expression () -> JS.Statement ()
33−define name body =
34− if Help.isOp name then
35− let
36− root =
37− JS.VarRef () (JS.Id () "_op")
38
39
39− lvalue =
40+define :: Maybe ModuleName.Canonical -> String -> JS.Expression () -> [JS.Statement ()]
40− JS.LBracket () root (JS.StringLit () name)
41+define maybeHome name body =
42+ if not (Help.isOp name) then
43+ let
44+ jsName =
45+ maybe unqualified qualified maybeHome name
41 in
46 in
42− JS.ExprStmt () (JS.AssignExpr () JS.OpAssign lvalue body)
47+ [ JS.VarDeclStmt () [ JS.varDecl jsName body ] ]
43
48
44 else
49 else
45− JS.VarDeclStmt () [ JS.VarDecl () (JS.Id () (safe name)) (Just body) ]
50+ case maybeHome of
51+ Nothing ->
52+ error "can only define infix operators at the top level"
53+
54+ Just home ->
55+ let
56+ opsDictName =
57+ getOpsDictName (Var.TopLevel home)
58+
59+ lvalue =
60+ JS.LBracket () (JS.ref opsDictName) (JS.StringLit () name)
61+ in
62+ [ JS.VarDeclStmt () [ JS.varDecl opsDictName (JS.refOrObject opsDictName) ]
63+ , JS.ExprStmt () (JS.AssignExpr () JS.OpAssign lvalue body)
64+ ]
65+
46
66
47
67
48-- INSTANTIATE VARIABLES
68-- INSTANTIATE VARIABLES
49
69
70+
50canonical :: Var.Canonical -> JS.Expression ()
71canonical :: Var.Canonical -> JS.Expression ()
51canonical (Var.Canonical home name) =
72canonical (Var.Canonical home name) =
52 if Help.isOp name then
73 if Help.isOp name then
53− JS.BracketRef () (addRoot home "_op") (JS.StringLit () name)
74+ JS.BracketRef () (JS.ref (getOpsDictName home)) (JS.StringLit () name)
54
75
55 else
76 else
56− addRoot home (safe name)
77+ case home of
78+ Var.Local ->
79+ JS.ref (unqualified name)
80+
81+ Var.BuiltIn ->
82+ JS.ref (unqualified name)
83+
84+ Var.Module moduleName@(ModuleName.Canonical _ rawName) ->
85+ if ModuleName.isNative rawName then
86+ native moduleName name
87+
88+ else
89+ JS.ref (qualified moduleName name)
57
90
91+ Var.TopLevel moduleName ->
92+ JS.ref (qualified moduleName name)
58
93
59−addRoot :: Var.Home -> String -> JS.Expression ()
60−addRoot home name =
61− case home of
62− Var.Local ->
63− JS.ref name
64
94
65− Var.TopLevel _moduleName ->
95+unqualified :: String -> String
66− JS.ref name
96+unqualified =
97+ safe
67
98
68− Var.BuiltIn ->
69− JS.ref name
70
99
71− Var.Module (ModuleName.Canonical _ moduleName) ->
100+qualified :: ModuleName.Canonical -> String -> String
72− JS.DotRef () (JS.ref (modulePrefix moduleName)) (JS.Id () name)
101+qualified moduleName name =
102+ moduleToString moduleName ++ "$" ++ removePrimes name
73
103
74
104
105+native :: ModuleName.Canonical -> String -> JS.Expression ()
106+native moduleName name =
107+ JS.obj [ moduleToString moduleName, name ]
108+
109+
110+coreNative :: String -> String -> JS.Expression ()
111+coreNative moduleName name =
112+ native (ModuleName.inCore ["Native",moduleName]) name
113+
114+
115+getOpsDictName :: Var.Home -> String
116+getOpsDictName home =
117+ let
118+ moduleName =
119+ case home of
120+ Var.Local -> error "infix operators should only be defined in top-level declarations"
121+ Var.BuiltIn -> error "there should be no built-in infix operators"
122+ Var.Module name -> name
123+ Var.TopLevel name -> name
124+ in
125+ moduleToString moduleName ++ "_ops"
126+
127+
75−modulePrefix :: ModuleName.Raw -> String
128+moduleToString :: ModuleName.Canonical -> String
76−modulePrefix moduleName =
129+moduleToString (ModuleName.Canonical (Pkg.Name user project) moduleName) =
130+ let
131+ safeUser =
132+ map (swap '-' '_') user
133+
134+ safeProject =
135+ map (swap '-' '_') project
136+
137+ safeModuleName =
77− '$' : List.intercalate "$" moduleName
138+ List.intercalate "_" moduleName
139+ in
140+ '_' : safeUser ++ "$" ++ safeProject ++ "$" ++ safeModuleName
78
141
79
142
80swap :: Char -> Char -> Char -> Char
143swap :: Char -> Char -> Char -> Char
@@ -82,14 +145,19 @@ swap from to c =
82 if c == from then to else c
145 if c == from then to else c
83
146
84
147
148+
85-- SAFE NAMES
149-- SAFE NAMES
86
150
151+
87safe :: String -> String
152safe :: String -> String
88safe name =
153safe name =
89− let saferName =
154+ removePrimes $
90− if Set.member name jsReserveds then '$' : name else name
155+ if Set.member name jsReserveds then '$' : name else name
91− in
156+
157+
158+removePrimes :: String -> String
159+removePrimes name =
92− map (swap '\'' '$') saferName
160+ map (swap '\'' '$') name
93
161
94
162
95jsReserveds :: Set.Set String
163jsReserveds :: Set.Set String
src/Nitpick/Pattern.hs+1−1
@@ -20,7 +20,7 @@ data Pattern
20 deriving (Eq)
20 deriving (Eq)
21
21
22
22
23−fromCanonicalPattern :: P.CanonicalPattern -> Pattern
23+fromCanonicalPattern :: P.Canonical -> Pattern
24fromCanonicalPattern (A.A _ pattern) =
24fromCanonicalPattern (A.A _ pattern) =
25 case pattern of
25 case pattern of
26 P.Data tag patterns ->
26 P.Data tag patterns ->
src/Nitpick/PatternMatches.hs+46−37
@@ -22,23 +22,25 @@ import qualified Reporting.Region as Region
22import qualified Reporting.Result as Result
22import qualified Reporting.Result as Result
23
23
24
24
25−patternMatches
25+
26− :: Module.Interfaces
26+type Result warning a =
27− -> Module.CanonicalModule
27+ Result.Result () warning Error.Error a
28− -> Result.Result w Error.Error DT.VariantDict
28+
29+
30+patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict
29−patternMatches interfaces modul =
31+patternMatches interfaces (Module.Module name _ info) =
30 let
32 let
31− name = Module.name modul
32− body = Module.body modul
33 tagDict =
33 tagDict =
34− toTagDict interfaces name (Module.datatypes body)
34+ toTagDict interfaces name (Module.unions info)
35 in
35 in
36 const (Map.map (Map.map length) tagDict)
36 const (Map.map (Map.map length) tagDict)
37− <$> checkExpression tagDict (Module.program body)
37+ <$> checkExpression tagDict (Module.program info)
38+
38
39
39
40
40-- TAG DICT
41-- TAG DICT
41
42
43+
42type TagDict =
44type TagDict =
43 Map.Map Var.Home (Map.Map Tag [TagInfo])
45 Map.Map Var.Home (Map.Map Tag [TagInfo])
44
46
@@ -52,8 +54,8 @@ data TagInfo = TagInfo
52 }
54 }
53
55
54
56
55−toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.ADTs -> TagDict
57+toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> TagDict
56−toTagDict interfaces localName localAdts =
58+toTagDict interfaces localName localUnions =
57 let
59 let
58 listTags =
60 listTags =
59 [ TagInfo "::" 2
61 [ TagInfo "::" 2
@@ -76,14 +78,14 @@ toTagDict interfaces localName localAdts =
76
78
77 interfaceDict =
79 interfaceDict =
78 interfaces
80 interfaces
79− |> Map.map (toTagMapping . Module.iAdts)
81+ |> Map.map (toTagMapping . Module.iUnions)
80 |> Map.mapKeysMonotonic Var.Module
82 |> Map.mapKeysMonotonic Var.Module
81− |> Map.insert (Var.Module localName) (toTagMapping localAdts)
83+ |> Map.insert (Var.Module localName) (toTagMapping localUnions)
82 in
84 in
83 Map.union builtinDict interfaceDict
85 Map.union builtinDict interfaceDict
84
86
85
87
86−toTagMapping :: Module.ADTs -> Map.Map Tag [TagInfo]
88+toTagMapping :: Module.Unions -> Map.Map Tag [TagInfo]
87toTagMapping adts =
89toTagMapping adts =
88 let
90 let
89 toTagAndArity (_tvars, tagInfoList) =
91 toTagAndArity (_tvars, tagInfoList) =
@@ -113,12 +115,11 @@ lookupOtherTags (Var.Canonical home name) tagDict =
113 \found."
115 \found."
114
116
115
117
118+
116-- CHECK EXPRESSIONS
119-- CHECK EXPRESSIONS
117
120
121+
118−checkExpression
122+checkExpression :: TagDict -> Canonical.Expr -> Result wrn ()
119− :: TagDict
120− -> Canonical.Expr
121− -> Result.Result w Error.Error ()
122checkExpression tagDict (A.A region expression) =
123checkExpression tagDict (A.A region expression) =
123 let
124 let
124 go =
125 go =
@@ -158,7 +159,7 @@ checkExpression tagDict (A.A region expression) =
158 go body
159 go body
159 <* F.traverse_ goDef defs
160 <* F.traverse_ goDef defs
160 where
161 where
161− goDef (Canonical.Definition _ pattern@(A.A patRegion _) expr _) =
162+ goDef (Canonical.Def _ pattern@(A.A patRegion _) expr _) =
162 checkPatterns tagDict patRegion Error.LetBound [pattern]
163 checkPatterns tagDict patRegion Error.LetBound [pattern]
163 <* go expr
164 <* go expr
164
165
@@ -180,29 +181,33 @@ checkExpression tagDict (A.A region expression) =
180 E.Record fields ->
181 E.Record fields ->
181 F.traverse_ (go . snd) fields
182 F.traverse_ (go . snd) fields
182
183
183− E.Port impl ->
184+ E.Cmd _ ->
184− case impl of
185+ Result.ok ()
186+
185− E.In _ _ ->
187+ E.Sub _ ->
186− Result.ok ()
188+ Result.ok ()
187
189
188− E.Out _ expr _ ->
190+ E.OutgoingPort _ _ ->
189− go expr
191+ Result.ok ()
190
192
191− E.Task _ expr _ ->
193+ E.IncomingPort _ _ ->
192− go expr
194+ Result.ok ()
195+
196+ E.Program _ _ ->
197+ error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
198+
199+ E.SaveEnv _ _ ->
200+ Result.ok ()
193
201
194 E.GLShader _ _ _ ->
202 E.GLShader _ _ _ ->
195 Result.ok ()
203 Result.ok ()
196
204
197
205
206+
198-- CHECK PATTERNS
207-- CHECK PATTERNS
199
208
200−checkPatterns
209+
201− :: TagDict
210+checkPatterns :: TagDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
202− -> Region.Region
203− -> Error.Origin
204− -> [Pattern.CanonicalPattern]
205− -> Result.Result w Error.Error ()
206checkPatterns tagDict region origin patterns =
211checkPatterns tagDict region origin patterns =
207 checkPatternsHelp tagDict region origin [Anything] patterns
212 checkPatternsHelp tagDict region origin [Anything] patterns
208
213
@@ -212,8 +217,8 @@ checkPatternsHelp
212 -> Region.Region
217 -> Region.Region
213 -> Error.Origin
218 -> Error.Origin
214 -> [Pattern]
219 -> [Pattern]
215− -> [Pattern.CanonicalPattern]
220+ -> [Pattern.Canonical]
216− -> Result.Result w Error.Error ()
221+ -> Result wrn ()
217checkPatternsHelp tagDict region origin unhandled patterns =
222checkPatternsHelp tagDict region origin unhandled patterns =
218 case (unhandled, patterns) of
223 case (unhandled, patterns) of
219 ([], []) ->
224 ([], []) ->
@@ -230,9 +235,9 @@ checkPatternsHelp tagDict region origin unhandled patterns =
230filterPatterns
235filterPatterns
231 :: TagDict
236 :: TagDict
232 -> Region.Region
237 -> Region.Region
233− -> Pattern.CanonicalPattern
238+ -> Pattern.Canonical
234 -> [Pattern]
239 -> [Pattern]
235− -> Result.Result w Error.Error [Pattern]
240+ -> Result wrn [Pattern]
236filterPatterns tagDict region pattern unhandled =
241filterPatterns tagDict region pattern unhandled =
237 let
242 let
238 nitPattern =
243 nitPattern =
@@ -252,8 +257,10 @@ filterPatterns tagDict region pattern unhandled =
252 unhandled
257 unhandled
253
258
254
259
260+
255-- PATTERN INTERSECTION
261-- PATTERN INTERSECTION
256
262
263+
257intersection :: Pattern -> Pattern -> Maybe Pattern
264intersection :: Pattern -> Pattern -> Maybe Pattern
258intersection pattern1 pattern2 =
265intersection pattern1 pattern2 =
259 case (pattern1, pattern2) of
266 case (pattern1, pattern2) of
@@ -309,8 +316,10 @@ intersection pattern1 pattern2 =
309 Nothing
316 Nothing
310
317
311
318
319+
312-- PATTERN COMPLEMENT
320-- PATTERN COMPLEMENT
313
321
322+
314complement :: TagDict -> Pattern -> [Pattern]
323complement :: TagDict -> Pattern -> [Pattern]
315complement tagDict nitPattern =
324complement tagDict nitPattern =
316 case nitPattern of
325 case nitPattern of
src/Nitpick/TopLevelTypes.hs+85−68
@@ -1,16 +1,17 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Nitpick.TopLevelTypes (topLevelTypes) where
2module Nitpick.TopLevelTypes (topLevelTypes) where
3
3
4−import Prelude hiding (maybe)
5import qualified Data.Foldable as F
4import qualified Data.Foldable as F
5+import Data.Map ((!))
6import qualified Data.Map as Map
6import qualified Data.Map as Map
7
7
8−import qualified AST.Expression.Valid as Valid
8+import qualified AST.Expression.Canonical as Can
9−import qualified AST.Declaration as Decl
9+import qualified AST.Expression.General as Expr
10import qualified AST.Module.Name as ModuleName
10import qualified AST.Module.Name as ModuleName
11import qualified AST.Pattern as P
11import qualified AST.Pattern as P
12import qualified AST.Type as Type
12import qualified AST.Type as Type
13import qualified AST.Variable as Var
13import qualified AST.Variable as Var
14+import qualified Canonicalize.Effects as Effects
14import qualified Elm.Package as Pkg
15import qualified Elm.Package as Pkg
15import qualified Reporting.Annotation as A
16import qualified Reporting.Annotation as A
16import qualified Reporting.Error.Type as Error
17import qualified Reporting.Error.Type as Error
@@ -18,91 +19,107 @@ import qualified Reporting.Result as Result
18import qualified Reporting.Warning as Warning
19import qualified Reporting.Warning as Warning
19
20
20
21
21−topLevelTypes
22− :: Map.Map String Type.Canonical
23− -> [Decl.ValidDecl]
24− -> Result.Result Warning.Warning Error.Error ()
25−topLevelTypes typeEnv validDecls =
26− do F.traverse_ (warnMissingAnnotation typeEnv) validDecls
27− checkMainType typeEnv validDecls
28
22
23+type Result =
24+ Result.Result () Warning.Warning Error.Error
29
25
30−-- MISSING ANNOTATIONS
31
26
32−warnMissingAnnotation
27+type TypeDict =
33− :: Map.Map String Type.Canonical
28+ Map.Map String Type.Canonical
34− -> Decl.ValidDecl
29+
35− -> Result.Result Warning.Warning Error.Error ()
30+
36−warnMissingAnnotation typeEnv (A.A (region,_) decl) =
31+
32+-- CHECK TOP LEVEL TYPES
33+
34+
35+topLevelTypes :: TypeDict -> Can.SortedDefs -> Result [Can.Def]
36+topLevelTypes typeEnv sortedDefs =
37+ let
38+ check =
39+ checkAnnotation typeEnv
40+ in
37− case decl of
41+ case sortedDefs of
38− Decl.Definition (Valid.Definition (A.A _ (P.Var name)) _ Nothing) ->
42+ Can.NoMain defs ->
39− case Map.lookup name typeEnv of
43+ pure defs
40− Nothing ->
44+ <* F.traverse_ check defs
41− return ()
45+
42− Just tipe ->
46+ Can.YesMain before main after ->
43− Result.warn region (Warning.MissingTypeAnnotation name tipe)
47+ do check main
44− _ ->
48+ <* F.traverse_ check before
45− return ()
49+ <* F.traverse_ check after
46
50
51+ mainDef <- checkMain typeEnv main
47
52
48−-- MAIN TYPE
53+ return (before ++ mainDef : after)
49
54
50−checkMainType
51− :: Map.Map String Type.Canonical
52− -> [Decl.ValidDecl]
53− -> Result.Result w Error.Error ()
54−checkMainType typeEnv decls =
55− case decls of
56− A.A (region,_) (Decl.Definition (Valid.Definition (A.A _ (P.Var "main")) _ _)) : _ ->
57− case Map.lookup "main" typeEnv of
58− Nothing ->
59− return ()
60
55
61− Just typeOfMain ->
62− let tipe = Type.deepDealias typeOfMain
63− in
64− if tipe `elem` validMainTypes
65− then return ()
66− else Result.throw region (Error.BadMain typeOfMain)
67
56
68− _ : remainingDecls ->
57+-- MISSING ANNOTATIONS
69− checkMainType typeEnv remainingDecls
58+
59+
60+checkAnnotation :: TypeDict -> Can.Def -> Result ()
61+checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =
62+ case (pattern, maybeType) of
63+ (P.Var name, Nothing) ->
64+ let
65+ warning =
66+ Warning.MissingTypeAnnotation name (typeEnv ! name)
67+ in
68+ Result.warn region warning ()
69+
70+ _ ->
71+ return ()
72+
73+
70
74
71− [] ->
75+-- CHECK MAIN TYPE
72− return ()
73
76
74
77
75−validMainTypes :: [Type.Canonical]
78+checkMain :: TypeDict -> Can.Def -> Result Can.Def
76−validMainTypes =
79+checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
77− [ element
80+ let
78− , html
81+ mainType =
79− , signal element
82+ typeEnv ! "main"
80− , signal html
81− ]
82
83
84+ makeError tipe maybeMsg =
85+ A.A region (Error.BadFlags tipe maybeMsg)
83
86
84−html :: Type.Canonical
87+ getMainKind =
85−html =
88+ case Type.deepDealias mainType of
86− Type.Type (Var.fromModule virtualDom "Node")
89+ Type.App name [arg]
90+ | name == vdomNode ->
91+ return Expr.VDom
87
92
93+ | name == program && arg == never ->
94+ return Expr.NoFlags
88
95
89−virtualDom :: ModuleName.Canonical
96+ | name == program ->
90−virtualDom =
97+ return (Expr.Flags arg)
91− ModuleName.Canonical (Pkg.Name "evancz" "virtual-dom") ["VirtualDom"]
98+ <* Effects.checkPortType makeError arg
92
99
100+ _ ->
101+ Result.throw region (Error.BadMain mainType)
102+ in
103+ do kind <- getMainKind
104+ let newBody = A.A undefined (Expr.Program kind body)
105+ return (Can.Def facts pattern newBody maybeType)
93
106
94−element :: Type.Canonical
95−element =
96− core ["Graphics","Element"] "Element"
97
107
108+program :: Type.Canonical
109+program =
110+ Type.Type (Var.inCore ["Platform"] "Program")
98
111
99−signal :: Type.Canonical -> Type.Canonical
100−signal tipe =
101− Type.App (core ["Signal"] "Signal") [ tipe ]
102
112
113+never :: Type.Canonical
114+never =
115+ Type.Type (Var.inCore ["Basics"] "Never")
103
116
104−core :: [String] -> String -> Type.Canonical
105−core home name =
106− Type.Type (Var.inCore home name)
107
117
118+vdomNode :: Type.Canonical
119+vdomNode =
120+ let
121+ vdom =
122+ ModuleName.Canonical Pkg.virtualDom ["VirtualDom"]
123+ in
124+ Type.Type (Var.fromModule vdom "Node")
108
125
src/Optimize.hs+52−57
@@ -7,7 +7,6 @@ import qualified Data.Traversable as T
7import qualified AST.Expression.General as Expr
7import qualified AST.Expression.General as Expr
8import qualified AST.Expression.Canonical as Can
8import qualified AST.Expression.Canonical as Can
9import qualified AST.Expression.Optimized as Opt
9import qualified AST.Expression.Optimized as Opt
10−import qualified AST.Module as Module
11import qualified AST.Module.Name as ModuleName
10import qualified AST.Module.Name as ModuleName
12import qualified AST.Pattern as P
11import qualified AST.Pattern as P
13import qualified AST.Variable as Var
12import qualified AST.Variable as Var
@@ -23,26 +22,9 @@ import qualified Reporting.Region as R
23-- OPTIMIZE
22-- OPTIMIZE
24
23
25
24
26−optimize :: DT.VariantDict -> Module.CanonicalModule -> Module.Optimized
25+optimize :: DT.VariantDict -> ModuleName.Canonical -> [Can.Def] -> [Opt.Def]
27−optimize variantDict module_@(Module.Module home _ _ _ _ body) =
26+optimize variantDict home defs =
28− let
29− (defs, _) =
30− flattenLets [] (Module.program body)
31−
32− optDefs =
33− Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)
27+ Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)
34− in
35− module_ { Module.body = body { Module.program = optDefs } }
36−
37−
38−flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)
39−flattenLets defs annExpr@(A.A _ expr) =
40− case expr of
41− Expr.Let ds body ->
42− flattenLets (defs ++ ds) body
43−
44− _ ->
45− (defs, annExpr)
46
28
47
29
48
30
@@ -50,25 +32,27 @@ flattenLets defs annExpr@(A.A _ expr) =
50
32
51
33
52optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]
34optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]
53−optimizeDef isRoot (Can.Definition (Can.Facts deps) pattern expression _) =
35+optimizeDef isRoot (Can.Def (Can.Facts deps) pattern expression _) =
54 let
36 let
55 (args, canBody) =
37 (args, canBody) =
56 Expr.collectLambdas expression
38 Expr.collectLambdas expression
57− in
58− do home <-
59− if isRoot then
60− Just <$> Env.getHome
61− else
62− return Nothing
63
39
40+ maybeGetHome =
41+ if isRoot then
42+ Just <$> Env.getHome
43+
44+ else
45+ return Nothing
46+ in
47+ do home <- maybeGetHome
64 optimizeDefHelp home deps pattern args canBody
48 optimizeDefHelp home deps pattern args canBody
65
49
66
50
67optimizeDefHelp
51optimizeDefHelp
68 :: Maybe ModuleName.Canonical
52 :: Maybe ModuleName.Canonical
69 -> [Var.TopLevel]
53 -> [Var.TopLevel]
70− -> P.CanonicalPattern
54+ -> P.Canonical
71− -> [P.CanonicalPattern]
55+ -> [P.Canonical]
72 -> Can.Expr
56 -> Can.Expr
73 -> Env.Optimizer [Opt.Def]
57 -> Env.Optimizer [Opt.Def]
74optimizeDefHelp home deps pattern@(A.A _ ptrn) args rawBody =
58optimizeDefHelp home deps pattern@(A.A _ ptrn) args rawBody =
@@ -118,7 +102,7 @@ optimizeDefHelp home deps pattern@(A.A _ ptrn) args rawBody =
118
102
119optimizeFunction
103optimizeFunction
120 :: Maybe String
104 :: Maybe String
121− -> [P.CanonicalPattern]
105+ -> [P.Canonical]
122 -> Can.Expr
106 -> Can.Expr
123 -> Env.Optimizer ([String], Opt.Expr)
107 -> Env.Optimizer ([String], Opt.Expr)
124optimizeFunction maybeName patterns givenBody =
108optimizeFunction maybeName patterns givenBody =
@@ -132,20 +116,13 @@ makeContext argNames name =
132 Just (name, length argNames, argNames)
116 Just (name, length argNames, argNames)
133
117
134
118
135−depatternArgs
136− :: ([String], Can.Expr)
137− -> P.CanonicalPattern
138− -> Env.Optimizer ([String], Can.Expr)
119+depatternArgs :: ([String], Can.Expr) -> P.Canonical -> Env.Optimizer ([String], Can.Expr)
139depatternArgs (names, rawExpr) ptrn =
120depatternArgs (names, rawExpr) ptrn =
140 do (name, expr) <- depattern ptrn rawExpr
121 do (name, expr) <- depattern ptrn rawExpr
141 return (name : names, expr)
122 return (name : names, expr)
142
123
143
124
144−patternToDefs
145− :: Maybe ModuleName.Canonical
125+patternToDefs :: Maybe ModuleName.Canonical -> String -> P.Canonical -> [Opt.Def]
146− -> String
147− -> P.CanonicalPattern
148− -> [Opt.Def]
149patternToDefs home rootName pattern =
126patternToDefs home rootName pattern =
150 let
127 let
151 (deps, rootExpr) =
128 (deps, rootExpr) =
@@ -166,9 +143,11 @@ patternToDefs home rootName pattern =
166 map toDef (patternToSubstitutions rootExpr pattern)
143 map toDef (patternToSubstitutions rootExpr pattern)
167
144
168
145
146+
169-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS
147-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS
170
148
149+
171−patternToSubstitutions :: Opt.Expr -> P.CanonicalPattern -> [(String, Opt.Expr)]
150+patternToSubstitutions :: Opt.Expr -> P.Canonical -> [(String, Opt.Expr)]
172patternToSubstitutions expr (A.A _ pattern) =
151patternToSubstitutions expr (A.A _ pattern) =
173 case pattern of
152 case pattern of
174 P.Var name ->
153 P.Var name ->
@@ -190,8 +169,10 @@ patternToSubstitutions expr (A.A _ pattern) =
190 concat (zipWith (patternToSubstitutions . Opt.DataAccess expr) [0..] patterns)
169 concat (zipWith (patternToSubstitutions . Opt.DataAccess expr) [0..] patterns)
191
170
192
171
172+
193-- OPTIMIZE EXPRESSIONS
173-- OPTIMIZE EXPRESSIONS
194
174
175+
195type Context = Maybe (String, Int, [String])
176type Context = Maybe (String, Int, [String])
196
177
197
178
@@ -301,20 +282,26 @@ optimizeExpr context annExpr@(A.A region expression) =
301 Opt.Record
282 Opt.Record
302 <$> T.traverse (mapSnd justConvert) fields
283 <$> T.traverse (mapSnd justConvert) fields
303
284
304− Expr.GLShader uid src gltipe ->
285+ Expr.Cmd moduleName ->
305− pure (Opt.GLShader uid src gltipe)
286+ pure (Opt.Cmd moduleName)
287+
288+ Expr.Sub moduleName ->
289+ pure (Opt.Sub moduleName)
290+
291+ Expr.OutgoingPort name tipe ->
292+ pure (Opt.OutgoingPort name tipe)
306
293
307− Expr.Port impl ->
294+ Expr.IncomingPort name tipe ->
308− Opt.Port <$>
309− case impl of
310− Expr.In name tipe ->
311− pure (Expr.In name tipe)
295+ pure (Opt.IncomingPort name tipe)
312
296
313− Expr.Out name expr tipe ->
297+ Expr.Program kind expr ->
314− (\e -> Expr.Out name e tipe) <$> justConvert expr
298+ Opt.Program kind <$> justConvert expr
315
299
316− Expr.Task name expr tipe ->
300+ Expr.SaveEnv _ _ ->
317− (\e -> Expr.Task name e tipe) <$> justConvert expr
301+ error "save_the_environment should never make it to optimization phase"
302+
303+ Expr.GLShader uid src gltipe ->
304+ pure (Opt.GLShader uid src gltipe)
318
305
319
306
320mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)
307mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)
@@ -322,14 +309,16 @@ mapSnd func (x, a) =
322 (,) x <$> func a
309 (,) x <$> func a
323
310
324
311
312+
325-- OPTIMIZE CASE BRANCHES
313-- OPTIMIZE CASE BRANCHES
326
314
315+
327optimizeBranch
316optimizeBranch
328 :: Context
317 :: Context
329 -> R.Region
318 -> R.Region
330 -> String
319 -> String
331− -> (P.CanonicalPattern, Can.Expr)
320+ -> (P.Canonical, Can.Expr)
332− -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)
321+ -> Env.Optimizer (P.Canonical, Opt.Expr)
333optimizeBranch context region exprName (rawPattern, canBranch) =
322optimizeBranch context region exprName (rawPattern, canBranch) =
334 let
323 let
335 root =
324 root =
@@ -346,9 +335,9 @@ optimizeBranch context region exprName (rawPattern, canBranch) =
346
335
347tagCrashBranch
336tagCrashBranch
348 :: R.Region
337 :: R.Region
349− -> P.CanonicalPattern
338+ -> P.Canonical
350 -> Opt.Expr
339 -> Opt.Expr
351− -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)
340+ -> Env.Optimizer (P.Canonical, Opt.Expr)
352tagCrashBranch region pattern@(A.A pr _) expr =
341tagCrashBranch region pattern@(A.A pr _) expr =
353 case expr of
342 case expr of
354 Opt.Call (Opt.Crash home _ _) [arg] ->
343 Opt.Call (Opt.Crash home _ _) [arg] ->
@@ -362,8 +351,10 @@ tagCrashBranch region pattern@(A.A pr _) expr =
362 return (pattern, expr)
351 return (pattern, expr)
363
352
364
353
354+
365-- DETECT TAIL CALL
355-- DETECT TAIL CALL
366
356
357+
367isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])
358isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])
368isTailCall context (A.A _ function) arity =
359isTailCall context (A.A _ function) arity =
369 case (context, function) of
360 case (context, function) of
@@ -379,12 +370,14 @@ isTailCall context (A.A _ function) arity =
379 Nothing
370 Nothing
380
371
381
372
373+
382-- DEPATTERN
374-- DEPATTERN
383-- given a pattern and an expression, push the actual pattern matching into the
375-- given a pattern and an expression, push the actual pattern matching into the
384-- expression as a case-expression if necessary. The pattern compiler will work
376-- expression as a case-expression if necessary. The pattern compiler will work
385-- it out from there
377-- it out from there
386
378
379+
387−depattern :: P.CanonicalPattern -> Can.Expr -> Env.Optimizer (String, Can.Expr)
380+depattern :: P.Canonical -> Can.Expr -> Env.Optimizer (String, Can.Expr)
388depattern canPattern@(A.A _ pattern) expr =
381depattern canPattern@(A.A _ pattern) expr =
389 let
382 let
390 ann =
383 ann =
@@ -424,8 +417,10 @@ depattern canPattern@(A.A _ pattern) expr =
424 caseify
417 caseify
425
418
426
419
420+
427-- OPTIMIZE BINOPS
421-- OPTIMIZE BINOPS
428
422
423+
429optimizeBinop
424optimizeBinop
430 :: Context
425 :: Context
431 -> R.Region
426 -> R.Region
src/Optimize/Case.hs+1−1
@@ -15,7 +15,7 @@ import qualified Optimize.DecisionTree as DT
15-- OPTIMIZE A CASE EXPRESSION
15-- OPTIMIZE A CASE EXPRESSION
16
16
17
17
18−optimize :: DT.VariantDict -> String -> [(P.CanonicalPattern, Opt.Expr)] -> Opt.Expr
18+optimize :: DT.VariantDict -> String -> [(P.Canonical, Opt.Expr)] -> Opt.Expr
19optimize variantDict exprName optBranches =
19optimize variantDict exprName optBranches =
20 let
20 let
21 (patterns, indexedBranches) =
21 (patterns, indexedBranches) =
src/Optimize/DecisionTree.hs+17−12
@@ -24,7 +24,7 @@ import qualified AST.Variable as Var
24import qualified Reporting.Annotation as A
24import qualified Reporting.Annotation as A
25
25
26
26
27−type CPattern = P.CanonicalPattern
27+type CPattern = P.Canonical
28
28
29
29
30-- COMPILE CASES
30-- COMPILE CASES
@@ -431,19 +431,24 @@ addWeights toWeight paths =
431
431
432
432
433bests :: [(Path, Int)] -> [Path]
433bests :: [(Path, Int)] -> [Path]
434−bests ((path,weight):weightedPaths) =
434+bests allPaths =
435− let
435+ case allPaths of
436− gatherMinimum acc@(minWeight, paths) (path, weight) =
436+ [] ->
437− if weight == minWeight then
437+ error "Cannot choose the best of zero paths. This should never happen."
438− (minWeight, path : paths)
439
438
439+ (headPath, headWeight) : weightedPaths ->
440+ let
441+ gatherMinimum acc@(minWeight, paths) (path, weight) =
440− else if weight < minWeight then
442+ if weight == minWeight then
441− (weight, [path])
443+ (minWeight, path : paths)
442
444
445+ else if weight < minWeight then
446+ (weight, [path])
447+
443− else
448+ else
444− acc
449+ acc
445− in
450+ in
446− snd (List.foldl' gatherMinimum (weight, [path]) weightedPaths)
451+ snd (List.foldl' gatherMinimum (headWeight, [headPath]) weightedPaths)
447
452
448
453
449-- PATH PICKING HEURISTICS
454-- PATH PICKING HEURISTICS
src/Optimize/Inline.hs+29−18
@@ -6,7 +6,6 @@ import Control.Monad (foldM)
6import qualified Data.List as List
6import qualified Data.List as List
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8
8
9−import AST.Expression.General (PortImpl(..))
10import AST.Expression.Optimized (Expr(..), Decider(..), Choice(..))
9import AST.Expression.Optimized (Expr(..), Decider(..), Choice(..))
11import qualified AST.Expression.Optimized as Opt
10import qualified AST.Expression.Optimized as Opt
12import qualified AST.Variable as Var
11import qualified AST.Variable as Var
@@ -50,8 +49,11 @@ processSubs (Subs subs defs) (name, (n, expr)) =
50 (Map.insert name (Opt.Var (Var.local uniqueName)) subs)
49 (Map.insert name (Opt.Var (Var.local uniqueName)) subs)
51 ((uniqueName, expr) : defs)
50 ((uniqueName, expr) : defs)
52
51
52+
53+
53-- HELPERS
54-- HELPERS
54
55
56+
55deleteBatch :: [String] -> Map.Map String a -> Map.Map String a
57deleteBatch :: [String] -> Map.Map String a -> Map.Map String a
56deleteBatch names dict =
58deleteBatch names dict =
57 List.foldl' (flip Map.delete) dict names
59 List.foldl' (flip Map.delete) dict names
@@ -67,8 +69,10 @@ getDefName def =
67 name
69 name
68
70
69
71
72+
70-- COUNT VARIABLE APPEARANCES
73-- COUNT VARIABLE APPEARANCES
71
74
75+
72count :: Opt.Expr -> Map.Map String Int
76count :: Opt.Expr -> Map.Map String Int
73count expression =
77count expression =
74 let
78 let
@@ -165,16 +169,20 @@ count expression =
165 Record fields ->
169 Record fields ->
166 countMany (map snd fields)
170 countMany (map snd fields)
167
171
168− Port impl ->
172+ Cmd _ ->
169− case impl of
173+ Map.empty
170− In _ _ ->
174+
175+ Sub _ ->
171− Map.empty
176+ Map.empty
172
177
173− Out _name expr _tipe ->
178+ OutgoingPort _ _ ->
174− count expr
179+ Map.empty
180+
181+ IncomingPort _ _ ->
182+ Map.empty
175
183
176− Task _name expr _tipe ->
184+ Program _ expr ->
177− count expr
185+ count expr
178
186
179 GLShader _ _ _ ->
187 GLShader _ _ _ ->
180 Map.empty
188 Map.empty
@@ -275,17 +283,20 @@ replace substitutions expression =
275 Record fields ->
283 Record fields ->
276 Record (map (second go) fields)
284 Record (map (second go) fields)
277
285
278− Port impl ->
286+ Cmd _ ->
279− Port $
287+ expression
280− case impl of
281− In _ _ ->
282− impl
283
288
284− Out name expr tipe ->
289+ Sub _ ->
285− Out name (go expr) tipe
290+ expression
291+
292+ OutgoingPort _ _ ->
293+ expression
294+
295+ IncomingPort _ _ ->
296+ expression
286
297
287− Task name expr tipe ->
298+ Program kind expr ->
288− Task name (go expr) tipe
299+ Program kind (go expr)
289
300
290 GLShader _ _ _ ->
301 GLShader _ _ _ ->
291 expression
302 expression
src/Parse/Declaration.hs+45−36
@@ -1,34 +1,49 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2module Parse.Declaration where
2module Parse.Declaration where
3
3
4−import Text.Parsec ( (<|>), (<?>), choice, digit, optionMaybe, string, try )
4+import Text.Parsec ( (<?>), choice, digit, optionMaybe, string, try )
5
5
6−import qualified AST.Declaration as D
6+import qualified AST.Declaration as Decl
7import qualified Parse.Expression as Expr
7import qualified Parse.Expression as Expr
8import Parse.Helpers as Help
8import Parse.Helpers as Help
9import qualified Parse.Type as Type
9import qualified Parse.Type as Type
10
10
11
11
12+
12−declaration :: IParser D.SourceDecl
13+declaration :: IParser Decl.Source
13declaration =
14declaration =
15+ commentOr $ addLocation $
16+ choice
17+ [ typeDecl
18+ , infixDecl
19+ , portDecl
20+ , definition
21+ ]
22+
23+
24+commentOr :: IParser a -> IParser (Decl.CommentOr a)
25+commentOr parser =
14 choice
26 choice
15− [ D.Comment <$> Help.docComment
27+ [ Decl.Comment <$> addLocation Help.docComment
16− , D.Decl <$> addLocation (typeDecl <|> infixDecl <|> port <|> definition)
28+ , Decl.Whatever <$> parser
17 ]
29 ]
18
30
19
31
32+
20-- TYPE ANNOTATIONS and DEFINITIONS
33-- TYPE ANNOTATIONS and DEFINITIONS
21
34
35+
22−definition :: IParser D.SourceDecl'
36+definition :: IParser Decl.Raw
23definition =
37definition =
24− D.Definition
25− <$> (Expr.typeAnnotation <|> Expr.definition)
26− <?> "a value definition"
38+ do def <- Expr.def <?> "a value definition"
39+ return $ Decl.Def def
40+
27
41
28
42
29-- TYPE ALIAS and UNION TYPES
43-- TYPE ALIAS and UNION TYPES
30
44
45+
31−typeDecl :: IParser D.SourceDecl'
46+typeDecl :: IParser Decl.Raw
32typeDecl =
47typeDecl =
33 do try (reserved "type") <?> "a type declaration"
48 do try (reserved "type") <?> "a type declaration"
34 forcedWS
49 forcedWS
@@ -41,50 +56,44 @@ typeDecl =
41 case isAlias of
56 case isAlias of
42 Just _ ->
57 Just _ ->
43 do tipe <- Type.expr <?> "a type"
58 do tipe <- Type.expr <?> "a type"
44− return (D.TypeAlias name args tipe)
59+ return $ Decl.Alias (Decl.Type name args tipe)
45
60
46 Nothing ->
61 Nothing ->
47 do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"
62 do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"
48− return $ D.Datatype name args tcs
63+ return $ Decl.Union (Decl.Type name args tcs)
64+
49
65
50
66
51-- INFIX
67-- INFIX
52
68
69+
53−infixDecl :: IParser D.SourceDecl'
70+infixDecl :: IParser Decl.Raw
54infixDecl =
71infixDecl =
55 expecting "an infix declaration" $
72 expecting "an infix declaration" $
56 do assoc <-
73 do assoc <-
57 choice
74 choice
58− [ try (reserved "infixl") >> return D.L
75+ [ try (reserved "infixl") >> return Decl.L
59− , try (reserved "infixr") >> return D.R
76+ , try (reserved "infixr") >> return Decl.R
60− , try (reserved "infix") >> return D.N
77+ , try (reserved "infix") >> return Decl.N
61 ]
78 ]
62 forcedWS
79 forcedWS
63 n <- digit
80 n <- digit
64 forcedWS
81 forcedWS
82+ op <- anyOp
65− D.Fixity assoc (read [n]) <$> anyOp
83+ return $ Decl.Fixity (Decl.Infix op assoc (read [n]))
66
84
67
85
68−-- PORT
69
86
70−port :: IParser D.SourceDecl'
87+-- FOREIGN
71−port =
88+
89+
90+portDecl :: IParser Decl.Raw
91+portDecl =
72 expecting "a port declaration" $
92 expecting "a port declaration" $
73 do try (reserved "port")
93 do try (reserved "port")
74− whitespace
94+ forcedWS
75− name <- lowVar
95+ name <- Help.lowVar
76− whitespace
77− choice [ portAnnotation name, portDefinition name ]
78− where
79− portAnnotation name =
80− do try hasType
96+ padded hasType
81− whitespace
82− tipe <- Type.expr <?> "a type"
97+ tipe <- Type.expr
83− return (D.Port (D.PortAnnotation name tipe))
98+ return $ Decl.Port name tipe
84−
85− portDefinition name =
86− do try equals
87− whitespace
88− expr <- Expr.expr
89− return (D.Port (D.PortDefinition name expr))
90
99
src/Parse/Expression.hs+39−17
@@ -1,4 +1,4 @@
1−module Parse.Expression (term, typeAnnotation, definition, expr) where
1+module Parse.Expression (term, annotation, definition, expr, def) where
2
2
3import qualified Data.List as List
3import qualified Data.List as List
4import Text.Parsec hiding (newline, spaces)
4import Text.Parsec hiding (newline, spaces)
@@ -15,12 +15,15 @@ import qualified AST.Expression.General as E
15import qualified AST.Expression.Source as Source
15import qualified AST.Expression.Source as Source
16import qualified AST.Literal as L
16import qualified AST.Literal as L
17import qualified AST.Pattern as P
17import qualified AST.Pattern as P
18+import qualified AST.Type as T
18import qualified AST.Variable as Var
19import qualified AST.Variable as Var
19import qualified Reporting.Annotation as A
20import qualified Reporting.Annotation as A
20
21
21
22
23+
22-------- Basic Terms --------
24-------- Basic Terms --------
23
25
26+
24varTerm :: IParser Source.Expr'
27varTerm :: IParser Source.Expr'
25varTerm =
28varTerm =
26 toVar <$> var
29 toVar <$> var
@@ -70,8 +73,10 @@ negative =
70 nTerm
73 nTerm
71
74
72
75
76+
73-------- Complex Terms --------
77-------- Complex Terms --------
74
78
79+
75listTerm :: IParser Source.Expr'
80listTerm :: IParser Source.Expr'
76listTerm =
81listTerm =
77 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
82 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
@@ -122,7 +127,6 @@ parensTerm =
122 return (mkExpr start end)
127 return (mkExpr start end)
123
128
124
129
125−
126recordTerm :: IParser Source.Expr
130recordTerm :: IParser Source.Expr
127recordTerm =
131recordTerm =
128 addLocation $ brackets $ choice $
132 addLocation $ brackets $ choice $
@@ -168,8 +172,10 @@ term =
168 <?> "an expression"
172 <?> "an expression"
169
173
170
174
175+
171-------- Applications --------
176-------- Applications --------
172
177
178+
173appExpr :: IParser Source.Expr
179appExpr :: IParser Source.Expr
174appExpr =
180appExpr =
175 expecting "an expression" $
181 expecting "an expression" $
@@ -182,8 +188,10 @@ appExpr =
182 _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts
188 _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts
183
189
184
190
191+
185-------- Normal Expressions --------
192-------- Normal Expressions --------
186
193
194+
187expr :: IParser Source.Expr
195expr :: IParser Source.Expr
188expr =
196expr =
189 addLocation (choice [ letExpr, caseExpr, ifExpr ])
197 addLocation (choice [ letExpr, caseExpr, ifExpr ])
@@ -256,51 +264,65 @@ caseExpr =
256 (,) p <$> expr
264 (,) p <$> expr
257
265
258
266
267+
259-- LET
268-- LET
260
269
270+
261letExpr :: IParser Source.Expr'
271letExpr :: IParser Source.Expr'
262letExpr =
272letExpr =
263 do try (reserved "let")
273 do try (reserved "let")
264 whitespace
274 whitespace
265 defs <-
275 defs <-
266− Indent.block $
276+ Indent.block (def <* whitespace)
267− do def <- typeAnnotation <|> definition
277+ whitespace
268− whitespace
269− return def
270− padded (reserved "in")
278+ reserved "in"
279+ whitespace
271 E.Let defs <$> expr
280 E.Let defs <$> expr
272
281
273
282
283+def :: IParser Source.Def
284+def =
285+ choice
286+ [ annotation Source.Annotation
287+ , definition Source.Definition
288+ ]
289+
290+
291+
274-- TYPE ANNOTATION
292-- TYPE ANNOTATION
275
293
276−typeAnnotation :: IParser Source.Def
294+
277−typeAnnotation =
295+annotation :: (String -> T.Raw -> a) -> IParser (A.Located a)
278− addLocation (Source.TypeAnnotation <$> try start <*> Type.expr)
296+annotation creator =
279− where
297+ let
280 start =
298 start =
281 do v <- lowVar <|> parens symOp
299 do v <- lowVar <|> parens symOp
282 padded hasType
300 padded hasType
283 return v
301 return v
302+ in
303+ addLocation (creator <$> try start <*> Type.expr)
304+
284
305
285
306
286-- DEFINITION
307-- DEFINITION
287
308
309+
288−definition :: IParser Source.Def
310+definition :: (P.Raw -> Source.Expr -> a) -> IParser (A.Located a)
289−definition =
311+definition creator =
290 addLocation $
312 addLocation $
291 Indent.withPos $
313 Indent.withPos $
292 do (name, args) <- defStart
314 do (name, args) <- defStart
293 padded equals
315 padded equals
294 body <- expr
316 body <- expr
295− return . Source.Definition name $ makeFunction args body
317+ return . creator name $ makeFunction args body
296
318
297
319
298−makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
320+makeFunction :: [P.Raw] -> Source.Expr -> Source.Expr
299makeFunction args body@(A.A ann _) =
321makeFunction args body@(A.A ann _) =
300− foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args
322+ foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args
301
323
302
324
303−defStart :: IParser (P.RawPattern, [P.RawPattern])
325+defStart :: IParser (P.Raw, [P.Raw])
304defStart =
326defStart =
305 expecting "the definition of a value (x = ...)" $
327 expecting "the definition of a value (x = ...)" $
306 do starter <- try Pattern.term <|> addLocation (P.Var <$> parens symOp)
328 do starter <- try Pattern.term <|> addLocation (P.Var <$> parens symOp)
src/Parse/Helpers.hs+3−4
@@ -29,10 +29,9 @@ reserveds =
29 , "let", "in"
29 , "let", "in"
30 , "type"
30 , "type"
31 , "module", "where"
31 , "module", "where"
32− , "import", "as", "hiding", "exposing"
32+ , "import", "exposing"
33− , "port", "export", "foreign"
33+ , "as"
34− , "perform"
34+ , "port"
35− , "deriving"
36 ]
35 ]
37
36
38
37
src/Parse/Module.hs+83−19
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1module Parse.Module (moduleDecl, header, getModuleName) where
2module Parse.Module (moduleDecl, header, getModuleName) where
2
3
3import Text.Parsec hiding (newline, spaces)
4import Text.Parsec hiding (newline, spaces)
@@ -6,49 +7,112 @@ import Parse.Helpers
6import qualified AST.Module as Module
7import qualified AST.Module as Module
7import qualified AST.Module.Name as ModuleName
8import qualified AST.Module.Name as ModuleName
8import qualified AST.Variable as Var
9import qualified AST.Variable as Var
9−import Reporting.Annotation as A
10+import qualified Reporting.Annotation as A
11+import qualified Reporting.Region as R
10
12
11
13
12getModuleName :: String -> Maybe String
14getModuleName :: String -> Maybe String
13getModuleName source =
15getModuleName source =
16+ let
17+ minimalParser =
18+ do optional freshLine
19+ (ModuleDecl _ names _ _) <- moduleDecl
20+ return (ModuleName.toString names)
21+ in
14− case iParse getModuleName source of
22+ case iParse minimalParser source of
15− Right name ->
23+ Right name ->
16 Just name
24 Just name
17
25
18− Left _ ->
26+ Left _ ->
19 Nothing
27 Nothing
20− where
21− getModuleName =
22− do optional freshLine
23− (names, _) <- moduleDecl
24− return (ModuleName.toString names)
25
28
26
29
27header :: IParser (Module.Header [Module.UserImport])
30header :: IParser (Module.Header [Module.UserImport])
28header =
31header =
29 do optional freshLine
32 do optional freshLine
30− (names, exports) <-
33+ (ModuleDecl tag names exports settings) <-
34+ option
35+ (ModuleDecl Module.Normal ["Main"] Var.openListing Module.emptySettings)
31− option (["Main"], Var.openListing) (moduleDecl `followedBy` freshLine)
36+ (moduleDecl `followedBy` freshLine)
37+
32 docs <-
38 docs <-
33 choice
39 choice
34 [ addLocation (Just <$> docComment) `followedBy` freshLine
40 [ addLocation (Just <$> docComment) `followedBy` freshLine
35 , addLocation (return Nothing)
41 , addLocation (return Nothing)
36 ]
42 ]
43+
37 imports' <- imports
44 imports' <- imports
38− return (Module.Header names docs exports imports')
39
45
46+ return (Module.Header tag names exports settings docs imports')
47+
48+
49+data ModuleDecl =
50+ ModuleDecl
51+ { _tag :: Module.SourceTag
52+ , _name :: [String]
53+ , _exports :: Var.Listing (A.Located Var.Value)
54+ , _settings :: Module.SourceSettings
55+ }
40
56
57+
41−moduleDecl :: IParser ([String], Var.Listing (A.Located Var.Value))
58+moduleDecl :: IParser ModuleDecl
42moduleDecl =
59moduleDecl =
43 expecting "a module declaration" $
60 expecting "a module declaration" $
44− do try (reserved "module")
61+ do
62+ tag <- parseTag
45 whitespace
63 whitespace
64+
46 names <- dotSep1 capVar <?> "the name of this module"
65 names <- dotSep1 capVar <?> "the name of this module"
47 whitespace
66 whitespace
67+
68+ settings <-
69+ case tag of
70+ Module.Effect _ ->
71+ parseSetting <* whitespace
72+
73+ _ ->
74+ return Module.emptySettings
75+
76+ reserved "exposing" <?> "something like `exposing (..)` which replaced `where` in 0.17"
77+ whitespace
78+
48− exports <- option Var.openListing (listing (addLocation value))
79+ exports <- listing (addLocation value)
80+
81+ return (ModuleDecl tag names exports settings)
82+
83+
84+parseTag :: IParser Module.SourceTag
85+parseTag =
86+ choice
87+ [
88+ do try (reserved "module")
89+ return Module.Normal
90+ ,
91+ do start <- getMyPosition
92+ try (reserved "effect")
93+ whitespace
94+ reserved "module"
95+ end <- getMyPosition
96+ return (Module.Effect (R.Region start end))
97+ ,
98+ do start <- getMyPosition
99+ try (reserved "port")
100+ whitespace
101+ reserved "module"
102+ end <- getMyPosition
103+ return (Module.Port (R.Region start end))
104+ ]
105+
106+
107+parseSetting :: IParser Module.SourceSettings
108+parseSetting =
109+ do try (reserved "where")
49 whitespace
110 whitespace
50− reserved "where"
111+ addLocation $ brackets $ commaSep $
51− return (names, exports)
112+ do name <- addLocation lowVar
113+ padded equals
114+ typeName <- addLocation capVar
115+ return (name, typeName)
52
116
53
117
54imports :: IParser [Module.UserImport]
118imports :: IParser [Module.UserImport]
@@ -89,14 +153,14 @@ listing item =
89 expecting "a listing of values and types to expose, like (..)" $
153 expecting "a listing of values and types to expose, like (..)" $
90 do try (whitespace >> char '(')
154 do try (whitespace >> char '(')
91 whitespace
155 whitespace
92− listing <-
156+ actualListing <-
93 choice
157 choice
94 [ const Var.openListing <$> string ".."
158 [ const Var.openListing <$> string ".."
95 , Var.Listing <$> commaSep1 item <*> return False
159 , Var.Listing <$> commaSep1 item <*> return False
96 ]
160 ]
97 whitespace
161 whitespace
98 char ')'
162 char ')'
99− return listing
163+ return actualListing
100
164
101
165
102value :: IParser Var.Value
166value :: IParser Var.Value
src/Parse/Parse.hs+40−46
@@ -1,4 +1,4 @@
1−{-# OPTIONS_GHC -Wall #-}
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2module Parse.Parse (program, parse) where
2module Parse.Parse (program, parse) where
3
3
4import qualified Data.Map as Map
4import qualified Data.Map as Map
@@ -6,72 +6,69 @@ import qualified Data.Traversable as T
6import Text.Parsec (char, eof, letter, many, putState, (<|>))
6import Text.Parsec (char, eof, letter, many, putState, (<|>))
7import qualified Text.Parsec.Error as Parsec
7import qualified Text.Parsec.Error as Parsec
8
8
9−import qualified AST.Declaration as D
9+import qualified AST.Declaration as Decl
10−import qualified AST.Module as M
10+import qualified AST.Module as Module
11import qualified AST.Module.Name as ModuleName
11import qualified AST.Module.Name as ModuleName
12−import qualified Elm.Compiler.Imports as Imports
13import qualified Elm.Package as Package
12import qualified Elm.Package as Package
14import Parse.Helpers
13import Parse.Helpers
15−import qualified Parse.Module as Module
14+import qualified Parse.Module as Parse (header)
16−import qualified Parse.Declaration as Decl
15+import qualified Parse.Declaration as Parse (declaration, infixDecl)
17import qualified Reporting.Region as R
16import qualified Reporting.Region as R
18import qualified Reporting.Error.Syntax as Error
17import qualified Reporting.Error.Syntax as Error
19import qualified Reporting.Result as Result
18import qualified Reporting.Result as Result
20import qualified Validate
19import qualified Validate
21
20
22
21
23−program
24− :: Package.Name
25− -> Bool
26− -> OpTable
27− -> String
28− -> Result.Result wrn Error.Error M.ValidModule
29−program pkgName isRoot table src =
30− do (M.Module name filePath docs exports imports sourceDecls) <-
31− parseWithTable table src (programParser pkgName)
32
22
33− validDecls <- Validate.declarations isRoot sourceDecls
23+program :: Package.Name -> OpTable -> String -> Validate.Result wrn Module.Valid
24+program pkgName table src =
25+ do modul <-
26+ parseWithTable table src (programParser pkgName)
34
27
35− -- determine if default imports should be added, only elm-lang/core is exempt
28+ Validate.module' modul
36− let ammendedImports =
37− ( if pkgName == Package.coreName then [] else Imports.defaults
38− , imports
39− )
40
29
41− return (M.Module name filePath docs exports ammendedImports validDecls)
42
30
43
31
44-- HEADERS AND DECLARATIONS
32-- HEADERS AND DECLARATIONS
45
33
34+
46−programParser :: Package.Name -> IParser M.SourceModule
35+programParser :: Package.Name -> IParser Module.Source
47programParser pkgName =
36programParser pkgName =
48− do (M.Header name docs exports imports) <- Module.header
37+ do (Module.Header tag name exports settings docs imports) <-
38+ Parse.header
39+
40+ decls <-
49− decls <- declarations
41+ declarations
42+
50− _ <- many (spaces <|> newline)
43+ many (spaces <|> newline)
51− eof
52
44
53− let canonicalName =
45+ eof
54− ModuleName.Canonical pkgName name
55
46
47+ return $
48+ Module.Module
49+ (ModuleName.Canonical pkgName name)
50+ ""
56− return $ M.Module canonicalName "" docs exports imports decls
51+ (Module.Source tag settings docs exports imports decls)
57
52
58
53
59−declarations :: IParser [D.SourceDecl]
54+declarations :: IParser [Decl.Source]
60declarations =
55declarations =
61− (:) <$> Decl.declaration
56+ (:) <$> Parse.declaration
62 <*> many freshDef
57 <*> many freshDef
63
58
64
59
65−freshDef :: IParser D.SourceDecl
60+freshDef :: IParser Decl.Source
66freshDef =
61freshDef =
67 commitIf (freshLine >> (letter <|> char '_')) $
62 commitIf (freshLine >> (letter <|> char '_')) $
68− do _ <- freshLine
63+ do freshLine
69− Decl.declaration
64+ Parse.declaration
65+
70
66
71
67
72-- RUN PARSERS
68-- RUN PARSERS
73
69
70+
74−parse :: String -> IParser a -> Result.Result wrn Error.Error a
71+parse :: String -> IParser a -> Validate.Result wrn a
75parse source parser =
72parse source parser =
76 case iParse parser source of
73 case iParse parser source of
77 Right result ->
74 Right result ->
@@ -84,11 +81,7 @@ parse source parser =
84 Result.throw (R.Region pos pos) (Error.Parse msgs)
81 Result.throw (R.Region pos pos) (Error.Parse msgs)
85
82
86
83
87−parseWithTable
84+parseWithTable :: OpTable -> String -> IParser a -> Validate.Result wrn a
88− :: OpTable
89− -> String
90− -> IParser a
91− -> Result.Result wrn Error.Error a
92parseWithTable table source parser =
85parseWithTable table source parser =
93 do infixInfoList <- parse source parseFixities
86 do infixInfoList <- parse source parseFixities
94
87
@@ -102,10 +95,11 @@ parseWithTable table source parser =
102
95
103-- INFIX INFO
96-- INFIX INFO
104
97
98+
105makeInfixTable
99makeInfixTable
106− :: Map.Map String (Int, D.Assoc)
100+ :: Map.Map String (Int, Decl.Assoc)
107 -> [(String, InfixInfo)]
101 -> [(String, InfixInfo)]
108− -> Result.Result wrn Error.Error (Map.Map String (Int, D.Assoc))
102+ -> Validate.Result wrn (Map.Map String (Int, Decl.Assoc))
109makeInfixTable table newInfo =
103makeInfixTable table newInfo =
110 let add (op, info) dict =
104 let add (op, info) dict =
111 Map.insertWith (++) op [info] dict
105 Map.insertWith (++) op [info] dict
@@ -135,12 +129,12 @@ parseFixities =
135 where
129 where
136 infics =
130 infics =
137 do start <- getMyPosition
131 do start <- getMyPosition
138− (D.Fixity assoc level op) <- Decl.infixDecl
132+ (Decl.Fixity (Decl.Infix op assoc level)) <- Parse.infixDecl
139 end <- getMyPosition
133 end <- getMyPosition
140 return (op, InfixInfo (R.Region start end) (level, assoc))
134 return (op, InfixInfo (R.Region start end) (level, assoc))
141
135
142
136
143data InfixInfo = InfixInfo
137data InfixInfo = InfixInfo
144 { _region :: R.Region
138 { _region :: R.Region
145− , _info :: (Int, D.Assoc)
139+ , _info :: (Int, Decl.Assoc)
146− }
140+ }
src/Parse/Pattern.hs+8−8
@@ -13,7 +13,7 @@ import qualified Reporting.Annotation as A
13import qualified Reporting.Region as R
13import qualified Reporting.Region as R
14
14
15
15
16−basic :: IParser P.RawPattern
16+basic :: IParser P.Raw
17basic =
17basic =
18 addLocation $
18 addLocation $
19 choice
19 choice
@@ -37,7 +37,7 @@ basic =
37 P.Var str
37 P.Var str
38
38
39
39
40−asPattern :: IParser P.RawPattern -> IParser P.RawPattern
40+asPattern :: IParser P.Raw -> IParser P.Raw
41asPattern patternParser =
41asPattern patternParser =
42 do pattern <- patternParser
42 do pattern <- patternParser
43
43
@@ -59,13 +59,13 @@ asPattern patternParser =
59 lowVar
59 lowVar
60
60
61
61
62−record :: IParser P.RawPattern
62+record :: IParser P.Raw
63record =
63record =
64 addLocation
64 addLocation
65 (P.Record <$> brackets (commaSep1 lowVar))
65 (P.Record <$> brackets (commaSep1 lowVar))
66
66
67
67
68−tuple :: IParser P.RawPattern
68+tuple :: IParser P.Raw
69tuple =
69tuple =
70 do (start, patterns, end) <-
70 do (start, patterns, end) <-
71 located (parens (commaSep expr))
71 located (parens (commaSep expr))
@@ -78,20 +78,20 @@ tuple =
78 return (A.at start end (P.tuple patterns))
78 return (A.at start end (P.tuple patterns))
79
79
80
80
81−list :: IParser P.RawPattern
81+list :: IParser P.Raw
82list =
82list =
83 braces $
83 braces $
84 do (_, patterns, end) <- located (commaSep expr)
84 do (_, patterns, end) <- located (commaSep expr)
85 return (P.list end patterns)
85 return (P.list end patterns)
86
86
87
87
88−term :: IParser P.RawPattern
88+term :: IParser P.Raw
89term =
89term =
90 choice [ record, tuple, list, basic ]
90 choice [ record, tuple, list, basic ]
91 <?> "a pattern"
91 <?> "a pattern"
92
92
93
93
94−patternConstructor :: IParser P.RawPattern
94+patternConstructor :: IParser P.Raw
95patternConstructor =
95patternConstructor =
96 addLocation $
96 addLocation $
97 do v <- List.intercalate "." <$> dotSep1 capVar
97 do v <- List.intercalate "." <$> dotSep1 capVar
@@ -101,7 +101,7 @@ patternConstructor =
101 _ -> P.Data (Var.Raw v) <$> spacePrefix term
101 _ -> P.Data (Var.Raw v) <$> spacePrefix term
102
102
103
103
104−expr :: IParser P.RawPattern
104+expr :: IParser P.Raw
105expr =
105expr =
106 asPattern subPattern <?> "a pattern"
106 asPattern subPattern <?> "a pattern"
107 where
107 where
src/Parse/Type.hs+2−2
@@ -2,7 +2,7 @@
2module Parse.Type where
2module Parse.Type where
3
3
4import Data.List (intercalate)
4import Data.List (intercalate)
5−import Text.Parsec ((<|>), (<?>), char, many, optionMaybe, string, try)
5+import Text.Parsec ((<|>), (<?>), char, choice, many, optionMaybe, string, try)
6
6
7import qualified AST.Type as Type
7import qualified AST.Type as Type
8import qualified AST.Variable as Var
8import qualified AST.Variable as Var
@@ -64,7 +64,7 @@ constructor0 =
64
64
65term :: IParser Type.Raw
65term :: IParser Type.Raw
66term =
66term =
67− tuple <|> record <|> tvar <|> constructor0
67+ choice [ tuple, record, tvar, constructor0 ]
68
68
69
69
70app :: IParser Type.Raw
70app :: IParser Type.Raw
src/Reporting/Annotation.hs+6
@@ -4,8 +4,10 @@ import Prelude hiding (map)
4import qualified Reporting.Region as R
4import qualified Reporting.Region as R
5
5
6
6
7+
7-- ANNOTATION
8-- ANNOTATION
8
9
10+
9data Annotated annotation a
11data Annotated annotation a
10 = A annotation a
12 = A annotation a
11
13
@@ -18,8 +20,10 @@ type Commented a =
18 Annotated (R.Region, Maybe String) a
20 Annotated (R.Region, Maybe String) a
19
21
20
22
23+
21-- CREATE
24-- CREATE
22
25
26+
23at :: R.Position -> R.Position -> a -> Located a
27at :: R.Position -> R.Position -> a -> Located a
24at start end value =
28at start end value =
25 A (R.Region start end) value
29 A (R.Region start end) value
@@ -35,8 +39,10 @@ sameAs (A annotation _) value =
35 A annotation value
39 A annotation value
36
40
37
41
42+
38-- MANIPULATE
43-- MANIPULATE
39
44
45+
40map :: (a -> b) -> Annotated info a -> Annotated info b
46map :: (a -> b) -> Annotated info a -> Annotated info b
41map f (A annotation value) =
47map f (A annotation value) =
42 A annotation (f value)
48 A annotation (f value)
src/Reporting/Bag.hsnew file+101
@@ -0,0 +1,101 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Reporting.Bag
3+ ( Bag
4+ , empty, singleton, cons, append, map
5+ , toList, fromList
6+ )
7+ where
8+
9+
10+import Prelude hiding (map)
11+
12+
13+
14+-- BAGS
15+
16+
17+data Bag a
18+ = Empty
19+ | One a
20+ | Two (Bag a) (Bag a)
21+ | Many [a]
22+
23+
24+empty :: Bag a
25+empty =
26+ Empty
27+
28+
29+singleton :: a -> Bag a
30+singleton =
31+ One
32+
33+
34+cons :: a -> Bag a -> Bag a
35+cons x bag =
36+ case bag of
37+ Empty ->
38+ One x
39+
40+ _ ->
41+ Two (One x) bag
42+
43+
44+append :: Bag a -> Bag a -> Bag a
45+append left right =
46+ case (left, right) of
47+ (other, Empty) ->
48+ other
49+
50+ (Empty, other) ->
51+ other
52+
53+ (_, _) ->
54+ Two left right
55+
56+
57+map :: (a -> b) -> Bag a -> Bag b
58+map func bag =
59+ case bag of
60+ Empty ->
61+ Empty
62+
63+ One x ->
64+ One (func x)
65+
66+ Two left right ->
67+ Two (map func left) (map func right)
68+
69+ Many xs ->
70+ Many (fmap func xs)
71+
72+
73+
74+-- LIST CONVERSIONS
75+
76+
77+fromList :: [a] -> Bag a
78+fromList =
79+ Many
80+
81+
82+toList :: (a -> b) -> Bag a -> [b]
83+toList func bag =
84+ toListHelp func bag []
85+
86+
87+toListHelp :: (a -> b) -> Bag a -> [b] -> [b]
88+toListHelp func bag list =
89+ case bag of
90+ Empty ->
91+ list
92+
93+ One x ->
94+ func x : list
95+
96+ Two left right ->
97+ toListHelp func left (toListHelp func right list)
98+
99+ Many xs ->
100+ foldr (\x newList -> func x : newList) list xs
101+
src/Reporting/Error/Canonicalize.hs+26−33
@@ -100,24 +100,17 @@ alias name expected actual =
100-- PORTS
100-- PORTS
101
101
102
102
103−data PortError = PortError
103+data PortError =
104+ PortError
104 { portName :: String
105 { portName :: String
105− , portIsInbound :: Bool
106− , portRootType :: Type.Canonical
107− , portLocalType :: Type.Canonical
106+ , portType :: Type.Canonical
108 , portMessage :: Maybe String
107 , portMessage :: Maybe String
109 }
108 }
110
109
111
110
112−port
113− :: String
114− -> Bool
115− -> Type.Canonical
111+port :: String -> Type.Canonical -> Maybe String -> Error
116− -> Type.Canonical
117− -> Maybe String
118− -> Error
119−port name isInbound rootType localType maybeMessage =
112+port name tipe maybeMessage =
120− Port (PortError name isInbound rootType localType maybeMessage)
113+ Port (PortError name tipe maybeMessage)
121
114
122
115
123
116
@@ -228,26 +221,26 @@ toReport localizer err =
228 ("You are trying to export `" ++ name ++ "` multiple times!")
221 ("You are trying to export `" ++ name ++ "` multiple times!")
229 "Remove duplicates until there is only one listed."
222 "Remove duplicates until there is only one listed."
230
223
231− Port (PortError name isInbound _rootType localType maybeMessage) ->
224+ Port (PortError name tipe maybeMessage) ->
232− let
225+ let
233− boundPort =
226+ context =
234− if isInbound then "inbound port" else "outbound port"
227+ maybe "" (" the following " ++ ) maybeMessage
235− in
228+ in
236− Report.report
229+ Report.report
237− "PORT ERROR"
230+ "PORT ERROR"
238− Nothing
231+ Nothing
239− ("Trying to send " ++ maybe "an unsupported type" id maybeMessage
232+ ("Port `" ++ name ++ "` is trying to communicate an unsupported type."
240− ++ " through " ++ boundPort ++ " `" ++ name ++ "`"
241− )
233+ )
242− ( Help.stack
234+ ( Help.stack
243− [ text "The specific unsupported type is:"
235+ [ text ("The specific unsupported type is" ++ context ++ ":")
244− , indent 4 (RenderType.toDoc localizer localType)
236+ , indent 4 (RenderType.toDoc localizer tipe)
245− , text ("The types of values that can flow through " ++ boundPort ++ "s include:")
237+ , text "The types of values that can flow through in and out of Elm include:"
246− , indent 4 $ Help.reflowParagraph $
238+ , indent 4 $ Help.reflowParagraph $
247− "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\
239+ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\
248− \ Tuples, Json.Values, and concrete records."
240+ \ Tuples, Json.Values, and concrete records."
241+ -- TODO add a note about custom decoders and encoders when they exist!
249− ]
242+ ]
250− )
243+ )
251
244
252
245
253argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report
246argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report
src/Reporting/Error/Syntax.hs+103−28
@@ -15,10 +15,19 @@ data Error
15 = Parse [Parsec.Message]
15 = Parse [Parsec.Message]
16 | BadFunctionName Int
16 | BadFunctionName Int
17 | BadPattern String
17 | BadPattern String
18+
19+ | CommentOnNothing
20+
21+ | SettingsOnNormalModule
22+ | SettingsOnPortModule
23+ | DuplicateSettingOnEffectModule String
24+ | BadSettingOnEffectModule String
25+ | NoSettingsOnEffectModule
26+ | MissingManagerOnEffectModule String
27+ | UnexpectedPort String
28+
18 | InfixDuplicate String
29 | InfixDuplicate String
19 | TypeWithoutDefinition String
30 | TypeWithoutDefinition String
20− | PortWithoutAnnotation String
21− | UnexpectedPort
22 | DuplicateFieldName String
31 | DuplicateFieldName String
23 | DuplicateValueDeclaration String
32 | DuplicateValueDeclaration String
24 | DuplicateTypeDeclaration String
33 | DuplicateTypeDeclaration String
@@ -64,6 +73,94 @@ toReport _localizer err =
64 ]
73 ]
65 )
74 )
66
75
76+ CommentOnNothing ->
77+ Report.report
78+ "STRAY COMMENT"
79+ Nothing
80+ ("This documentation comment is not followed by anything.")
81+ ( Help.reflowParagraph $
82+ "All documentation comments need to be right above the declaration they\
83+ \ describe. Maybe some code got deleted or commented out by accident? Or\
84+ \ maybe this comment is here by accident?"
85+ )
86+
87+ SettingsOnNormalModule ->
88+ Report.report
89+ "BAD MODULE DECLARATION"
90+ Nothing
91+ "A normal module can expose values, but not settings like this."
92+ ( Help.reflowParagraph $
93+ "If you want a normal module, just remove this stuff. If you want to create\
94+ \ an `effect module` you just forgot to use the `effect` keyword. In that\
95+ \ case, just change `module` to `effect module` and you should be headed in\
96+ \ the right direction!"
97+ )
98+
99+ SettingsOnPortModule ->
100+ Report.report
101+ "BAD MODULE DECLARATION"
102+ Nothing
103+ "A port module can expose values, but not have settings like this."
104+ ( Help.reflowParagraph $
105+ "If you want a port module, just remove this stuff. If you want to create\
106+ \ a custom effect module instead (which is rare) just change `port module`\
107+ \ to `effect module` and you should be headed in the right direction!"
108+ )
109+
110+ DuplicateSettingOnEffectModule name ->
111+ Report.report
112+ "EFFECT MODULE PROBLEM"
113+ Nothing
114+ ("You have defined " ++ Help.functionName name ++ " multiple times.")
115+ ( Help.reflowParagraph $
116+ "There can only be one " ++ Help.functionName name
117+ ++ " though! Remove until there is one left."
118+ )
119+
120+ BadSettingOnEffectModule name ->
121+ Report.report
122+ "EFFECT MODULE PROBLEM"
123+ Nothing
124+ ("Setting " ++ Help.functionName name ++ " is not recognized.")
125+ ( Help.reflowParagraph $
126+ "Remove this entry and you should be all set!"
127+ )
128+
129+ NoSettingsOnEffectModule ->
130+ Report.report
131+ "EFFECT MODULE PROBLEM"
132+ Nothing
133+ ("You are defining an effect module, but it has no settings.")
134+ ( Help.reflowParagraph $
135+ "If you just wanted a normal module, change the keywords `effect module`\
136+ \ to `module` and you should be all set. If you want a proper effect module,\
137+ \ you need to specify your commands and/or subscriptions. Read more about this\
138+ \ here: <TODO> (please forgive me if I forgot to fill this in!)"
139+ )
140+
141+ MissingManagerOnEffectModule name ->
142+ Report.report
143+ "EFFECT MODULE PROBLEM"
144+ Nothing
145+ ("You are defining an effect module, but there is no " ++ Help.functionName name ++ " defined.")
146+ ( Help.reflowParagraph $
147+ "There is a small set of top-level functions and values that must be defined\
148+ \ in any complete effect module. The best thing is probably to just read more\
149+ \ about effect modules here:\
150+ \ <TODO> (please forgive me if I forgot to fill this in!)"
151+ )
152+
153+ UnexpectedPort name ->
154+ Report.report
155+ "BAD PORT"
156+ Nothing
157+ ("You are declaring port " ++ Help.functionName name ++ " in a normal module.")
158+ ( Help.reflowParagraph $
159+ "All ports must be defined in a `port module`. You should probably have just\
160+ \ one of these for your project. This way all of your foreign interactions\
161+ \ stay relatively organized."
162+ )
163+
67 InfixDuplicate opName ->
164 InfixDuplicate opName ->
68 Report.report
165 Report.report
69 "INFIX OVERLAP"
166 "INFIX OVERLAP"
@@ -87,28 +184,6 @@ toReport _localizer err =
87 ++ " " ++ valueName ++ " = 42"
184 ++ " " ++ valueName ++ " = 42"
88 )
185 )
89
186
90− PortWithoutAnnotation portName ->
91− Report.report
92− "PORT ERROR"
93− Nothing
94− ("Port `" ++ portName ++ "` does not have a type annotation!")
95− ( text $
96− "Directly above the port definition, I need something like this:\n\n"
97− ++ " port " ++ portName ++ " : Signal Int"
98− )
99−
100−
101− UnexpectedPort ->
102− Report.report
103− "PORT ERROR"
104− Nothing
105− "This module has ports, but ports can only appear in the main module."
106− ( Help.reflowParagraph $
107− "Ports in library code would create hidden dependencies where importing a\
108− \ module could bring in constraints not captured in the public API. Furthermore,\
109− \ if the module is imported twice, do we send values out the port twice?"
110− )
111−
112 DuplicateFieldName name ->
187 DuplicateFieldName name ->
113 Report.report
188 Report.report
114 "DUPLICATE FIELD"
189 "DUPLICATE FIELD"
@@ -191,7 +266,7 @@ toReport _localizer err =
191
266
192
267
193unboundTypeVars :: String -> String -> [String] -> [String] -> Report.Report
268unboundTypeVars :: String -> String -> [String] -> [String] -> Report.Report
194−unboundTypeVars declKind typeName givenVars unboundVars@(tvar:_) =
269+unboundTypeVars declKind typeName givenVars unboundVars =
195 Report.report
270 Report.report
196 "UNBOUND TYPE VARIABLES"
271 "UNBOUND TYPE VARIABLES"
197 Nothing
272 Nothing
@@ -205,9 +280,9 @@ unboundTypeVars declKind typeName givenVars unboundVars@(tvar:_) =
205 ++ map (dullyellow . text) unboundVars
280 ++ map (dullyellow . text) unboundVars
206 ++ map text ["=", "..."]
281 ++ map text ["=", "..."]
207 , Help.reflowParagraph $
282 , Help.reflowParagraph $
208− "Here's why. Imagine one `" ++ typeName ++ "` where `" ++ tvar ++ "` is an Int and\
283+ "Here's why. Imagine one `" ++ typeName ++ "` where `" ++ head unboundVars ++
209− \ another where it is a Bool. When we explicitly list the type variables, type\
284+ "` is an Int and another where it is a Bool. When we explicitly list the type\
210− \ checker can see that they are actually different types."
285+ \ variables, type checker can see that they are actually different types."
211 ]
286 ]
212 )
287 )
213
288
src/Reporting/Error/Type.hs+90−5
@@ -23,6 +23,7 @@ import qualified Reporting.Report as Report
23data Error
23data Error
24 = Mismatch Mismatch
24 = Mismatch Mismatch
25 | BadMain Type.Canonical
25 | BadMain Type.Canonical
26+ | BadFlags Type.Canonical (Maybe String)
26 | InfiniteType String Type.Canonical
27 | InfiniteType String Type.Canonical
27
28
28
29
@@ -72,6 +73,10 @@ data Hint
72 | Range
73 | Range
73 | Lambda
74 | Lambda
74 | Record
75 | Record
76+ -- effect manager problems
77+ | Manager String
78+ | State String
79+ | SelfMsg
75
80
76
81
77data Pattern
82data Pattern
@@ -98,15 +103,34 @@ toReport localizer err =
98 Report.report
103 Report.report
99 "BAD MAIN TYPE"
104 "BAD MAIN TYPE"
100 Nothing
105 Nothing
101− "The 'main' value has an unsupported type."
106+ "The `main` value has an unsupported type."
102 ( Help.stack
107 ( Help.stack
103 [ Help.reflowParagraph $
108 [ Help.reflowParagraph $
104− "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\
109+ "I need Html, Svg, or a Program so I have something to render on\
105− \ on screen, but you gave me:"
110+ \ screen, but you gave me:"
106 , indent 4 (RenderType.toDoc localizer tipe)
111 , indent 4 (RenderType.toDoc localizer tipe)
107 ]
112 ]
108 )
113 )
109
114
115+ BadFlags tipe maybeMessage ->
116+ let
117+ context =
118+ maybe "" (" the following " ++ ) maybeMessage
119+ in
120+ Report.report
121+ "BAD FLAGS"
122+ Nothing
123+ ("Your `main` is demanding an unsupported type as a flag."
124+ )
125+ ( Help.stack
126+ [ text ("The specific unsupported type is" ++ context ++ ":")
127+ , indent 4 (RenderType.toDoc localizer tipe)
128+ , text "The types of values that can flow through in and out of Elm include:"
129+ , indent 4 $ Help.reflowParagraph $
130+ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\
131+ \ Tuples, Json.Values, and concrete records."
132+ ]
133+ )
110
134
111
135
112-- TYPE MISMATCHES
136-- TYPE MISMATCHES
@@ -281,7 +305,7 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =
281 ( cmpHint
305 ( cmpHint
282 (Help.capitalize (funcName maybeName) ++ " is expecting the argument to be:")
306 (Help.capitalize (funcName maybeName) ++ " is expecting the argument to be:")
283 "But it is:"
307 "But it is:"
284− []
308+ (functionHint maybeName)
285 )
309 )
286
310
287 UnexpectedArg maybeName index _totalArgs region ->
311 UnexpectedArg maybeName index _totalArgs region ->
@@ -295,7 +319,9 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =
295 ++ Help.ordinalize index ++ " argument to be:"
319 ++ Help.ordinalize index ++ " argument to be:"
296 )
320 )
297 "But it is:"
321 "But it is:"
322+ ( functionHint maybeName
323+ ++
298− ( if index == 1 then
324+ if index == 1 then
299 []
325 []
300 else
326 else
301 [ "I always figure out the type of arguments from left to right. If an argument\
327 [ "I always figure out the type of arguments from left to right. If an argument\
@@ -425,6 +451,45 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =
425 []
451 []
426 )
452 )
427
453
454+ Manager name ->
455+ report
456+ Nothing
457+ ("The `" ++ name ++ "` in your effect manager has a weird type.")
458+ ( cmpHint
459+ ("Your `" ++ name ++ "` function has this type:")
460+ "But it needs to have a type like this:"
461+ [ "TODO - link to overview of effect managers"
462+ ]
463+ )
464+
465+ State name ->
466+ report
467+ Nothing
468+ ( "Your effect manager creates a certain type of state with `init`, but your `"
469+ ++ name ++ "` function expects a different kind of state."
470+ )
471+ ( cmpHint
472+ "The state created by `init` has this type:"
473+ ("But `" ++ name ++ "` expects state of this type:")
474+ [ "Make the two state types match and you should be all set!"
475+ , "TODO - link to overview of effect managers"
476+ ]
477+ )
478+
479+ SelfMsg ->
480+ report
481+ Nothing
482+ "Effect managers can send messages to themselves, but `onEffects` and `onSelfMsg` are defined for different types of self messages."
483+ ( cmpHint
484+ "The `onEffects` function can send this type of message:"
485+ "But the `onSelfMsg` function receives this type:"
486+ [ "Make the two message types match and you should be all set!"
487+ , "TODO - link to overview of effect managers"
488+ ]
489+ )
490+
491+
492+
428
493
429comparisonHint
494comparisonHint
430 :: RenderType.Localizer
495 :: RenderType.Localizer
@@ -452,6 +517,7 @@ comparisonHint localizer leftType rightType leftWords rightWords finalHints =
452
517
453-- BINOP HINTS
518-- BINOP HINTS
454
519
520+
455binopHint :: Var.Canonical -> Type.Canonical -> Type.Canonical -> [String]
521binopHint :: Var.Canonical -> Type.Canonical -> Type.Canonical -> [String]
456binopHint op leftType rightType =
522binopHint op leftType rightType =
457 let
523 let
@@ -477,6 +543,25 @@ binopHint op leftType rightType =
477
543
478
544
479
545
546+-- FUNCTION HINTS
547+
548+
549+functionHint :: Maybe Var.Canonical -> [String]
550+functionHint maybeName =
551+ case maybeName of
552+ Nothing ->
553+ []
554+
555+ Just name ->
556+ if Var.inHtml ["Html","App"] "program" == name then
557+ [ "Does your program have flags? Maybe you want `programWithFlags` instead."
558+ ]
559+
560+ else
561+ []
562+
563+
564+
480-- MISMATCH HELPERS
565-- MISMATCH HELPERS
481
566
482
567
src/Reporting/Render/Type.hs+4−3
@@ -87,13 +87,14 @@ type Localizer =
87varToDoc :: Localizer -> Var.Canonical -> Doc
87varToDoc :: Localizer -> Var.Canonical -> Doc
88varToDoc localizer var =
88varToDoc localizer var =
89 let
89 let
90+ name =
90− name = Var.toString var
91+ Var.toString var
91 in
92 in
92 if name == "_Tuple0" then
93 if name == "_Tuple0" then
93− text "()"
94+ text "()"
94
95
95 else
96 else
96− text (maybe name id (Map.lookup name localizer))
97+ text (maybe name id (Map.lookup name localizer))
97
98
98
99
99
100
src/Reporting/Result.hs+97−57
@@ -1,45 +1,69 @@
1+{-# OPTIONS_GHC -Wall #-}
1module Reporting.Result where
2module Reporting.Result where
2
3
3−import Control.Applicative ((<|>))
4−import qualified Control.Monad as M
5import Control.Monad.Except (Except, runExcept)
4import Control.Monad.Except (Except, runExcept)
6
5
7import qualified Reporting.Annotation as A
6import qualified Reporting.Annotation as A
7+import qualified Reporting.Bag as Bag
8import qualified Reporting.Region as R
8import qualified Reporting.Region as R
9−import qualified Reporting.Render.Type as RenderType
10
9
11
10
12−-- TASK
13
11
14−data Result warning error result =
12+-- RESULTS
15− Result
16− (Maybe RenderType.Localizer, [A.Located warning])
17− (RawResult [A.Located error] result)
18
13
19
14
20−data RawResult e a
15+data Result info warning error result =
21− = Ok a
16+ Result
22− | Err e
17+ { _info :: info
18+ , _warnings :: LBag warning
19+ , _answer :: Answer (LBag error) result
20+ }
23
21
24
22
25−-- HELPERS
23+data Answer e a = Ok a | Err e
26
24
25+
26+type LBag a =
27+ Bag.Bag (A.Located a)
28+
29+
30+data One a = None | One a
31+
32+
33+
34+-- RESULT HELPERS
35+
36+
27−ok :: a -> Result w e a
37+ok :: (Monoid i) => a -> Result i w e a
28ok value =
38ok value =
29− Result (Nothing, []) (Ok value)
39+ Result mempty Bag.empty (Ok value)
30
40
31
41
32−throw :: R.Region -> e -> Result w e a
42+throw :: (Monoid i) => R.Region -> e -> Result i w e a
33throw region err =
43throw region err =
34− Result (Nothing, []) (Err [A.A region err])
44+ Result mempty Bag.empty (Err (Bag.singleton (A.A region err)))
35
45
36
46
37−throwMany :: [A.Located e] -> Result w e a
47+throwMany :: (Monoid i) => [A.Located e] -> Result i w e a
38throwMany errors =
48throwMany errors =
39− Result (Nothing, []) (Err errors)
49+ Result mempty Bag.empty (Err (Bag.fromList errors))
50+
51+
52+accumulate :: (Monoid i) => i -> a -> Result i w e a
53+accumulate info value =
54+ Result info Bag.empty (Ok value)
55+
40
56
57+warn :: (Monoid i) => R.Region -> w -> a -> Result i w e a
58+warn region warning a =
59+ Result mempty (Bag.singleton (A.A region warning)) (Ok a)
41
60
61+
62+
63+-- EXTRACTION HELPERS
64+
65+
42−from :: (e -> e') -> Except [A.Located e] a -> Result w e' a
66+from :: (Monoid i) => (e -> e') -> Except [A.Located e] a -> Result i w e' a
43from f except =
67from f except =
44 case runExcept except of
68 case runExcept except of
45 Right answer ->
69 Right answer ->
@@ -49,66 +73,68 @@ from f except =
49 throwMany (map (A.map f) errors)
73 throwMany (map (A.map f) errors)
50
74
51
75
52−mapError :: (e -> e') -> Result w e a -> Result w e' a
76+mapError :: (e -> e') -> Result i w e a -> Result i w e' a
53−mapError f (Result warnings rawResult) =
77+mapError f (Result info warnings rawResult) =
54− Result warnings $
78+ Result info warnings $
55 case rawResult of
79 case rawResult of
56 Ok v ->
80 Ok v ->
57 Ok v
81 Ok v
58
82
59 Err msgs ->
83 Err msgs ->
60− Err (map (A.map f) msgs)
84+ Err (Bag.map (A.map f) msgs)
61
85
62
86
63−warn :: R.Region -> w -> Result w e ()
87+format :: (Monoid i) => (e -> e') -> Result () w e a -> Result i w e' a
64−warn region warning =
88+format func (Result _ warnings answer) =
65− Result (Nothing, [A.A region warning]) (Ok ())
89+ mapError func (Result mempty warnings answer)
66
90
67
91
68−addWarnings :: [A.Located w] -> Result w e a -> Result w e a
92+answerToEither :: (A.Located e -> e') -> (a -> a') -> Answer (LBag e) a -> Either [e'] a'
69−addWarnings newWarnings (Result (dealiaser, warnings) rawResult) =
93+answerToEither onErr onOk answer =
70− Result (dealiaser, newWarnings ++ warnings) rawResult
94+ case answer of
95+ Ok value ->
96+ Right (onOk value)
71
97
98+ Err errors ->
99+ Left (Bag.toList onErr errors)
72
100
73−addDealiaser :: RenderType.Localizer -> Result w e a -> Result w e a
74−addDealiaser dealiaser (Result (_, warnings) rawResult) =
75− Result (Just dealiaser, warnings) rawResult
76
101
102+oneToValue :: b -> (a -> b) -> One a -> b
103+oneToValue fallback onOne one =
104+ case one of
105+ None ->
106+ fallback
77
107
78−destruct :: (e -> b) -> (a -> b) -> RawResult e a -> b
108+ One value ->
79−destruct errFunc okFunc rawResult =
109+ onOne value
80− case rawResult of
81− Ok answer ->
82− okFunc answer
83
110
84− Err errors ->
85− errFunc errors
86
111
87
112
88-- EXTRA FANCY HELPERS
113-- EXTRA FANCY HELPERS
89
114
115+
90−instance M.Functor (Result w e) where
116+instance Functor (Result i w e) where
91− fmap func (Result warnings rawResult) =
117+ fmap func (Result info warnings rawResult) =
92 case rawResult of
118 case rawResult of
93 Ok a ->
119 Ok a ->
94− Result warnings (Ok (func a))
120+ Result info warnings (Ok (func a))
95
121
96 Err msgs ->
122 Err msgs ->
97− Result warnings (Err msgs)
123+ Result info warnings (Err msgs)
98
124
99
125
100−instance Applicative (Result w e) where
126+instance (Monoid i) => Applicative (Result i w e) where
101 pure value =
127 pure value =
102 ok value
128 ok value
103
129
104− (<*>) (Result context resultFunc) (Result context' resultVal) =
130+ (<*>) (Result info warnings resultFunc) (Result info' warnings' resultVal) =
105− Result (merge context context') $
131+ Result (mappend info info') (Bag.append warnings warnings') $
106 case (resultFunc, resultVal) of
132 case (resultFunc, resultVal) of
107 (Ok func, Ok val) ->
133 (Ok func, Ok val) ->
108 Ok (func val)
134 Ok (func val)
109
135
110 (Err msgs, Err msgs') ->
136 (Err msgs, Err msgs') ->
111− Err (msgs ++ msgs')
137+ Err (Bag.append msgs msgs')
112
138
113 (Err msgs, _) ->
139 (Err msgs, _) ->
114 Err msgs
140 Err msgs
@@ -117,23 +143,37 @@ instance Applicative (Result w e) where
117 Err msgs
143 Err msgs
118
144
119
145
120−instance M.Monad (Result w e) where
146+instance (Monoid i) => Monad (Result i w e) where
121 return value =
147 return value =
122 ok value
148 ok value
123
149
124− (>>=) (Result context rawResult) callback =
150+ (>>=) (Result info warnings rawResult) callback =
125 case rawResult of
151 case rawResult of
126 Err msg ->
152 Err msg ->
127− Result context (Err msg)
153+ Result info warnings (Err msg)
128
154
129 Ok value ->
155 Ok value ->
156+ let
157+ (Result info' warnings' rawResult') =
130− let (Result context' rawResult') = callback value
158+ callback value
131 in
159 in
160+ Result
161+ (mappend info info')
162+ (Bag.append warnings warnings')
132− Result (merge context context') rawResult'
163+ rawResult'
164+
165+
166+instance Monoid (One a) where
167+ mempty =
168+ None
169+
170+ mappend left right =
171+ case (left, right) of
172+ (other, None) ->
173+ other
133
174
175+ (None, other) ->
176+ other
134
177
135−merge :: (Maybe a, [b]) -> (Maybe a, [b]) -> (Maybe a, [b])
178+ (One _, One _) ->
136−merge (dealiaser, warnings) (dealiaser', warnings') =
179+ error "There should only be one!"
137− ( dealiaser <|> dealiaser'
138− , warnings ++ warnings'
139− )
src/Type/Constrain/Effects.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Type.Constrain.Effects (constrain) where
3+
4+import qualified Data.Map as Map
5+
6+import qualified AST.Effects as Effects
7+import qualified AST.Module.Name as ModuleName
8+import qualified Reporting.Annotation as A
9+import qualified Reporting.Error.Type as Error
10+import qualified Type.Environment as Env
11+import Type.Type
12+ ( Variable, Type, TypeConstraint, Constraint(..), Scheme(Scheme)
13+ , TermN(VarN), (==>), (<|), mkVar
14+ )
15+
16+
17+constrain
18+ :: Env.Environment
19+ -> ModuleName.Canonical
20+ -> Effects.Canonical
21+ -> IO TypeConstraint
22+constrain env moduleName effects =
23+ case effects of
24+ Effects.None ->
25+ return CSaveEnv
26+
27+ Effects.Port _ ->
28+ return CSaveEnv
29+
30+ Effects.Manager _ info ->
31+ constrainHelp env moduleName info
32+
33+
34+constrainHelp
35+ :: Env.Environment
36+ -> ModuleName.Canonical
37+ -> Effects.Info
38+ -> IO TypeConstraint
39+constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =
40+ let
41+ task t =
42+ Env.getType env "Platform.Task" <| Env.getType env "Basics.Never" <| VarN t
43+
44+ router msg selfMsg =
45+ Env.getType env "Platform.Router" <| VarN msg <| VarN selfMsg
46+ in
47+ do v0 <- mkVar Nothing
48+ v1 <- mkVar Nothing
49+ v2 <- mkVar Nothing
50+
51+ state0 <- mkVar Nothing
52+ state1 <- mkVar Nothing
53+ state2 <- mkVar Nothing
54+
55+ msg1 <- mkVar Nothing
56+ msg2 <- mkVar Nothing
57+
58+ selfMsg1 <- mkVar Nothing
59+ selfMsg2 <- mkVar Nothing
60+
61+ let
62+ vars =
63+ [v0, v1, v2, state0, state1, state2, msg1, msg2, selfMsg1, selfMsg2]
64+
65+ onEffectsType =
66+ router msg1 selfMsg1
67+ ==> addEffectArgs env moduleName managerType msg1
68+ (VarN state1 ==> task state1)
69+
70+ onSelfMsgType =
71+ router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN state2 ==> task state2
72+
73+ constrains =
74+ [ CInstance tagRegion "init" (VarN v0)
75+ , CInstance tagRegion "onEffects" (VarN v1)
76+ , CInstance tagRegion "onSelfMsg" (VarN v2)
77+ , CEqual (Error.Manager "init") r0 (VarN v0) (task state0)
78+ , CEqual (Error.Manager "onEffects") r1 (VarN v1) onEffectsType
79+ , CEqual (Error.Manager "onSelfMsg") r2 (VarN v2) onSelfMsgType
80+ , CEqual (Error.State "onEffects") r1 (VarN state0) (VarN state1)
81+ , CEqual (Error.State "onSelfMsg") r2 (VarN state0) (VarN state2)
82+ , CEqual Error.SelfMsg r2 (VarN selfMsg1) (VarN selfMsg2)
83+ ]
84+
85+ return $
86+ CLet [Scheme [] vars (CAnd constrains) Map.empty] CSaveEnv
87+
88+
89+addEffectArgs
90+ :: Env.Environment
91+ -> ModuleName.Canonical
92+ -> Effects.ManagerType
93+ -> Variable
94+ -> Type
95+ -> Type
96+addEffectArgs env moduleName managerType msg result =
97+ let
98+ toTypeName (A.A _ name) =
99+ ModuleName.canonicalToString moduleName ++ "." ++ name
100+
101+ effectList fxName =
102+ Env.getType env "List" <|
103+ (Env.getType env (toTypeName fxName) <| VarN msg)
104+ in
105+ case managerType of
106+ Effects.CmdManager cmd ->
107+ effectList cmd ==> result
108+
109+ Effects.SubManager sub ->
110+ effectList sub ==> result
111+
112+ Effects.FxManager cmd sub ->
113+ effectList cmd ==> effectList sub ==> result
114+
src/Type/Constrain/Expression.hs+167−139
@@ -14,6 +14,7 @@ import qualified AST.Variable as V
14import qualified Reporting.Annotation as A
14import qualified Reporting.Annotation as A
15import qualified Reporting.Error.Type as Error
15import qualified Reporting.Error.Type as Error
16import qualified Reporting.Region as R
16import qualified Reporting.Region as R
17+import qualified Type.Constrain.Effects as Effects
17import qualified Type.Constrain.Literal as Literal
18import qualified Type.Constrain.Literal as Literal
18import qualified Type.Constrain.Pattern as Pattern
19import qualified Type.Constrain.Pattern as Pattern
19import qualified Type.Environment as Env
20import qualified Type.Environment as Env
@@ -21,155 +22,164 @@ import qualified Type.Fragment as Fragment
21import Type.Type hiding (Descriptor(..))
22import Type.Type hiding (Descriptor(..))
22
23
23
24
25+
24constrain
26constrain
25 :: Env.Environment
27 :: Env.Environment
26 -> Canonical.Expr
28 -> Canonical.Expr
27 -> Type
29 -> Type
28 -> IO TypeConstraint
30 -> IO TypeConstraint
29constrain env annotatedExpr@(A.A region expression) tipe =
31constrain env annotatedExpr@(A.A region expression) tipe =
32+ let
33+ list t =
30− let list t = Env.getType env "List" <| t
34+ Env.getType env "List" <| t
31− (<?) = CInstance region
32− in
35+ in
33− case expression of
36+ case expression of
34− E.Literal lit ->
37+ E.Literal lit ->
35− Literal.constrain env region lit tipe
38+ Literal.constrain env region lit tipe
36−
37− E.GLShader _uid _src gltipe ->
38− exists $ \attr ->
39− exists $ \unif ->
40− let
41− shaderTipe a u v =
42− Env.getType env "WebGL.Shader" <| a <| u <| v
43−
44− glToType glTipe =
45− Env.getType env (Lit.glTipeName glTipe)
46−
47− makeRec accessor baseRec =
48− let decls = accessor gltipe
49− in
50− if Map.size decls == 0 then
51− baseRec
52− else
53− record (Map.map glToType decls) baseRec
54−
55− attribute = makeRec Lit.attribute attr
56− uniform = makeRec Lit.uniform unif
57− varying = makeRec Lit.varying (TermN EmptyRecord1)
58− in
59− return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)
60
39
61− E.Var var ->
40+ E.Cmd _ ->
62− let name = V.toString var
63− in
64− return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
65−
66− E.Range lowExpr highExpr ->
67− existsNumber $ \n ->
68− do lowCon <- constrain env lowExpr n
69− highCon <- constrain env highExpr n
70− return $ CAnd
41+ return CTrue
71− [ lowCon
42+
72− , highCon
43+ E.Sub _ ->
73− , CEqual Error.Range region (list n) tipe
44+ return CTrue
74− ]
75−
76− E.ExplicitList exprs ->
77− constrainList env region exprs tipe
78−
79− E.Binop op leftExpr rightExpr ->
80− constrainBinop env region op leftExpr rightExpr tipe
81−
82− E.Lambda pattern body ->
83− exists $ \argType ->
84− exists $ \resType ->
85− do fragment <- Pattern.constrain env pattern argType
86− bodyCon <- constrain env body resType
87− let con =
88− ex (Fragment.vars fragment)
89− (CLet [monoscheme (Fragment.typeEnv fragment)]
90− (Fragment.typeConstraint fragment /\ bodyCon)
91− )
92− return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe
93−
94− E.App _ _ ->
95− let
96− (f:args) = E.collectApps annotatedExpr
97− in
98− constrainApp env region f args tipe
99
45
100− E.If branches finally ->
46+ E.OutgoingPort _ _ ->
101− constrainIf env region branches finally tipe
47+ return CTrue
102
48
103− E.Case expr branches ->
49+ E.IncomingPort _ _ ->
104− constrainCase env region expr branches tipe
50+ return CTrue
105
51
106− E.Data name exprs ->
52+ E.Program _ _ ->
107− do vars <- Monad.forM exprs $ \_ -> mkVar Nothing
53+ error "DANGER - Program AST nodes should not be in type inference."
108− let pairs = zip exprs (map VarN vars)
109− (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
110− return $ ex vars (cs /\ name <? ctipe)
111− where
112− step (t,c) (e,x) =
113− do c' <- constrain env e x
114− return (x ==> t, c /\ c')
115
54
116− E.Access expr label ->
55+ E.SaveEnv moduleName effects ->
117− exists $ \t ->
56+ Effects.constrain env moduleName effects
118− constrain env expr (record (Map.singleton label tipe) t)
119
57
120− E.Update expr fields ->
58+ E.GLShader _uid _src gltipe ->
121− exists $ \t ->
59+ exists $ \attr ->
122− do oldVars <- mapM (\_ -> mkVar Nothing) fields
60+ exists $ \unif ->
123− let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))
61+ let
124− cOld <- ex oldVars <$> constrain env expr (record oldFields t)
62+ shaderTipe a u v =
63+ Env.getType env "WebGL.Shader" <| a <| u <| v
125
64
126− newVars <- mapM (\_ -> mkVar Nothing) fields
65+ glToType glTipe =
127− let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))
66+ Env.getType env (Lit.glTipeName glTipe)
128− let cNew = CEqual Error.Record region (record newFields t) tipe
129
67
130− cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)
68+ makeRec accessor baseRec =
69+ let decls = accessor gltipe
70+ in
71+ if Map.size decls == 0 then
72+ baseRec
73+ else
74+ record (Map.map glToType decls) baseRec
75+
76+ attribute = makeRec Lit.attribute attr
77+ uniform = makeRec Lit.uniform unif
78+ varying = makeRec Lit.varying (TermN EmptyRecord1)
79+ in
80+ return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)
81+
82+ E.Var var ->
83+ return (CInstance region (V.toString var) tipe)
84+
85+ E.Range lowExpr highExpr ->
86+ existsNumber $ \n ->
87+ do lowCon <- constrain env lowExpr n
88+ highCon <- constrain env highExpr n
89+ return $ CAnd
90+ [ lowCon
91+ , highCon
92+ , CEqual Error.Range region (list n) tipe
93+ ]
94+
95+ E.ExplicitList exprs ->
96+ constrainList env region exprs tipe
97+
98+ E.Binop op leftExpr rightExpr ->
99+ constrainBinop env region op leftExpr rightExpr tipe
100+
101+ E.Lambda pattern body ->
102+ exists $ \argType ->
103+ exists $ \resType ->
104+ do fragment <- Pattern.constrain env pattern argType
105+ bodyCon <- constrain env body resType
106+ let con =
107+ ex (Fragment.vars fragment)
108+ (CLet [monoscheme (Fragment.typeEnv fragment)]
109+ (Fragment.typeConstraint fragment /\ bodyCon)
110+ )
111+ return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe
112+
113+ E.App _ _ ->
114+ let
115+ (f:args) = E.collectApps annotatedExpr
116+ in
117+ constrainApp env region f args tipe
118+
119+ E.If branches finally ->
120+ constrainIf env region branches finally tipe
121+
122+ E.Case expr branches ->
123+ constrainCase env region expr branches tipe
124+
125+ E.Data name exprs ->
126+ do vars <- Monad.forM exprs $ \_ -> mkVar Nothing
127+ let pairs = zip exprs (map VarN vars)
128+ (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
129+ return $ ex vars (cs /\ CInstance region name ctipe)
130+ where
131+ step (t,c) (e,x) =
132+ do c' <- constrain env e x
133+ return (x ==> t, c /\ c')
134+
135+ E.Access expr label ->
136+ exists $ \t ->
137+ constrain env expr (record (Map.singleton label tipe) t)
138+
139+ E.Update expr fields ->
140+ exists $ \t ->
141+ do oldVars <- mapM (\_ -> mkVar Nothing) fields
142+ let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))
143+ cOld <- ex oldVars <$> constrain env expr (record oldFields t)
131
144
132− return $ cOld /\ ex newVars (CAnd (cNew : cs))
145+ newVars <- mapM (\_ -> mkVar Nothing) fields
146+ let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))
147+ let cNew = CEqual Error.Record region (record newFields t) tipe
133
148
134− E.Record fields ->
149+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)
135− do vars <- Monad.forM fields (\_ -> mkVar Nothing)
136− fieldCons <-
137− Monad.zipWithM
138− (constrain env)
139− (map snd fields)
140− (map VarN vars)
141− let fields' = Map.fromList (zip (map fst fields) (map VarN vars))
142− let recordType = record fields' (TermN EmptyRecord1)
143− return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))
144
150
145− E.Let defs body ->
151+ return $ cOld /\ ex newVars (CAnd (cNew : cs))
146− do bodyCon <- constrain env body tipe
147
152
148− (Info schemes rqs fqs headers c2 c1) <-
153+ E.Record fields ->
154+ do vars <- Monad.forM fields (\_ -> mkVar Nothing)
155+ fieldCons <-
149− Monad.foldM
156+ Monad.zipWithM
150− (constrainDef env)
157+ (constrain env)
151− (Info [] [] [] Map.empty CTrue CTrue)
158+ (map snd fields)
152− (concatMap expandPattern defs)
159+ (map VarN vars)
160+ let fields' = Map.fromList (zip (map fst fields) (map VarN vars))
161+ let recordType = record fields' (TermN EmptyRecord1)
162+ return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))
153
163
154− let letScheme =
164+ E.Let defs body ->
155− [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
165+ do bodyCon <- constrain env body tipe
156
166
157− return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
167+ (Info schemes rqs fqs headers c2 c1) <-
168+ Monad.foldM
169+ (constrainDef env)
170+ (Info [] [] [] Map.empty CTrue CTrue)
171+ (concatMap expandPattern defs)
158
172
159− E.Port impl ->
173+ let letScheme =
160− case impl of
174+ [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
161− E.In _ _ ->
162− return CTrue
163
175
164− E.Out _ expr _ ->
176+ return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
165− constrain env expr tipe
166
177
167− E.Task _ expr _ ->
168− constrain env expr tipe
169
178
170
179
171-- CONSTRAIN APP
180-- CONSTRAIN APP
172
181
182+
173constrainApp
183constrainApp
174 :: Env.Environment
184 :: Env.Environment
175 -> R.Region
185 -> R.Region
@@ -250,9 +260,9 @@ argConstraints env name region totalArgs overallVar index args =
250
260
251
261
252
262
253−
254-- CONSTRAIN BINOP
263-- CONSTRAIN BINOP
255
264
265+
256constrainBinop
266constrainBinop
257 :: Env.Environment
267 :: Env.Environment
258 -> R.Region
268 -> R.Region
@@ -285,8 +295,10 @@ constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightReg
285 ]
295 ]
286
296
287
297
298+
288-- CONSTRAIN LISTS
299-- CONSTRAIN LISTS
289
300
301+
290constrainList
302constrainList
291 :: Env.Environment
303 :: Env.Environment
292 -> R.Region
304 -> R.Region
@@ -310,8 +322,10 @@ constrainList env region exprs tipe =
310 CEqual Error.List region (Env.getType env "List" <| VarN var) tipe
322 CEqual Error.List region (Env.getType env "List" <| VarN var) tipe
311
323
312
324
325+
313-- CONSTRAIN IF EXPRESSIONS
326-- CONSTRAIN IF EXPRESSIONS
314
327
328+
315constrainIf
329constrainIf
316 :: Env.Environment
330 :: Env.Environment
317 -> R.Region
331 -> R.Region
@@ -367,13 +381,15 @@ constrainIf env region branches finally tipe =
367 CEqual Error.If region (VarN var) tipe
381 CEqual Error.If region (VarN var) tipe
368
382
369
383
384+
370-- CONSTRAIN CASE EXPRESSIONS
385-- CONSTRAIN CASE EXPRESSIONS
371
386
387+
372constrainCase
388constrainCase
373 :: Env.Environment
389 :: Env.Environment
374 -> R.Region
390 -> R.Region
375 -> Canonical.Expr
391 -> Canonical.Expr
376− -> [(P.CanonicalPattern, Canonical.Expr)]
392+ -> [(P.Canonical, Canonical.Expr)]
377 -> Type
393 -> Type
378 -> IO TypeConstraint
394 -> IO TypeConstraint
379constrainCase env region expr branches tipe =
395constrainCase env region expr branches tipe =
@@ -400,8 +416,10 @@ constrainCase env region expr branches tipe =
400 CEqual Error.Case region tipe (VarN var)
416 CEqual Error.Case region tipe (VarN var)
401
417
402
418
419+
403-- COLLECT PAIRS
420-- COLLECT PAIRS
404
421
422+
405data Pair = Pair
423data Pair = Pair
406 { _index :: Int
424 { _index :: Int
407 , _var1 :: Variable
425 , _var1 :: Variable
@@ -423,11 +441,11 @@ pairCons region pairHint varToCon items =
423 in
441 in
424 case collectPairs 2 items of
442 case collectPairs 2 items of
425 Nothing ->
443 Nothing ->
426− do var <- mkVar Nothing
444+ do var <- mkVar Nothing
427− return ([var], [varToCon var])
445+ return ([var], [varToCon var])
428
446
429 Just (pairs, var) ->
447 Just (pairs, var) ->
430− return (map fst items, map pairToCon pairs ++ [varToCon var])
448+ return (map fst items, map pairToCon pairs ++ [varToCon var])
431
449
432
450
433collectPairs :: Int -> [(Variable, R.Region)] -> Maybe ([Pair], Variable)
451collectPairs :: Int -> [(Variable, R.Region)] -> Maybe ([Pair], Variable)
@@ -444,11 +462,15 @@ collectPairs index items =
444 return (Pair index var var' region : pairs, summaryVar)
462 return (Pair index var var' region : pairs, summaryVar)
445
463
446
464
465+
447-- EXPAND PATTERNS
466-- EXPAND PATTERNS
448
467
468+
449expandPattern :: Canonical.Def -> [Canonical.Def]
469expandPattern :: Canonical.Def -> [Canonical.Def]
450−expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =
470+expandPattern def@(Canonical.Def facts lpattern expr maybeType) =
471+ let
451− let (A.A patternRegion pattern) = lpattern
472+ (A.A patternRegion pattern) =
473+ lpattern
452 in
474 in
453 case pattern of
475 case pattern of
454 P.Var _ ->
476 P.Var _ ->
@@ -457,27 +479,33 @@ expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =
457 _ ->
479 _ ->
458 mainDef : map toDef vars
480 mainDef : map toDef vars
459 where
481 where
482+ vars =
460− vars = P.boundVarList lpattern
483+ P.boundVarList lpattern
461
484
462− combinedName = "$" ++ concat vars
485+ combinedName =
486+ "$" ++ concat vars
463
487
464 pvar name =
488 pvar name =
465− A.A patternRegion (P.Var name)
489+ A.A patternRegion (P.Var name)
466
490
467 localVar name =
491 localVar name =
468− A.A patternRegion (E.localVar name)
492+ A.A patternRegion (E.localVar name)
469
493
494+ mainDef =
470− mainDef = Canonical.Definition facts (pvar combinedName) expr maybeType
495+ Canonical.Def facts (pvar combinedName) expr maybeType
471
496
472 toDef name =
497 toDef name =
498+ let
473− let extract =
499+ extract =
474− E.Case (localVar combinedName) [(lpattern, localVar name)]
500+ E.Case (localVar combinedName) [(lpattern, localVar name)]
475− in
501+ in
476− Canonical.Definition facts (pvar name) (A.A patternRegion extract) Nothing
502+ Canonical.Def facts (pvar name) (A.A patternRegion extract) Nothing
503+
477
504
478
505
479-- CONSTRAIN DEFINITIONS
506-- CONSTRAIN DEFINITIONS
480
507
508+
481data Info = Info
509data Info = Info
482 { iSchemes :: [TypeScheme]
510 { iSchemes :: [TypeScheme]
483 , iRigid :: [Variable]
511 , iRigid :: [Variable]
@@ -489,7 +517,7 @@ data Info = Info
489
517
490
518
491constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
519constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
492−constrainDef env info (Canonical.Definition _ (A.A patternRegion pattern) expr maybeTipe) =
520+constrainDef env info (Canonical.Def _ (A.A patternRegion pattern) expr maybeTipe) =
493 let qs = [] -- should come from the def, but I'm not sure what would live there...
521 let qs = [] -- should come from the def, but I'm not sure what would live there...
494 in
522 in
495 case (pattern, maybeTipe) of
523 case (pattern, maybeTipe) of
src/Type/Constrain/Pattern.hs+1−5
@@ -14,11 +14,7 @@ import Type.Fragment
14import Type.Type
14import Type.Type
15
15
16
16
17−constrain
18− :: Env.Environment
17+constrain :: Env.Environment -> P.Canonical -> Type -> IO Fragment
19− -> P.CanonicalPattern
20− -> Type
21− -> IO Fragment
22constrain env (A.A region pattern) tipe =
18constrain env (A.A region pattern) tipe =
23 let
19 let
24 equal patternError leftType rightType =
20 equal patternError leftType rightType =
src/Type/Environment.hs+12−10
@@ -31,7 +31,7 @@ data Environment = Environment
31 }
31 }
32
32
33
33
34−initialize :: [Module.CanonicalAdt] -> IO Environment
34+initialize :: [Module.CanonicalUnion] -> IO Environment
35initialize datatypes =
35initialize datatypes =
36 do types <- makeTypes datatypes
36 do types <- makeTypes datatypes
37 let env =
37 let env =
@@ -43,13 +43,13 @@ initialize datatypes =
43 return $ env { _constructor = makeConstructors env datatypes }
43 return $ env { _constructor = makeConstructors env datatypes }
44
44
45
45
46−makeTypes :: [Module.CanonicalAdt] -> IO TypeDict
46+makeTypes :: [Module.CanonicalUnion] -> IO TypeDict
47makeTypes datatypes =
47makeTypes datatypes =
48− do adts <- mapM makeImported datatypes
48+ do unions <- mapM makeImported datatypes
49− bs <- mapM makeBuiltin builtins
49+ bs <- mapM makeBuiltin builtins
50− return (Map.fromList (adts ++ bs))
50+ return (Map.fromList (unions ++ bs))
51 where
51 where
52− makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)
52+ makeImported :: (V.Canonical, Module.UnionInfo V.Canonical) -> IO (String, Type)
53 makeImported (name, _) =
53 makeImported (name, _) =
54 do tvar <- mkAtom name
54 do tvar <- mkAtom name
55 return (V.toString name, VarN tvar)
55 return (V.toString name, VarN tvar)
@@ -73,7 +73,7 @@ makeTypes datatypes =
73
73
74makeConstructors
74makeConstructors
75 :: Environment
75 :: Environment
76− -> [Module.CanonicalAdt]
76+ -> [Module.CanonicalUnion]
77 -> Map.Map String (IO (Int, [Variable], [Type], Type))
77 -> Map.Map String (IO (Int, [Variable], [Type], Type))
78makeConstructors env datatypes =
78makeConstructors env datatypes =
79 Map.fromList builtins
79 Map.fromList builtins
@@ -101,7 +101,7 @@ makeConstructors env datatypes =
101
101
102ctorToType
102ctorToType
103 :: Environment
103 :: Environment
104− -> (V.Canonical, Module.AdtInfo V.Canonical)
104+ -> (V.Canonical, Module.UnionInfo V.Canonical)
105 -> [(String, IO (Int, [Variable], [Type], Type))]
105 -> [(String, IO (Int, [Variable], [Type], Type))]
106ctorToType env (name, (tvars, ctors)) =
106ctorToType env (name, (tvars, ctors)) =
107 zip (map (V.toString . fst) ctors) (map inst ctors)
107 zip (map (V.toString . fst) ctors) (map inst ctors)
@@ -176,8 +176,10 @@ instantiator env sourceType =
176
176
177instantiatorHelp :: Environment -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type
177instantiatorHelp :: Environment -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type
178instantiatorHelp env aliasVars sourceType =
178instantiatorHelp env aliasVars sourceType =
179+ let
180+ go =
179− let go = instantiatorHelp env aliasVars
181+ instantiatorHelp env aliasVars
180− in
182+ in
181 case sourceType of
183 case sourceType of
182 T.Lambda t1 t2 ->
184 T.Lambda t1 t2 ->
183 (==>) <$> go t1 <*> go t2
185 (==>) <$> go t1 <*> go t2
src/Type/Inference.hs+18−18
@@ -5,7 +5,7 @@ import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6import qualified Data.Traversable as Traverse
6import qualified Data.Traversable as Traverse
7
7
8−import AST.Module as Module
8+import qualified AST.Module as Module
9import qualified AST.Module.Name as ModuleName
9import qualified AST.Module.Name as ModuleName
10import qualified AST.Type as Type
10import qualified AST.Type as Type
11import qualified AST.Variable as Var
11import qualified AST.Variable as Var
@@ -24,7 +24,7 @@ import System.IO.Unsafe
24
24
25infer
25infer
26 :: Module.Interfaces
26 :: Module.Interfaces
27− -> Module.CanonicalModule
27+ -> Module.Canonical
28 -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)
28 -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)
29infer interfaces modul =
29infer interfaces modul =
30 either throwError return $ unsafePerformIO $ runExceptT $
30 either throwError return $ unsafePerformIO $ runExceptT $
@@ -41,10 +41,10 @@ infer interfaces modul =
41
41
42genConstraints
42genConstraints
43 :: Module.Interfaces
43 :: Module.Interfaces
44− -> Module.CanonicalModule
44+ -> Module.Canonical
45 -> IO (Map.Map String T.Type, T.TypeConstraint)
45 -> IO (Map.Map String T.Type, T.TypeConstraint)
46genConstraints interfaces modul =
46genConstraints interfaces modul =
47− do env <- Env.initialize (canonicalizeAdts interfaces modul)
47+ do env <- Env.initialize (canonicalizeUnions interfaces modul)
48
48
49 ctors <-
49 ctors <-
50 forM (Env.ctorNames env) $ \name ->
50 forM (Env.ctorNames env) $ \name ->
@@ -62,17 +62,17 @@ genConstraints interfaces modul =
62 fvar <- T.mkVar Nothing
62 fvar <- T.mkVar Nothing
63
63
64 constraint <-
64 constraint <-
65− TcExpr.constrain env (program (body modul)) (T.VarN fvar)
65+ TcExpr.constrain env (Module.program (Module.info modul)) (T.VarN fvar)
66
66
67 return (header, environ constraint)
67 return (header, environ constraint)
68
68
69
69
70canonicalizeValues
70canonicalizeValues
71 :: Env.Environment
71 :: Env.Environment
72− -> (ModuleName.Canonical, Interface)
72+ -> (ModuleName.Canonical, Module.Interface)
73 -> IO [(String, ([T.Variable], T.Type))]
73 -> IO [(String, ([T.Variable], T.Type))]
74canonicalizeValues env (moduleName, iface) =
74canonicalizeValues env (moduleName, iface) =
75− forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
75+ forM (Map.toList (Module.iTypes iface)) $ \(name,tipe) ->
76 do tipe' <- Env.instantiateType env tipe Map.empty
76 do tipe' <- Env.instantiateType env tipe Map.empty
77 return
77 return
78 ( ModuleName.canonicalToString moduleName ++ "." ++ name
78 ( ModuleName.canonicalToString moduleName ++ "." ++ name
@@ -80,24 +80,24 @@ canonicalizeValues env (moduleName, iface) =
80 )
80 )
81
81
82
82
83−canonicalizeAdts :: Module.Interfaces -> Module.CanonicalModule -> [CanonicalAdt]
83+canonicalizeUnions :: Module.Interfaces -> Module.Canonical -> [Module.CanonicalUnion]
84−canonicalizeAdts interfaces modul =
84+canonicalizeUnions interfaces (Module.Module name _ info) =
85− localAdts ++ importedAdts
85+ localUnions ++ importedUnions
86 where
86 where
87− localAdts :: [CanonicalAdt]
87+ localUnions :: [Module.CanonicalUnion]
88− localAdts =
88+ localUnions =
89− format (Module.name modul, datatypes (body modul))
89+ format (name, Module.unions info)
90
90
91− importedAdts :: [CanonicalAdt]
91+ importedUnions :: [Module.CanonicalUnion]
92− importedAdts =
92+ importedUnions =
93− concatMap (format . second iAdts) (Map.toList interfaces)
93+ concatMap (format . second Module.iUnions) (Map.toList interfaces)
94
94
95
95
96−format :: (ModuleName.Canonical, Module.ADTs) -> [CanonicalAdt]
96+format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]
97format (home, adts) =
97format (home, adts) =
98 map canonical (Map.toList adts)
98 map canonical (Map.toList adts)
99 where
99 where
100− canonical :: (String, AdtInfo String) -> CanonicalAdt
100+ canonical :: (String, Module.UnionInfo String) -> Module.CanonicalUnion
101 canonical (name, (tvars, ctors)) =
101 canonical (name, (tvars, ctors)) =
102 ( toVar name
102 ( toVar name
103 , (tvars, map (first toVar) ctors)
103 , (tvars, map (first toVar) ctors)
src/Type/Type.hs+11−12
@@ -309,22 +309,22 @@ termToSrcType :: Term1 Variable -> StateT NameState IO T.Canonical
309termToSrcType term =
309termToSrcType term =
310 case term of
310 case term of
311 App1 func arg ->
311 App1 func arg ->
312− do srcFunc <- variableToSrcType func
312+ do srcFunc <- variableToSrcType func
313− srcArg <- variableToSrcType arg
313+ srcArg <- variableToSrcType arg
314− case srcFunc of
314+ case srcFunc of
315− T.App f args ->
315+ T.App f args ->
316− return (T.App f (args ++ [srcArg]))
316+ return (T.App f (args ++ [srcArg]))
317
317
318− _ ->
318+ _ ->
319− return (T.App srcFunc [srcArg])
319+ return (T.App srcFunc [srcArg])
320
320
321 Fun1 a b ->
321 Fun1 a b ->
322− T.Lambda
322+ T.Lambda
323− <$> variableToSrcType a
323+ <$> variableToSrcType a
324− <*> variableToSrcType b
324+ <*> variableToSrcType b
325
325
326 EmptyRecord1 ->
326 EmptyRecord1 ->
327− return $ T.Record [] Nothing
327+ return $ T.Record [] Nothing
328
328
329 Record1 fields extension ->
329 Record1 fields extension ->
330 do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields
330 do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields
@@ -455,4 +455,3 @@ getVarNamesTerm term =
455 Record1 fields extension ->
455 Record1 fields extension ->
456 do fieldVars <- Set.unions <$> mapM go (Map.elems fields)
456 do fieldVars <- Set.unions <$> mapM go (Map.elems fields)
457 Set.union fieldVars <$> go extension
457 Set.union fieldVars <$> go extension
458−
src/Type/Unify.hs+3−1
@@ -270,6 +270,7 @@ unifyRigid context maybeSuper maybeName otherContent =
270 mismatch context (Just (badRigid maybeName))
270 mismatch context (Just (badRigid maybeName))
271
271
272
272
273+
273-- UNIFY SUPER VARIABLES
274-- UNIFY SUPER VARIABLES
274
275
275
276
@@ -353,7 +354,7 @@ atomMatchesSuper super name =
353 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
354 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
354
355
355 Appendable ->
356 Appendable ->
356− Var.isPrim "String" name || Var.isText name
357+ Var.isPrim "String" name
357
358
358 CompAppend ->
359 CompAppend ->
359 Var.isPrim "String" name
360 Var.isPrim "String" name
@@ -496,6 +497,7 @@ isIntFloat name otherName =
496 Var.isPrim "Int" name && Var.isPrim "Float" otherName
497 Var.isPrim "Int" name && Var.isPrim "Float" otherName
497
498
498
499
500+
499-- UNIFY ALIASES
501-- UNIFY ALIASES
500
502
501
503
src/Validate.hs+478−251
@@ -1,18 +1,25 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Validate (declarations) where
2+module Validate (Result, module') where
3
3
4+import Prelude hiding (init)
4−import Control.Monad (foldM)
5+import Control.Monad (foldM, when)
5import qualified Data.Map as Map
6import qualified Data.Map as Map
7+import qualified Data.Maybe as Maybe
6import qualified Data.Set as Set
8import qualified Data.Set as Set
7import qualified Data.Foldable as F
9import qualified Data.Foldable as F
8import qualified Data.Traversable as T
10import qualified Data.Traversable as T
9
11
10import AST.Expression.General as Expr
12import AST.Expression.General as Expr
13+import qualified AST.Effects as Effects
11import qualified AST.Expression.Source as Source
14import qualified AST.Expression.Source as Source
12import qualified AST.Expression.Valid as Valid
15import qualified AST.Expression.Valid as Valid
13import qualified AST.Declaration as D
16import qualified AST.Declaration as D
17+import qualified AST.Module as Module
18+import qualified AST.Module.Name as ModuleName
14import qualified AST.Pattern as Pattern
19import qualified AST.Pattern as Pattern
15import qualified AST.Type as Type
20import qualified AST.Type as Type
21+import qualified Elm.Compiler.Imports as Imports
22+import qualified Elm.Package as Package
16import Elm.Utils ((|>))
23import Elm.Utils ((|>))
17import qualified Reporting.Annotation as A
24import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Syntax as Error
25import qualified Reporting.Error.Syntax as Error
@@ -20,163 +27,401 @@ import qualified Reporting.Region as R
20import qualified Reporting.Result as Result
27import qualified Reporting.Result as Result
21
28
22
29
23−-- VALIDATE DECLARATIONS
24
30
25−declarations
31+type Result warning a =
26− :: Bool
32+ Result.Result () warning Error.Error a
27− -> [D.SourceDecl]
33+
28− -> Result.Result wrn Error.Error [D.ValidDecl]
34+
29−declarations isRoot sourceDecls =
35+
30− do validDecls <- validateDecls Nothing sourceDecls
36+-- MODULES
31− (\_ _ -> validDecls)
37+
32− <$> declDuplicates validDecls
38+
33− <*> T.traverse (checkDecl isRoot) validDecls
39+module' :: Module.Source -> Result wrn Module.Valid
34−
40+module' (Module.Module name path info) =
35−
41+ let
36−validateDecls
42+ (ModuleName.Canonical pkgName _) =
37− :: Maybe String
43+ name
38− -> [D.SourceDecl]
44+
39− -> Result.Result wrn Error.Error [D.ValidDecl]
45+ (Module.Source tag settings docs exports imports decls) =
40−validateDecls maybeComment sourceDecls =
46+ info
41− case sourceDecls of
47+ in
48+ do (ValidStuff ports structure) <- validateDecls decls
49+
50+ validEffects <- validateEffects tag settings ports (D._defs structure)
51+
52+ return $ Module.Module name path $
53+ Module.Valid docs exports (addDefaults pkgName imports) structure validEffects
54+
55+
56+
57+-- IMPORTS
58+
59+
60+addDefaults
61+ :: Package.Name
62+ -> [Module.UserImport]
63+ -> ([Module.DefaultImport], [Module.UserImport])
64+addDefaults pkgName imports =
65+ flip (,) imports $
66+ if pkgName == Package.core then
67+ []
68+
69+ else
70+ Imports.defaults
71+
72+
73+
74+-- EFFECTS
75+
76+
77+validateEffects
78+ :: Module.SourceTag
79+ -> Module.SourceSettings
80+ -> [A.Commented Effects.PortRaw]
81+ -> [A.Commented Valid.Def]
82+ -> Result wrn Effects.Raw
83+validateEffects tag settings@(A.A _ pairs) ports validDefs =
84+ case tag of
85+ Module.Normal ->
86+ do noSettings Error.SettingsOnNormalModule settings
87+ noPorts ports
88+ return Effects.None
89+
90+ Module.Port _ ->
91+ do noSettings Error.SettingsOnPortModule settings
92+ return (Effects.Port ports)
93+
94+ Module.Effect tagRegion ->
95+ let
96+ collectSettings (A.A region setting, userValue) dict =
97+ Map.insertWith (++) setting [(region, userValue)] dict
98+
99+ settingsDict =
100+ foldr collectSettings Map.empty pairs
101+ in
102+ do noPorts ports
103+ managerType <- toManagerType tagRegion settingsDict
104+ (r0, r1, r2) <- checkManager tagRegion managerType validDefs
105+ return (Effects.Manager () (Effects.Info tagRegion r0 r1 r2 managerType))
106+
107+
108+noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()
109+noSettings errorMsg (A.A region settings) =
110+ case settings of
42 [] ->
111 [] ->
43− return []
112+ Result.ok ()
44−
113+
45− sourceDecl : decls ->
114+ _ : _ ->
115+ Result.throw region errorMsg
116+
117+
118+noPorts :: [A.Commented Effects.PortRaw] -> Result wrn ()
119+noPorts ports =
46− case sourceDecl of
120+ case ports of
47− D.Comment comment ->
121+ [] ->
48− validateDecls (Just comment) decls
122+ Result.ok ()
49−
123+
50− D.Decl decl ->
124+ _ : _ ->
51− validateDeclsHelp maybeComment decl decls
125+ let
52−
126+ toError (A.A (region, _) (Effects.PortRaw name _)) =
53−
127+ A.A region (Error.UnexpectedPort name)
54−validateDeclsHelp
128+ in
55− :: Maybe String
129+ Result.throwMany (map toError ports)
56− -> A.Located D.SourceDecl'
130+
57− -> [D.SourceDecl]
131+
58− -> Result.Result wrn Error.Error [D.ValidDecl]
132+toManagerType
59−validateDeclsHelp comment (A.A region decl) decls =
133+ :: R.Region
60− let addRest validDecl =
134+ -> Map.Map String [(R.Region, A.Located String)]
61− (:) (A.A (region, comment) validDecl)
135+ -> Result wrn Effects.ManagerType
62− <$> validateDecls Nothing decls
136+toManagerType tagRegion settingsDict =
137+ let
138+ toErrors name entries =
139+ map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
140+
141+ errors =
142+ settingsDict
143+ |> Map.delete "command"
144+ |> Map.delete "subscription"
145+ |> Map.mapWithKey toErrors
146+ |> Map.elems
147+ |> concat
63 in
148 in
149+ do when (not (null errors)) (Result.throwMany errors)
150+ maybeEffects <-
151+ (,) <$> extractOne "command" settingsDict
152+ <*> extractOne "subscription" settingsDict
153+
154+ -- TODO check that cmd and sub types exist?
64− case decl of
155+ case maybeEffects of
65− D.Datatype name tvars ctors ->
156+ (Nothing, Nothing) ->
66− addRest (D.Datatype name tvars ctors)
157+ Result.throw tagRegion Error.NoSettingsOnEffectModule
158+
159+ (Just cmd, Nothing) ->
160+ return (Effects.CmdManager cmd)
161+
162+ (Nothing, Just sub) ->
163+ return (Effects.SubManager sub)
164+
165+ (Just cmd, Just sub) ->
166+ return (Effects.FxManager cmd sub)
67
167
68− D.TypeAlias name tvars alias ->
69− addRest (D.TypeAlias name tvars alias)
70
168
71− D.Fixity assoc prec op ->
169+extractOne
72− addRest (D.Fixity assoc prec op)
170+ :: String
171+ -> Map.Map String [(R.Region, A.Located String)]
172+ -> Result wrn (Maybe (A.Located String))
173+extractOne name settingsDict =
174+ case Map.lookup name settingsDict of
175+ Nothing ->
176+ return Nothing
73
177
74− D.Definition def ->
178+ Just [] ->
75− defHelp comment def decls
179+ error "Empty lists should never be added to the dictionary of effect module settings."
76
180
77− D.Port port ->
181+ Just [(_, userType)] ->
78− portHelp comment region port decls
182+ return (Just userType)
79
183
184+ Just ((region, _) : _) ->
185+ Result.throw region (Error.DuplicateSettingOnEffectModule name)
80
186
81−-- VALIDATE DEFINITIONS IN DECLARATIONS
82
187
83−defHelp
188+
84− :: Maybe String
189+-- CHECK EFFECT MANAGER
85− -> Source.Def
190+
86− -> [D.SourceDecl]
191+
87− -> Result.Result wrn Error.Error [D.ValidDecl]
192+checkManager
88−defHelp comment (A.A region def) decls =
193+ :: R.Region
89− let addRest def' rest =
194+ -> Effects.ManagerType
90− (:) (A.A (region, comment) (D.Definition def'))
195+ -> [A.Commented Valid.Def]
91− <$> validateDecls Nothing rest
196+ -> Result wrn (R.Region, R.Region, R.Region)
197+checkManager tagRegion managerType validDefs =
198+ let
199+ regionDict =
200+ Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)
92 in
201 in
93− case def of
202+ const (,,)
94− Source.Definition pat expr ->
203+ <$> requireMaps tagRegion regionDict managerType
95− do expr' <- expression expr
204+ <*> requireRegion tagRegion regionDict "init"
96− let def' = Valid.Definition pat expr' Nothing
205+ <*> requireRegion tagRegion regionDict "onEffects"
97− checkDefinition def'
206+ <*> requireRegion tagRegion regionDict "onSelfMsg"
98− addRest def' decls
99−
100− Source.TypeAnnotation name tipe ->
101− case decls of
102− D.Decl (A.A _ (D.Definition (A.A _
103− (Source.Definition pat@(A.A _ (Pattern.Var name')) expr)))) : rest
104− | name == name' ->
105− do expr' <- expression expr
106− let def' = Valid.Definition pat expr' (Just tipe)
107− checkDefinition def'
108− addRest def' rest
109
207
110− _ ->
111− Result.throw region (Error.TypeWithoutDefinition name)
112
208
209+getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)
210+getSimpleDefRegion decl =
211+ case decl of
212+ A.A (region, _) (Valid.Def (A.A _ (Pattern.Var name)) _ _) ->
213+ Just (name, region)
214+
215+ _ ->
216+ Nothing
113
217
114−-- VALIDATE PORTS IN DECLARATIONS
115
218
116−portHelp
219+requireMaps
117− :: Maybe String
220+ :: R.Region
118− -> R.Region
221+ -> Map.Map String R.Region
119− -> D.SourcePort
222+ -> Effects.ManagerType
120− -> [D.SourceDecl]
121− -> Result.Result wrn Error.Error [D.ValidDecl]
223+ -> Result wrn ()
122−portHelp comment region port decls =
224+requireMaps tagRegion regionDict managerType =
123− let addRest port' rest =
225+ let
124− (:) (A.A (region,comment) (D.Port port'))
226+ check name =
125− <$> validateDecls Nothing rest
227+ when (Map.notMember name regionDict) $
228+ Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
126 in
229 in
127− case port of
230+ case managerType of
128− D.PortDefinition name _ ->
231+ Effects.CmdManager _ ->
129− Result.throw region (Error.PortWithoutAnnotation name)
232+ check "cmdMap"
130−
233+
131− D.PortAnnotation name tipe ->
234+ Effects.SubManager _ ->
132− case decls of
235+ check "subMap"
133− D.Decl (A.A _ (D.Port (D.PortDefinition name' expr))) : rest
236+
134− | name == name' ->
237+ Effects.FxManager _ _ ->
135− do expr' <- expression expr
238+ check "cmdMap" <* check "subMap"
136− let port' = D.Out name expr' tipe
239+
137− addRest port' rest
240+
241+requireRegion :: R.Region -> Map.Map String R.Region -> String -> Result wrn R.Region
242+requireRegion tagRegion regionDict name =
243+ case Map.lookup name regionDict of
244+ Just region ->
245+ return region
246+
247+ Nothing ->
248+ Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
249+
250+
251+
252+-- COLLAPSE COMMENTS
253+
254+
255+collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]
256+collapseComments listWithComments =
257+ case listWithComments of
258+ [] ->
259+ Result.ok []
260+
261+ D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->
262+ let
263+ entry =
264+ A.A (region, Just msg) a
265+ in
266+ fmap (entry:) (collapseComments rest)
267+
268+ D.Comment (A.A region _) : rest ->
269+ collapseComments rest
270+ <* Result.throw region Error.CommentOnNothing
271+
272+
273+ D.Whatever (A.A region a) : rest ->
274+ let
275+ entry =
276+ A.A (region, Nothing) a
277+ in
278+ fmap (entry:) (collapseComments rest)
279+
280+
281+
282+-- VALIDATE STRUCTURED SOURCE
283+
284+
285+validateDecls :: [D.Source] -> Result wrn ValidStuff
286+validateDecls sourceDecls =
287+ do rawDecls <- collapseComments sourceDecls
288+
289+ validStuff <- validateRawDecls rawDecls
290+
291+ let (D.Decls _ unions aliases _) = _structure validStuff
292+
293+ return validStuff
294+ <* F.traverse_ checkTypeVarsInUnion unions
295+ <* F.traverse_ checkTypeVarsInAlias aliases
296+ <* checkDuplicates validStuff
297+
298+
299+
300+-- VALIDATE DECLARATIONS
301+
302+
303+data ValidStuff =
304+ ValidStuff
305+ { _ports :: [A.Commented Effects.PortRaw]
306+ , _structure :: D.Valid
307+ }
308+
309+
310+validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff
311+validateRawDecls commentedDecls =
312+ vrdHelp commentedDecls [] (D.Decls [] [] [] [])
313+
314+
315+vrdHelp
316+ :: [A.Commented D.Raw]
317+ -> [A.Commented Effects.PortRaw]
318+ -> D.Valid
319+ -> Result wrn ValidStuff
320+vrdHelp commentedDecls ports structure =
321+ case commentedDecls of
322+ [] ->
323+ Result.ok (ValidStuff ports structure)
324+
325+ A.A ann decl : rest ->
326+ case decl of
327+ D.Union (D.Type name tvars ctors) ->
328+ vrdHelp rest ports (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)
329+
330+ D.Alias (D.Type name tvars alias) ->
331+ vrdHelp rest ports (D.addAlias (A.A ann (D.Type name tvars alias)) structure)
332+
333+ D.Fixity fixity ->
334+ vrdHelp rest ports (D.addInfix fixity structure)
335+
336+ D.Def (A.A region def) ->
337+ vrdDefHelp rest (A.A (region, snd ann) def) ports structure
338+
339+ D.Port name tipe ->
340+ vrdHelp rest (A.A ann (Effects.PortRaw name tipe) : ports) structure
341+
342+
343+vrdDefHelp
344+ :: [A.Commented D.Raw]
345+ -> A.Commented Source.Def'
346+ -> [A.Commented Effects.PortRaw]
347+ -> D.Valid
348+ -> Result wrn ValidStuff
349+vrdDefHelp remainingDecls (A.A ann def) ports structure =
350+ let
351+ addDef validDef (ValidStuff finalPorts struct) =
352+ ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)
353+ in
354+ case def of
355+ Source.Definition pat expr ->
356+ addDef
357+ <$> validateDef pat expr Nothing
358+ <*> vrdHelp remainingDecls ports structure
359+
360+ Source.Annotation name tipe ->
361+ case remainingDecls of
362+ A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
363+ | Pattern.isVar name pat ->
364+ addDef
365+ <$> validateDef pat expr (Just tipe)
366+ <*> vrdHelp rest ports structure
138
367
139 _ ->
368 _ ->
140− addRest (D.In name tipe) decls
369+ vrdHelp remainingDecls ports structure
370+ <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)
371+
141
372
142
373
143-- VALIDATE DEFINITIONS
374-- VALIDATE DEFINITIONS
144
375
376+
145−definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
377+definitions :: [Source.Def] -> Result wrn [Valid.Def]
146definitions sourceDefs =
378definitions sourceDefs =
147 do validDefs <- definitionsHelp sourceDefs
379 do validDefs <- definitionsHelp sourceDefs
148− let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
380+
149− defDuplicates patterns
381+ validDefs
382+ |> map Valid.getPattern
383+ |> concatMap Pattern.boundVars
384+ |> detectDuplicates Error.DuplicateDefinition
385+
150 return validDefs
386 return validDefs
151
387
152
388
153−definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
389+definitionsHelp :: [Source.Def] -> Result wrn [Valid.Def]
154definitionsHelp sourceDefs =
390definitionsHelp sourceDefs =
155 case sourceDefs of
391 case sourceDefs of
156 [] ->
392 [] ->
157− return []
393+ return []
158
394
159 A.A _ (Source.Definition pat expr) : rest ->
395 A.A _ (Source.Definition pat expr) : rest ->
160− do expr' <- expression expr
396+ (:)
161− let def = Valid.Definition pat expr' Nothing
397+ <$> validateDef pat expr Nothing
162− checkDefinition def
163− (:) def <$> definitionsHelp rest
398+ <*> definitionsHelp rest
164−
399+
165− A.A region (Source.TypeAnnotation name tipe) : rest ->
400+ A.A region (Source.Annotation name tipe) : rest ->
166− case rest of
401+ case rest of
167− A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'
402+ A.A _ (Source.Definition pat expr) : rest'
168− | name == name' ->
403+ | Pattern.isVar name pat ->
169− do expr' <- expression expr
404+ (:)
170− let def = Valid.Definition pat expr' (Just tipe)
405+ <$> validateDef pat expr (Just tipe)
171− checkDefinition def
172− (:) def <$> definitionsHelp rest'
406+ <*> definitionsHelp rest'
173−
407+
174− _ ->
408+ _ ->
175− Result.throw region (Error.TypeWithoutDefinition name)
409+ Result.throw region (Error.TypeWithoutDefinition name)
176−
410+
177−
411+
178−checkDefinition :: Valid.Def -> Result.Result wrn Error.Error ()
412+validateDef
179−checkDefinition (Valid.Definition pattern body _) =
413+ :: Pattern.Raw
414+ -> Source.Expr
415+ -> Maybe Type.Raw
416+ -> Result wrn Valid.Def
417+validateDef pat expr maybeType =
418+ do validExpr <- expression expr
419+ validateDefPattern pat validExpr
420+ return $ Valid.Def pat validExpr maybeType
421+
422+
423+validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()
424+validateDefPattern pattern body =
180 case fst (Expr.collectLambdas body) of
425 case fst (Expr.collectLambdas body) of
181 [] ->
426 [] ->
182 return ()
427 return ()
@@ -194,9 +439,11 @@ checkDefinition (Valid.Definition pattern body _) =
194 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
439 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
195
440
196
441
442+
197-- VALIDATE EXPRESSIONS
443-- VALIDATE EXPRESSIONS
198
444
445+
199−expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
446+expression :: Source.Expr -> Result wrn Valid.Expr
200expression (A.A ann sourceExpression) =
447expression (A.A ann sourceExpression) =
201 A.A ann <$>
448 A.A ann <$>
202 case sourceExpression of
449 case sourceExpression of
@@ -270,162 +517,144 @@ expression (A.A ann sourceExpression) =
270 <$> definitions defs
517 <$> definitions defs
271 <*> expression body
518 <*> expression body
272
519
273− GLShader uid src gltipe ->
520+ Cmd moduleName ->
274− return (GLShader uid src gltipe)
521+ return (Cmd moduleName)
275
522
276− Port impl ->
523+ Sub moduleName ->
277− Port <$>
524+ return (Sub moduleName)
278− case impl of
279− In name tipe ->
280− return (In name tipe)
281
525
282− Out name expr tipe ->
526+ OutgoingPort name tipe ->
283− do expr' <- expression expr
284− return (Out name expr' tipe)
527+ return (OutgoingPort name tipe)
285
528
286− Task name expr tipe ->
529+ IncomingPort name tipe ->
287− do expr' <- expression expr
288− return (Task name expr' tipe)
530+ return (IncomingPort name tipe)
289
531
532+ Program _ _ ->
533+ error "DANGER - Program AST nodes should not be in validation phase."
290
534
535+ SaveEnv moduleName effects ->
536+ return (SaveEnv moduleName effects)
537+
538+ GLShader uid src gltipe ->
539+ return (GLShader uid src gltipe)
540+
541+
291−second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
542+second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)
292second (value, expr) =
543second (value, expr) =
293 (,) value <$> expression expr
544 (,) value <$> expression expr
294
545
295
546
296−both
297− :: (Source.Expr, Source.Expr)
298− -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
547+both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)
299both (expr1, expr2) =
548both (expr1, expr2) =
300 (,) <$> expression expr1 <*> expression expr2
549 (,) <$> expression expr1 <*> expression expr2
301
550
302
551
552+
303-- VALIDATE PATTERNS
553-- VALIDATE PATTERNS
304
554
555+
305−validatePattern :: Pattern.RawPattern -> Result.Result wrn Error.Error Pattern.RawPattern
556+validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
306validatePattern pattern =
557validatePattern pattern =
307 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
558 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
308 return pattern
559 return pattern
309
560
310
561
311−-- DETECT DUPLICATES
312
562
313−detectDuplicates
563+-- DETECT DUPLICATES
314− :: (String -> Error.Error)
315− -> [A.Located String]
316− -> Result.Result wrn Error.Error ()
317−detectDuplicates tag names =
318− let add (A.A region name) dict =
319− Map.insertWith (++) name [region] dict
320
564
321− makeGroups pairs =
322− Map.toList (foldr add Map.empty pairs)
323
565
324− check (name, regions) =
566+checkDuplicates :: ValidStuff -> Result wrn ()
325− case regions of
567+checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
326− _ : region : _ ->
568+ let
327− Result.throw region (tag name)
569+ -- SIMPLE NAMES
328
570
329− _ ->
571+ defValues =
330− return ()
572+ concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs
331− in
332− F.traverse_ check (makeGroups names)
333
573
574+ portValues =
575+ map fromPort ports
334
576
335−defDuplicates
577+ fromPort (A.A (region, _) (Effects.PortRaw name _)) =
336− :: [Pattern.RawPattern]
578+ A.A region name
337− -> Result.Result wrn Error.Error ()
338−defDuplicates patterns =
339− concatMap Pattern.boundVars patterns
340− |> detectDuplicates Error.DuplicateDefinition
341
579
580+ -- TYPE NAMES
342
581
343−declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()
582+ (types, typeValues) =
344−declDuplicates decls =
583+ unzip (map fromUnion unions ++ map fromAlias aliases)
345− let (valueLists, typeLists) = unzip (map extractValues decls)
346− in
347− (\_ _ -> ())
348− <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
349− <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
350
584
585+ fromUnion (A.A (region, _) (D.Type name _ ctors)) =
586+ ( A.A region name
587+ , map (A.A region . fst) ctors
588+ )
351
589
352−extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])
590+ fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
353−extractValues (A.A (region, _) decl) =
591+ (,) (A.A region name) $
354− case decl of
592+ case tipe of
355− D.Definition (Valid.Definition pattern _ _) ->
593+ Type.RRecord _ _ ->
356− ( Pattern.boundVars pattern
594+ [A.A region name]
357− , []
358− )
359
595
360− D.Datatype name _ ctors ->
596+ _ ->
361− ( map (A.A region . fst) ctors
597+ []
362− , [A.A region name]
598+ in
363− )
599+ F.sequenceA_
600+ [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
601+ , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
602+ , detectDuplicates Error.DuplicateTypeDeclaration types
603+ ]
364
604
365− D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->
366− ( [A.A region name]
367− , [A.A region name]
368− )
369
605
370− D.TypeAlias name _ _ ->
606+detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
371− ( []
607+detectDuplicates tag names =
372− , [A.A region name]
608+ let
373− )
609+ add (A.A region name) dict =
610+ Map.insertWith (++) name [region] dict
374
611
375− D.Port port ->
612+ makeGroups pairs =
376− ( [A.A region (D.validPortName port)]
613+ Map.toList (foldr add Map.empty pairs)
377− , []
378− )
379
614
380− D.Fixity _ _ _ ->
615+ check (name, regions) =
381− ( []
616+ case regions of
382− , []
617+ _ : region : _ ->
383− )
618+ Result.throw region (tag name)
384
619
620+ _ ->
621+ return ()
622+ in
623+ F.traverse_ check (makeGroups names)
385
624
386−-- UNBOUND TYPE VARIABLES
387
625
388−checkDecl :: Bool -> D.ValidDecl -> Result.Result wrn Error.Error ()
389−checkDecl isRoot (A.A (region,_) decl) =
390− case decl of
391− D.Definition _ ->
392− return ()
393
626
394− D.Datatype name boundVars ctors ->
627+-- UNBOUND TYPE VARIABLES
395− case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
396− (_, []) ->
397− return ()
398
628
399− (_, unbound) ->
400− Result.throw region
401− (Error.UnboundTypeVarsInUnion name boundVars unbound)
402
629
403− D.TypeAlias name boundVars tipe ->
630+checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
631+checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
404− case diff boundVars (freeVars tipe) of
632+ case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
405− ([], []) ->
633+ (_, []) ->
406− return ()
634+ return ()
407
635
408− ([], unbound) ->
636+ (_, unbound) ->
409− Result.throw region
637+ Result.throw region
410− (Error.UnboundTypeVarsInAlias name boundVars unbound)
638+ (Error.UnboundTypeVarsInUnion name boundVars unbound)
411
639
412− (unused, []) ->
413− Result.throw region
414− (Error.UnusedTypeVarsInAlias name boundVars unused)
415
640
416− (unused, unbound) ->
641+checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
417− Result.throw region
642+checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
418− (Error.MessyTypeVarsInAlias name boundVars unused unbound)
643+ case diff boundVars (freeVars tipe) of
644+ ([], []) ->
645+ return ()
419
646
420− D.Port _ ->
647+ ([], unbound) ->
421− if isRoot then
648+ Result.throw region
422− return ()
649+ (Error.UnboundTypeVarsInAlias name boundVars unbound)
423
650
424− else
651+ (unused, []) ->
425− Result.throw region Error.UnexpectedPort
652+ Result.throw region
653+ (Error.UnusedTypeVarsInAlias name boundVars unused)
426
654
427− D.Fixity _ _ _ ->
655+ (unused, unbound) ->
428− return ()
656+ Result.throw region
657+ (Error.MessyTypeVarsInAlias name boundVars unused unbound)
429
658
430
659
431diff :: [String] -> [A.Located String] -> ([String], [String])
660diff :: [String] -> [A.Located String] -> ([String], [String])
@@ -442,23 +671,21 @@ diff left right =
442 )
671 )
443
672
444
673
445−
446freeVars :: Type.Raw -> [A.Located String]
674freeVars :: Type.Raw -> [A.Located String]
447freeVars (A.A region tipe) =
675freeVars (A.A region tipe) =
448− case tipe of
676+ case tipe of
449− Type.RLambda t1 t2 ->
677+ Type.RLambda t1 t2 ->
450− freeVars t1 ++ freeVars t2
678+ freeVars t1 ++ freeVars t2
451−
452− Type.RVar x ->
453− [A.A region x]
454
679
455− Type.RType _ ->
680+ Type.RVar x ->
456− []
681+ [A.A region x]
457
682
458− Type.RApp t ts ->
683+ Type.RType _ ->
459− concatMap freeVars (t:ts)
684+ []
460
685
461− Type.RRecord fields ext ->
686+ Type.RApp t ts ->
462− maybe [] freeVars ext
687+ concatMap freeVars (t:ts)
463− ++ concatMap (freeVars . snd) fields
464
688
689+ Type.RRecord fields ext ->
690+ maybe [] freeVars ext
691+ ++ concatMap (freeVars . snd) fields
tests/Test/Compiler.hs+14−12
@@ -4,6 +4,8 @@ module Test.Compiler (compilerTests) where
4
4
5import Control.Exception (try, IOException)
5import Control.Exception (try, IOException)
6
6
7+import qualified Data.Text.Lazy as Text
8+import qualified Data.Text.Lazy.IO as Text
7import qualified Data.Map as Map
9import qualified Data.Map as Map
8import Data.Maybe (isJust)
10import Data.Maybe (isJust)
9
11
@@ -86,15 +88,15 @@ essentialInterfaces =
86
88
87buildCoreInterface :: [(String, Type.Canonical)] -> Module.Interface
89buildCoreInterface :: [(String, Type.Canonical)] -> Module.Interface
88buildCoreInterface members =
90buildCoreInterface members =
91+ let
89− let exports = map (Variable.Value . fst) members
92+ exports = map (Variable.Value . fst) members
90− imports = []
93+ imports = []
91− types = Map.fromList members
94+ types = Map.fromList members
92− adts = Map.empty
95+ adts = Map.empty
93− aliases = Map.empty
96+ aliases = Map.empty
94− fixities = []
97+ fixities = []
95− ports = []
96 in
98 in
97− Module.Interface Compiler.version Package.coreName exports types imports adts aliases fixities ports
99+ Module.Interface Compiler.version Package.core exports imports types adts aliases fixities
98
100
99
101
100compileString :: FilePath -> String -> Either String Compiler.Result
102compileString :: FilePath -> String -> Either String Compiler.Result
@@ -102,7 +104,7 @@ compileString filePath source =
102 let dependentModuleNames =
104 let dependentModuleNames =
103 Map.keys essentialInterfaces
105 Map.keys essentialInterfaces
104 context =
106 context =
105− Compiler.Context Package.coreName True False dependentModuleNames
107+ Compiler.Context Package.core False dependentModuleNames
106 (dealiaser, _warnings, result) =
108 (dealiaser, _warnings, result) =
107 Compiler.compile context source essentialInterfaces
109 Compiler.compile context source essentialInterfaces
108 formatErrors errors =
110 formatErrors errors =
@@ -162,8 +164,8 @@ doWriteNewExpectedTest expectedJsDir filePath =
162 -- Force the evaluation of `js` before `writeFile`
164 -- Force the evaluation of `js` before `writeFile`
163 -- so that if an error is raised we do not unintentionally write an empty file.
165 -- so that if an error is raised we do not unintentionally write an empty file.
164 -- NB: `js` can be an empty string in the case of NoExpressions.elm
166 -- NB: `js` can be an empty string in the case of NoExpressions.elm
165− assertBool "" (length js >= 0)
167+ assertBool "" (Text.length js >= 0)
166− writeFile expectedFilePath js
168+ Text.writeFile expectedFilePath js
167 assertFailure ("Wrote new expected js: " ++ expectedFilePath)
169 assertFailure ("Wrote new expected js: " ++ expectedFilePath)
168
170
169 _ ->
171 _ ->
@@ -210,7 +212,7 @@ matchesExpected :: String -> Either String Compiler.Result -> Assertion
210matchesExpected expectedJs result =
212matchesExpected expectedJs result =
211 case result of
213 case result of
212 Right (Compiler.Result _ _ js) ->
214 Right (Compiler.Result _ _ js) ->
213− assertEqual matchFailureMessage expectedJs js
215+ assertEqual matchFailureMessage (Text.pack expectedJs) js
214
216
215 Left errorMessages ->
217 Left errorMessages ->
216 assertFailure $ "Compile failed:\n" ++ errorMessages
218 assertFailure $ "Compile failed:\n" ++ errorMessages
tests/test-files/good-expected-js/Cases/CharCase.elm.js+8−10
@@ -1,10 +1,8 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$foo = function (x) {
2−Elm.Main.make = function (_elm) {
2+ var _p0 = x;
3− "use strict";
3+ if (_p0.valueOf() === 'A') {
4− _elm.Main = _elm.Main || {};
4+ return 'hello';
5− if (_elm.Main.values) return _elm.Main.values;
5+ } else {
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var foo = function (x) { var _p0 = x;if (_p0.valueOf() === "A") { return "hello";} else { return "letter A was not seen";}};
6+ return 'letter A was not seen';
9− return _elm.Main.values = {_op: _op,foo: foo};
7+ }
10−};
8+};
tests/test-files/good-expected-js/Cases/ListZip.elm.js+21−23
@@ -1,23 +1,21 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$Cons = F2(
2−Elm.Main.make = function (_elm) {
2+ function (a, b) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var Cons = F2(function (a,b) { return {ctor: "Cons",_0: a,_1: b};});
3+ return {ctor: 'Cons', _0: a, _1: b};
4+ });
9− var Nil = {ctor: "Nil"};
5+var _elm_lang$core$Main$Nil = {ctor: 'Nil'};
6+var _elm_lang$core$Main$zip = F2(
10− var zip = F2(function (list1,list2) {
7+ function (list1, list2) {
11− var _p0 = {ctor: "_Tuple2",_0: list1,_1: list2};
8+ var _p0 = {ctor: '_Tuple2', _0: list1, _1: list2};
12− if (_p0._0.ctor === "Nil") {
9+ if (_p0._0.ctor === 'Nil') {
13− return Nil;
10+ return _elm_lang$core$Main$Nil;
14− } else {
11+ } else {
15− if (_p0._1.ctor === "Nil") {
12+ if (_p0._1.ctor === 'Nil') {
16− return Nil;
13+ return _elm_lang$core$Main$Nil;
17− } else {
14+ } else {
15+ return A2(
16+ _elm_lang$core$Main$Cons,
18− return A2(Cons,{ctor: "_Tuple2",_0: _p0._0._0,_1: _p0._1._0},A2(zip,_p0._0._1,_p0._1._1));
17+ {ctor: '_Tuple2', _0: _p0._0._0, _1: _p0._1._0},
18+ A2(_elm_lang$core$Main$zip, _p0._0._1, _p0._1._1));
19− }
19+ }
20− }
20+ }
21− });
21+ });
22− return _elm.Main.values = {_op: _op,Nil: Nil,Cons: Cons,zip: zip};
23−};
tests/test-files/good-expected-js/CodeGenBugs/CommentInterpretedAsInfix.elm.js+13−12
@@ -1,12 +1,13 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$always = F2(
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var always = F2(function (x,s) { return x;});
2+ function (x, s) {
3+ return x;
4+ });
5+var _elm_lang$core$Main_ops = _elm_lang$core$Main_ops || {};
6+_elm_lang$core$Main_ops['|>'] = F2(
9− _op["|>"] = F2(function (a,f) { return f(a);});
7+ function (a, f) {
8+ return f(a);
9+ });
10+var _elm_lang$core$Main$value = A2(
11+ _elm_lang$core$Main_ops['|>'],
12+ 'Hi',
10− var value = A2(_op["|>"],"Hi",always("Hello"));
13+ _elm_lang$core$Main$always('Hello'));
11− return _elm.Main.values = {_op: _op,always: always,value: value};
12−};
tests/test-files/good-expected-js/CodeGenBugs/NestedPatternMatch.elm.js+4−10
@@ -1,10 +1,4 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var foo = function (_p0) { var _p1 = _p0;return _p1;};
1+var _elm_lang$core$Main$foo = function (_p0) {
9− return _elm.Main.values = {_op: _op,foo: foo};
2+ var _p1 = _p0;
3+ return _p1;
10−};
4+};
tests/test-files/good-expected-js/CodeGenBugs/Shadowing.elm.js+16−15
@@ -1,15 +1,16 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var toName = function (a) {
1+var _elm_lang$core$Main$toName = function (a) {
9− var name = function () { var _p0 = a;if (_p0.ctor === "First") { return "True";} else { return _p0._0;}}();
2+ var name = function () {
3+ var _p0 = a;
4+ if (_p0.ctor === 'First') {
5+ return 'True';
6+ } else {
7+ return _p0._0;
8+ }
9+ }();
10− return name;
10+ return name;
11− };
11+};
12+var _elm_lang$core$Main$Second = F2(
13+ function (a, b) {
12− var Second = F2(function (a,b) { return {ctor: "Second",_0: a,_1: b};});
14+ return {ctor: 'Second', _0: a, _1: b};
15+ });
13− var First = {ctor: "First"};
16+var _elm_lang$core$Main$First = {ctor: 'First'};
14− return _elm.Main.values = {_op: _op,First: First,Second: Second,toName: toName};
15−};
tests/test-files/good-expected-js/CodeGenBugs/Shadowing2.elm.js+13−20
@@ -1,20 +1,13 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var Nothing = {ctor: "Nothing"};
1+var _elm_lang$core$Main$Nothing = {ctor: 'Nothing'};
2+var _elm_lang$core$Main$Just = function (a) {
9− var Just = function (a) { return {ctor: "Just",_0: a};};
3+ return {ctor: 'Just', _0: a};
4+};
10− var withDefault0 = function (maybe) {
5+var _elm_lang$core$Main$withDefault0 = function (maybe) {
11− var _p0 = maybe;
6+ var _p0 = maybe;
12− if (_p0.ctor === "Just") {
7+ if (_p0.ctor === 'Just') {
13− var maybe = Just("shadow argument, but do not overwrite it in JS!");
8+ var maybe = _elm_lang$core$Main$Just('shadow argument, but do not overwrite it in JS!');
14− return _p0._0;
9+ return _p0._0;
15− } else {
10+ } else {
16− return 0;
11+ return 0;
17− }
12+ }
18− };
19− return _elm.Main.values = {_op: _op,Just: Just,Nothing: Nothing,withDefault0: withDefault0};
20−};
13+};
tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_ListAny.elm.js+20−24
@@ -1,24 +1,20 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$any = F2(
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var any = F2(function (isOk,list) {
2+ function (isOk, list) {
3+ any:
9− any: while (true) {
4+ while (true) {
10− var _p0 = list;
5+ var _p0 = list;
11− if (_p0.ctor === "::") {
6+ if (_p0.ctor === '::') {
12− if (isOk(_p0._0)) return true; else {
7+ if (isOk(_p0._0)) {
8+ return true;
9+ } else {
13− var _v1 = isOk,_v2 = _p0._1;
10+ var _v1 = isOk,
11+ _v2 = _p0._1;
14− isOk = _v1;
12+ isOk = _v1;
15− list = _v2;
13+ list = _v2;
16− continue any;
14+ continue any;
17− }
15+ }
18− } else {
16+ } else {
19− return false;
17+ return false;
20− }
18+ }
21− }
19+ }
22− });
20+ });
23− return _elm.Main.values = {_op: _op,any: any};
24−};
tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_NameNormalization.elm.js+12−10
@@ -1,10 +1,12 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$go = function (n$) {
2−Elm.Main.make = function (_elm) {
2+ go:
3− "use strict";
3+ while (true) {
4− _elm.Main = _elm.Main || {};
4+ if (n$) {
5− if (_elm.Main.values) return _elm.Main.values;
5+ var _v0 = n$;
6− var _U = Elm.Native.Utils.make(_elm);
6+ n$ = _v0;
7− var _op = {};
7+ continue go;
8− var go = function (n$) { go: while (true) if (n$) { var _v0 = n$;n$ = _v0;continue go;} else return false;};
8+ } else {
9− return _elm.Main.values = {_op: _op,go: go};
9+ return false;
10+ }
11+ }
10−};
12+};
tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_UnsafeLabel.elm.js+23−25
@@ -1,25 +1,23 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$foldl$ = F3(
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var foldl$ = F3(function (update,state,items) {
2+ function (update, state, items) {
3+ foldl$:
9− foldl$: while (true) {
4+ while (true) {
10− var _p0 = items;
5+ var _p0 = items;
11− if (_p0.ctor === "Nil") {
6+ if (_p0.ctor === 'Nil') {
12− return state;
7+ return state;
13− } else {
8+ } else {
9+ var _v1 = update,
14− var _v1 = update,_v2 = A2(update,_p0._0,state),_v3 = _p0._1;
10+ _v2 = A2(update, _p0._0, state),
11+ _v3 = _p0._1;
15− update = _v1;
12+ update = _v1;
16− state = _v2;
13+ state = _v2;
17− items = _v3;
14+ items = _v3;
18− continue foldl$;
15+ continue foldl$;
19− }
16+ }
20− }
17+ }
21− });
18+ });
19+var _elm_lang$core$Main$Cons = F2(
20+ function (a, b) {
22− var Cons = F2(function (a,b) { return {ctor: "Cons",_0: a,_1: b};});
21+ return {ctor: 'Cons', _0: a, _1: b};
22+ });
23− var Nil = {ctor: "Nil"};
23+var _elm_lang$core$Main$Nil = {ctor: 'Nil'};
24− return _elm.Main.values = {_op: _op,Nil: Nil,Cons: Cons,foldl$: foldl$};
25−};
tests/test-files/good-expected-js/Crash/CrashCase.elm.js+14−17
@@ -1,17 +1,14 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm),$Debug = Elm.Debug.make(_elm);
7− var _op = {};
8− var test = function (x) {
1+var _elm_lang$core$Main$test = function (x) {
9− var _p0 = x;
2+ var _p0 = x;
10− if (_p0 === 1) {
3+ if (_p0 === 1) {
11− return 2;
4+ return 2;
12− } else {
5+ } else {
6+ return _elm_lang$core$Native_Utils.crashCase(
7+ 'Main',
8+ {
9+ start: {line: 5, column: 5},
10+ end: {line: 9, column: 43}
11+ },
13− return _U.crashCase("Main",{start: {line: 5,column: 5},end: {line: 9,column: 43}},_p0)("unexpected value");
12+ _p0)('unexpected value');
14− }
13+ }
15− };
16− return _elm.Main.values = {_op: _op,test: test};
17−};
14+};
tests/test-files/good-expected-js/Crash/CrashIf.elm.js+8−10
@@ -1,10 +1,8 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$test = function (x) {
2−Elm.Main.make = function (_elm) {
2+ return x ? 2 : _elm_lang$core$Native_Utils.crash(
3− "use strict";
3+ 'Main',
4− _elm.Main = _elm.Main || {};
4+ {
5− if (_elm.Main.values) return _elm.Main.values;
5+ start: {line: 8, column: 9},
6− var _U = Elm.Native.Utils.make(_elm),$Debug = Elm.Debug.make(_elm);
6+ end: {line: 8, column: 20}
7− var _op = {};
7+ })('unexpected value');
8− var test = function (x) { return x ? 2 : _U.crash("Main",{start: {line: 8,column: 9},end: {line: 8,column: 20}})("unexpected value");};
9− return _elm.Main.values = {_op: _op,test: test};
10−};
8+};
tests/test-files/good-expected-js/Declarations/NoDefinitions.elm.js−9
@@ -1,9 +0,0 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− return _elm.Main.values = {_op: _op};
9−};
tests/test-files/good-expected-js/Declarations/Ports.elm.jsdeleted−49
@@ -1,49 +0,0 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var students = Elm.Native.Port.make(_elm).outbound("students",
9− function (v) {
10− return Elm.Native.List.make(_elm).toArray(v).map(function (v) { return {name: v.name,age: v.age};});
11− },
12− _U.list([{name: "Tom",age: 42}]));
13− var time = Elm.Native.Port.make(_elm).outbound("time",function (v) { return v;},3.14);
14− var fortyTwo = Elm.Native.Port.make(_elm).outbound("fortyTwo",function (v) { return v;},42);
15− var record = Elm.Native.Port.make(_elm).inbound("record",
16− "{ x : Float, y : Float }",
17− function (v) {
18− return typeof v === "object" && "x" in v && "y" in v ? {_: {}
19− ,x: typeof v.x === "number" ? v.x : _U.badPort("a number",v.x)
20− ,y: typeof v.y === "number" ? v.y : _U.badPort("a number",
21− v.y)} : _U.badPort("an object with fields `x`, `y`",v);
22− });
23− var array = Elm.Native.Port.make(_elm).inbound("array",
24− "List Float",
25− function (v) {
26− return typeof v === "object" && v instanceof Array ? Elm.Native.List.make(_elm).fromArray(v.map(function (v) {
27− return typeof v === "number" ? v : _U.badPort("a number",v);
28− })) : _U.badPort("an array",v);
29− });
30− var tuple = Elm.Native.Port.make(_elm).inbound("tuple",
31− "( Float, Bool )",
32− function (v) {
33− return typeof v === "object" && v instanceof Array ? {ctor: "_Tuple2"
34− ,_0: typeof v[0] === "number" ? v[0] : _U.badPort("a number",v[0])
35− ,_1: typeof v[1] === "boolean" ? v[1] : _U.badPort("a boolean (true or false)",
36− v[1])} : _U.badPort("an array",v);
37− });
38− var number = Elm.Native.Port.make(_elm).inbound("number",
39− "Int",
40− function (v) {
41− return typeof v === "number" && isFinite(v) && Math.floor(v) === v ? v : _U.badPort("an integer",v);
42− });
43− var userID = Elm.Native.Port.make(_elm).inbound("userID",
44− "String",
45− function (v) {
46− return typeof v === "string" || typeof v === "object" && v instanceof String ? v : _U.badPort("a string",v);
47− });
48− return _elm.Main.values = {_op: _op};
49−};
tests/test-files/good-expected-js/Declarations/PortsWithTypeAliases.elm.jsdeleted−27
@@ -1,27 +0,0 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var pairs = Elm.Native.Port.make(_elm).inbound("pairs",
9− "Main.Point String String",
10− function (v) {
11− return typeof v === "object" && "x" in v && "y" in v ? {_: {}
12− ,x: typeof v.x === "string" || typeof v.x === "object" && v.x instanceof String ? v.x : _U.badPort("a string",
13− v.x)
14− ,y: typeof v.y === "string" || typeof v.y === "object" && v.y instanceof String ? v.y : _U.badPort("a string",
15− v.y)} : _U.badPort("an object with fields `x`, `y`",v);
16− });
17− var points = Elm.Native.Port.make(_elm).inbound("points",
18− "Main.Point2D",
19− function (v) {
20− return typeof v === "object" && "x" in v && "y" in v ? {_: {}
21− ,x: typeof v.x === "number" ? v.x : _U.badPort("a number",v.x)
22− ,y: typeof v.y === "number" ? v.y : _U.badPort("a number",
23− v.y)} : _U.badPort("an object with fields `x`, `y`",v);
24− });
25− var Point = F2(function (a,b) { return {x: a,y: b};});
26− return _elm.Main.values = {_op: _op,Point: Point};
27−};
tests/test-files/good-expected-js/Lists/EmptyList.elm.js+2−10
@@ -1,10 +1,2 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$emptyList = _elm_lang$core$Native_List.fromArray(
2−Elm.Main.make = function (_elm) {
2+ []);
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var emptyList = _U.list([]);
9− return _elm.Main.values = {_op: _op,emptyList: emptyList};
10−};
tests/test-files/good-expected-js/Lists/ListRange.elm.js+1−10
@@ -1,10 +1 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var listRange = _U.range(2,10);
1+var _elm_lang$core$Main$listRange = _elm_lang$core$Native_List.range(2, 10);
9− return _elm.Main.values = {_op: _op,listRange: listRange};
10−};
tests/test-files/good-expected-js/Lists/NonEmptyList.elm.js+2−10
@@ -1,10 +1,2 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$nonEmptyList = _elm_lang$core$Native_List.fromArray(
2−Elm.Main.make = function (_elm) {
2+ [1, 4, 5]);
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var nonEmptyList = _U.list([1,4,5]);
9− return _elm.Main.values = {_op: _op,nonEmptyList: nonEmptyList};
10−};
tests/test-files/good-expected-js/Records/AliasSubstitution.elm.js+3−10
@@ -1,10 +1,3 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var extractVec = function (v) { return {x: v.x,y: v.y};};
1+var _elm_lang$core$Main$extractVec = function (v) {
9− return _elm.Main.values = {_op: _op,extractVec: extractVec};
2+ return {x: v.x, y: v.y};
10−};
3+};
tests/test-files/good-expected-js/Records/NonHomogeneousRecords.elm.js+9−11
@@ -1,11 +1,9 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var bindFields = function (thing) { var y = thing.y;var x = thing.x;return thing;};
1+var _elm_lang$core$Main$bindFields = function (thing) {
2+ var y = thing.y;
3+ var x = thing.x;
4+ return thing;
5+};
6+var _elm_lang$core$Main$Thing = F2(
9− var Thing = F2(function (a,b) { return {x: a,y: b};});
7+ function (a, b) {
10− return _elm.Main.values = {_op: _op,Thing: Thing,bindFields: bindFields};
8+ return {x: a, y: b};
11−};
9+ });
tests/test-files/good-expected-js/Soundness/Apply.elm.js+6−10
@@ -1,10 +1,6 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$apply = function (f) {
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var apply = function (f) { var g = function (x) { return f(x);};return g;};
2+ var g = function (x) {
9− return _elm.Main.values = {_op: _op,apply: apply};
3+ return f(x);
4+ };
5+ return g;
10−};
6+};
tests/test-files/good-expected-js/Soundness/ApplyAnnotated.elm.js+6−10
@@ -1,10 +1,6 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$apply = function (f) {
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var apply = function (f) { var g = function (x) { return f(x);};return g;};
2+ var g = function (x) {
9− return _elm.Main.values = {_op: _op,apply: apply};
3+ return f(x);
4+ };
5+ return g;
10−};
6+};
tests/test-files/good-expected-js/Soundness/Id.elm.js+6−10
@@ -1,10 +1,6 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$myId = function () {
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var myId = function () { var id = function (x) { return x;};return id;}();
2+ var id = function (x) {
9− return _elm.Main.values = {_op: _op,myId: myId};
3+ return x;
10−};
4+ };
5+ return id;
6+}();
tests/test-files/good-expected-js/Soundness/IdAnnotated.elm.js+6−10
@@ -1,10 +1,6 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$myId = function () {
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var myId = function () { var id = function (x) { return x;};return id;}();
2+ var id = function (x) {
9− return _elm.Main.values = {_op: _op,myId: myId};
3+ return x;
10−};
4+ };
5+ return id;
6+}();
tests/test-files/good-expected-js/Soundness/SpecificAnnotationInt.elm.js+3−10
@@ -1,10 +1,3 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$px = function (x) {
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var px = function (x) { return "test";};
2+ return 'test';
9− return _elm.Main.values = {_op: _op,px: px};
10−};
3+};
tests/test-files/good-expected-js/Soundness/SpecificAnnotationNumber.elm.js+3−10
@@ -1,10 +1,3 @@
1−Elm.Main = Elm.Main || {};
1+var _elm_lang$core$Main$px = function (x) {
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var px = function (x) { return "test";};
2+ return 'test';
9− return _elm.Main.values = {_op: _op,px: px};
10−};
3+};
tests/test-files/good-expected-js/Soundness/TrickyId.elm.js+4−10
@@ -1,10 +1,4 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var myId = function (x) { var y = x;return y;};
1+var _elm_lang$core$Main$myId = function (x) {
9− return _elm.Main.values = {_op: _op,myId: myId};
2+ var y = x;
3+ return y;
10−};
4+};
tests/test-files/good-expected-js/Soundness/TrickyIdAnnotated.elm.js+4−10
@@ -1,10 +1,4 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var myId = function (x) { var y = x;return y;};
1+var _elm_lang$core$Main$myId = function (x) {
9− return _elm.Main.values = {_op: _op,myId: myId};
2+ var y = x;
3+ return y;
10−};
4+};
tests/test-files/good-expected-js/Strings/Multiline.elm.js+1−10
@@ -1,10 +1 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var s = "\nhere\'s a quote: \"\n\n";
1+var _elm_lang$core$Main$s = '\nhere\'s a quote: \"\n\n';
9− return _elm.Main.values = {_op: _op,s: s};
10−};
tests/test-files/good-expected-js/Strings/MultilineNormal.elm.js+1−10
@@ -1,10 +1 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var s = "\nhere\'s a quote: \"\n\n";
1+var _elm_lang$core$Main$s = '\nhere\'s a quote: \"\n\n';
9− return _elm.Main.values = {_op: _op,s: s};
10−};
tests/test-files/good-expected-js/Strings/QuotesAndComments.elm.js+7−13
@@ -1,13 +1,7 @@
1−Elm.Main = Elm.Main || {};
2−Elm.Main.make = function (_elm) {
3− "use strict";
4− _elm.Main = _elm.Main || {};
5− if (_elm.Main.values) return _elm.Main.values;
6− var _U = Elm.Native.Utils.make(_elm);
7− var _op = {};
8− var commentStart = "{-";
1+var _elm_lang$core$Main$commentStart = '{-';
9− var singleQuote = _U.chr("\'");
2+var _elm_lang$core$Main$singleQuote = _elm_lang$core$Native_Utils.chr('\'');
10− var doubleQuote = _U.chr("\"");
3+var _elm_lang$core$Main$doubleQuote = _elm_lang$core$Native_Utils.chr('\"');
11− var variablesWithPrimes = function (x) { var x$ = x;return x$;};
4+var _elm_lang$core$Main$variablesWithPrimes = function (x) {
12− return _elm.Main.values = {_op: _op,variablesWithPrimes: variablesWithPrimes,doubleQuote: doubleQuote,singleQuote: singleQuote,commentStart: commentStart};
5+ var x$ = x;
6+ return x$;
13−};
7+};
tests/test-files/good/Declarations/Ports.elmdeleted−21
@@ -1,21 +0,0 @@
1−
2−-- incoming
3−port userID : String
4−port number : Int
5−port tuple : (Float,Bool)
6−port array : List Float
7−port record : { x:Float, y:Float }
8−
9−-- outgoing
10−port fortyTwo : Int
11−port fortyTwo =
12− 42
13−
14−
15−port time : Float
16−port time =
17− 3.14
18−
19−port students : List { name:String, age:Int }
20−port students =
21− [ { name = "Tom", age = 42 } ]
tests/test-files/good/Declarations/PortsWithTypeAliases.elmdeleted−13
@@ -1,13 +0,0 @@
1−
2−
3−type alias Point2D =
4− Point Float Float
5−
6−type alias Point x y =
7− { x:x, y:y }
8−
9−
10−port points : Point2D
11−
12−
13−port pairs : Point String String