git.iko.soy/rowtype-yoga/purescript-native
on 794d45e help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Bundle.hs
555 lines 23 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 #-}
23module Language.PureScript.Bundle (
24 bundle
25 , ModuleIdentifier(..)
26 , moduleName
27 , ModuleType(..)
28 , ErrorMessage(..)
29 , printErrorMessage
30) where
32import Prelude ()
33import Prelude.Compat
35import Data.List (nub, stripPrefix)
36import Data.Maybe (mapMaybe, catMaybes, fromMaybe)
37import Data.Generics (everything, everywhere, mkQ, mkT)
38import Data.Graph
39import Data.Version (showVersion)
41import qualified Data.Set as S
43import Control.Monad
44import Control.Monad.Error.Class
45import Language.JavaScript.Parser
47import qualified Paths_purescript as Paths
49-- | The type of error messages. We separate generation and rendering of errors using a data
50-- type, in case we need to match on error types later.
51data ErrorMessage
52 = UnsupportedModulePath String
53 | InvalidTopLevel
54 | UnableToParseModule String
55 | UnsupportedExport
56 | ErrorInModule ModuleIdentifier ErrorMessage
57 deriving (Show, Read)
59-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
60data ModuleType
61 = Regular
62 | Foreign
63 deriving (Show, Read, Eq, Ord)
65showModuleType :: ModuleType -> String
66showModuleType Regular = "Regular"
67showModuleType Foreign = "Foreign"
69-- | A module is identified by its module name and its type.
70data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord)
72moduleName :: ModuleIdentifier -> String
73moduleName (ModuleIdentifier name _) = name
75-- | A piece of code is identified by its module and its name. These keys are used to label vertices
76-- in the dependency graph.
77type Key = (ModuleIdentifier, String)
79-- | An export is either a "regular export", which exports a name from the regular module we are in,
80-- or a reexport of a declaration in the corresponding foreign module.
81--
82-- Regular exports are labelled, since they might re-export an operator with another name.
83data ExportType
84 = RegularExport String
85 | ForeignReexport
86 deriving (Show, Read, Eq, Ord)
88-- | There are four types of module element we are interested in:
89--
90-- 1) Require statements
91-- 2) Member declarations
92-- 3) Export lists
93-- 4) Everything else
94--
95-- Each is labelled with the original AST node which generated it, so that we can dump it back
96-- into the output during codegen.
97data ModuleElement
98 = Require JSNode String (Either String ModuleIdentifier)
99 | Member JSNode Bool String [JSNode] [Key]
100 | ExportsList [(ExportType, String, JSNode, [Key])]
101 | Other JSNode
102 deriving (Show, Read)
104-- | A module is just a list of elements of the types listed above.
105data Module = Module ModuleIdentifier [ModuleElement] deriving (Show, Read)
107-- | Prepare an error message for consumption by humans.
108printErrorMessage :: ErrorMessage -> [String]
109printErrorMessage (UnsupportedModulePath s) =
110 [ "A CommonJS module has an unsupported name (" ++ show s ++ ")."
111 , "The following file names are supported:"
112 , " 1) index.js (psc native modules)"
113 , " 2) foreign.js (psc foreign modules)"
114 ]
115printErrorMessage InvalidTopLevel =
116 [ "Expected a list of source elements at the top level." ]
117printErrorMessage (UnableToParseModule err) =
118 [ "The module could not be parsed:"
119 , err
120 ]
121printErrorMessage UnsupportedExport =
122 [ "An export was unsupported. Exports can be defined in one of two ways: "
123 , " 1) exports.name = ..."
124 , " 2) exports = { ... }"
125 ]
126printErrorMessage (ErrorInModule mid e) =
127 ("Error in module " ++ displayIdentifier mid ++ ":")
128 : ""
129 : map (" " ++) (printErrorMessage e)
130 where
131 displayIdentifier (ModuleIdentifier name ty) =
132 name ++ " (" ++ showModuleType ty ++ ")"
134-- | Unpack the node inside a JSNode. This is useful when pattern matching.
135node :: JSNode -> Node
136node (NN n) = n
137node (NT n _ _) = n
139-- | Calculate the ModuleIdentifier which a require(...) statement imports.
140checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
141checkImportPath _ "./foreign" m _ =
142 Right (ModuleIdentifier (moduleName m) Foreign)
143checkImportPath requirePath name _ names
144 | Just name' <- stripPrefix (fromMaybe "" requirePath) name
145 , name' `S.member` names = Right (ModuleIdentifier name' Regular)
146checkImportPath _ name _ _ = Left name
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 (Right 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) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module
213toModule requirePath 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 , importPath' <- checkImportPath requirePath 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 _ _ (Right 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 "=") : either require (return . moduleReference sp . moduleName) req))
420 ]
421 (nt (JSLiteral ";"))) ]
422 declToJS (ExportsList exps) = map toExport exps
424 where
425 toExport :: (ExportType, String, JSNode, [Key]) -> JSNode
426 toExport (_, nm, val, _) =
427 NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]
428 (nt (JSLiteral "["))
429 (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))
430 (nt (JSLiteral "]")))
431 , NN (JSOperator (sp (JSLiteral "=")))
432 , reindent val
433 , nt (JSLiteral ";")
434 ])
436 reindent :: JSNode -> JSNode
437 reindent (NT n _ _) = sp n
438 reindent nn = nn
440 indent :: [JSNode] -> [JSNode]
441 indent = everywhere (mkT squash)
442 where
443 squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)
444 squash nn = nn
446 splat (CommentA pos s) = CommentA (keepCol pos) s
447 splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
448 splat ann = ann
450 keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)
452 prelude :: [JSNode]
453 prelude =
454 [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)
455 , WhiteSpace tokenPosnEmpty "\n"
456 ])
457 [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))
458 [ sp (JSLiteral "=")
459 , NN (JSObjectLiteral (sp (JSLiteral "{"))
460 []
461 (sp (JSLiteral "}")))
462 ])
463 ]
464 (nt (JSLiteral ";")))
465 , lf
466 ]
468 require :: String -> [JSNode]
469 require mn = [ sp (JSIdentifier "require")
470 , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")")))
471 ]
473 moduleReference :: (Node -> JSNode) -> String -> JSNode
474 moduleReference f mn =
475 NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]
476 (nt (JSLiteral "["))
477 (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
478 (nt (JSLiteral "]")))
480 wrap :: String -> [JSNode] -> [JSNode]
481 wrap mn ds =
482 [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))
483 (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))
484 []
485 (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))
486 (NN (JSBlock [sp (JSLiteral "{")]
487 (lf : ds)
488 [nl (JSLiteral "}")])))]))
489 (nt (JSLiteral ")")))
490 , NN (JSArguments (nt (JSLiteral "("))
491 [ NN (JSExpression [ moduleReference nt mn
492 , NN (JSOperator (sp (JSLiteral "=")))
493 , NN (JSExpressionBinary "||"
494 [ moduleReference sp mn ]
495 (sp (JSLiteral "||"))
496 [ emptyObj ])
497 ])
498 ]
499 (nt (JSLiteral ")")))
500 ])
501 , nt (JSLiteral ";")
502 , lf
503 ]
504 where
505 emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))
507 runMain :: String -> [JSNode]
508 runMain mn =
509 [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]
510 (nt (JSLiteral "["))
511 (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
512 (nt (JSLiteral "]")))
513 ]
514 (nt (JSLiteral "."))
515 (nt (JSIdentifier "main")))
516 , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")")))
517 ])
518 , nt (JSLiteral ";")
519 ]
521 nt :: Node -> JSNode
522 nt n = NT n tokenPosnEmpty []
524 lf :: JSNode
525 lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
527 sp :: Node -> JSNode
528 sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
530 nl :: Node -> JSNode
531 nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
533-- | The bundling function.
534-- This function performs dead code elimination, filters empty modules
535-- and generates and prints the final Javascript bundle.
536bundle :: (Applicative m, MonadError ErrorMessage m)
537 => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
538 -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
539 -> Maybe String -- ^ An optional main module.
540 -> String -- ^ The namespace (e.g. PS).
541 -> Maybe FilePath -- ^ The require path prefix
542 -> m String
543bundle inputStrs entryPoints mainModule namespace requirePath = do
544 input <- forM inputStrs $ \(ident, js) -> do
545 ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident)
546 return (ident, ast)
548 let mids = S.fromList (map (moduleName . fst) input)
550 modules <- traverse (fmap withDeps . uncurry (toModule requirePath mids)) input
552 let compiled = compile modules entryPoints
553 sorted = sortModules (filter (not . isModuleEmpty) compiled)
555 return (codeGen mainModule namespace sorted)