git.iko.soy/rowtype-yoga/purescript-native
on a42b939 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Bundle.hs
548 lines 21 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
46import Language.JavaScript.Parser.AST
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, 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 JSStatement String (Either String ModuleIdentifier)
100 | Member JSStatement Bool String JSExpression [Key]
101 | ExportsList [(ExportType, String, JSExpression, [Key])]
102 | Other JSStatement
103 deriving (Show)
105-- | A module is just a list of elements of the types listed above.
106data Module = Module ModuleIdentifier [ModuleElement] deriving (Show)
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-- | Calculate the ModuleIdentifier which a require(...) statement imports.
136checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
137checkImportPath _ "./foreign" m _ =
138 Right (ModuleIdentifier (moduleName m) Foreign)
139checkImportPath requirePath name _ names
140 | Just name' <- stripPrefix (fromMaybe "../" requirePath) name
141 , name' `S.member` names = Right (ModuleIdentifier name' Regular)
142checkImportPath _ name _ _ = Left name
144-- | Compute the dependencies of all elements in a module, and add them to the tree.
145--
146-- Members and exports can have dependencies. A dependency is of one of the following forms:
147--
148-- 1) module.name or member["name"]
149--
150-- where module was imported using
151--
152-- var module = require("Module.Name");
153--
154-- 2) name
155--
156-- where name is the name of a member defined in the current module.
157withDeps :: Module -> Module
158withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
159 where
160 -- | Collects all modules which are imported, so that we can identify dependencies of the first type.
161 imports :: [(String, ModuleIdentifier)]
162 imports = mapMaybe toImport es
163 where
164 toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)
165 toImport (Require _ nm (Right mid)) = Just (nm, mid)
166 toImport _ = Nothing
168 -- | Collects all member names in scope, so that we can identify dependencies of the second type.
169 boundNames :: [String]
170 boundNames = mapMaybe toBoundName es
171 where
172 toBoundName :: ModuleElement -> Maybe String
173 toBoundName (Member _ _ nm _ _) = Just nm
174 toBoundName _ = Nothing
176 -- | Calculate dependencies and add them to the current element.
177 expandDeps :: ModuleElement -> ModuleElement
178 expandDeps (Member n f nm decl _) = Member n f nm decl (nub $ dependencies modulePath decl)
179 expandDeps (ExportsList exps) = ExportsList (map expand exps)
180 where
181 expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
182 expandDeps other = other
184 dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)]
185 dependencies m = everything (++) (mkQ [] toReference)
186 where
187 toReference :: JSExpression -> [(ModuleIdentifier, String)]
188 toReference (JSMemberDot mn _ nm)
189 | JSIdentifier _ mn' <- mn
190 , JSIdentifier _ nm' <- nm
191 , Just mid <- lookup mn' imports
192 = [(mid, nm')]
193 toReference (JSMemberSquare mn _ nm _)
194 | JSIdentifier _ mn' <- mn
195 , Just nm' <- fromStringLiteral nm
196 , Just mid <- lookup mn' imports
197 = [(mid, nm')]
198 toReference (JSIdentifier _ nm)
199 | nm `elem` boundNames
200 = [(m, nm)]
201 toReference _ = []
203-- String literals include the quote chars
204fromStringLiteral :: JSExpression -> Maybe String
205fromStringLiteral (JSStringLiteral _ str) = Just $ trimStringQuotes str
206fromStringLiteral _ = Nothing
208trimStringQuotes :: String -> String
209trimStringQuotes str = reverse $ drop 1 $ reverse $ drop 1 $ str
211commaList :: JSCommaList a -> [a]
212commaList JSLNil = []
213commaList (JSLOne x) = [x]
214commaList (JSLCons l _ x) = commaList l ++ [x]
216trailingCommaList :: JSCommaTrailingList a -> [a]
217trailingCommaList (JSCTLComma l _) = commaList l
218trailingCommaList (JSCTLNone l) = commaList l
220-- | Attempt to create a Module from a Javascript AST.
221--
222-- Each type of module element is matched using pattern guards, and everything else is bundled into the
223-- Other constructor.
224toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSAST -> m Module
225toModule requirePath mids mid top
226 | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts
227 | otherwise = err InvalidTopLevel
228 where
229 err = throwError . ErrorInModule mid
231 toModuleElement :: JSStatement -> m ModuleElement
232 -- var ModuleName = require("file");
233 toModuleElement stmt
234 | JSVariable _ jsInit _ <- stmt
235 , [JSVarInitExpression var varInit] <- commaList jsInit
236 , JSIdentifier _ importName <- var
237 , JSVarInit _ jsInitEx <- varInit
238 , JSMemberExpression req _ argsE _ <- jsInitEx
239 , JSIdentifier _ "require" <- req
240 , [ Just importPath ] <- map fromStringLiteral (commaList argsE)
241 , importPath' <- checkImportPath requirePath importPath mid mids
242 = pure (Require stmt importName importPath')
243 -- var foo = expr;
244 toModuleElement stmt
245 | JSVariable _ jsInit _ <- stmt
246 , [JSVarInitExpression var varInit] <- commaList jsInit
247 , JSIdentifier _ name <- var
248 , JSVarInit _ decl <- varInit
249 = pure (Member stmt False name decl [])
250 -- exports.foo = expr; exports["foo"] = expr;
251 toModuleElement stmt
252 | JSAssignStatement e (JSAssign _) decl _ <- stmt
253 , Just name <- accessor e
254 = pure (Member stmt True name decl [])
255 where
256 accessor :: JSExpression -> Maybe String
257 accessor (JSMemberDot exports _ nm)
258 | JSIdentifier _ "exports" <- exports
259 , JSIdentifier _ name <- nm
260 = Just name
261 accessor (JSMemberSquare exports _ nm _)
262 | JSIdentifier _ "exports" <- exports
263 , Just name <- fromStringLiteral nm
264 = Just name
265 accessor _ = Nothing
266 -- module.exports = { ... }
267 toModuleElement stmt
268 | JSAssignStatement e (JSAssign _) decl _ <- stmt
269 , JSMemberDot module' _ exports <- e
270 , JSIdentifier _ "module" <- module'
271 , JSIdentifier _ "exports" <- exports
272 , JSObjectLiteral _ props _ <- decl
273 = (ExportsList <$> traverse toExport (trailingCommaList props))
274 where
275 toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])
276 toExport (JSPropertyNameandValue name _ [val]) =
277 (,,val,[]) <$> exportType val
278 <*> extractLabel name
279 toExport _ = err UnsupportedExport
281 exportType :: JSExpression -> m ExportType
282 exportType (JSMemberDot f _ _)
283 | JSIdentifier _ "$foreign" <- f
284 = pure ForeignReexport
285 exportType (JSMemberSquare f _ _ _)
286 | JSIdentifier _ "$foreign" <- f
287 = pure ForeignReexport
288 exportType (JSIdentifier _ s) = pure (RegularExport s)
289 exportType _ = err UnsupportedExport
290--
291 extractLabel :: JSPropertyName -> m String
292 extractLabel (JSPropertyString _ nm) = pure (trimStringQuotes nm)
293 extractLabel (JSPropertyIdent _ nm) = pure nm
294 extractLabel _ = err UnsupportedExport
296 toModuleElement other = pure (Other other)
298-- | Eliminate unused code based on the specified entry point set.
299compile :: [Module] -> [ModuleIdentifier] -> [Module]
300compile modules [] = modules
301compile modules entryPoints = filteredModules
302 where
303 (graph, _, vertexFor) = graphFromEdges verts
305 -- | The vertex set
306 verts :: [(ModuleElement, Key, [Key])]
307 verts = do
308 Module mid els <- modules
309 concatMap (toVertices mid) els
310 where
311 -- | Create a set of vertices for a module element.
312 --
313 -- Some special cases worth commenting on:
314 --
315 -- 1) Regular exports which simply export their own name do not count as dependencies.
316 -- Regular exports which rename and reexport an operator do count, however.
317 --
318 -- 2) Require statements don't contribute towards dependencies, since they effectively get
319 -- inlined wherever they are used inside other module elements.
320 toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])]
321 toVertices p m@(Member _ _ nm _ deps) = [(m, (p, nm), deps)]
322 toVertices p m@(ExportsList exps) = mapMaybe toVertex exps
323 where
324 toVertex (ForeignReexport, nm, _, ks) = Just (m, (p, nm), ks)
325 toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks)
326 toVertex _ = Nothing
327 toVertices _ _ = []
329 -- | The set of vertices whose connected components we are interested in keeping.
330 entryPointVertices :: [Vertex]
331 entryPointVertices = catMaybes $ do
332 (_, k@(mid, _), _) <- verts
333 guard $ mid `elem` entryPoints
334 return (vertexFor k)
336 -- | The set of vertices reachable from an entry point
337 reachableSet :: S.Set Vertex
338 reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)
340 filteredModules :: [Module]
341 filteredModules = map filterUsed modules
342 where
343 filterUsed :: Module -> Module
344 filterUsed (Module mid ds) = Module mid (map filterExports (go ds))
345 where
346 go :: [ModuleElement] -> [ModuleElement]
347 go [] = []
348 go (d : rest)
349 | not (isDeclUsed d) = go rest
350 | otherwise = d : go rest
352 -- | Filter out the exports for members which aren't used.
353 filterExports :: ModuleElement -> ModuleElement
354 filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps)
355 filterExports me = me
357 isDeclUsed :: ModuleElement -> Bool
358 isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)
359 isDeclUsed _ = True
361 isKeyUsed :: Key -> Bool
362 isKeyUsed k
363 | Just me <- vertexFor k = me `S.member` reachableSet
364 | otherwise = False
366-- | Topologically sort the module dependency graph, so that when we generate code, modules can be
367-- defined in the right order.
368sortModules :: [Module] -> [Module]
369sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph))
370 where
371 (graph, nodeFor, _) = graphFromEdges $ do
372 m@(Module mid els) <- modules
373 return (m, mid, mapMaybe getKey els)
375 getKey :: ModuleElement -> Maybe ModuleIdentifier
376 getKey (Require _ _ (Right mi)) = Just mi
377 getKey _ = Nothing
379-- | A module is empty if it contains no exported members (in other words,
380-- if the only things left after dead code elimination are module imports and
381-- "other" foreign code).
382--
383-- If a module is empty, we don't want to generate code for it.
384isModuleEmpty :: Module -> Bool
385isModuleEmpty (Module _ els) = all isElementEmpty els
386 where
387 isElementEmpty :: ModuleElement -> Bool
388 isElementEmpty (ExportsList exps) = null exps
389 isElementEmpty Require{} = True
390 isElementEmpty (Other _) = True
391 isElementEmpty _ = False
393-- | Generate code for a set of modules, including a call to main().
394--
395-- Modules get defined on the global PS object, as follows:
396--
397-- var PS = { };
398-- (function(exports) {
399-- ...
400-- })(PS["Module.Name"] = PS["Module.Name"] || {});
401--
402-- In particular, a module and its foreign imports share the same namespace inside PS.
403-- This saves us from having to generate unique names for a module and its foreign imports,
404-- and is safe since a module shares a namespace with its foreign imports in PureScript as well
405-- (so there is no way to have overlaps in code generated by psc).
406codeGen :: Maybe String -- ^ main module
407 -> String -- ^ namespace
408 -> [Module] -- ^ input modules
409 -> String
410codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (prelude : concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule) JSNoAnnot)
411 where
412 moduleToJS :: Module -> [JSStatement]
413 moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
414 where
415 declToJS :: ModuleElement -> [JSStatement]
416 declToJS (Member n _ _ _ _) = [n]
417 declToJS (Other n) = [n]
418 declToJS (Require _ nm req) =
419 [
420 JSVariable lfsp
421 (cList [
422 JSVarInitExpression (JSIdentifier sp nm)
423 (JSVarInit sp $ either require (moduleReference sp . moduleName) req )
424 ]) (JSSemi JSNoAnnot)
425 ]
426 declToJS (ExportsList exps) = map toExport exps
428 where
429 toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement
430 toExport (_, nm, val, _) =
431 JSAssignStatement
432 (JSMemberSquare (JSIdentifier lfsp "exports") JSNoAnnot
433 (str nm) JSNoAnnot)
434 (JSAssign sp)
435 val
436 (JSSemi JSNoAnnot)
438 -- comma lists are reverse-consed
439 cList :: [a] -> JSCommaList a
440 cList [] = JSLNil
441 cList [x] = JSLOne x
442 cList l = go $ reverse l
443 where
444 go [x] = JSLOne x
445 go (h:t)= JSLCons (go t) JSNoAnnot h
446 go [] = error "Invalid case in comma-list"
448 indent :: [JSStatement] -> [JSStatement]
449 indent = everywhere (mkT squash)
450 where
451 squash JSNoAnnot = (JSAnnot (TokenPn 0 0 2) [])
452 squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)
454 splat (CommentA pos s) = CommentA (keepCol pos) s
455 splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
456 splat ann = ann
458 keepCol (TokenPn _ _ c) = TokenPn 0 0 (if c >= 0 then c + 2 else 2)
460 prelude :: JSStatement
461 prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by psc-bundle " ++ showVersion Paths.version
462 , WhiteSpace tokenPosnEmpty "\n" ])
463 (cList [
464 JSVarInitExpression (JSIdentifier sp optionsNamespace)
465 (JSVarInit sp (emptyObj sp))
466 ]) (JSSemi JSNoAnnot)
468 require :: String -> JSExpression
469 require mn =
470 JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot (cList [ str mn ]) JSNoAnnot
472 moduleReference :: JSAnnot -> String -> JSExpression
473 moduleReference a mn =
474 JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot
475 (str mn) JSNoAnnot
477 str :: String -> JSExpression
478 str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\""
481 emptyObj :: JSAnnot -> JSExpression
482 emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot
484 wrap :: String -> [JSStatement] -> [JSStatement]
485 wrap mn ds =
486 [
487 JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot
488 (JSLOne (JSIdentName JSNoAnnot "exports")) JSNoAnnot
489 (JSBlock sp (lfHead ds) lf)) -- \n not quite in right place
490 JSNoAnnot)
491 JSNoAnnot
492 (JSLOne (JSAssignExpression (moduleReference JSNoAnnot mn) (JSAssign sp)
493 (JSExpressionBinary (moduleReference sp mn) (JSBinOpOr sp) (emptyObj sp))))
494 JSNoAnnot
495 (JSSemi JSNoAnnot)
496 ]
497 where
498 lfHead (h:t) = (addAnn (WhiteSpace tokenPosnEmpty "\n ") h) : t
499 lfHead x = x
501 addAnn :: CommentAnnotation -> JSStatement -> JSStatement
502 addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) =
503 (JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot))
504 addAnn _ x = x
506 appendAnn a JSNoAnnot = (JSAnnot tokenPosnEmpty [a])
507 appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])
509 runMain :: String -> [JSStatement]
510 runMain mn =
511 [JSMethodCall
512 (JSMemberDot (moduleReference lf mn) JSNoAnnot
513 (JSIdentifier JSNoAnnot "main"))
514 JSNoAnnot (cList []) JSNoAnnot (JSSemi JSNoAnnot)]
516 lf :: JSAnnot
517 lf = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
520 lfsp :: JSAnnot
521 lfsp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ]
523 sp :: JSAnnot
524 sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
526-- | The bundling function.
527-- This function performs dead code elimination, filters empty modules
528-- and generates and prints the final Javascript bundle.
529bundle :: (MonadError ErrorMessage m)
530 => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
531 -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
532 -> Maybe String -- ^ An optional main module.
533 -> String -- ^ The namespace (e.g. PS).
534 -> Maybe FilePath -- ^ The require path prefix
535 -> m String
536bundle inputStrs entryPoints mainModule namespace requirePath = 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 <- traverse (fmap withDeps . uncurry (toModule requirePath mids)) input
545 let compiled = compile modules entryPoints
546 sorted = sortModules (filter (not . isModuleEmpty) compiled)
548 return (codeGen mainModule namespace sorted)