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