git.iko.soy/rowtype-yoga/purescript-native
on 2978939 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Bundle.hs
551 lines 22 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : psc-bundle
4-- Copyright : (c) Phil Freeman 2015
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- | Bundles compiled PureScript modules for the browser.
12--
13-- This module takes as input the individual generated modules from 'Language.PureScript.Make' and
14-- performs dead code elimination, filters empty modules,
15-- and generates the final Javascript bundle.
16-----------------------------------------------------------------------------
18{-# LANGUAGE PatternGuards #-}
19{-# LANGUAGE FlexibleContexts #-}
20{-# LANGUAGE ScopedTypeVariables #-}
21{-# LANGUAGE TupleSections #-}
22{-# LANGUAGE RecordWildCards #-}
24module Language.PureScript.Bundle (
25 bundle
26 , ModuleIdentifier(..)
27 , moduleName
28 , ModuleType(..)
29 , ErrorMessage(..)
30 , printErrorMessage
31) where
33import Prelude ()
34import Prelude.Compat
36import Data.List (nub)
37import Data.Maybe (mapMaybe, catMaybes)
38import Data.Generics (everything, everywhere, mkQ, mkT)
39import Data.Graph
40import Data.Version (showVersion)
42import qualified Data.Set as S
44import Control.Monad
45import Control.Monad.Error.Class
46import Language.JavaScript.Parser
48import qualified Paths_purescript as Paths
50-- | The type of error messages. We separate generation and rendering of errors using a data
51-- type, in case we need to match on error types later.
52data ErrorMessage
53 = UnsupportedModulePath String
54 | InvalidTopLevel
55 | UnableToParseModule String
56 | UnsupportedExport
57 | ErrorInModule ModuleIdentifier ErrorMessage
58 deriving (Show, Read)
60-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
61data ModuleType
62 = Regular
63 | Foreign
64 deriving (Show, Read, Eq, Ord)
66showModuleType :: ModuleType -> String
67showModuleType Regular = "Regular"
68showModuleType Foreign = "Foreign"
70-- | A module is identified by its module name and its type.
71data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord)
73moduleName :: ModuleIdentifier -> String
74moduleName (ModuleIdentifier name _) = name
76-- | A piece of code is identified by its module and its name. These keys are used to label vertices
77-- in the dependency graph.
78type Key = (ModuleIdentifier, String)
80-- | An export is either a "regular export", which exports a name from the regular module we are in,
81-- or a reexport of a declaration in the corresponding foreign module.
82--
83-- Regular exports are labelled, since they might re-export an operator with another name.
84data ExportType
85 = RegularExport String
86 | ForeignReexport
87 deriving (Show, Read, Eq, Ord)
89-- | There are four types of module element we are interested in:
90--
91-- 1) Require statements
92-- 2) Member declarations
93-- 3) Export lists
94-- 4) Everything else
95--
96-- Each is labelled with the original AST node which generated it, so that we can dump it back
97-- into the output during codegen.
98data ModuleElement
99 = Require JSNode String ModuleIdentifier
100 | Member JSNode Bool String [JSNode] [Key]
101 | ExportsList [(ExportType, String, JSNode, [Key])]
102 | Other JSNode
103 deriving (Show, Read)
105-- | A module is just a list of elements of the types listed above.
106data Module = Module ModuleIdentifier [ModuleElement] deriving (Show, Read)
108-- | Prepare an error message for consumption by humans.
109printErrorMessage :: ErrorMessage -> [String]
110printErrorMessage (UnsupportedModulePath s) =
111 [ "A CommonJS module has an unsupported name (" ++ show s ++ ")."
112 , "The following file names are supported:"
113 , " 1) index.js (psc native modules)"
114 , " 2) foreign.js (psc foreign modules)"
115 ]
116printErrorMessage InvalidTopLevel =
117 [ "Expected a list of source elements at the top level." ]
118printErrorMessage (UnableToParseModule err) =
119 [ "The module could not be parsed:"
120 , err
121 ]
122printErrorMessage UnsupportedExport =
123 [ "An export was unsupported. Exports can be defined in one of two ways: "
124 , " 1) exports.name = ..."
125 , " 2) exports = { ... }"
126 ]
127printErrorMessage (ErrorInModule mid e) =
128 ("Error in module " ++ displayIdentifier mid ++ ":")
129 : ""
130 : map (" " ++) (printErrorMessage e)
131 where
132 displayIdentifier (ModuleIdentifier name ty) =
133 name ++ " (" ++ showModuleType ty ++ ")"
135-- | Unpack the node inside a JSNode. This is useful when pattern matching.
136node :: JSNode -> Node
137node (NN n) = n
138node (NT n _ _) = n
140-- | Calculate the ModuleIdentifier which a require(...) statement imports.
141checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier
142checkImportPath "./foreign" m _ =
143 Just (ModuleIdentifier (moduleName m) Foreign)
144checkImportPath name _ names
145 | name `S.member` names = Just (ModuleIdentifier name Regular)
146checkImportPath _ _ _ = Nothing
148-- | Compute the dependencies of all elements in a module, and add them to the tree.
149--
150-- Members and exports can have dependencies. A dependency is of one of the following forms:
151--
152-- 1) module.name or member["name"]
153--
154-- where module was imported using
155--
156-- var module = require("Module.Name");
157--
158-- 2) name
159--
160-- where name is the name of a member defined in the current module.
161withDeps :: Module -> Module
162withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
163 where
164 -- | Collects all modules which are imported, so that we can identify dependencies of the first type.
165 imports :: [(String, ModuleIdentifier)]
166 imports = mapMaybe toImport es
167 where
168 toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)
169 toImport (Require _ nm mid) = Just (nm, mid)
170 toImport _ = Nothing
172 -- | Collects all member names in scope, so that we can identify dependencies of the second type.
173 boundNames :: [String]
174 boundNames = mapMaybe toBoundName es
175 where
176 toBoundName :: ModuleElement -> Maybe String
177 toBoundName (Member _ _ nm _ _) = Just nm
178 toBoundName _ = Nothing
180 -- | Calculate dependencies and add them to the current element.
181 expandDeps :: ModuleElement -> ModuleElement
182 expandDeps (Member n f nm decl _) = Member n f nm decl (nub (concatMap (dependencies modulePath) decl))
183 expandDeps (ExportsList exps) = ExportsList (map expand exps)
184 where
185 expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
186 expandDeps other = other
188 dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)]
189 dependencies m = everything (++) (mkQ [] toReference)
190 where
191 toReference :: Node -> [(ModuleIdentifier, String)]
192 toReference (JSMemberDot [ mn ] _ nm)
193 | JSIdentifier mn' <- node mn
194 , JSIdentifier nm' <- node nm
195 , Just mid <- lookup mn' imports
196 = [(mid, nm')]
197 toReference (JSMemberSquare [ mn ] _ nm _)
198 | JSIdentifier mn' <- node mn
199 , JSExpression [ s ] <- node nm
200 , JSStringLiteral _ nm' <- node s
201 , Just mid <- lookup mn' imports
202 = [(mid, nm')]
203 toReference (JSIdentifier nm)
204 | nm `elem` boundNames
205 = [(m, nm)]
206 toReference _ = []
208-- | Attempt to create a Module from a Javascript AST.
209--
210-- Each type of module element is matched using pattern guards, and everything else is bundled into the
211-- Other constructor.
212toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSNode -> m Module
213toModule mids mid top
214 | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns
215 | otherwise = err InvalidTopLevel
216 where
217 err = throwError . ErrorInModule mid
219 toModuleElement :: JSNode -> m ModuleElement
220 toModuleElement n
221 | JSVariables var [ varIntro ] _ <- node n
222 , JSLiteral "var" <- node var
223 , JSVarDecl impN [ eq, req, impP ] <- node varIntro
224 , JSIdentifier importName <- node impN
225 , JSLiteral "=" <- node eq
226 , JSIdentifier "require" <- node req
227 , JSArguments _ [ impS ] _ <- node impP
228 , JSStringLiteral _ importPath <- node impS
229 , Just importPath' <- checkImportPath importPath mid mids
230 = pure (Require n importName importPath')
231 toModuleElement n
232 | JSVariables var [ varIntro ] _ <- node n
233 , JSLiteral "var" <- node var
234 , JSVarDecl declN (eq : decl) <- node varIntro
235 , JSIdentifier name <- node declN
236 , JSLiteral "=" <- node eq
237 = pure (Member n False name decl [])
238 toModuleElement n
239 | JSExpression (e : op : decl) <- node n
240 , Just name <- accessor (node e)
241 , JSOperator eq <- node op
242 , JSLiteral "=" <- node eq
243 = pure (Member n True name decl [])
244 where
245 accessor :: Node -> Maybe String
246 accessor (JSMemberDot [ exports ] _ nm)
247 | JSIdentifier "exports" <- node exports
248 , JSIdentifier name <- node nm
249 = Just name
250 accessor (JSMemberSquare [ exports ] _ nm _)
251 | JSIdentifier "exports" <- node exports
252 , JSExpression [e] <- node nm
253 , JSStringLiteral _ name <- node e
254 = Just name
255 accessor _ = Nothing
256 toModuleElement n
257 | JSExpression (mnExp : op : obj: _) <- node n
258 , JSMemberDot [ mn ] _ e <- node mnExp
259 , JSIdentifier "module" <- node mn
260 , JSIdentifier "exports" <- node e
261 , JSOperator eq <- node op
262 , JSLiteral "=" <- node eq
263 , JSObjectLiteral _ props _ <- node obj
264 = ExportsList <$> traverse toExport (filter (not . isSeparator) (map node props))
265 where
266 toExport :: Node -> m (ExportType, String, JSNode, [Key])
267 toExport (JSPropertyNameandValue name _ [val] ) =
268 (,,val,[]) <$> exportType (node val)
269 <*> extractLabel (node name)
270 toExport _ = err UnsupportedExport
272 exportType :: Node -> m ExportType
273 exportType (JSMemberDot [f] _ _)
274 | JSIdentifier "$foreign" <- node f
275 = pure ForeignReexport
276 exportType (JSMemberSquare [f] _ _ _)
277 | JSIdentifier "$foreign" <- node f
278 = pure ForeignReexport
279 exportType (JSIdentifier s) = pure (RegularExport s)
280 exportType _ = err UnsupportedExport
282 extractLabel :: Node -> m String
283 extractLabel (JSStringLiteral _ nm) = pure nm
284 extractLabel (JSIdentifier nm) = pure nm
285 extractLabel _ = err UnsupportedExport
287 isSeparator :: Node -> Bool
288 isSeparator (JSLiteral ",") = True
289 isSeparator _ = False
290 toModuleElement other = pure (Other other)
292-- | Eliminate unused code based on the specified entry point set.
293compile :: [Module] -> [ModuleIdentifier] -> [Module]
294compile modules [] = modules
295compile modules entryPoints = filteredModules
296 where
297 (graph, _, vertexFor) = graphFromEdges verts
299 -- | The vertex set
300 verts :: [(ModuleElement, Key, [Key])]
301 verts = do
302 Module mid els <- modules
303 concatMap (toVertices mid) els
304 where
305 -- | Create a set of vertices for a module element.
306 --
307 -- Some special cases worth commenting on:
308 --
309 -- 1) Regular exports which simply export their own name do not count as dependencies.
310 -- Regular exports which rename and reexport an operator do count, however.
311 --
312 -- 2) Require statements don't contribute towards dependencies, since they effectively get
313 -- inlined wherever they are used inside other module elements.
314 toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])]
315 toVertices p m@(Member _ _ nm _ deps) = [(m, (p, nm), deps)]
316 toVertices p m@(ExportsList exps) = mapMaybe toVertex exps
317 where
318 toVertex (ForeignReexport, nm, _, ks) = Just (m, (p, nm), ks)
319 toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks)
320 toVertex _ = Nothing
321 toVertices _ _ = []
323 -- | The set of vertices whose connected components we are interested in keeping.
324 entryPointVertices :: [Vertex]
325 entryPointVertices = catMaybes $ do
326 (_, k@(mid, _), _) <- verts
327 guard $ mid `elem` entryPoints
328 return (vertexFor k)
330 -- | The set of vertices reachable from an entry point
331 reachableSet :: S.Set Vertex
332 reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)
334 filteredModules :: [Module]
335 filteredModules = map filterUsed modules
336 where
337 filterUsed :: Module -> Module
338 filterUsed (Module mid ds) = Module mid (map filterExports (go ds))
339 where
340 go :: [ModuleElement] -> [ModuleElement]
341 go [] = []
342 go (d : Other semi : rest)
343 | JSLiteral ";" <- node semi
344 , not (isDeclUsed d)
345 = go rest
346 go (d : rest)
347 | not (isDeclUsed d) = go rest
348 | otherwise = d : go rest
350 -- | Filter out the exports for members which aren't used.
351 filterExports :: ModuleElement -> ModuleElement
352 filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps)
353 filterExports me = me
355 isDeclUsed :: ModuleElement -> Bool
356 isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)
357 isDeclUsed _ = True
359 isKeyUsed :: Key -> Bool
360 isKeyUsed k
361 | Just me <- vertexFor k = me `S.member` reachableSet
362 | otherwise = False
364-- | Topologically sort the module dependency graph, so that when we generate code, modules can be
365-- defined in the right order.
366sortModules :: [Module] -> [Module]
367sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph))
368 where
369 (graph, nodeFor, _) = graphFromEdges $ do
370 m@(Module mid els) <- modules
371 return (m, mid, mapMaybe getKey els)
373 getKey :: ModuleElement -> Maybe ModuleIdentifier
374 getKey (Require _ _ mi) = Just mi
375 getKey _ = Nothing
377-- | A module is empty if it contains no exported members (in other words,
378-- if the only things left after dead code elimination are module imports and
379-- "other" foreign code).
380--
381-- If a module is empty, we don't want to generate code for it.
382isModuleEmpty :: Module -> Bool
383isModuleEmpty (Module _ els) = all isElementEmpty els
384 where
385 isElementEmpty :: ModuleElement -> Bool
386 isElementEmpty (ExportsList exps) = null exps
387 isElementEmpty Require{} = True
388 isElementEmpty (Other _) = True
389 isElementEmpty _ = False
391-- | Generate code for a set of modules, including a call to main().
392--
393-- Modules get defined on the global PS object, as follows:
394--
395-- var PS = { };
396-- (function(exports) {
397-- ...
398-- })(PS["Module.Name"] = PS["Module.Name"] || {});
399--
400-- In particular, a module and its foreign imports share the same namespace inside PS.
401-- This saves us from having to generate unique names for a module and its foreign imports,
402-- and is safe since a module shares a namespace with its foreign imports in PureScript as well
403-- (so there is no way to have overlaps in code generated by psc).
404codeGen :: Maybe String -- ^ main module
405 -> String -- ^ namespace
406 -> [Module] -- ^ input modules
407 -> String
408codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElementsTop (prelude ++ concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule)))
409 where
410 moduleToJS :: Module -> [JSNode]
411 moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
412 where
413 declToJS :: ModuleElement -> [JSNode]
414 declToJS (Member n _ _ _ _) = [n]
415 declToJS (Other n) = [n]
416 declToJS (Require _ nm req) =
417 [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])
418 [ NN (JSVarDecl (sp (JSIdentifier nm))
419 [ sp (JSLiteral "=")
420 , moduleReference sp (moduleName req)
421 ])
422 ]
423 (nt (JSLiteral ";"))) ]
424 declToJS (ExportsList exps) = map toExport exps
426 where
427 toExport :: (ExportType, String, JSNode, [Key]) -> JSNode
428 toExport (_, nm, val, _) =
429 NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]
430 (nt (JSLiteral "["))
431 (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))
432 (nt (JSLiteral "]")))
433 , NN (JSOperator (sp (JSLiteral "=")))
434 , reindent val
435 , nt (JSLiteral ";")
436 ])
438 reindent :: JSNode -> JSNode
439 reindent (NT n _ _) = sp n
440 reindent nn = nn
442 indent :: [JSNode] -> [JSNode]
443 indent = everywhere (mkT squash)
444 where
445 squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)
446 squash nn = nn
448 splat (CommentA pos s) = CommentA (keepCol pos) s
449 splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
450 splat ann = ann
452 keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)
454 prelude :: [JSNode]
455 prelude =
456 [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)
457 , WhiteSpace tokenPosnEmpty "\n"
458 ])
459 [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))
460 [ sp (JSLiteral "=")
461 , NN (JSObjectLiteral (sp (JSLiteral "{"))
462 []
463 (sp (JSLiteral "}")))
464 ])
465 ]
466 (nt (JSLiteral ";")))
467 , lf
468 ]
470 moduleReference :: (Node -> JSNode) -> String -> JSNode
471 moduleReference f mn =
472 NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]
473 (nt (JSLiteral "["))
474 (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
475 (nt (JSLiteral "]")))
477 wrap :: String -> [JSNode] -> [JSNode]
478 wrap mn ds =
479 [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))
480 (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))
481 []
482 (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))
483 (NN (JSBlock [sp (JSLiteral "{")]
484 (lf : ds)
485 [nl (JSLiteral "}")])))]))
486 (nt (JSLiteral ")")))
487 , NN (JSArguments (nt (JSLiteral "("))
488 [ NN (JSExpression [ moduleReference nt mn
489 , NN (JSOperator (sp (JSLiteral "=")))
490 , NN (JSExpressionBinary "||"
491 [ moduleReference sp mn ]
492 (sp (JSLiteral "||"))
493 [ emptyObj ])
494 ])
495 ]
496 (nt (JSLiteral ")")))
497 ])
498 , nt (JSLiteral ";")
499 , lf
500 ]
501 where
502 emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))
504 runMain :: String -> [JSNode]
505 runMain mn =
506 [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]
507 (nt (JSLiteral "["))
508 (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
509 (nt (JSLiteral "]")))
510 ]
511 (nt (JSLiteral "."))
512 (nt (JSIdentifier "main")))
513 , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")")))
514 ])
515 , nt (JSLiteral ";")
516 ]
518 nt :: Node -> JSNode
519 nt n = NT n tokenPosnEmpty []
521 lf :: JSNode
522 lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
524 sp :: Node -> JSNode
525 sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
527 nl :: Node -> JSNode
528 nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
530-- | The bundling function.
531-- This function performs dead code elimination, filters empty modules
532-- and generates and prints the final Javascript bundle.
533bundle :: forall m. (Applicative m, MonadError ErrorMessage m)
534 => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
535 -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
536 -> Maybe String -- ^ An optional main module.
537 -> String -- ^ The namespace (e.g. PS).
538 -> m String
539bundle inputStrs entryPoints mainModule namespace = do
540 input <- forM inputStrs $ \(ident, js) -> do
541 ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident)
542 return (ident, ast)
544 let mids = S.fromList (map (moduleName . fst) input)
546 modules <- traverse (fmap withDeps . uncurry (toModule mids)) input
548 let compiled = compile modules entryPoints
549 sorted = sortModules (filter (not . isModuleEmpty) compiled)
551 return (codeGen mainModule namespace sorted)