git.iko.soy/elk
on master help sign in
Expose Elm.Compiler.parseKernel to grab all kernel dependencies
973bf00Evan Czaplicki
elm-compiler.cabal+1
compare with master
unifiedsplit
@@ -66,6 +66,7 @@ Library
66 AST.Expression.Optimized,
66 AST.Expression.Optimized,
67 AST.Expression.Source,
67 AST.Expression.Source,
68 AST.Helpers,
68 AST.Helpers,
69+ AST.Kernel,
69 AST.Literal,
70 AST.Literal,
70 AST.Module,
71 AST.Module,
71 AST.Module.Name,
72 AST.Module.Name,
src/AST/Kernel.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Kernel
3+ ( Info(..)
4+ , Chunk(..)
5+ )
6+ where
7+
8+
9+import Control.Monad (liftM, liftM2)
10+import Data.Binary
11+import qualified Data.ByteString as BS
12+import qualified Data.Text as Text
13+
14+import qualified AST.Module.Name as ModuleName
15+
16+
17+
18+-- INFO
19+
20+
21+data Info =
22+ Info
23+ { _imports :: [(ModuleName.Raw, Text.Text)]
24+ , _chunks :: [Chunk]
25+ }
26+
27+
28+data Chunk
29+ = JS BS.ByteString
30+ | Var ModuleName.Raw Text.Text
31+
32+
33+
34+-- BINARY
35+
36+
37+instance Binary Info where
38+ put (Info imports chunks) =
39+ put imports >> put chunks
40+
41+ get =
42+ liftM2 Info get get
43+
44+
45+instance Binary Chunk where
46+ put chunk =
47+ case chunk of
48+ JS bytes ->
49+ putWord8 0 >> put bytes
50+
51+ Var home name ->
52+ putWord8 1 >> put home >> put name
53+
54+ get =
55+ do word <- getWord8
56+ case word of
57+ 0 -> liftM JS get
58+ 1 -> liftM2 Var get get
59+ _ -> error "problem deserializing Parse.Kernel.Chunk"
src/Elm/Compiler.hs+22−2
@@ -7,16 +7,17 @@ module Elm.Compiler
7 , Error, errorToDoc, errorToJson
7 , Error, errorToDoc, errorToJson
8 , Warning, warningToDoc, warningToJson
8 , Warning, warningToDoc, warningToJson
9 , Tag(..), parseHeader
9 , Tag(..), parseHeader
10+ , KernelInfo(..), parseKernel
10 )
11 )
11 where
12 where
12
13
13import qualified Data.Aeson as Json
14import qualified Data.Aeson as Json
14import qualified Data.Map as Map
15import qualified Data.Map as Map
15−import qualified Data.Set as Set
16import Data.Text (Text)
16import Data.Text (Text)
17import qualified Data.ByteString.Builder as BS
17import qualified Data.ByteString.Builder as BS
18import Text.PrettyPrint.ANSI.Leijen (Doc)
18import Text.PrettyPrint.ANSI.Leijen (Doc)
19
19
20+import qualified AST.Kernel as Kernel (Info)
20import qualified AST.Module as Module
21import qualified AST.Module as Module
21import qualified AST.Module.Name as ModuleName
22import qualified AST.Module.Name as ModuleName
22import qualified Compile
23import qualified Compile
@@ -29,6 +30,7 @@ import qualified Elm.Docs as Docs
29import qualified Elm.Package as Package
30import qualified Elm.Package as Package
30import qualified Generate.JavaScript as JS
31import qualified Generate.JavaScript as JS
31import qualified Parse.Helpers as Parse (run)
32import qualified Parse.Helpers as Parse (run)
33+import qualified Parse.Kernel as Kernel (parser)
32import qualified Parse.Module as Parse (header)
34import qualified Parse.Module as Parse (header)
33import qualified Reporting.Annotation as A
35import qualified Reporting.Annotation as A
34import qualified Reporting.Bag as Bag
36import qualified Reporting.Bag as Bag
@@ -112,7 +114,7 @@ docsGen isExposed (Module.Module name info) =
112-- CODE GENERATION
114-- CODE GENERATION
113
115
114
116
115−generate :: Obj.SymbolTable -> Obj.Graph -> Obj.Roots -> (Set.Set M.Canonical, BS.Builder)
117+generate :: Obj.Graph -> Obj.Roots -> BS.Builder
116generate =
118generate =
117 JS.generate
119 JS.generate
118
120
@@ -204,3 +206,21 @@ toHeaderSummary pkgName (Module.Header maybeHeaderDecl imports) =
204 Module.Effect _ -> Effect
206 Module.Effect _ -> Effect
205 in
207 in
206 ( tag, Just name, dependencies )
208 ( tag, Just name, dependencies )
209+
210+
211+
212+-- PARSE KERNEL
213+
214+
215+newtype KernelInfo =
216+ KernelInfo Kernel.Info
217+
218+
219+parseKernel :: Text -> Either Error KernelInfo
220+parseKernel sourceCode =
221+ case Parse.run Kernel.parser sourceCode of
222+ Right info ->
223+ Right (KernelInfo info)
224+
225+ Left err ->
226+ Left (Error (A.map Error.Syntax err))
src/Elm/Compiler/Objects.hs+19−1
@@ -3,6 +3,7 @@ module Elm.Compiler.Objects
3 ( Graph
3 ( Graph
4 , union
4 , union
5 , unions
5 , unions
6+ , graphForPackage
6 , Roots
7 , Roots
7 , mains
8 , mains
8 , value
9 , value
@@ -10,4 +11,21 @@ module Elm.Compiler.Objects
10 where
11 where
11
12
12
13
14+import qualified Data.Map as Map
15+
16+import qualified AST.Module.Name as ModuleName
17+import qualified Elm.Compiler as Compiler
13−import Elm.Compiler.Objects.Internal
18+import Elm.Compiler.Objects.Internal as Obj
19+
20+
21+
22+-- HELPER
23+
24+
25+graphForPackage :: Map.Map ModuleName.Raw Compiler.KernelInfo -> [Compiler.Result] -> Obj.Graph
26+graphForPackage kernels results =
27+ let
28+ kernelGraph =
29+ Obj.Graph Map.empty (Map.map (\(Compiler.KernelInfo info) -> info) kernels)
30+ in
31+ Obj.unions (kernelGraph : map Compiler._objs results)
src/Elm/Compiler/Objects/Internal.hs+20−19
@@ -15,12 +15,13 @@ module Elm.Compiler.Objects.Internal
15
15
16import Prelude hiding (lookup)
16import Prelude hiding (lookup)
17import Control.Arrow (first)
17import Control.Arrow (first)
18−import Control.Monad (liftM, liftM2)
18+import Control.Monad (liftM2)
19import Data.Binary
19import Data.Binary
20import qualified Data.Map as Map
20import qualified Data.Map as Map
21import qualified Data.Text as Text
21import qualified Data.Text as Text
22
22
23import qualified AST.Expression.Optimized as Opt
23import qualified AST.Expression.Optimized as Opt
24+import qualified AST.Kernel as Kernel
24import qualified AST.Module.Name as ModuleName
25import qualified AST.Module.Name as ModuleName
25import qualified AST.Module as Module
26import qualified AST.Module as Module
26import qualified AST.Variable as Var
27import qualified AST.Variable as Var
@@ -30,8 +31,11 @@ import qualified AST.Variable as Var
30-- OBJECT GRAPH
31-- OBJECT GRAPH
31
32
32
33
33−newtype Graph =
34+data Graph =
35+ Graph
34− Graph { _graph :: Map.Map Var.Global Opt.Decl }
36+ { _decls :: Map.Map Var.Global Opt.Decl
37+ , _kernels :: Map.Map ModuleName.Raw Kernel.Info
38+ }
35
39
36
40
37
41
@@ -40,18 +44,23 @@ newtype Graph =
40
44
41fromModule :: Module.Optimized -> Graph
45fromModule :: Module.Optimized -> Graph
42fromModule (Module.Module home info) =
46fromModule (Module.Module home info) =
43− Graph $ Map.fromList $
47+ let
48+ decls =
44− map (first (Var.Global home)) (Module.program info)
49+ Map.fromList $ map (first (Var.Global home)) (Module.program info)
50+ in
51+ Graph decls Map.empty
45
52
46
53
47union :: Graph -> Graph -> Graph
54union :: Graph -> Graph -> Graph
48−union (Graph objs1) (Graph objs2) =
55+union (Graph decls1 kernels1) (Graph decls2 kernels2) =
49− Graph (Map.union objs1 objs2)
56+ Graph (Map.union decls1 decls2) (Map.union kernels1 kernels2)
50
57
51
58
52unions :: [Graph] -> Graph
59unions :: [Graph] -> Graph
53unions graphs =
60unions graphs =
61+ Graph
62+ (Map.unions (map _decls graphs))
54− Graph (Map.unions (map _graph graphs))
63+ (Map.unions (map _kernels graphs))
55
64
56
65
57
66
@@ -88,16 +97,8 @@ toGlobals roots =
88
97
89
98
90instance Binary Graph where
99instance Binary Graph where
91− put (Graph dict) =
100+ put (Graph decls kernels) =
92− put dict
101+ put decls >> put kernels
93
102
94 get =
103 get =
95− liftM Graph get
104+ liftM2 Graph get get
96−
97−
98−instance Binary Symbol where
99− put (Symbol home name) =
100− put home >> put name
101−
102− get =
103− liftM2 Symbol get get
src/Generate/JavaScript.hs+94−42
@@ -2,7 +2,7 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript (generate) where
3module Generate.JavaScript (generate) where
4
4
5−import Prelude hiding (init)
5+import Control.Monad (foldM)
6import Data.Monoid ((<>))
6import Data.Monoid ((<>))
7import qualified Data.List as List
7import qualified Data.List as List
8import qualified Data.Map as Map
8import qualified Data.Map as Map
@@ -12,13 +12,14 @@ import qualified Data.ByteString.Builder as BS
12
12
13import qualified AST.Effects as Effects
13import qualified AST.Effects as Effects
14import qualified AST.Expression.Optimized as Opt
14import qualified AST.Expression.Optimized as Opt
15+import qualified AST.Kernel as Kernel
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Module.Name as ModuleName
16import qualified AST.Variable as Var
17import qualified AST.Variable as Var
17import qualified Elm.Package as Pkg
18import qualified Elm.Package as Pkg
18import qualified Elm.Compiler.Objects.Internal as Obj
19import qualified Elm.Compiler.Objects.Internal as Obj
19−import qualified Generate.JavaScript.Builder as JS
20+import qualified Generate.JavaScript.Builder as JsBuilder
20−import qualified Generate.JavaScript.Effects as Effects
21+import qualified Generate.JavaScript.Effects as JsEffects
21−import qualified Generate.JavaScript.Expression as JS
22+import qualified Generate.JavaScript.Expression as JsExpr
22import qualified Generate.JavaScript.Variable as JS
23import qualified Generate.JavaScript.Variable as JS
23
24
24
25
@@ -26,84 +27,91 @@ import qualified Generate.JavaScript.Variable as JS
26-- GENERATE JAVASCRIPT
27-- GENERATE JAVASCRIPT
27
28
28
29
29−generate :: Obj.SymbolTable -> Obj.Graph -> Obj.Roots -> (Set.Set ModuleName.Canonical, BS.Builder)
30+generate :: Obj.Graph -> Obj.Roots -> BS.Builder
30−generate symbols (Obj.Graph graph) roots =
31+generate graph roots =
31 let
32 let
32− (State builders _ kernels effects table) =
33+ (State builders _ _ effects table) =
33− List.foldl' (crawl graph) (init symbols) (Obj.toGlobals roots)
34+ List.foldl' (crawl graph) initialState (Obj.toGlobals roots)
34
35
35 managers =
36 managers =
36− fst $ JS.run table (Effects.generate effects)
37+ fst $ JS.run table (JsEffects.generate effects)
37−
38− javascript =
39− List.foldl' (\rest stmt -> JS.encodeUtf8 stmt <> rest) managers builders
40 in
38 in
41− (kernels, javascript)
39+ List.foldl' (\rest stmt -> stmt <> rest) managers builders
42
40
43
41
44
42
45−-- DCE STATE
43+-- CRAWL STATE
46
44
47
45
48data State =
46data State =
49 State
47 State
50− { _stmts :: [JS.Stmt]
48+ { _builders :: [BS.Builder]
51− , _seen :: Set.Set Var.Global
49+ , _seenDecls :: Set.Set Var.Global
52− , _kernels :: Set.Set ModuleName.Canonical
50+ , _seenKernels :: Set.Set ModuleName.Raw
53 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
51 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
54 , _table :: JS.Table
52 , _table :: JS.Table
55 }
53 }
56
54
57
55
58−init :: Obj.SymbolTable -> State
56+initialState :: State
59−init symbols =
57+initialState =
60− State [] Set.empty Set.empty Map.empty (JS.init symbols)
58+ State [] Set.empty Set.empty Map.empty JS.emptyTable
61−
62−
63
59
64−-- DEAD CODE ELIMINATION
65
60
66
61
67−type Graph = Map.Map Var.Global Opt.Decl
62+-- CRAWL
68
63
69
64
70−crawl :: Graph -> State -> Var.Global -> State
65+crawl :: Obj.Graph -> State -> Var.Global -> State
71−crawl graph state@(State js seen kernels effects table) name@(Var.Global home _) =
66+crawl graph@(Obj.Graph decls kernels) state@(State _ seenDecls seenKernels _ _) name@(Var.Global home _) =
72− if Set.member name seen then
67+ if Set.member name seenDecls then
73 state
68 state
74
69
75 else if home == virtualDomDebug then
70 else if home == virtualDomDebug then
76 state
71 state
77
72
78 else
73 else
79− case Map.lookup name graph of
74+ case Map.lookup name decls of
80 Just decl ->
75 Just decl ->
81 crawlDecl graph name decl state
76 crawlDecl graph name decl state
82
77
83 Nothing ->
78 Nothing ->
84− if ModuleName.canonicalIsKernel home then
79+ let
85− State js seen (Set.insert home kernels) effects table
80+ kernelModule =
86− else
81+ ModuleName._module home
82+ in
83+ if Set.member kernelModule seenKernels then
84+ state
85+ else
86+ case Map.lookup kernelModule kernels of
87+ Just info ->
88+ crawlKernel graph kernelModule info state
89+
90+ Nothing ->
87− error (crawlError name)
91+ error (crawlError name)
92+
93+
88
94
95+-- CRAWL DECL
89
96
97+
90−crawlDecl :: Graph -> Var.Global -> Opt.Decl -> State -> State
98+crawlDecl :: Obj.Graph -> Var.Global -> Opt.Decl -> State -> State
91crawlDecl graph var@(Var.Global home name) (Opt.Decl direct indirect fx body) state1 =
99crawlDecl graph var@(Var.Global home name) (Opt.Decl direct indirect fx body) state1 =
92 let
100 let
93 state2 =
101 state2 =
94− state1 { _seen = Set.insert var (_seen state1) }
102+ state1 { _seenDecls = Set.insert var (_seenDecls state1) }
95
103
96− (State stmts seen kernels effects table) =
104+ (State builders seenDecls seenKernels effects table) =
97 Set.foldl' (crawl graph) state2 direct
105 Set.foldl' (crawl graph) state2 direct
98
106
99 (stmt, newTable) =
107 (stmt, newTable) =
100− JS.run table (JS.generateDecl home name body)
108+ JS.run table (JsExpr.generateDecl home name body)
101
109
102 state4 =
110 state4 =
103 State
111 State
104− { _stmts = stmt : stmts
112+ { _builders = JsBuilder.stmtToBuilder stmt : builders
105− , _seen = seen
113+ , _seenDecls = seenDecls
106− , _kernels = kernels
114+ , _seenKernels = seenKernels
107 , _effects = maybe id (Map.insert home) fx effects
115 , _effects = maybe id (Map.insert home) fx effects
108 , _table = newTable
116 , _table = newTable
109 }
117 }
@@ -111,13 +119,57 @@ crawlDecl graph var@(Var.Global home name) (Opt.Decl direct indirect fx body) st
111 Set.foldl' (crawl graph) state4 indirect
119 Set.foldl' (crawl graph) state4 indirect
112
120
113
121
122+
123+-- CRAWL KERNEL
124+
125+
126+crawlKernel :: Obj.Graph -> ModuleName.Raw -> Kernel.Info -> State -> State
127+crawlKernel graph name (Kernel.Info imports chunks) state1 =
128+ let
129+ state2 =
130+ state1 { _seenKernels = Set.insert name (_seenKernels state1) }
131+
132+ (State builders seenDecls seenKernels effects table) =
133+ List.foldl' (crawl graph) state2 (map toCoreGlobal imports)
134+
135+ (builder, newTable) =
136+ JS.run table (foldM chunkToBuilder mempty chunks)
137+ in
138+ State
139+ { _builders = builder : builders
140+ , _seenDecls = seenDecls
141+ , _seenKernels = seenKernels
142+ , _effects = effects
143+ , _table = newTable
144+ }
145+
146+
147+toCoreGlobal :: ( ModuleName.Raw, Text.Text ) -> Var.Global
148+toCoreGlobal (home, name) =
149+ Var.Global (ModuleName.inCore home) name
150+
151+
152+chunkToBuilder :: BS.Builder -> Kernel.Chunk -> JS.Generator BS.Builder
153+chunkToBuilder builder chunk =
154+ case chunk of
155+ Kernel.JS javascript ->
156+ return $ BS.byteString javascript <> builder
157+
158+ Kernel.Var home name ->
159+ do expr <- JS.global (Var.Global (ModuleName.inCore home) name)
160+ return $ JsBuilder.exprToBuilder expr <> builder
161+
162+
163+-- CRAWL HELPERS
164+
165+
114crawlError :: Var.Global -> String
166crawlError :: Var.Global -> String
115crawlError (Var.Global (ModuleName.Canonical pkg home) name) =
167crawlError (Var.Global (ModuleName.Canonical pkg home) name) =
116 Text.unpack $
168 Text.unpack $
117 "compiler bug manifesting in Generate.JavaScript\n"
169 "compiler bug manifesting in Generate.JavaScript\n"
118− <> "could not find " <> Pkg.toText pkg <> " " <> ModuleName.toText home <> "." <> name <> "\n"
170+ <> "Could not find " <> Pkg.toText pkg <> " " <> ModuleName.toText home <> "." <> name <> "\n"
119− <> "please report at <https://github.com/elm-lang/elm-compiler/issues>\n"
171+ <> "Please report at <https://github.com/elm-lang/elm-compiler/issues>\n"
120− <> "try to make an <http://sscce.org/> that demonstrates the issue!"
172+ <> "Try to make an <http://sscce.org/> that demonstrates the issue!"
121
173
122
174
123virtualDomDebug :: ModuleName.Canonical
175virtualDomDebug :: ModuleName.Canonical
src/Parse/Kernel.hs+10−30
@@ -1,18 +1,18 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Kernel
3module Parse.Kernel
4− ( Chunk(..)
4+ ( parser
5− , parse
6 )
5 )
7 where
6 where
8
7
9−import qualified Data.ByteString as BS
8+
10import qualified Data.Map as Map
9import qualified Data.Map as Map
11import Data.Monoid ((<>))
10import Data.Monoid ((<>))
12import Data.Text (Text)
11import Data.Text (Text)
13import qualified Data.Text as Text
12import qualified Data.Text as Text
14
13
15import qualified AST.Exposing as Exposing
14import qualified AST.Exposing as Exposing
15+import qualified AST.Kernel as Kernel
16import qualified AST.Module as Module
16import qualified AST.Module as Module
17import qualified AST.Module.Name as Module
17import qualified AST.Module.Name as Module
18import Parse.Helpers (Parser)
18import Parse.Helpers (Parser)
@@ -22,42 +22,23 @@ import qualified Reporting.Annotation as A
22
22
23
23
24
24
25−-- PARSE
26−
27−
28−data Chunk
29− = JS BS.ByteString
30− | Var Module.Raw Text
31−
32−
33−parse :: Text -> ( [(Module.Raw, Text)], [Chunk] )
34−parse source =
35− case Parse.run parser source of
36− Left _ ->
37− error "problem parsing kernel code"
38−
39− Right answer ->
40− answer
41−
42−
43−
44-- PARSER
25-- PARSER
45
26
46
27
47−parser :: Parser ( [(Module.Raw, Text)], [Chunk] )
28+parser :: Parser Kernel.Info
48parser =
29parser =
49 do imports <- Parse.kernelHeader
30 do imports <- Parse.kernelHeader
50 let table = Map.unions (map importToTable imports)
31 let table = Map.unions (map importToTable imports)
51− chunks <- parserHelp table
32+ chunks <- parserHelp table []
52− return ( Map.elems table, chunks )
33+ return (Kernel.Info (Map.elems table) chunks)
53
34
54
35
55−parserHelp :: Table -> Parser [Chunk]
36+parserHelp :: Table -> [Kernel.Chunk] -> Parser [Kernel.Chunk]
56−parserHelp table =
37+parserHelp table chunks =
57 do chunk <- Parse.kernelChunk
38 do chunk <- Parse.kernelChunk
58 case chunk of
39 case chunk of
59 Left js ->
40 Left js ->
60− return [JS js]
41+ return (Kernel.JS js : chunks)
61
42
62 Right (js, var) ->
43 Right (js, var) ->
63 case Map.lookup var table of
44 case Map.lookup var table of
@@ -65,8 +46,7 @@ parserHelp table =
65 error $ show $ "could not find " <> var <> " when parsing kernel code"
46 error $ show $ "could not find " <> var <> " when parsing kernel code"
66
47
67 Just (home, name) ->
48 Just (home, name) ->
68− do rest <- parserHelp table
49+ parserHelp table (Kernel.Var home name : Kernel.JS js : chunks)
69− return (JS js : Var home name : rest)
70
50
71
51
72
52