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