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