git.iko.soy/elk
on master help sign in
Make code gen of `main` values easier

Figure out the trie structure of modules, generate the Builders for anything that needs to know about code gen naming conventions, replace some (function + union type args) with (functions) to make things simpler.

commit247359cc0bfce8b9f5713f5dfe190dd20f241f52 authorEvan Czaplicki <evancz@users.noreply.github.com> dateThu 14 Dec 2017, 15:05 (9 years ago) parentba4c3df
10 files changed+189−104
compare with master
unifiedsplit
src/AST/Optimized.hs+7−4 src/Elm/Compiler/Module.hs−6 src/Elm/Compiler/Objects.hs+7−21 src/Elm/Compiler/Type.hs+6−6 src/Elm/Compiler/Type/Extract.hs+10−22 src/Elm/Name.hs+6−1 src/Generate/JavaScript.hs+104−42 src/Generate/JavaScript/Builder.hs+5 src/Generate/JavaScript/Expression.hs+39 src/Nitpick/TopLevelTypes.hs+5−2
src/AST/Optimized.hs+7−4
@@ -121,7 +121,10 @@ data Graph =
121121
122122data Main
123123 = Static
124− | Dynamic Can.Type
124+ | Dynamic
125+ { _decoder :: Expr
126+ , _message :: Can.Type
127+ }
125128
126129
127130data Node
@@ -274,14 +277,14 @@ instance Binary Graph where
274277instance Binary Main where
275278 put main =
276279 case main of
277− Static -> putWord8 0
278− Dynamic a -> putWord8 1 >> put a
280+ Static -> putWord8 0
281+ Dynamic a b -> putWord8 1 >> put a >> put b
279282
280283 get =
281284 do word <- getWord8
282285 case word of
283286 0 -> return Static
284− 1 -> liftM Dynamic get
287+ 1 -> liftM2 Dynamic get get
285288 _ -> error "problem getting Opt.Main binary"
286289
287290
src/Elm/Compiler/Module.hs−6
@@ -5,7 +5,6 @@ module Elm.Compiler.Module
55 ( I.Interface
66 , I.Interfaces
77 , interfaceAliasedTypes
8− , programTypes
98
109 -- module names
1110 , Raw
@@ -46,11 +45,6 @@ interfaceAliasedTypes interface =
4645 Map.map Extract.fromAnnotation (I._types interface)
4746
4847
49−programTypes :: I.Interfaces -> ModuleName.Canonical -> Maybe Type.Program
50−programTypes =
51− Extract.fromProgram
52−
53−
5448
5549-- NAMES
5650
src/Elm/Compiler/Objects.hs+7−21
@@ -1,11 +1,12 @@
11{-# OPTIONS_GHC -Wall #-}
22module Elm.Compiler.Objects
3− ( JS.Mode(..)
4− , Name.Target(..)
5− , JS.generate
6− , JS.Roots
7− , mains
8− , value
3+ ( Name.Target(..)
4+ , JS.ReplBuilder(..)
5+ , JS.generateForRepl
6+ , JS.Mode(..)
7+ , JS.MainsBuilder(..)
8+ , JS.MainTrie(..)
9+ , JS.generateMains
910 , Opt.Graph
1011 , empty
1112 , union
@@ -16,7 +17,6 @@ module Elm.Compiler.Objects
1617
1718
1819import qualified Data.Map as Map
19−import qualified Data.Text as Text
2020
2121import qualified AST.Optimized as Opt
2222import qualified AST.Module.Name as ModuleName
@@ -27,20 +27,6 @@ import qualified Generate.JavaScript.Name as Name
2727
2828
2929
30−-- ROOTS
31−
32−
33−mains :: [ModuleName.Canonical] -> JS.Roots
34−mains =
35− JS.Mains
36−
37−
38−value :: ModuleName.Canonical -> String -> JS.Roots
39−value home name =
40− JS.Value home (Text.pack name)
41−
42−
43−
4430-- COMBINE GRAPHS
4531
4632
src/Elm/Compiler/Type.hs+6−6
@@ -4,12 +4,12 @@ module Elm.Compiler.Type
44 ( Type(..)
55 , Format(..)
66 , toString
7− , Program(..)
7+ , DebugMetadata(..)
88 , Alias(..)
99 , Union(..)
1010 , encode
1111 , decoder
12− , encodeProgram
12+ , encodeMetadata
1313 )
1414 where
1515
@@ -43,8 +43,8 @@ data Type
4343 | Tuple Type Type [Type]
4444
4545
46−data Program =
47− Program
46+data DebugMetadata =
47+ DebugMetadata
4848 { _message :: Type
4949 , _aliases :: [Alias]
5050 , _unions :: [Union]
@@ -230,8 +230,8 @@ fromRawType (A.At _ astType) =
230230-- JSON for PROGRAM
231231
232232
233−encodeProgram :: Program -> Encode.Value
234−encodeProgram (Program msg aliases unions) =
233+encodeMetadata :: DebugMetadata -> Encode.Value
234+encodeMetadata (DebugMetadata msg aliases unions) =
235235 Encode.object
236236 [ "message" ==> encode msg
237237 , "aliases" ==> Encode.object (map toAliasField aliases)
src/Elm/Compiler/Type/Extract.hs+10−22
@@ -4,7 +4,7 @@
44module Elm.Compiler.Type.Extract
55 ( fromAnnotation
66 , fromType
7− , fromProgram
7+ , fromMsg
88 )
99 where
1010
@@ -83,28 +83,16 @@ toPublicName (ModuleName.Canonical _ home) name =
8383-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
8484
8585
86−fromProgram :: I.Interfaces -> ModuleName.Canonical -> Maybe T.Program
87−fromProgram interfaces name =
88− do iface <- Map.lookup name interfaces
89− mainType <- Map.lookup "main" (I._types iface)
90− message <- getMessage mainType
91−
92− let (msgDeps, msgType) = run (extract message)
93− let (aliases, unions) = extractTransitive interfaces noDeps msgDeps
94− Just (T.Program msgType aliases unions)
95−
96−
97−getMessage :: Can.Annotation -> Maybe Can.Type
98−getMessage (Can.Forall _ mainType) =
99− case Type.deepDealias mainType of
100− Can.TType _ _program [_flags, _model, msg] ->
101− Just msg
102−
103− Can.TType _ _node [msg] ->
104− Just msg
86+fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata
87+fromMsg interfaces message =
88+ let
89+ (msgDeps, msgType) =
90+ run (extract message)
10591
106− _ ->
107− Nothing
92+ (aliases, unions) =
93+ extractTransitive interfaces noDeps msgDeps
94+ in
95+ T.DebugMetadata msgType aliases unions
10896
10997
11098extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
src/Elm/Name.hs+6−1
@@ -10,7 +10,7 @@ module Elm.Name
1010 , toCompositeName
1111 , int, float, bool, char, string
1212 , maybe, list, array, tuple
13− , task, router, cmd, sub, platform
13+ , task, router, cmd, sub, platform, browser
1414 , shader, debug, bitwise, basics
1515 , utils, negate, value
1616 , node, program, main, dollar
@@ -137,6 +137,11 @@ platform :: Name
137137platform = "Platform"
138138
139139
140+{-# NOINLINE browser #-}
141+browser :: Name
142+browser = "Browser"
143+
144+
140145{-# NOINLINE shader #-}
141146shader :: Name
142147shader = "Shader"
src/Generate/JavaScript.hs+104−42
@@ -1,9 +1,12 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Generate.JavaScript
4− ( Mode(..)
5− , Roots(..)
6− , generate
4+ ( ReplBuilder(..)
5+ , generateForRepl
6+ , Mode(..)
7+ , MainsBuilder(..)
8+ , MainTrie(..)
9+ , generateMains
710 )
811 where
912
@@ -15,9 +18,11 @@ import qualified Data.List as List
1518import Data.Map ((!))
1619import qualified Data.Map as Map
1720import qualified Data.Set as Set
21+import qualified Data.Text as Text
1822
1923import qualified AST.Optimized as Opt
2024import qualified AST.Module.Name as ModuleName
25+import qualified Elm.Interface as I
2126import qualified Elm.Name as N
2227import qualified Generate.JavaScript.Builder as JS
2328import qualified Generate.JavaScript.Expression as Expr
@@ -25,27 +30,62 @@ import qualified Generate.JavaScript.Name as Name
2530
2631
2732
28−-- GENERATE
33+-- GENERATE FOR REPL
34+
35+
36+data ReplBuilder =
37+ ReplBuilder
38+ { _repl_code :: B.Builder
39+ , _repl_name :: B.Builder
40+ }
41+
42+
43+generateForRepl :: Opt.Graph -> ModuleName.Canonical -> N.Name -> ReplBuilder
44+generateForRepl (Opt.Graph _ graph _) home name =
45+ ReplBuilder
46+ { _repl_code =
47+ stateToBuilder $
48+ addGlobal (Name.Debug Name.Client) graph emptyState (Opt.Global home name)
49+ , _repl_name =
50+ Name.toBuilder (Name.fromGlobal home name)
51+ }
52+
53+
54+
55+-- GENERATE MAINS
56+
57+
58+data MainsBuilder =
59+ MainsBuilder
60+ { _main_code :: B.Builder
61+ , _main_trie :: MainTrie
62+ }
2963
3064
3165data Mode = Debug | Prod
3266
3367
34−data Roots
35− = Mains [ModuleName.Canonical]
36− | Value ModuleName.Canonical N.Name
68+generateMains :: Mode -> Name.Target -> Opt.Graph -> I.Interfaces -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] MainsBuilder
69+generateMains mode target (Opt.Graph mains graph fields) interfaces roots =
70+ let
71+ rootSet = Set.fromList roots
72+ rootMap = Map.restrictKeys mains rootSet
73+ in
74+ if Map.size rootMap == Set.size rootSet then
75+ let
76+ realMode = toRealMode mode target fields
77+ state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
78+ in
79+ Right $ MainsBuilder (stateToBuilder state) (toMainTrie realMode interfaces rootMap)
3780
81+ else
82+ Left $ Set.toList $
83+ Set.intersection rootSet (Map.keysSet mains)
3884
39−generate :: Mode -> Name.Target -> Opt.Graph -> Roots -> Either [ModuleName.Canonical] B.Builder
40−generate mode target (Opt.Graph mains nodes fields) roots =
41− case roots of
42− Value home name ->
43− Right $ stateToBuilder $
44− addGlobal (toRealMode mode target fields) nodes emptyState (Opt.Global home name)
4585
46− Mains modules ->
47− generateMain (toRealMode mode target fields) nodes
48− <$> verifyMains mains modules
86+addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
87+addMain mode graph home _ state =
88+ addGlobal mode graph state (Opt.Global home "main")
4989
5090
5191toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
@@ -327,39 +367,61 @@ generateManagerHelp home effectsType =
327367
328368
329369
330−-- ADD MAIN
370+-- MAIN TRIE
331371
332372
333−type Mains =
334− Map.Map ModuleName.Canonical Opt.Main
335−
373+data MainTrie =
374+ MainTrie
375+ { _main :: Maybe B.Builder
376+ , _subs :: Map.Map N.Name MainTrie
377+ }
336378
337−generateMain :: Name.Mode -> Graph -> Mains -> B.Builder
338−generateMain mode graph mains =
339− mconcat
340− [ stateToBuilder $ Map.foldrWithKey (addMain mode graph) emptyState mains
341− , exportMains mains
342− ]
343379
380+emptyTrie :: MainTrie
381+emptyTrie =
382+ MainTrie Nothing Map.empty
344383
345−addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
346−addMain mode graph home _ state =
347− addGlobal mode graph state (Opt.Global home "main")
348384
385+toMainTrie :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> MainTrie
386+toMainTrie mode interfaces mains =
387+ Map.foldrWithKey (addMainTrie mode interfaces) emptyTrie mains
349388
350−exportMains :: Mains -> B.Builder
351−exportMains mains =
352− error "TODO" mains
353389
354−
355−verifyMains :: Mains -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] Mains
356−verifyMains mains modules =
390+addMainTrie :: Name.Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> MainTrie -> MainTrie
391+addMainTrie mode interfaces home@(ModuleName.Canonical _ moduleName) main trie =
357392 let
358− rootSet = Set.fromList modules
359− rootMap = Map.restrictKeys mains rootSet
393+ segments = Text.splitOn "." moduleName
394+ initMain = Expr.generateMain mode interfaces home segments main
395+ newTrie = segmentsToTrie segments (JS.exprToBuilder initMain)
360396 in
361− if Map.size rootMap == Set.size rootSet then
362− Right rootMap
363− else
364− Left $ Set.toList $
365− Set.intersection rootSet (Map.keysSet mains)
397+ merge trie newTrie
398+
399+
400+segmentsToTrie :: [N.Name] -> B.Builder -> MainTrie
401+segmentsToTrie segments mainBuilder =
402+ case segments of
403+ [] ->
404+ MainTrie (Just mainBuilder) Map.empty
405+
406+ segment : otherSegments ->
407+ MainTrie Nothing (Map.singleton segment (segmentsToTrie otherSegments mainBuilder))
408+
409+
410+merge :: MainTrie -> MainTrie -> MainTrie
411+merge (MainTrie main1 subs1) (MainTrie main2 subs2) =
412+ MainTrie
413+ (checkedMerge main1 main2)
414+ (Map.unionWith merge subs1 subs2)
415+
416+
417+checkedMerge :: Maybe a -> Maybe a -> Maybe a
418+checkedMerge a b =
419+ case (a, b) of
420+ (Nothing, main) ->
421+ main
422+
423+ (main, Nothing) ->
424+ main
425+
426+ (Just _, Just _) ->
427+ error "cannot have two modules with the same name"
src/Generate/JavaScript/Builder.hs+5
@@ -20,6 +20,7 @@ import Data.ByteString.Builder as B
2020import Data.Monoid ((<>))
2121import qualified Generate.JavaScript.Name as Name
2222import Generate.JavaScript.Name (Name)
23+import qualified Json.Encode as Json
2324
2425
2526
@@ -32,6 +33,7 @@ data Expr
3233 | Int Int
3334 | Bool Bool
3435 | Null
36+ | Json Json.Value
3537 | Array [Expr]
3638 | Object [(Name, Expr)]
3739 | Ref Name
@@ -312,6 +314,9 @@ fromExpr indent grouping expression =
312314 Null ->
313315 (One, "null")
314316
317+ Json json ->
318+ ( One, Json.encodeUgly json )
319+
315320 Array exprs ->
316321 (,) Many $
317322 let
src/Generate/JavaScript/Expression.hs+39
@@ -3,6 +3,7 @@ module Generate.JavaScript.Expression
33 ( generate
44 , generateCtor
55 , generateFunction
6+ , generateMain
67 , Code
78 , codeToExpr
89 , codeToStmtList
@@ -18,6 +19,9 @@ import qualified Data.Text.Encoding as Text
1819import qualified AST.Optimized as Opt
1920import qualified AST.Module.Name as ModuleName
2021import qualified Data.Index as Index
22+import qualified Elm.Compiler.Type as Type
23+import qualified Elm.Compiler.Type.Extract as Extract
24+import qualified Elm.Interface as I
2125import qualified Elm.Name as N
2226import qualified Elm.Package as Pkg
2327import qualified Generate.JavaScript.Builder as JS
@@ -849,3 +853,38 @@ pathToJsExpr mode expr path =
849853
850854 DT.Alias ->
851855 expr
856+
857+
858+
859+-- GENERATE MAIN
860+
861+
862+generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> [N.Name] -> Opt.Main -> JS.Expr
863+generateMain mode interfaces home segments main =
864+ case main of
865+ Opt.Static ->
866+ JS.Ref (Name.fromKernel N.browser "staticPage")
867+ # JS.Ref (Name.fromGlobal home "main")
868+ # List.foldl' addDot elm segments
869+
870+ Opt.Dynamic decoder msgType ->
871+ JS.Ref (Name.fromGlobal home "main")
872+ # List.foldl' addDot elm segments
873+ # generateJsExpr mode decoder
874+ # JS.Json (Type.encodeMetadata (Extract.fromMsg interfaces msgType))
875+
876+
877+(#) :: JS.Expr -> JS.Expr -> JS.Expr
878+(#) func arg =
879+ JS.Call func [arg]
880+
881+
882+addDot :: JS.Expr -> N.Name -> JS.Expr
883+addDot root name =
884+ JS.Index root (JS.String (N.toBuilder name))
885+
886+
887+{-# NOINLINE elm #-}
888+elm :: JS.Expr
889+elm =
890+ JS.Ref (Name.fromLocal "Elm")
src/Nitpick/TopLevelTypes.hs+5−2
@@ -16,6 +16,8 @@ import qualified AST.Module.Name as ModuleName
1616import qualified AST.Utils.Type as Type
1717import qualified Canonicalize.Effects as Effects
1818import qualified Elm.Name as N
19+import qualified Optimize.Names as Names
20+import qualified Optimize.Port as Port
1921import qualified Reporting.Annotation as A
2022import qualified Reporting.Error.Main as Error
2123import qualified Reporting.Region as R
@@ -95,14 +97,15 @@ checkMainType region (Can.Forall _ tipe) =
9597 | home == ModuleName.virtualDom && name == N.node ->
9698 Result.ok Opt.Static
9799
98− Can.TType home name [flags, _, _]
100+ Can.TType home name [flags, message, _]
99101 | home == ModuleName.platform && name == N.program ->
100102 case Effects.checkPayload flags of
101103 Left (subType, invalidPayload) ->
102104 Result.throw (Error.BadFlags region subType invalidPayload)
103105
104106 Right () ->
105− Result.ok (Opt.Dynamic flags)
107+ let (_, _, flagDecoder) = Names.run (Port.toFlagsDecoder flags) in
108+ Result.ok (Opt.Dynamic flagDecoder message)
106109
107110 _ ->
108111 Result.throw (Error.BadType region tipe)