git.iko.soy/elk
on master help sign in
Update Nitpick.TopLevelTypes / fit main into Opt.Graph more nicely
2c1b2e8Evan Czaplicki
src/AST/Module/Name.hs+6−1
compare with master
unifiedsplit
@@ -4,7 +4,7 @@ module AST.Module.Name
4 ( Canonical(..)
4 ( Canonical(..)
5 , basics, char, string, debug
5 , basics, char, string, debug
6 , maybe, list, array
6 , maybe, list, array
7− , platform, cmd, sub
7+ , platform, cmd, sub, virtualDom
8 , jsonDecode, jsonEncode
8 , jsonDecode, jsonEncode
9 , webgl, vector2, vector3, vector4, matrix4
9 , webgl, vector2, vector3, vector4, matrix4
10 , canonicalToText
10 , canonicalToText
@@ -102,6 +102,11 @@ sub :: Canonical
102sub = Canonical Pkg.core "Platform.Sub"
102sub = Canonical Pkg.core "Platform.Sub"
103
103
104
104
105+{-# NOINLINE virtualDom #-}
106+virtualDom :: Canonical
107+virtualDom = Canonical Pkg.virtualDom "VirtualDom"
108+
109+
105
110
106-- JSON
111-- JSON
107
112
src/AST/Optimized.hs+9−1
@@ -6,6 +6,7 @@ module AST.Optimized
6 , Decider(..)
6 , Decider(..)
7 , Choice(..)
7 , Choice(..)
8 , Graph(..)
8 , Graph(..)
9+ , Main(..)
9 , Node(..)
10 , Node(..)
10 , EffectsType(..)
11 , EffectsType(..)
11 )
12 )
@@ -18,6 +19,7 @@ import qualified Data.Map as Map
18import qualified Data.Set as Set
19import qualified Data.Set as Set
19import Data.Text (Text)
20import Data.Text (Text)
20
21
22+import qualified AST.Canonical as Can
21import qualified AST.Module.Name as ModuleName
23import qualified AST.Module.Name as ModuleName
22import qualified Data.Index as Index
24import qualified Data.Index as Index
23import qualified Elm.Name as N
25import qualified Elm.Name as N
@@ -100,11 +102,17 @@ data Choice
100
102
101data Graph =
103data Graph =
102 Graph
104 Graph
103− { _fields :: Map.Map N.Name Int
105+ { _mains :: Map.Map ModuleName.Canonical Main
104 , _nodes :: Map.Map Global Node
106 , _nodes :: Map.Map Global Node
107+ , _fields :: Map.Map N.Name Int
105 }
108 }
106
109
107
110
111+data Main
112+ = Static
113+ | Dynamic Can.Type
114+
115+
108data Node
116data Node
109 = Define Expr (Set.Set N.Name) (Set.Set Global)
117 = Define Expr (Set.Set N.Name) (Set.Set Global)
110 | DefineTailFunc [N.Name] Expr (Set.Set N.Name) (Set.Set Global)
118 | DefineTailFunc [N.Name] Expr (Set.Set N.Name) (Set.Set Global)
src/Nitpick/TopLevelTypes.hs+68−80
@@ -1,119 +1,107 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module Nitpick.TopLevelTypes (topLevelTypes) where
3+module Nitpick.TopLevelTypes
4+ ( check
5+ )
6+ where
4
7
5−import qualified Data.Foldable as F
8+
6−import Data.Map ((!))
9+import Control.Monad (foldM)
7import qualified Data.Map as Map
10import qualified Data.Map as Map
8−import Data.Text (Text)
11+import Data.Map ((!))
9
12
10−import qualified AST.Expression.Canonical as Can
13+import qualified AST.Canonical as Can
14+import qualified AST.Optimized as Opt
11import qualified AST.Module.Name as ModuleName
15import qualified AST.Module.Name as ModuleName
12−import qualified AST.Pattern as P
16+import qualified AST.Utils.Type as Type
13−import qualified AST.Type as Type
14−import qualified AST.Variable as Var
15import qualified Canonicalize.Effects as Effects
17import qualified Canonicalize.Effects as Effects
16−import qualified Elm.Package as Pkg
18+import qualified Canonicalize.Result as Result
19+import qualified Elm.Name as N
17import qualified Reporting.Annotation as A
20import qualified Reporting.Annotation as A
18−import qualified Reporting.Error.Type as Error
21+import qualified Reporting.Error.Canonicalize as Error
19−import qualified Reporting.Result as Result
22+import qualified Reporting.Region as R
20−import qualified Reporting.Warning as Warning
23+import qualified Reporting.Warning as W
21
24
22
25
23
26
24−type Result =
27+-- CHECK TOP-LEVEL TYPES
25− Result.Result () Warning.Warning Error.Error
26
28
27
29
28−type TypeDict =
30+type Result i w a =
29− Map.Map Text Type.Canonical
31+ Result.Result i w Error.Error a
30
32
31
33
34+type Types =
35+ Map.Map N.Name Can.Type
32
36
33−-- CHECK TOP LEVEL TYPES
34
37
38+type Mains =
39+ Map.Map ModuleName.Canonical Opt.Main
35
40
36−topLevelTypes :: TypeDict -> Can.SortedDefs -> Result [Can.Def]
37−topLevelTypes typeEnv sortedDefs =
38− let
39− check =
40− checkAnnotation typeEnv
41− in
42− case sortedDefs of
43− Can.NoMain defs ->
44− pure defs
45− <* F.traverse_ check defs
46
41
47− Can.YesMain before main after ->
42+check :: Types -> Can.Module -> Result i [W.Warning] Mains
48− do check main
43+check types (Can.Module home _ _ decls _ _ _ _) =
49− <* F.traverse_ check before
44+ checkDecls home types decls Map.empty
50− <* F.traverse_ check after
51
45
52− mainDef <- checkMain typeEnv main
53
46
54− return (before ++ mainDef : after)
47+checkDecls :: ModuleName.Canonical -> Types -> Can.Decls -> Mains -> Result i [W.Warning] Mains
48+checkDecls home types decls mains =
49+ case decls of
50+ Can.Declare def subDecls ->
51+ checkDecls home types subDecls =<<
52+ checkDef home types mains def
55
53
54+ Can.DeclareRec defs subDecls ->
55+ checkDecls home types subDecls =<<
56+ foldM (checkDef home types) mains defs
56
57
57−
58+ Can.SaveTheEnvironment ->
58−-- MISSING ANNOTATIONS
59+ Result.ok mains
59
60
60
61
61−checkAnnotation :: TypeDict -> Can.Def -> Result ()
62−checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =
63− case (pattern, maybeType) of
64− (P.Var name, Nothing) ->
65− let
66− warning =
67− Warning.MissingTypeAnnotation name (typeEnv ! name)
68− in
69− Result.warn region warning ()
70−
71− _ ->
72− return ()
73
62
63+-- MISSING ANNOTATIONS
74
64
75
65
76−-- CHECK MAIN TYPE
66+checkDef :: ModuleName.Canonical -> Types -> Mains -> Can.Def -> Result i [W.Warning] Mains
67+checkDef home types mains def =
68+ case def of
69+ Can.Def (A.At region name) _ _ ->
70+ do Result.warn $ W.MissingTypeAnnotation region name (types ! name)
71+ checkMain region types home name mains
77
72
73+ Can.TypedDef (A.At region name) _ _ _ _ ->
74+ checkMain region types home name mains
78
75
79−checkMain :: TypeDict -> Can.Def -> Result Can.Def
80−checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
81− let
82− mainType =
83− typeEnv ! "main"
84
76
85− makeError tipe maybeMsg =
86− A.A region (Error.BadFlags tipe maybeMsg)
87
77
88− getMainKind =
78+-- CHECK MAIN TYPE
89− case Type.deepDealias mainType of
90− Type.Type name [_]
91− | name == vdomNode ->
92− return Can.Static
93
79
94− Type.Type name [flags, _, _]
95− | name == program ->
96− return (Can.Dynamic flags)
97− <* Effects.checkPortType makeError flags
98
80
99− _ ->
81+checkMain :: R.Region -> Types -> ModuleName.Canonical -> N.Name -> Mains -> Result i w Mains
100− Result.throw region (Error.BadMain mainType)
82+checkMain region types home name mains =
101− in
83+ if name == N.main then
102− do kind <- getMainKind
84+ do mainType <- checkMainType region (types ! name)
103− let newBody = A.A undefined (Can.Program kind body)
85+ Result.ok $ Map.insert home mainType mains
104− return (Can.Def facts pattern newBody maybeType)
86+ else
87+ Result.ok mains
105
88
106
89
107−program :: Var.Canonical
90+checkMainType :: R.Region -> Can.Type -> Result i w Opt.Main
108−program =
91+checkMainType region tipe =
109− Var.inCore "Platform" "Program"
92+ case Type.deepDealias tipe of
93+ Can.TType home name [_]
94+ | home == ModuleName.virtualDom && name == N.node ->
95+ Result.ok Opt.Static
110
96
97+ Can.TType home name [flags, _, _]
98+ | home == ModuleName.platform && name == N.program ->
99+ case Effects.checkPayload flags of
100+ Left (subType, invalidPayload) ->
101+ Result.throw (Error.MainFlags region subType invalidPayload)
111
102
112−vdomNode :: Var.Canonical
103+ Right () ->
113−vdomNode =
104+ Result.ok (Opt.Dynamic flags)
114− let
115− vdom =
116− ModuleName.Canonical Pkg.virtualDom "VirtualDom"
117− in
118− Var.fromModule vdom "Node"
119
105
106+ _ ->
107+ Result.throw (Error.MainType region tipe)
src/Optimize/Module.hs+36−28
@@ -1,7 +1,8 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Optimize.Module
3module Optimize.Module
4+ ( Graph(..)
4− ( optimize
5+ , optimize
5 )
6 )
6 where
7 where
7
8
@@ -25,29 +26,36 @@ import qualified Reporting.Annotation as A
25-- OPTIMIZE
26-- OPTIMIZE
26
27
27
28
29+data Graph =
30+ Graph
31+ { _fields :: Map.Map N.Name Int
32+ , _nodes :: Nodes
33+ }
34+
35+
36+type Nodes =
37+ Map.Map Opt.Global Opt.Node
38+
39+
28−optimize :: Can.Module -> Opt.Graph
40+optimize :: Can.Module -> Graph
29optimize (Can.Module home _ _ decls unions aliases _ effects) =
41optimize (Can.Module home _ _ decls unions aliases _ effects) =
30 addEffects home effects $
42 addEffects home effects $
31 addUnions home unions $
43 addUnions home unions $
32 addAliases home aliases $
44 addAliases home aliases $
33 addDecls home decls $
45 addDecls home decls $
34− Opt.Graph Map.empty Map.empty
46+ Graph Map.empty Map.empty
35
47
36
48
37
49
38-- UNION
50-- UNION
39
51
40
52
41−addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Opt.Graph -> Opt.Graph
53+addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Graph -> Graph
42−addUnions home unions (Opt.Graph fields nodes) =
54+addUnions home unions (Graph fields nodes) =
43− Opt.Graph fields $
55+ Graph fields $
44 Map.foldr (addUnion home) nodes unions
56 Map.foldr (addUnion home) nodes unions
45
57
46
58
47−type Nodes =
48− Map.Map Opt.Global Opt.Node
49−
50−
51addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
59addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
52addUnion home (Can.Union _ ctors) nodes =
60addUnion home (Can.Union _ ctors) nodes =
53 foldr (addCtor home) nodes ctors
61 foldr (addCtor home) nodes ctors
@@ -73,13 +81,13 @@ addCtor home (ctor, args) nodes =
73-- ALIAS
81-- ALIAS
74
82
75
83
76−addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Opt.Graph -> Opt.Graph
84+addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Graph -> Graph
77addAliases home aliases graph =
85addAliases home aliases graph =
78 Map.foldrWithKey (addAlias home) graph aliases
86 Map.foldrWithKey (addAlias home) graph aliases
79
87
80
88
81−addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Opt.Graph -> Opt.Graph
89+addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Graph -> Graph
82−addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph fieldCounts nodes) =
90+addAlias home name (Can.Alias _ _ maybeFields) graph@(Graph fieldCounts nodes) =
83 case maybeFields of
91 case maybeFields of
84 Nothing ->
92 Nothing ->
85 graph
93 graph
@@ -93,7 +101,7 @@ addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph fieldCounts node
93 node =
101 node =
94 Opt.Define function Set.empty Set.empty
102 Opt.Define function Set.empty Set.empty
95 in
103 in
96− Opt.Graph
104+ Graph
97 (foldr addOne fieldCounts fields)
105 (foldr addOne fieldCounts fields)
98 (Map.insert (Opt.Global home name) node nodes)
106 (Map.insert (Opt.Global home name) node nodes)
99
107
@@ -112,8 +120,8 @@ addOne name fields =
112-- ADD EFFECTS
120-- ADD EFFECTS
113
121
114
122
115−addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph
123+addEffects :: ModuleName.Canonical -> Can.Effects -> Graph -> Graph
116−addEffects home effects graph@(Opt.Graph fields nodes) =
124+addEffects home effects graph@(Graph fields nodes) =
117 case effects of
125 case effects of
118 Can.NoEffects ->
126 Can.NoEffects ->
119 graph
127 graph
@@ -122,7 +130,7 @@ addEffects home effects graph@(Opt.Graph fields nodes) =
122 Map.foldrWithKey (addPort home) graph ports
130 Map.foldrWithKey (addPort home) graph ports
123
131
124 Can.Manager _ _ _ manager ->
132 Can.Manager _ _ _ manager ->
125− Opt.Graph fields $
133+ Graph fields $
126 let
134 let
127 fx = Opt.Global home "$fx$"
135 fx = Opt.Global home "$fx$"
128 cmd = Opt.Global home "command"
136 cmd = Opt.Global home "command"
@@ -145,7 +153,7 @@ addEffects home effects graph@(Opt.Graph fields nodes) =
145
153
146
154
147
155
148−addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Opt.Graph -> Opt.Graph
156+addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Graph -> Graph
149addPort home name port_ graph =
157addPort home name port_ graph =
150 case port_ of
158 case port_ of
151 Can.Incoming _ tipe ->
159 Can.Incoming _ tipe ->
@@ -167,7 +175,7 @@ addPort home name port_ graph =
167-- ADD DECLS
175-- ADD DECLS
168
176
169
177
170−addDecls :: ModuleName.Canonical -> Can.Decls -> Opt.Graph -> Opt.Graph
178+addDecls :: ModuleName.Canonical -> Can.Decls -> Graph -> Graph
171addDecls home decls graph =
179addDecls home decls graph =
172 case decls of
180 case decls of
173 Can.Declare def subDecls ->
181 Can.Declare def subDecls ->
@@ -184,7 +192,7 @@ addDecls home decls graph =
184-- ADD DEFS
192-- ADD DEFS
185
193
186
194
187−addDef :: ModuleName.Canonical -> Can.Def -> Opt.Graph -> Opt.Graph
195+addDef :: ModuleName.Canonical -> Can.Def -> Graph -> Graph
188addDef home def graph =
196addDef home def graph =
189 case def of
197 case def of
190 Can.Def (A.At _ name) args body ->
198 Can.Def (A.At _ name) args body ->
@@ -194,7 +202,7 @@ addDef home def graph =
194 addDefHelp (Opt.Global home name) (map fst typedArgs) body graph
202 addDefHelp (Opt.Global home name) (map fst typedArgs) body graph
195
203
196
204
197−addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Opt.Graph
205+addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Graph -> Graph
198addDefHelp name args body graph =
206addDefHelp name args body graph =
199 case args of
207 case args of
200 [] ->
208 [] ->
@@ -216,9 +224,9 @@ addDefHelp name args body graph =
216 addToGraph name (Opt.Define function kernels globals) fields graph
224 addToGraph name (Opt.Define function kernels globals) fields graph
217
225
218
226
219−addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Opt.Graph -> Opt.Graph
227+addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Graph -> Graph
220−addToGraph name node fields (Opt.Graph fieldCounts nodes) =
228+addToGraph name node fields (Graph fieldCounts nodes) =
221− Opt.Graph
229+ Graph
222 (Map.unionWith (+) fields fieldCounts)
230 (Map.unionWith (+) fields fieldCounts)
223 (Map.insert name node nodes)
231 (Map.insert name node nodes)
224
232
@@ -227,7 +235,7 @@ addToGraph name node fields (Opt.Graph fieldCounts nodes) =
227-- ADD RECURSIVE DEFS
235-- ADD RECURSIVE DEFS
228
236
229
237
230−addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
238+addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Graph -> Graph
231addRecDefs home defs graph =
239addRecDefs home defs graph =
232 let
240 let
233 cycleValues =
241 cycleValues =
@@ -266,7 +274,7 @@ addValueName def valueNames =
266data State =
274data State =
267 State
275 State
268 { _values :: [(N.Name, Opt.Expr)]
276 { _values :: [(N.Name, Opt.Expr)]
269− , _graph :: Opt.Graph
277+ , _graph :: Graph
270 }
278 }
271
279
272
280
@@ -296,11 +304,11 @@ addRecDef home dummyName cycle state@(State values graph) def =
296
304
297
305
298addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State
306addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State
299−addRecValue home dummyName cycle name body (State values (Opt.Graph fields nodes)) =
307+addRecValue home dummyName cycle name body (State values (Graph fields nodes)) =
300 do obody <- Expr.optimize cycle body
308 do obody <- Expr.optimize cycle body
301 pure $
309 pure $
302 State
310 State
303 { _values = (name, obody) : values
311 { _values = (name, obody) : values
304− , _graph = Opt.Graph fields $
312+ , _graph = Graph fields $
305 Map.insert (Opt.Global home name) (Opt.Link dummyName) nodes
313 Map.insert (Opt.Global home name) (Opt.Link dummyName) nodes
306 }
314 }