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