git.iko.soy/elk
on master help sign in
Update Nitpick.TopLevelTypes / fit main into Opt.Graph more nicely
commit2c1b2e8e3bcb9a383796f8bc0383abd53f355f91 authorEvan Czaplicki <evancz@users.noreply.github.com> dateSun 3 Dec 2017, 16:24 (9 years ago) parent8e73b5b
4 files changed+119−110
compare with master
unifiedsplit
src/AST/Module/Name.hs+6−1 src/AST/Optimized.hs+9−1 src/Nitpick/TopLevelTypes.hs+68−80 src/Optimize/Module.hs+36−28
src/AST/Module/Name.hs+6−1
@@ -4,7 +4,7 @@ module AST.Module.Name
44 ( Canonical(..)
55 , basics, char, string, debug
66 , maybe, list, array
7− , platform, cmd, sub
7+ , platform, cmd, sub, virtualDom
88 , jsonDecode, jsonEncode
99 , webgl, vector2, vector3, vector4, matrix4
1010 , canonicalToText
@@ -102,6 +102,11 @@ sub :: Canonical
102102sub = Canonical Pkg.core "Platform.Sub"
103103
104104
105+{-# NOINLINE virtualDom #-}
106+virtualDom :: Canonical
107+virtualDom = Canonical Pkg.virtualDom "VirtualDom"
108+
109+
105110
106111-- JSON
107112
src/AST/Optimized.hs+9−1
@@ -6,6 +6,7 @@ module AST.Optimized
66 , Decider(..)
77 , Choice(..)
88 , Graph(..)
9+ , Main(..)
910 , Node(..)
1011 , EffectsType(..)
1112 )
@@ -18,6 +19,7 @@ import qualified Data.Map as Map
1819import qualified Data.Set as Set
1920import Data.Text (Text)
2021
22+import qualified AST.Canonical as Can
2123import qualified AST.Module.Name as ModuleName
2224import qualified Data.Index as Index
2325import qualified Elm.Name as N
@@ -100,11 +102,17 @@ data Choice
100102
101103data Graph =
102104 Graph
103− { _fields :: Map.Map N.Name Int
105+ { _mains :: Map.Map ModuleName.Canonical Main
104106 , _nodes :: Map.Map Global Node
107+ , _fields :: Map.Map N.Name Int
105108 }
106109
107110
111+data Main
112+ = Static
113+ | Dynamic Can.Type
114+
115+
108116data Node
109117 = Define Expr (Set.Set N.Name) (Set.Set Global)
110118 | DefineTailFunc [N.Name] Expr (Set.Set N.Name) (Set.Set Global)
src/Nitpick/TopLevelTypes.hs+68−80
@@ -1,119 +1,107 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Nitpick.TopLevelTypes (topLevelTypes) where
3+module Nitpick.TopLevelTypes
4+ ( check
5+ )
6+ where
47
5−import qualified Data.Foldable as F
6−import Data.Map ((!))
8+
9+import Control.Monad (foldM)
710import qualified Data.Map as Map
8−import Data.Text (Text)
11+import Data.Map ((!))
912
10−import qualified AST.Expression.Canonical as Can
13+import qualified AST.Canonical as Can
14+import qualified AST.Optimized as Opt
1115import qualified AST.Module.Name as ModuleName
12−import qualified AST.Pattern as P
13−import qualified AST.Type as Type
14−import qualified AST.Variable as Var
16+import qualified AST.Utils.Type as Type
1517import 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
1720import qualified Reporting.Annotation as A
18−import qualified Reporting.Error.Type as Error
19−import qualified Reporting.Result as Result
20−import qualified Reporting.Warning as Warning
21+import qualified Reporting.Error.Canonicalize as Error
22+import qualified Reporting.Region as R
23+import qualified Reporting.Warning as W
2124
2225
2326
24−type Result =
25− Result.Result () Warning.Warning Error.Error
27+-- CHECK TOP-LEVEL TYPES
2628
2729
28−type TypeDict =
29− Map.Map Text Type.Canonical
30+type Result i w a =
31+ Result.Result i w Error.Error a
3032
3133
34+type Types =
35+ Map.Map N.Name Can.Type
3236
33−-- CHECK TOP LEVEL TYPES
3437
38+type Mains =
39+ Map.Map ModuleName.Canonical Opt.Main
3540
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
4641
47− Can.YesMain before main after ->
48− do check main
49− <* F.traverse_ check before
50− <* F.traverse_ check after
42+check :: Types -> Can.Module -> Result i [W.Warning] Mains
43+check types (Can.Module home _ _ decls _ _ _ _) =
44+ checkDecls home types decls Map.empty
5145
52− mainDef <- checkMain typeEnv main
5346
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
5553
54+ Can.DeclareRec defs subDecls ->
55+ checkDecls home types subDecls =<<
56+ foldM (checkDef home types) mains defs
5657
57−
58−-- MISSING ANNOTATIONS
58+ Can.SaveTheEnvironment ->
59+ Result.ok mains
5960
6061
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 ()
7362
63+-- MISSING ANNOTATIONS
7464
7565
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
7772
73+ Can.TypedDef (A.At region name) _ _ _ _ ->
74+ checkMain region types home name mains
7875
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"
8476
85− makeError tipe maybeMsg =
86− A.A region (Error.BadFlags tipe maybeMsg)
8777
88− getMainKind =
89− case Type.deepDealias mainType of
90− Type.Type name [_]
91− | name == vdomNode ->
92− return Can.Static
78+-- CHECK MAIN TYPE
9379
94− Type.Type name [flags, _, _]
95− | name == program ->
96− return (Can.Dynamic flags)
97− <* Effects.checkPortType makeError flags
9880
99− _ ->
100− Result.throw region (Error.BadMain mainType)
101− in
102− do kind <- getMainKind
103− let newBody = A.A undefined (Can.Program kind body)
104− return (Can.Def facts pattern newBody maybeType)
81+checkMain :: R.Region -> Types -> ModuleName.Canonical -> N.Name -> Mains -> Result i w Mains
82+checkMain region types home name mains =
83+ if name == N.main then
84+ do mainType <- checkMainType region (types ! name)
85+ Result.ok $ Map.insert home mainType mains
86+ else
87+ Result.ok mains
10588
10689
107−program :: Var.Canonical
108−program =
109− Var.inCore "Platform" "Program"
90+checkMainType :: R.Region -> Can.Type -> Result i w Opt.Main
91+checkMainType region tipe =
92+ case Type.deepDealias tipe of
93+ Can.TType home name [_]
94+ | home == ModuleName.virtualDom && name == N.node ->
95+ Result.ok Opt.Static
11096
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)
111102
112−vdomNode :: Var.Canonical
113−vdomNode =
114− let
115− vdom =
116− ModuleName.Canonical Pkg.virtualDom "VirtualDom"
117− in
118− Var.fromModule vdom "Node"
103+ Right () ->
104+ Result.ok (Opt.Dynamic flags)
119105
106+ _ ->
107+ Result.throw (Error.MainType region tipe)
src/Optimize/Module.hs+36−28
@@ -1,7 +1,8 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Optimize.Module
4− ( optimize
4+ ( Graph(..)
5+ , optimize
56 )
67 where
78
@@ -25,29 +26,36 @@ import qualified Reporting.Annotation as A
2526-- OPTIMIZE
2627
2728
28−optimize :: Can.Module -> Opt.Graph
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+
40+optimize :: Can.Module -> Graph
2941optimize (Can.Module home _ _ decls unions aliases _ effects) =
3042 addEffects home effects $
3143 addUnions home unions $
3244 addAliases home aliases $
3345 addDecls home decls $
34− Opt.Graph Map.empty Map.empty
46+ Graph Map.empty Map.empty
3547
3648
3749
3850-- UNION
3951
4052
41−addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Opt.Graph -> Opt.Graph
42−addUnions home unions (Opt.Graph fields nodes) =
43− Opt.Graph fields $
53+addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Graph -> Graph
54+addUnions home unions (Graph fields nodes) =
55+ Graph fields $
4456 Map.foldr (addUnion home) nodes unions
4557
4658
47−type Nodes =
48− Map.Map Opt.Global Opt.Node
49−
50−
5159addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
5260addUnion home (Can.Union _ ctors) nodes =
5361 foldr (addCtor home) nodes ctors
@@ -73,13 +81,13 @@ addCtor home (ctor, args) nodes =
7381-- ALIAS
7482
7583
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
7785addAliases home aliases graph =
7886 Map.foldrWithKey (addAlias home) graph aliases
7987
8088
81−addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Opt.Graph -> Opt.Graph
82−addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph fieldCounts nodes) =
89+addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Graph -> Graph
90+addAlias home name (Can.Alias _ _ maybeFields) graph@(Graph fieldCounts nodes) =
8391 case maybeFields of
8492 Nothing ->
8593 graph
@@ -93,7 +101,7 @@ addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph fieldCounts node
93101 node =
94102 Opt.Define function Set.empty Set.empty
95103 in
96− Opt.Graph
104+ Graph
97105 (foldr addOne fieldCounts fields)
98106 (Map.insert (Opt.Global home name) node nodes)
99107
@@ -112,8 +120,8 @@ addOne name fields =
112120-- ADD EFFECTS
113121
114122
115−addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph
116−addEffects home effects graph@(Opt.Graph fields nodes) =
123+addEffects :: ModuleName.Canonical -> Can.Effects -> Graph -> Graph
124+addEffects home effects graph@(Graph fields nodes) =
117125 case effects of
118126 Can.NoEffects ->
119127 graph
@@ -122,7 +130,7 @@ addEffects home effects graph@(Opt.Graph fields nodes) =
122130 Map.foldrWithKey (addPort home) graph ports
123131
124132 Can.Manager _ _ _ manager ->
125− Opt.Graph fields $
133+ Graph fields $
126134 let
127135 fx = Opt.Global home "$fx$"
128136 cmd = Opt.Global home "command"
@@ -145,7 +153,7 @@ addEffects home effects graph@(Opt.Graph fields nodes) =
145153
146154
147155
148−addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Opt.Graph -> Opt.Graph
156+addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Graph -> Graph
149157addPort home name port_ graph =
150158 case port_ of
151159 Can.Incoming _ tipe ->
@@ -167,7 +175,7 @@ addPort home name port_ graph =
167175-- ADD DECLS
168176
169177
170−addDecls :: ModuleName.Canonical -> Can.Decls -> Opt.Graph -> Opt.Graph
178+addDecls :: ModuleName.Canonical -> Can.Decls -> Graph -> Graph
171179addDecls home decls graph =
172180 case decls of
173181 Can.Declare def subDecls ->
@@ -184,7 +192,7 @@ addDecls home decls graph =
184192-- ADD DEFS
185193
186194
187−addDef :: ModuleName.Canonical -> Can.Def -> Opt.Graph -> Opt.Graph
195+addDef :: ModuleName.Canonical -> Can.Def -> Graph -> Graph
188196addDef home def graph =
189197 case def of
190198 Can.Def (A.At _ name) args body ->
@@ -194,7 +202,7 @@ addDef home def graph =
194202 addDefHelp (Opt.Global home name) (map fst typedArgs) body graph
195203
196204
197−addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Opt.Graph
205+addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Graph -> Graph
198206addDefHelp name args body graph =
199207 case args of
200208 [] ->
@@ -216,9 +224,9 @@ addDefHelp name args body graph =
216224 addToGraph name (Opt.Define function kernels globals) fields graph
217225
218226
219−addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Opt.Graph -> Opt.Graph
220−addToGraph name node fields (Opt.Graph fieldCounts nodes) =
221− Opt.Graph
227+addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Graph -> Graph
228+addToGraph name node fields (Graph fieldCounts nodes) =
229+ Graph
222230 (Map.unionWith (+) fields fieldCounts)
223231 (Map.insert name node nodes)
224232
@@ -227,7 +235,7 @@ addToGraph name node fields (Opt.Graph fieldCounts nodes) =
227235-- ADD RECURSIVE DEFS
228236
229237
230−addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
238+addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Graph -> Graph
231239addRecDefs home defs graph =
232240 let
233241 cycleValues =
@@ -266,7 +274,7 @@ addValueName def valueNames =
266274data State =
267275 State
268276 { _values :: [(N.Name, Opt.Expr)]
269− , _graph :: Opt.Graph
277+ , _graph :: Graph
270278 }
271279
272280
@@ -296,11 +304,11 @@ addRecDef home dummyName cycle state@(State values graph) def =
296304
297305
298306addRecValue :: 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)) =
300308 do obody <- Expr.optimize cycle body
301309 pure $
302310 State
303311 { _values = (name, obody) : values
304− , _graph = Opt.Graph fields $
312+ , _graph = Graph fields $
305313 Map.insert (Opt.Global home name) (Opt.Link dummyName) nodes
306314 }