git.iko.soy/rowtype-yoga/purescript-native
on a628008 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Bundle.hs
588 lines 22 kB history raw
1-- |
2-- Bundles compiled PureScript modules for the browser.
3--
4-- This module takes as input the individual generated modules from 'Language.PureScript.Make' and
5-- performs dead code elimination, filters empty modules,
6-- and generates the final Javascript bundle.
7module Language.PureScript.Bundle
8 ( bundle
9 , ModuleIdentifier(..)
10 , moduleName
11 , ModuleType(..)
12 , ErrorMessage(..)
13 , printErrorMessage
14 , getExportedIdentifiers
15 ) where
17import Prelude.Compat
19import Control.Monad
20import Control.Monad.Error.Class
22import Data.Generics (everything, everywhere, mkQ, mkT)
23import Data.Graph
24import Data.List (nub, stripPrefix)
25import Data.Maybe (mapMaybe, catMaybes)
26import Data.Version (showVersion)
27import qualified Data.Set as S
29import Language.JavaScript.Parser
30import Language.JavaScript.Parser.AST
32import qualified Paths_purescript as Paths
34-- | The type of error messages. We separate generation and rendering of errors using a data
35-- type, in case we need to match on error types later.
36data ErrorMessage
37 = UnsupportedModulePath String
38 | InvalidTopLevel
39 | UnableToParseModule String
40 | UnsupportedExport
41 | ErrorInModule ModuleIdentifier ErrorMessage
42 deriving (Show, Read)
44-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
45data ModuleType
46 = Regular
47 | Foreign
48 deriving (Show, Read, Eq, Ord)
50showModuleType :: ModuleType -> String
51showModuleType Regular = "Regular"
52showModuleType Foreign = "Foreign"
54-- | A module is identified by its module name and its type.
55data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord)
57moduleName :: ModuleIdentifier -> String
58moduleName (ModuleIdentifier name _) = name
60-- | A piece of code is identified by its module and its name. These keys are used to label vertices
61-- in the dependency graph.
62type Key = (ModuleIdentifier, String)
64-- | An export is either a "regular export", which exports a name from the regular module we are in,
65-- or a reexport of a declaration in the corresponding foreign module.
66--
67-- Regular exports are labelled, since they might re-export an operator with another name.
68data ExportType
69 = RegularExport String
70 | ForeignReexport
71 deriving (Show, Eq, Ord)
73-- | There are four types of module element we are interested in:
74--
75-- 1) Require statements
76-- 2) Member declarations
77-- 3) Export lists
78-- 4) Everything else
79--
80-- Each is labelled with the original AST node which generated it, so that we can dump it back
81-- into the output during codegen.
82data ModuleElement
83 = Require JSStatement String (Either String ModuleIdentifier)
84 | Member JSStatement Bool String JSExpression [Key]
85 | ExportsList [(ExportType, String, JSExpression, [Key])]
86 | Other JSStatement
87 deriving (Show)
89-- | A module is just a list of elements of the types listed above.
90data Module = Module ModuleIdentifier [ModuleElement] deriving (Show)
92-- | Prepare an error message for consumption by humans.
93printErrorMessage :: ErrorMessage -> [String]
94printErrorMessage (UnsupportedModulePath s) =
95 [ "A CommonJS module has an unsupported name (" ++ show s ++ ")."
96 , "The following file names are supported:"
97 , " 1) index.js (psc native modules)"
98 , " 2) foreign.js (psc foreign modules)"
99 ]
100printErrorMessage InvalidTopLevel =
101 [ "Expected a list of source elements at the top level." ]
102printErrorMessage (UnableToParseModule err) =
103 [ "The module could not be parsed:"
104 , err
105 ]
106printErrorMessage UnsupportedExport =
107 [ "An export was unsupported. Exports can be defined in one of two ways: "
108 , " 1) exports.name = ..."
109 , " 2) exports = { ... }"
110 ]
111printErrorMessage (ErrorInModule mid e) =
112 ("Error in module " ++ displayIdentifier mid ++ ":")
113 : ""
114 : map (" " ++) (printErrorMessage e)
115 where
116 displayIdentifier (ModuleIdentifier name ty) =
117 name ++ " (" ++ showModuleType ty ++ ")"
119-- | Calculate the ModuleIdentifier which a require(...) statement imports.
120checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
121checkImportPath "./foreign" m _ =
122 Right (ModuleIdentifier (moduleName m) Foreign)
123checkImportPath name _ names
124 | Just name' <- stripPrefix "../" name
125 , name' `S.member` names = Right (ModuleIdentifier name' Regular)
126checkImportPath name _ _ = Left name
128-- | Compute the dependencies of all elements in a module, and add them to the tree.
129--
130-- Members and exports can have dependencies. A dependency is of one of the following forms:
131--
132-- 1) module.name or member["name"]
133--
134-- where module was imported using
135--
136-- var module = require("Module.Name");
137--
138-- 2) name
139--
140-- where name is the name of a member defined in the current module.
141withDeps :: Module -> Module
142withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
143 where
144 -- | Collects all modules which are imported, so that we can identify dependencies of the first type.
145 imports :: [(String, ModuleIdentifier)]
146 imports = mapMaybe toImport es
147 where
148 toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)
149 toImport (Require _ nm (Right mid)) = Just (nm, mid)
150 toImport _ = Nothing
152 -- | Collects all member names in scope, so that we can identify dependencies of the second type.
153 boundNames :: [String]
154 boundNames = mapMaybe toBoundName es
155 where
156 toBoundName :: ModuleElement -> Maybe String
157 toBoundName (Member _ _ nm _ _) = Just nm
158 toBoundName _ = Nothing
160 -- | Calculate dependencies and add them to the current element.
161 expandDeps :: ModuleElement -> ModuleElement
162 expandDeps (Member n f nm decl _) = Member n f nm decl (nub $ dependencies modulePath decl)
163 expandDeps (ExportsList exps) = ExportsList (map expand exps)
164 where
165 expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
166 expandDeps other = other
168 dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)]
169 dependencies m = everything (++) (mkQ [] toReference)
170 where
171 toReference :: JSExpression -> [(ModuleIdentifier, String)]
172 toReference (JSMemberDot mn _ nm)
173 | JSIdentifier _ mn' <- mn
174 , JSIdentifier _ nm' <- nm
175 , Just mid <- lookup mn' imports
176 = [(mid, nm')]
177 toReference (JSMemberSquare mn _ nm _)
178 | JSIdentifier _ mn' <- mn
179 , Just nm' <- fromStringLiteral nm
180 , Just mid <- lookup mn' imports
181 = [(mid, nm')]
182 toReference (JSIdentifier _ nm)
183 | nm `elem` boundNames
184 = [(m, nm)]
185 toReference _ = []
187-- String literals include the quote chars
188fromStringLiteral :: JSExpression -> Maybe String
189fromStringLiteral (JSStringLiteral _ str) = Just $ trimStringQuotes str
190fromStringLiteral _ = Nothing
192trimStringQuotes :: String -> String
193trimStringQuotes str = reverse $ drop 1 $ reverse $ drop 1 $ str
195commaList :: JSCommaList a -> [a]
196commaList JSLNil = []
197commaList (JSLOne x) = [x]
198commaList (JSLCons l _ x) = commaList l ++ [x]
200trailingCommaList :: JSCommaTrailingList a -> [a]
201trailingCommaList (JSCTLComma l _) = commaList l
202trailingCommaList (JSCTLNone l) = commaList l
204-- | Attempt to create a Module from a Javascript AST.
205--
206-- Each type of module element is matched using pattern guards, and everything else is bundled into the
207-- Other constructor.
208toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSAST -> m Module
209toModule mids mid top
210 | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts
211 | otherwise = err InvalidTopLevel
212 where
213 err = throwError . ErrorInModule mid
215 toModuleElement :: JSStatement -> m ModuleElement
216 toModuleElement stmt
217 | Just (importName, importPath) <- matchRequire mids mid stmt
218 = pure (Require stmt importName importPath)
219 toModuleElement stmt
220 | Just (exported, name, decl) <- matchMember stmt
221 = pure (Member stmt exported name decl [])
222 toModuleElement stmt
223 | Just props <- matchExportsAssignment stmt
224 = (ExportsList <$> traverse toExport (trailingCommaList props))
225 where
226 toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])
227 toExport (JSPropertyNameandValue name _ [val]) =
228 (,,val,[]) <$> exportType val
229 <*> extractLabel' name
230 toExport _ = err UnsupportedExport
232 exportType :: JSExpression -> m ExportType
233 exportType (JSMemberDot f _ _)
234 | JSIdentifier _ "$foreign" <- f
235 = pure ForeignReexport
236 exportType (JSMemberSquare f _ _ _)
237 | JSIdentifier _ "$foreign" <- f
238 = pure ForeignReexport
239 exportType (JSIdentifier _ s) = pure (RegularExport s)
240 exportType _ = err UnsupportedExport
242 extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
244 toModuleElement other = pure (Other other)
246-- Get a list of all the exported identifiers from a foreign module.
247--
248-- TODO: what if we assign to exports.foo and then later assign to
249-- module.exports (presumably overwriting exports.foo)?
250getExportedIdentifiers :: (MonadError ErrorMessage m)
251 => String
252 -> JSAST
253 -> m [String]
254getExportedIdentifiers mname top
255 | JSAstProgram stmts _ <- top = concat <$> traverse go stmts
256 | otherwise = err InvalidTopLevel
257 where
258 err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
260 go stmt
261 | Just props <- matchExportsAssignment stmt
262 = traverse toIdent (trailingCommaList props)
263 | Just (True, name, _) <- matchMember stmt
264 = pure [name]
265 | otherwise
266 = pure []
268 toIdent (JSPropertyNameandValue name _ [_]) =
269 extractLabel' name
270 toIdent _ =
271 err UnsupportedExport
273 extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
275-- Matches JS statements like this:
276-- var ModuleName = require("file");
277matchRequire :: S.Set String
278 -> ModuleIdentifier
279 -> JSStatement
280 -> Maybe (String, Either String ModuleIdentifier)
281matchRequire mids mid stmt
282 | JSVariable _ jsInit _ <- stmt
283 , [JSVarInitExpression var varInit] <- commaList jsInit
284 , JSIdentifier _ importName <- var
285 , JSVarInit _ jsInitEx <- varInit
286 , JSMemberExpression req _ argsE _ <- jsInitEx
287 , JSIdentifier _ "require" <- req
288 , [ Just importPath ] <- map fromStringLiteral (commaList argsE)
289 , importPath' <- checkImportPath importPath mid mids
290 = Just (importName, importPath')
291 | otherwise
292 = Nothing
294-- Matches JS member declarations.
295matchMember :: JSStatement -> Maybe (Bool, String, JSExpression)
296matchMember stmt
297 -- var foo = expr;
298 | JSVariable _ jsInit _ <- stmt
299 , [JSVarInitExpression var varInit] <- commaList jsInit
300 , JSIdentifier _ name <- var
301 , JSVarInit _ decl <- varInit
302 = Just (False, name, decl)
303 -- exports.foo = expr; exports["foo"] = expr;
304 | JSAssignStatement e (JSAssign _) decl _ <- stmt
305 , Just name <- accessor e
306 = Just (True, name, decl)
307 | otherwise
308 = Nothing
309 where
310 accessor :: JSExpression -> Maybe String
311 accessor (JSMemberDot exports _ nm)
312 | JSIdentifier _ "exports" <- exports
313 , JSIdentifier _ name <- nm
314 = Just name
315 accessor (JSMemberSquare exports _ nm _)
316 | JSIdentifier _ "exports" <- exports
317 , Just name <- fromStringLiteral nm
318 = Just name
319 accessor _ = Nothing
321-- Matches assignments to module.exports, like this:
322-- module.exports = { ... }
323matchExportsAssignment :: JSStatement -> Maybe JSObjectPropertyList
324matchExportsAssignment stmt
325 | JSAssignStatement e (JSAssign _) decl _ <- stmt
326 , JSMemberDot module' _ exports <- e
327 , JSIdentifier _ "module" <- module'
328 , JSIdentifier _ "exports" <- exports
329 , JSObjectLiteral _ props _ <- decl
330 = Just props
331 | otherwise
332 = Nothing
334extractLabel :: JSPropertyName -> Maybe String
335extractLabel (JSPropertyString _ nm) = Just (trimStringQuotes nm)
336extractLabel (JSPropertyIdent _ nm) = Just nm
337extractLabel _ = Nothing
339-- | Eliminate unused code based on the specified entry point set.
340compile :: [Module] -> [ModuleIdentifier] -> [Module]
341compile modules [] = modules
342compile modules entryPoints = filteredModules
343 where
344 (graph, _, vertexFor) = graphFromEdges verts
346 -- | The vertex set
347 verts :: [(ModuleElement, Key, [Key])]
348 verts = do
349 Module mid els <- modules
350 concatMap (toVertices mid) els
351 where
352 -- | Create a set of vertices for a module element.
353 --
354 -- Some special cases worth commenting on:
355 --
356 -- 1) Regular exports which simply export their own name do not count as dependencies.
357 -- Regular exports which rename and reexport an operator do count, however.
358 --
359 -- 2) Require statements don't contribute towards dependencies, since they effectively get
360 -- inlined wherever they are used inside other module elements.
361 toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])]
362 toVertices p m@(Member _ _ nm _ deps) = [(m, (p, nm), deps)]
363 toVertices p m@(ExportsList exps) = mapMaybe toVertex exps
364 where
365 toVertex (ForeignReexport, nm, _, ks) = Just (m, (p, nm), ks)
366 toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks)
367 toVertex _ = Nothing
368 toVertices _ _ = []
370 -- | The set of vertices whose connected components we are interested in keeping.
371 entryPointVertices :: [Vertex]
372 entryPointVertices = catMaybes $ do
373 (_, k@(mid, _), _) <- verts
374 guard $ mid `elem` entryPoints
375 return (vertexFor k)
377 -- | The set of vertices reachable from an entry point
378 reachableSet :: S.Set Vertex
379 reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)
381 filteredModules :: [Module]
382 filteredModules = map filterUsed modules
383 where
384 filterUsed :: Module -> Module
385 filterUsed (Module mid ds) = Module mid (map filterExports (go ds))
386 where
387 go :: [ModuleElement] -> [ModuleElement]
388 go [] = []
389 go (d : rest)
390 | not (isDeclUsed d) = go rest
391 | otherwise = d : go rest
393 -- | Filter out the exports for members which aren't used.
394 filterExports :: ModuleElement -> ModuleElement
395 filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps)
396 filterExports me = me
398 isDeclUsed :: ModuleElement -> Bool
399 isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)
400 isDeclUsed _ = True
402 isKeyUsed :: Key -> Bool
403 isKeyUsed k
404 | Just me <- vertexFor k = me `S.member` reachableSet
405 | otherwise = False
407-- | Topologically sort the module dependency graph, so that when we generate code, modules can be
408-- defined in the right order.
409sortModules :: [Module] -> [Module]
410sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph))
411 where
412 (graph, nodeFor, _) = graphFromEdges $ do
413 m@(Module mid els) <- modules
414 return (m, mid, mapMaybe getKey els)
416 getKey :: ModuleElement -> Maybe ModuleIdentifier
417 getKey (Require _ _ (Right mi)) = Just mi
418 getKey _ = Nothing
420-- | A module is empty if it contains no exported members (in other words,
421-- if the only things left after dead code elimination are module imports and
422-- "other" foreign code).
423--
424-- If a module is empty, we don't want to generate code for it.
425isModuleEmpty :: Module -> Bool
426isModuleEmpty (Module _ els) = all isElementEmpty els
427 where
428 isElementEmpty :: ModuleElement -> Bool
429 isElementEmpty (ExportsList exps) = null exps
430 isElementEmpty Require{} = True
431 isElementEmpty (Other _) = True
432 isElementEmpty _ = False
434-- | Generate code for a set of modules, including a call to main().
435--
436-- Modules get defined on the global PS object, as follows:
437--
438-- var PS = { };
439-- (function(exports) {
440-- ...
441-- })(PS["Module.Name"] = PS["Module.Name"] || {});
442--
443-- In particular, a module and its foreign imports share the same namespace inside PS.
444-- This saves us from having to generate unique names for a module and its foreign imports,
445-- and is safe since a module shares a namespace with its foreign imports in PureScript as well
446-- (so there is no way to have overlaps in code generated by psc).
447codeGen :: Maybe String -- ^ main module
448 -> String -- ^ namespace
449 -> [Module] -- ^ input modules
450 -> String
451codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (prelude : concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule) JSNoAnnot)
452 where
453 moduleToJS :: Module -> [JSStatement]
454 moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
455 where
456 declToJS :: ModuleElement -> [JSStatement]
457 declToJS (Member n _ _ _ _) = [n]
458 declToJS (Other n) = [n]
459 declToJS (Require _ nm req) =
460 [
461 JSVariable lfsp
462 (cList [
463 JSVarInitExpression (JSIdentifier sp nm)
464 (JSVarInit sp $ either require (moduleReference sp . moduleName) req )
465 ]) (JSSemi JSNoAnnot)
466 ]
467 declToJS (ExportsList exps) = map toExport exps
469 where
470 toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement
471 toExport (_, nm, val, _) =
472 JSAssignStatement
473 (JSMemberSquare (JSIdentifier lfsp "exports") JSNoAnnot
474 (str nm) JSNoAnnot)
475 (JSAssign sp)
476 val
477 (JSSemi JSNoAnnot)
479 -- comma lists are reverse-consed
480 cList :: [a] -> JSCommaList a
481 cList [] = JSLNil
482 cList [x] = JSLOne x
483 cList l = go $ reverse l
484 where
485 go [x] = JSLOne x
486 go (h:t)= JSLCons (go t) JSNoAnnot h
487 go [] = error "Invalid case in comma-list"
489 indent :: [JSStatement] -> [JSStatement]
490 indent = everywhere (mkT squash)
491 where
492 squash JSNoAnnot = (JSAnnot (TokenPn 0 0 2) [])
493 squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)
495 splat (CommentA pos s) = CommentA (keepCol pos) s
496 splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
497 splat ann = ann
499 keepCol (TokenPn _ _ c) = TokenPn 0 0 (if c >= 0 then c + 2 else 2)
501 prelude :: JSStatement
502 prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by psc-bundle " ++ showVersion Paths.version
503 , WhiteSpace tokenPosnEmpty "\n" ])
504 (cList [
505 JSVarInitExpression (JSIdentifier sp optionsNamespace)
506 (JSVarInit sp (emptyObj sp))
507 ]) (JSSemi JSNoAnnot)
509 require :: String -> JSExpression
510 require mn =
511 JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot (cList [ str mn ]) JSNoAnnot
513 moduleReference :: JSAnnot -> String -> JSExpression
514 moduleReference a mn =
515 JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot
516 (str mn) JSNoAnnot
518 str :: String -> JSExpression
519 str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\""
522 emptyObj :: JSAnnot -> JSExpression
523 emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot
525 wrap :: String -> [JSStatement] -> [JSStatement]
526 wrap mn ds =
527 [
528 JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot
529 (JSLOne (JSIdentName JSNoAnnot "exports")) JSNoAnnot
530 (JSBlock sp (lfHead ds) lf)) -- \n not quite in right place
531 JSNoAnnot)
532 JSNoAnnot
533 (JSLOne (JSAssignExpression (moduleReference JSNoAnnot mn) (JSAssign sp)
534 (JSExpressionBinary (moduleReference sp mn) (JSBinOpOr sp) (emptyObj sp))))
535 JSNoAnnot
536 (JSSemi JSNoAnnot)
537 ]
538 where
539 lfHead (h:t) = (addAnn (WhiteSpace tokenPosnEmpty "\n ") h) : t
540 lfHead x = x
542 addAnn :: CommentAnnotation -> JSStatement -> JSStatement
543 addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) =
544 (JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot))
545 addAnn _ x = x
547 appendAnn a JSNoAnnot = (JSAnnot tokenPosnEmpty [a])
548 appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])
550 runMain :: String -> [JSStatement]
551 runMain mn =
552 [JSMethodCall
553 (JSMemberDot (moduleReference lf mn) JSNoAnnot
554 (JSIdentifier JSNoAnnot "main"))
555 JSNoAnnot (cList []) JSNoAnnot (JSSemi JSNoAnnot)]
557 lf :: JSAnnot
558 lf = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
561 lfsp :: JSAnnot
562 lfsp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ]
564 sp :: JSAnnot
565 sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
567-- | The bundling function.
568-- This function performs dead code elimination, filters empty modules
569-- and generates and prints the final Javascript bundle.
570bundle :: (MonadError ErrorMessage m)
571 => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
572 -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
573 -> Maybe String -- ^ An optional main module.
574 -> String -- ^ The namespace (e.g. PS).
575 -> m String
576bundle inputStrs entryPoints mainModule namespace = do
577 input <- forM inputStrs $ \(ident, js) -> do
578 ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident)
579 return (ident, ast)
581 let mids = S.fromList (map (moduleName . fst) input)
583 modules <- traverse (fmap withDeps . uncurry (toModule mids)) input
585 let compiled = compile modules entryPoints
586 sorted = sortModules (filter (not . isModuleEmpty) compiled)
588 return (codeGen mainModule namespace sorted)