git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1245 from wuzzeb/master
2e6b3eePhil Freeman
psc-bundle/Main.hs+10−493
compare with golang
unifiedsplit
@@ -20,15 +20,9 @@
20
20
21module Main (main) where
21module Main (main) where
22
22
23−import Data.List (nub)
24−import Data.Maybe (mapMaybe, catMaybes)
25import Data.Traversable (for)
23import Data.Traversable (for)
26−import Data.Generics (everything, everywhere, mkQ, mkT)
27−import Data.Graph
28import Data.Version (showVersion)
24import Data.Version (showVersion)
29
25
30−import qualified Data.Set as S
31−
32import Control.Applicative
26import Control.Applicative
33import Control.Monad
27import Control.Monad
34import Control.Monad.Error.Class
28import Control.Monad.Error.Class
@@ -41,66 +35,12 @@ import System.Exit (exitFailure)
41import System.IO (stderr, hPutStrLn)
35import System.IO (stderr, hPutStrLn)
42import System.Directory (createDirectoryIfMissing)
36import System.Directory (createDirectoryIfMissing)
43
37
44−import Language.JavaScript.Parser
38+import Language.PureScript.Bundle
45
39
46import Options.Applicative as Opts
40import Options.Applicative as Opts
47
41
48import qualified Paths_purescript as Paths
42import qualified Paths_purescript as Paths
49
43
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.
52−data ErrorMessage
53− = UnsupportedModulePath String
54− | InvalidTopLevel
55− | UnableToParseModule
56− | UnsupportedExport
57− | ErrorInFile FilePath ErrorMessage
58− deriving Show
59−
60−-- | Modules are either "regular modules" (i.e. those generated by psc-make) or foreign modules.
61−data ModuleType
62− = Regular
63− | Foreign
64− deriving (Show, Eq, Ord)
65−
66−-- | A module is identified by its module name and its type.
67−data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)
68−
69−moduleName :: ModuleIdentifier -> String
70−moduleName (ModuleIdentifier name _) = name
71−
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.
74−type Key = (ModuleIdentifier, String)
75−
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.
80−data ExportType
81− = RegularExport String
82− | ForeignReexport
83− deriving (Show, Eq, Ord)
84−
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.
94−data 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
100−
101−-- | A module is just a list of elements of the types listed above.
102−data Module = Module ModuleIdentifier [ModuleElement] deriving Show
103−
104-- | Command line options.
44-- | Command line options.
105data Options = Options
45data Options = Options
106 { optionsInputFiles :: [FilePath]
46 { optionsInputFiles :: [FilePath]
@@ -110,33 +50,6 @@ data Options = Options
110 , optionsNamespace :: String
50 , optionsNamespace :: String
111 } deriving Show
51 } deriving Show
112
52
113−-- | Prepare an error message for consumption by humans.
114−printErrorMessage :: ErrorMessage -> [String]
115−printErrorMessage (UnsupportedModulePath s) =
116− [ "A CommonJS module has an unsupported name (" ++ show s ++ ")."
117− , "The following file names are supported:"
118− , " 1) index.js (psc-make native modules)"
119− , " 2) foreign.js (psc-make foreign modules)"
120− ]
121−printErrorMessage InvalidTopLevel =
122− [ "Expected a list of source elements at the top level." ]
123−printErrorMessage UnableToParseModule =
124− [ "The module could not be parsed." ]
125−printErrorMessage UnsupportedExport =
126− [ "An export was unsupported. Exports can be defined in one of two ways: "
127− , " 1) exports.name = ..."
128− , " 2) exports = { ... }"
129− ]
130−printErrorMessage (ErrorInFile filename e) =
131− ("Error in file " ++ show filename ++ ":")
132− : ""
133− : map (" " ++) (printErrorMessage e)
134−
135−-- | Unpack the node inside a JSNode. This is useful when pattern matching.
136−node :: JSNode -> Node
137−node (NN n) = n
138−node (NT n _ _) = n
139−
140-- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.
53-- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.
141guessModuleIdentifier :: (Applicative m, MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier
54guessModuleIdentifier :: (Applicative m, MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier
142guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> (guessModuleType (takeFileName filename))
55guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> (guessModuleType (takeFileName filename))
@@ -145,419 +58,23 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f
145 guessModuleType "foreign.js" = pure Foreign
58 guessModuleType "foreign.js" = pure Foreign
146 guessModuleType name = throwError $ UnsupportedModulePath name
59 guessModuleType name = throwError $ UnsupportedModulePath name
147
60
148−-- | Calculate the ModuleIdentifier which a require(...) statement imports.
149−checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier
150−checkImportPath "./foreign" m _ =
151− Just (ModuleIdentifier (moduleName m) Foreign)
152−checkImportPath name _ names
153− | name `S.member` names = Just (ModuleIdentifier name Regular)
154−checkImportPath _ _ _ = Nothing
155−
156−-- | Compute the dependencies of all elements in a module, and add them to the tree.
157−--
158−-- Members and exports can have dependencies. A dependency is of one of the following forms:
159−--
160−-- 1) module.name or member["name"]
161−--
162−-- where module was imported using
163−--
164−-- var module = require("Module.Name");
165−--
166−-- 2) name
167−--
168−-- where name is the name of a member defined in the current module.
169−withDeps :: Module -> Module
170−withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
171− where
172− -- | Collects all modules which are imported, so that we can identify dependencies of the first type.
173− imports :: [(String, ModuleIdentifier)]
174− imports = mapMaybe toImport es
175− where
176− toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)
177− toImport (Require _ nm mid) = Just (nm, mid)
178− toImport _ = Nothing
179−
180− -- | Collects all member names in scope, so that we can identify dependencies of the second type.
181− boundNames :: [String]
182− boundNames = mapMaybe toBoundName es
183− where
184− toBoundName :: ModuleElement -> Maybe String
185− toBoundName (Member _ _ nm _ _) = Just nm
186− toBoundName _ = Nothing
187−
188− -- | Calculate dependencies and add them to the current element.
189− expandDeps :: ModuleElement -> ModuleElement
190− expandDeps (Member n f nm decl _) = Member n f nm decl (nub (concatMap (dependencies modulePath) decl))
191− expandDeps (ExportsList exps) = ExportsList (map expand exps)
192− where
193− expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
194− expandDeps other = other
195−
196− dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)]
197− dependencies m = everything (++) (mkQ [] toReference)
198− where
199− toReference :: Node -> [(ModuleIdentifier, String)]
200− toReference (JSMemberDot [ mn ] _ nm)
201− | JSIdentifier mn' <- node mn
202− , JSIdentifier nm' <- node nm
203− , Just mid <- lookup mn' imports
204− = [(mid, nm')]
205− toReference (JSMemberSquare [ mn ] _ nm _)
206− | JSIdentifier mn' <- node mn
207− , JSExpression [ s ] <- node nm
208− , JSStringLiteral _ nm' <- node s
209− , Just mid <- lookup mn' imports
210− = [(mid, nm')]
211− toReference (JSIdentifier nm)
212− | nm `elem` boundNames
213− = [(m, nm)]
214− toReference _ = []
215−
216−-- | Attempt to create a Module from a Javascript AST.
217−--
218−-- Each type of module element is matched using pattern guards, and everything else is bundled into the
219−-- Other constructor.
220−toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSNode -> m Module
221−toModule mids mid top
222− | JSSourceElementsTop ns <- node top = Module mid <$> mapM toModuleElement ns
223− | otherwise = throwError InvalidTopLevel
224− where
225− toModuleElement :: JSNode -> m ModuleElement
226− toModuleElement n
227− | JSVariables var [ varIntro ] _ <- node n
228− , JSLiteral "var" <- node var
229− , JSVarDecl impN [ eq, req, impP ] <- node varIntro
230− , JSIdentifier importName <- node impN
231− , JSLiteral "=" <- node eq
232− , JSIdentifier "require" <- node req
233− , JSArguments _ [ impS ] _ <- node impP
234− , JSStringLiteral _ importPath <- node impS
235− , Just importPath' <- checkImportPath importPath mid mids
236− = pure (Require n importName importPath')
237− toModuleElement n
238− | JSVariables var [ varIntro ] _ <- node n
239− , JSLiteral "var" <- node var
240− , JSVarDecl declN (eq : decl) <- node varIntro
241− , JSIdentifier name <- node declN
242− , JSLiteral "=" <- node eq
243− = pure (Member n False name decl [])
244− toModuleElement n
245− | JSExpression (e : op : decl) <- node n
246− , Just name <- accessor (node e)
247− , JSOperator eq <- node op
248− , JSLiteral "=" <- node eq
249− = pure (Member n True name decl [])
250− where
251− accessor :: Node -> Maybe String
252− accessor (JSMemberDot [ exports ] _ nm)
253− | JSIdentifier "exports" <- node exports
254− , JSIdentifier name <- node nm
255− = Just name
256− accessor (JSMemberSquare [ exports ] _ nm _)
257− | JSIdentifier "exports" <- node exports
258− , JSExpression [e] <- node nm
259− , JSStringLiteral _ name <- node e
260− = Just name
261− accessor _ = Nothing
262− toModuleElement n
263− | JSExpression (mnExp : op : obj: _) <- node n
264− , JSMemberDot [ mn ] _ e <- node mnExp
265− , JSIdentifier "module" <- node mn
266− , JSIdentifier "exports" <- node e
267− , JSOperator eq <- node op
268− , JSLiteral "=" <- node eq
269− , JSObjectLiteral _ props _ <- node obj
270− = ExportsList <$> mapM toExport (filter (not . isSeparator) (map node props))
271− where
272− toExport :: Node -> m (ExportType, String, JSNode, [Key])
273− toExport (JSPropertyNameandValue name _ [val] ) =
274− (,,val,[]) <$> exportType (node val)
275− <*> extractLabel (node name)
276− toExport _ = throwError UnsupportedExport
277−
278− exportType :: Node -> m ExportType
279− exportType (JSMemberDot [f] _ _)
280− | JSIdentifier "$foreign" <- node f
281− = pure ForeignReexport
282− exportType (JSMemberSquare [f] _ _ _)
283− | JSIdentifier "$foreign" <- node f
284− = pure ForeignReexport
285− exportType (JSIdentifier s) = pure (RegularExport s)
286− exportType _ = throwError UnsupportedExport
287−
288− extractLabel :: Node -> m String
289− extractLabel (JSStringLiteral _ nm) = pure nm
290− extractLabel (JSIdentifier nm) = pure nm
291− extractLabel _ = throwError UnsupportedExport
292−
293− isSeparator :: Node -> Bool
294− isSeparator (JSLiteral ",") = True
295− isSeparator _ = False
296− toModuleElement other = pure (Other other)
297−
298−-- | Eliminate unused code based on the specified entry point set.
299−compile :: [Module] -> [ModuleIdentifier] -> [Module]
300−compile modules [] = modules
301−compile modules entryPoints = filteredModules
302− where
303− (graph, _, vertexFor) = graphFromEdges verts
304−
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 _ _ = []
328−
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)
335−
336− -- | The set of vertices reachable from an entry point
337− reachableSet :: S.Set Vertex
338− reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)
339−
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 : Other semi : rest)
349− | JSLiteral ";" <- node semi
350− , not (isDeclUsed d)
351− = go rest
352− go (d : rest)
353− | not (isDeclUsed d) = go rest
354− | otherwise = d : go rest
355−
356− -- | Filter out the exports for members which aren't used.
357− filterExports :: ModuleElement -> ModuleElement
358− filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps)
359− filterExports me = me
360−
361− isDeclUsed :: ModuleElement -> Bool
362− isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)
363− isDeclUsed _ = True
364−
365− isKeyUsed :: Key -> Bool
366− isKeyUsed k
367− | Just me <- vertexFor k = me `S.member` reachableSet
368− | otherwise = False
369−
370−-- | Topologically sort the module dependency graph, so that when we generate code, modules can be
371−-- defined in the right order.
372−sortModules :: [Module] -> [Module]
373−sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph))
374− where
375− (graph, nodeFor, _) = graphFromEdges $ do
376− m@(Module mid els) <- modules
377− return (m, mid, mapMaybe getKey els)
378−
379− getKey :: ModuleElement -> Maybe ModuleIdentifier
380− getKey (Require _ _ mi) = Just mi
381− getKey _ = Nothing
382−
383−-- | A module is empty if it contains no exported members (in other words,
384−-- if the only things left after dead code elimination are module imports and
385−-- "other" foreign code).
386−--
387−-- If a module is empty, we don't want to generate code for it.
388−isModuleEmpty :: Module -> Bool
389−isModuleEmpty (Module _ els) = all isElementEmpty els
390− where
391− isElementEmpty :: ModuleElement -> Bool
392− isElementEmpty (ExportsList exps) = null exps
393− isElementEmpty (Require _ _ _) = True
394− isElementEmpty (Other _) = True
395− isElementEmpty _ = False
396−
397−-- | Generate code for a set of modules, including a call to main().
398−--
399−-- Modules get defined on the global PS object, as follows:
400−--
401−-- var PS = { };
402−-- (function(exports) {
403−-- ...
404−-- })(PS["Module.Name"] = PS["Module.Name"] || {});
405−--
406−-- In particular, a module and its foreign imports share the same namespace inside PS.
407−-- This saves us from having to generate unique names for a module and its foreign imports,
408−-- and is safe since a module shares a namespace with its foreign imports in PureScript as well
409−-- (so there is no way to have overlaps in code generated by psc-make).
410−codeGen :: Options -> [Module] -> String
411−codeGen Options{..} ms = renderToString (NN (JSSourceElementsTop (prelude ++ concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule)))
412− where
413− moduleToJS :: Module -> [JSNode]
414− moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
415− where
416− declToJS :: ModuleElement -> [JSNode]
417− declToJS (Member n _ _ _ _) = [n]
418− declToJS (Other n) = [n]
419− declToJS (Require _ nm req) =
420− [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])
421− [ NN (JSVarDecl (sp (JSIdentifier nm))
422− [ sp (JSLiteral "=")
423− , moduleReference sp (moduleName req)
424− ])
425− ]
426− (nt (JSLiteral ";"))) ]
427− declToJS (ExportsList exps) = map toExport exps
428−
429− where
430− toExport :: (ExportType, String, JSNode, [Key]) -> JSNode
431− toExport (_, nm, val, _) =
432− NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]
433− (nt (JSLiteral "["))
434− (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))
435− (nt (JSLiteral "]")))
436− , NN (JSOperator (sp (JSLiteral "=")))
437− , reindent val
438− , nt (JSLiteral ";")
439− ])
440−
441− reindent :: JSNode -> JSNode
442− reindent (NT n _ _) = sp n
443− reindent nn = nn
444−
445− indent :: [JSNode] -> [JSNode]
446− indent = everywhere (mkT squash)
447− where
448− squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)
449− squash nn = nn
450−
451− splat (CommentA pos s) = CommentA (keepCol pos) s
452− splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
453− splat ann = ann
454−
455− keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)
456−
457− prelude :: [JSNode]
458− prelude =
459− [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)
460− , WhiteSpace tokenPosnEmpty "\n"
461− ])
462− [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))
463− [ sp (JSLiteral "=")
464− , NN (JSObjectLiteral (sp (JSLiteral "{"))
465− []
466− (sp (JSLiteral "}")))
467− ])
468− ]
469− (nt (JSLiteral ";")))
470− , lf
471− ]
472−
473− moduleReference :: (Node -> JSNode) -> String -> JSNode
474− moduleReference f mn =
475− NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]
476− (nt (JSLiteral "["))
477− (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
478− (nt (JSLiteral "]")))
479−
480− wrap :: String -> [JSNode] -> [JSNode]
481− wrap mn ds =
482− [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))
483− (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))
484− []
485− (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))
486− (NN (JSBlock [sp (JSLiteral "{")]
487− (lf : ds)
488− [nl (JSLiteral "}")])))]))
489− (nt (JSLiteral ")")))
490− , NN (JSArguments (nt (JSLiteral "("))
491− [ NN (JSExpression [ moduleReference nt mn
492− , NN (JSOperator (sp (JSLiteral "=")))
493− , NN (JSExpressionBinary "||"
494− [ moduleReference sp mn ]
495− (sp (JSLiteral "||"))
496− [ emptyObj ])
497− ])
498− ]
499− (nt (JSLiteral ")")))
500− ])
501− , nt (JSLiteral ";")
502− , lf
503− ]
504− where
505− emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))
506−
507− runMain :: String -> [JSNode]
508− runMain mn =
509− [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]
510− (nt (JSLiteral "["))
511− (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
512− (nt (JSLiteral "]")))
513− ]
514− (nt (JSLiteral "."))
515− (nt (JSIdentifier "main")))
516− , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")")))
517− ])
518− , nt (JSLiteral ";")
519− ]
520−
521− nt :: Node -> JSNode
522− nt n = NT n tokenPosnEmpty []
523−
524− lf :: JSNode
525− lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
526−
527− sp :: Node -> JSNode
528− sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
529−
530− nl :: Node -> JSNode
531− nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
532−
533-- | The main application function.
61-- | The main application function.
534-- This function parses the input files, performs dead code elimination, filters empty modules
62-- This function parses the input files, performs dead code elimination, filters empty modules
535-- and generates and prints the final Javascript bundle.
63-- and generates and prints the final Javascript bundle.
536app :: forall m. (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String
64app :: forall m. (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String
537−app opts@Options{..} = do
65+app Options{..} = do
538 inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles
66 inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles
539 when (null inputFiles) . liftIO $ do
67 when (null inputFiles) . liftIO $ do
540 hPutStrLn stderr "psc-bundle: No input files."
68 hPutStrLn stderr "psc-bundle: No input files."
541 exitFailure
69 exitFailure
542 input <- for inputFiles $ \filename -> do
70 input <- for inputFiles $ \filename -> do
543 js <- liftIO (readFile filename)
71 js <- liftIO (readFile filename)
544− ast <- fromRight (parse js filename)
545 mid <- guessModuleIdentifier filename
72 mid <- guessModuleIdentifier filename
546− return (mid, ast)
73+ return (mid, js)
547−
548− let mids = S.fromList (map (moduleName . fst) input)
549
74
550− modules <- mapM (fmap withDeps . uncurry (toModule mids)) input
551−
552− let compiled = compile modules (map (`ModuleIdentifier` Regular) optionsEntryPoints)
75+ let entryIds = (map (`ModuleIdentifier` Regular) optionsEntryPoints)
553− sorted = sortModules (filter (not . isModuleEmpty) compiled)
76+
554−
77+ bundle input entryIds optionsMainModule optionsNamespace
555− return (codeGen opts sorted)
556−
557− where
558− fromRight :: Either a b -> m b
559− fromRight (Right b) = pure b
560− fromRight (Left _) = throwError UnableToParseModule
561
78
562-- | Command line options parser.
79-- | Command line options parser.
563options :: Parser Options
80options :: Parser Options
@@ -572,10 +89,10 @@ options = Options <$> some inputFile
572 metavar "FILE"
89 metavar "FILE"
573 <> help "The input .js file(s)"
90 <> help "The input .js file(s)"
574
91
575− outputFile :: Parser FilePath
92+ outputFile :: Parser FilePath
576− outputFile = strOption $
93+ outputFile = strOption $
577− short 'o'
94+ short 'o'
578− <> long "output"
95+ <> long "output"
579 <> help "The output .js file"
96 <> help "The output .js file"
580
97
581 entryPoint :: Parser String
98 entryPoint :: Parser String
psc/Main.hs+1−1
@@ -36,7 +36,7 @@ import System.FilePath.Glob (glob)
36import qualified Language.PureScript as P
36import qualified Language.PureScript as P
37import qualified Paths_purescript as Paths
37import qualified Paths_purescript as Paths
38
38
39−import Make
39+import Language.PureScript.Make
40
40
41data PSCMakeOptions = PSCMakeOptions
41data PSCMakeOptions = PSCMakeOptions
42 { pscmInput :: [FilePath]
42 { pscmInput :: [FilePath]
psc/Make.hsdeleted−140
@@ -1,140 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Make
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DataKinds #-}
16−{-# LANGUAGE FlexibleContexts #-}
17−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18−{-# LANGUAGE TupleSections #-}
19−
20−module Make
21− ( Make(..)
22− , runMake
23− , buildMakeActions
24− ) where
25−
26−import Control.Applicative
27−import Control.Monad
28−import Control.Monad.Error.Class (MonadError(..))
29−import Control.Monad.Trans.Except
30−import Control.Monad.Reader
31−import Control.Monad.Writer
32−
33−import Data.Maybe (fromMaybe)
34−import Data.Time.Clock
35−import Data.Traversable (traverse)
36−import Data.Version (showVersion)
37−import qualified Data.Map as M
38−
39−import System.Directory
40− (doesFileExist, getModificationTime, createDirectoryIfMissing)
41−import System.FilePath ((</>), takeDirectory)
42−import System.IO.Error (tryIOError)
43−
44−import qualified Language.PureScript as P
45−import qualified Language.PureScript.CodeGen.JS as J
46−import qualified Language.PureScript.CoreFn as CF
47−import qualified Paths_purescript as Paths
48−
49−newtype Make a = Make { unMake :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
50− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
51−
52−runMake :: P.Options -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))
53−runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
54−
55−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
56−makeIO f io = do
57− e <- liftIO $ tryIOError io
58− either (throwError . P.singleError . f) return e
59−
60−-- Traverse (Either e) instance (base 4.7)
61−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
62−traverseEither _ (Left x) = pure (Left x)
63−traverseEither f (Right y) = Right <$> f y
64−
65−buildMakeActions :: FilePath
66− -> M.Map P.ModuleName (Either P.RebuildPolicy String)
67− -> M.Map P.ModuleName (FilePath, P.ForeignJS)
68− -> Bool
69− -> P.MakeActions Make
70−buildMakeActions outputDir filePathMap foreigns usePrefix =
71− P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
72− where
73−
74− getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
75− getInputTimestamp mn = do
76− let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
77− e1 <- traverseEither getTimestamp path
78− fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
79− return $ fmap (max fPath) e1
80−
81− getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
82− getOutputTimestamp mn = do
83− let filePath = P.runModuleName mn
84− jsFile = outputDir </> filePath </> "index.js"
85− externsFile = outputDir </> filePath </> "externs.purs"
86− min <$> getTimestamp jsFile <*> getTimestamp externsFile
87−
88− readExterns :: P.ModuleName -> Make (FilePath, String)
89− readExterns mn = do
90− let path = outputDir </> P.runModuleName mn </> "externs.purs"
91− (path, ) <$> readTextFile path
92−
93− codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
94− codegen m _ nextVar exts = do
95− let mn = CF.moduleName m
96− foreignInclude <- case mn `M.lookup` foreigns of
97− Just (path, _)
98− | not $ requiresForeign m -> do
99− tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
100− return Nothing
101− | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
102− Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
103− | otherwise -> return Nothing
104− pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
105− let filePath = P.runModuleName mn
106− jsFile = outputDir </> filePath </> "index.js"
107− externsFile = outputDir </> filePath </> "externs.purs"
108− foreignFile = outputDir </> filePath </> "foreign.js"
109− prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
110− js = unlines $ map ("// " ++) prefix ++ [pjs]
111− writeTextFile jsFile js
112− maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
113− writeTextFile externsFile exts
114−
115− requiresForeign :: CF.Module a -> Bool
116− requiresForeign = not . null . CF.moduleForeign
117−
118− getTimestamp :: FilePath -> Make (Maybe UTCTime)
119− getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
120− exists <- doesFileExist path
121− traverse (const $ getModificationTime path) $ guard exists
122−
123− readTextFile :: FilePath -> Make String
124− readTextFile path = do
125− verboseErrorsEnabled <- asks P.optionsVerboseErrors
126− makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do
127− when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
128− readFile path
129−
130− writeTextFile :: FilePath -> String -> Make ()
131− writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
132− mkdirp path
133− putStrLn $ "Writing " ++ path
134− writeFile path text
135− where
136− mkdirp :: FilePath -> IO ()
137− mkdirp = createDirectoryIfMissing True . takeDirectory
138−
139− progress :: String -> Make ()
140− progress = liftIO . putStrLn
psci/Make.hsdeleted−127
@@ -1,127 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Make
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DataKinds #-}
16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−{-# LANGUAGE TupleSections #-}
18−
19−module Make where
20−
21−import Data.List (isPrefixOf)
22−import Data.Maybe (fromMaybe)
23−import Data.Time.Clock
24−import Data.Traversable (traverse)
25−import qualified Data.Map as M
26−
27−import Control.Applicative
28−import Control.Monad
29−import Control.Monad.Error.Class (MonadError(..))
30−import Control.Monad.IO.Class (MonadIO, liftIO)
31−import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
32−import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
33−import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
34−
35−import System.Directory (getModificationTime, doesFileExist)
36−import System.FilePath ((</>), pathSeparator)
37−import System.IO.Error (tryIOError)
38−
39−import qualified Language.PureScript as P
40−import qualified Language.PureScript.CodeGen.JS as J
41−import qualified Language.PureScript.CoreFn as CF
42−
43−import IO (mkdirp)
44−
45−options :: P.Options
46−options = P.Options False False Nothing False False False Nothing
47−
48−modulesDir :: FilePath
49−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
50−
51−newtype Make a = Make { unMake :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
52− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
53−
54−runMake :: Make a -> IO (Either P.MultipleErrors a)
55−runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
56−
57−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
58−makeIO f io = do
59− e <- liftIO $ tryIOError io
60− either (throwError . P.singleError . f) return e
61−
62−-- Traverse (Either e) instance (base 4.7)
63−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
64−traverseEither _ (Left x) = pure (Left x)
65−traverseEither f (Right y) = Right <$> f y
66−
67−buildMakeActions :: M.Map P.ModuleName (Either P.RebuildPolicy String)
68− -> M.Map P.ModuleName P.ForeignJS
69− -> P.MakeActions Make
70−buildMakeActions filePathMap foreigns =
71− P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
72− where
73−
74− getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
75− getInputTimestamp mn = do
76− let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
77− traverseEither getTimestamp path
78−
79− getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
80− getOutputTimestamp mn = do
81− let filePath = P.runModuleName mn
82− jsFile = modulesDir </> filePath </> "index.js"
83− externsFile = modulesDir </> filePath </> "externs.purs"
84− min <$> getTimestamp jsFile <*> getTimestamp externsFile
85−
86− readExterns :: P.ModuleName -> Make (FilePath, String)
87− readExterns mn = do
88− let path = modulesDir </> P.runModuleName mn </> "externs.purs"
89− (path, ) <$> readTextFile path
90−
91− codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
92− codegen m _ nextVar exts = do
93− let mn = CF.moduleName m
94− foreignInclude <- case CF.moduleName m `M.lookup` foreigns of
95− Just path
96− | not $ requiresForeign m -> do tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
97− return Nothing
98− | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
99− Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
100− | otherwise -> return Nothing
101− pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
102− let filePath = P.runModuleName $ CF.moduleName m
103− jsFile = modulesDir </> filePath </> "index.js"
104− externsFile = modulesDir </> filePath </> "externs.purs"
105− foreignFile = modulesDir </> filePath </> "foreign.js"
106− writeTextFile jsFile pjs
107− maybe (return ()) (writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns
108− writeTextFile externsFile exts
109−
110− requiresForeign :: CF.Module a -> Bool
111− requiresForeign = not . null . CF.moduleForeign
112−
113− getTimestamp :: FilePath -> Make (Maybe UTCTime)
114− getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
115− exists <- doesFileExist path
116− traverse (const $ getModificationTime path) $ guard exists
117−
118− readTextFile :: FilePath -> Make String
119− readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path
120−
121− writeTextFile :: FilePath -> String -> Make ()
122− writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
123− mkdirp path
124− writeFile path text
125−
126− progress :: String -> Make ()
127− progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s
psci/PSCi.hs+23−6
@@ -21,7 +21,7 @@
21module PSCi where
21module PSCi where
22
22
23import Data.Foldable (traverse_)
23import Data.Foldable (traverse_)
24−import Data.List (intercalate, nub, sort)
24+import Data.List (intercalate, nub, sort, isPrefixOf)
25import Data.Traversable (traverse)
25import Data.Traversable (traverse)
26import Data.Tuple (swap)
26import Data.Tuple (swap)
27import Data.Version (showVersion)
27import Data.Version (showVersion)
@@ -30,10 +30,12 @@ import qualified Data.Map as M
30import Control.Applicative
30import Control.Applicative
31import Control.Arrow (first)
31import Control.Arrow (first)
32import Control.Monad
32import Control.Monad
33+import Control.Monad.Error.Class (MonadError(..))
33import Control.Monad.Trans.Class
34import Control.Monad.Trans.Class
34import Control.Monad.Trans.Except (runExceptT)
35import Control.Monad.Trans.Except (runExceptT)
35import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
36import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
36import Control.Monad.Trans.State.Strict
37import Control.Monad.Trans.State.Strict
38+import Control.Monad.IO.Class (liftIO)
37import Control.Monad.Writer (runWriter)
39import Control.Monad.Writer (runWriter)
38import qualified Control.Monad.Trans.State.Lazy as L
40import qualified Control.Monad.Trans.State.Lazy as L
39
41
@@ -45,6 +47,7 @@ import System.Exit
45import System.FilePath (pathSeparator, (</>), isPathSeparator)
47import System.FilePath (pathSeparator, (</>), isPathSeparator)
46import System.FilePath.Glob (glob)
48import System.FilePath.Glob (glob)
47import System.Process (readProcessWithExitCode)
49import System.Process (readProcessWithExitCode)
50+import System.IO.Error (tryIOError)
48
51
49import qualified Language.PureScript as P
52import qualified Language.PureScript as P
50import qualified Language.PureScript.Names as N
53import qualified Language.PureScript.Names as N
@@ -53,7 +56,6 @@ import qualified Paths_purescript as Paths
53import qualified Directive as D
56import qualified Directive as D
54import Completion (completion)
57import Completion (completion)
55import IO (mkdirp)
58import IO (mkdirp)
56−import Make
57import Parser (parseCommand)
59import Parser (parseCommand)
58import Types
60import Types
59
61
@@ -240,10 +242,25 @@ importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
240indexFile :: FilePath
242indexFile :: FilePath
241indexFile = ".psci_modules" ++ pathSeparator : "index.js"
243indexFile = ".psci_modules" ++ pathSeparator : "index.js"
242
244
245+modulesDir :: FilePath
246+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
247+
248+-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
249+-- options and ignores the warning messages.
250+runMake :: P.Make a -> IO (Either P.MultipleErrors a)
251+runMake mk = fmap (fmap fst) $ P.runMake (P.Options False False Nothing False False False Nothing) mk
252+
253+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a
254+makeIO f io = do
255+ e <- liftIO $ tryIOError io
256+ either (throwError . P.singleError . f) return e
257+
243−make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> Make P.Environment
258+make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment
244−make PSCiState{..} ms =
259+make PSCiState{..} ms = P.make actions' (psciLoadedModules ++ ms)
260+ where
245− let filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
261+ filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
246− in P.make (buildMakeActions filePathMap (M.map snd psciForeignFiles)) (psciLoadedModules ++ ms)
262+ actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
263+ actions' = actions { P.progress = \s -> unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s }
247
264
248-- |
265-- |
249-- Takes a value declaration and evaluates it with the current state.
266-- Takes a value declaration and evaluates it with the current state.
purescript.cabal+6−6
@@ -46,7 +46,9 @@ library
46 aeson-better-errors >= 0.8,
46 aeson-better-errors >= 0.8,
47 bytestring -any,
47 bytestring -any,
48 text -any,
48 text -any,
49− split -any
49+ split -any,
50+ language-javascript == 0.5.*,
51+ syb -any
50
52
51 exposed-modules: Language.PureScript
53 exposed-modules: Language.PureScript
52 Language.PureScript.AST
54 Language.PureScript.AST
@@ -56,6 +58,7 @@ library
56 Language.PureScript.AST.SourcePos
58 Language.PureScript.AST.SourcePos
57 Language.PureScript.AST.Traversals
59 Language.PureScript.AST.Traversals
58 Language.PureScript.AST.Exported
60 Language.PureScript.AST.Exported
61+ Language.PureScript.Bundle
59 Language.PureScript.CodeGen
62 Language.PureScript.CodeGen
60 Language.PureScript.CodeGen.Externs
63 Language.PureScript.CodeGen.Externs
61 Language.PureScript.CodeGen.JS
64 Language.PureScript.CodeGen.JS
@@ -83,6 +86,7 @@ library
83 Language.PureScript.Errors
86 Language.PureScript.Errors
84 Language.PureScript.Kinds
87 Language.PureScript.Kinds
85 Language.PureScript.Linter
88 Language.PureScript.Linter
89+ Language.PureScript.Make
86 Language.PureScript.ModuleDependencies
90 Language.PureScript.ModuleDependencies
87 Language.PureScript.Names
91 Language.PureScript.Names
88 Language.PureScript.Options
92 Language.PureScript.Options
@@ -152,7 +156,6 @@ executable psc
152 main-is: Main.hs
156 main-is: Main.hs
153 buildable: True
157 buildable: True
154 hs-source-dirs: psc
158 hs-source-dirs: psc
155− other-modules: Make
156 ghc-options: -Wall -O2 -fno-warn-unused-do-bind
159 ghc-options: -Wall -O2 -fno-warn-unused-do-bind
157
160
158executable psci
161executable psci
@@ -169,7 +172,6 @@ executable psci
169 Directive
172 Directive
170 Completion
173 Completion
171 PSCi
174 PSCi
172− Make
173 IO
175 IO
174 ghc-options: -Wall -O2
176 ghc-options: -Wall -O2
175
177
@@ -217,9 +219,7 @@ executable psc-bundle
217 other-modules:
219 other-modules:
218 other-extensions:
220 other-extensions:
219 build-depends: base >=4 && <5,
221 build-depends: base >=4 && <5,
220− language-javascript == 0.5.*,
222+ purescript -any,
221− syb -any,
222− containers -any,
223 filepath -any,
223 filepath -any,
224 directory -any,
224 directory -any,
225 mtl -any,
225 mtl -any,
src/Language/PureScript.hs+1−153
@@ -20,37 +20,18 @@
20
20
21module Language.PureScript
21module Language.PureScript
22 ( module P
22 ( module P
23− , RebuildPolicy(..)
24− , MakeActions(..)
25− , SupplyVar()
26− , Externs()
27− , make
28 , version
23 , version
29 ) where
24 ) where
30
25
31−import Data.Function (on)
32−import Data.List (sortBy, groupBy)
33−import Data.Maybe (fromMaybe)
34−import Data.Time.Clock
35import Data.Version (Version)
26import Data.Version (Version)
36−import qualified Data.Map as M
37−import qualified Data.Set as S
38−
39−import Control.Applicative
40−import Control.Arrow ((&&&))
41−import Control.Monad
42−import Control.Monad.Error.Class (MonadError(..))
43−import Control.Monad.Reader
44−import Control.Monad.Writer
45−import Control.Monad.Supply.Class (fresh)
46
27
47import Language.PureScript.AST as P
28import Language.PureScript.AST as P
48import Language.PureScript.Comments as P
29import Language.PureScript.Comments as P
49−import Language.PureScript.CodeGen.Externs (moduleToPs)
50import Language.PureScript.Environment as P
30import Language.PureScript.Environment as P
51import Language.PureScript.Errors as P
31import Language.PureScript.Errors as P
52import Language.PureScript.Kinds as P
32import Language.PureScript.Kinds as P
53import Language.PureScript.Linter as P
33import Language.PureScript.Linter as P
34+import Language.PureScript.Make as P
54import Language.PureScript.ModuleDependencies as P
35import Language.PureScript.ModuleDependencies as P
55import Language.PureScript.Names as P
36import Language.PureScript.Names as P
56import Language.PureScript.Options as P
37import Language.PureScript.Options as P
@@ -61,141 +42,8 @@ import Language.PureScript.Sugar as P
61import Control.Monad.Supply as P
42import Control.Monad.Supply as P
62import Language.PureScript.TypeChecker as P
43import Language.PureScript.TypeChecker as P
63import Language.PureScript.Types as P
44import Language.PureScript.Types as P
64−import qualified Language.PureScript.CoreFn as CoreFn
65−import qualified Language.PureScript.Constants as C
66
45
67import qualified Paths_purescript as Paths
46import qualified Paths_purescript as Paths
68
47
69−-- |
70−-- Actions that require implementations when running in "make" mode.
71−--
72−data MakeActions m = MakeActions {
73− -- |
74− -- Get the timestamp for the input file(s) for a module. If there are multiple
75− -- files (.purs and foreign files, for example) the timestamp should be for
76− -- the most recently modified file.
77− --
78− getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
79− -- |
80− -- Get the timestamp for the output files for a module. This should be the
81− -- timestamp for the oldest modified file, or Nothing if any of the required
82− -- output files are missing.
83− --
84− , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
85− -- |
86− -- Read the externs file for a module as a string and also return the actual
87− -- path for the file.
88− , readExterns :: ModuleName -> m (FilePath, String)
89− -- |
90− -- Run the code generator for the module and write any required output files.
91− --
92− , codegen :: CoreFn.Module CoreFn.Ann -> Environment -> SupplyVar -> Externs -> m ()
93− -- |
94− -- Respond to a progress update.
95− --
96− , progress :: String -> m ()
97− }
98−
99−-- |
100−-- Generated code for an externs file.
101−--
102−type Externs = String
103−
104−-- |
105−-- A value to be used in the Supply monad.
106−--
107−type SupplyVar = Integer
108−
109−-- |
110−-- Determines when to rebuild a module
111−--
112−data RebuildPolicy
113− -- | Never rebuild this module
114− = RebuildNever
115− -- | Always rebuild this module
116− | RebuildAlways deriving (Show, Eq, Ord)
117−
118−-- |
119−-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
120−--
121−-- If timestamps have not changed, the externs file can be used to provide the module's types without
122−-- having to typecheck the module again.
123−--
124−make :: forall m. (Functor m, Applicative m, Monad m, MonadReader P.Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
125− => MakeActions m
126− -> [(Either RebuildPolicy FilePath, Module)]
127− -> m Environment
128−make MakeActions{..} ms = do
129− (sorted, graph) <- sortModules $ map (importPrim . snd) ms
130− mapM_ lint sorted
131− toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
132− inputTimestamp <- getInputTimestamp moduleName'
133− outputTimestamp <- getOutputTimestamp moduleName'
134− return $ case (inputTimestamp, outputTimestamp) of
135− (Right (Just t1), Just t2) | t1 < t2 -> s
136− (Left RebuildNever, Just _) -> s
137− _ -> S.insert moduleName' s) S.empty sorted
138−
139− marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
140− (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
141− evalSupplyT nextVar $ go initEnvironment desugared
142− where
143−
144− go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
145− go env [] = return env
146− go env ((False, m) : ms') = do
147− (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
148− go env' ms'
149− go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
150− lift $ progress $ "Compiling " ++ runModuleName moduleName'
151− (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
152− regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
153− let mod' = Module coms moduleName' regrouped exps
154− corefn = CoreFn.moduleToCoreFn env' mod'
155− [renamed] = renameInModules [corefn]
156− exts = moduleToPs mod' env'
157− nextVar <- fresh
158− lift $ codegen renamed env' nextVar exts
159− go env' ms'
160−
161− rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
162− rebuildIfNecessary _ _ [] = return []
163− rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
164− let deps = fromMaybe [] $ moduleName' `M.lookup` graph
165− toRebuild' = toRebuild `S.union` S.fromList deps
166− (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
167− rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
168− (path, externs) <- readExterns moduleName'
169− externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(path, externs)]
170− case externsModules of
171− [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
172− _ -> throwError . errorMessage . InvalidExternsFile $ path
173− where
174− alterErrors = flip catchError $ \(MultipleErrors errs) ->
175− throwError . MultipleErrors $ flip map errs $ \e -> case e of
176− SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
177− _ -> e
178−
179−reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
180−reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
181− where
182− combine :: (Ord a) => [(a, b)] -> M.Map a [b]
183− combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
184−
185−-- |
186−-- Add an import declaration for a module if it does not already explicitly import it.
187−--
188−addDefaultImport :: ModuleName -> Module -> Module
189−addDefaultImport toImport m@(Module coms mn decls exps) =
190− if isExistingImport `any` decls || mn == toImport then m
191− else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
192− where
193− isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
194− isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
195− isExistingImport _ = False
196−
197−importPrim :: Module -> Module
198−importPrim = addDefaultImport (ModuleName [ProperName C.prim])
199−
200version :: Version
48version :: Version
201version = Paths.version
49version = Paths.version
src/Language/PureScript/Bundle.hsnew file+540
@@ -0,0 +1,540 @@
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+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE PatternGuards #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE ScopedTypeVariables #-}
18+{-# LANGUAGE TupleSections #-}
19+{-# LANGUAGE RecordWildCards #-}
20+
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.
26+module Language.PureScript.Bundle (
27+ bundle
28+ , ModuleIdentifier(..)
29+ , moduleName
30+ , ModuleType(..)
31+ , ErrorMessage(..)
32+ , printErrorMessage
33+) where
34+
35+import Data.List (nub)
36+import Data.Maybe (mapMaybe, catMaybes)
37+import Data.Generics (everything, everywhere, mkQ, mkT)
38+import Data.Graph
39+import Data.Version (showVersion)
40+
41+import qualified Data.Set as S
42+
43+import Control.Applicative
44+import Control.Monad
45+import Control.Monad.Error.Class
46+import Language.JavaScript.Parser
47+
48+import qualified Paths_purescript as Paths
49+
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.
52+data ErrorMessage
53+ = UnsupportedModulePath String
54+ | InvalidTopLevel
55+ | UnableToParseModule
56+ | UnsupportedExport
57+ | ErrorInFile FilePath ErrorMessage
58+ deriving Show
59+
60+-- | Modules are either "regular modules" (i.e. those generated by psc-make) or foreign modules.
61+data ModuleType
62+ = Regular
63+ | Foreign
64+ deriving (Show, Eq, Ord)
65+
66+-- | A module is identified by its module name and its type.
67+data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)
68+
69+moduleName :: ModuleIdentifier -> String
70+moduleName (ModuleIdentifier name _) = name
71+
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.
74+type Key = (ModuleIdentifier, String)
75+
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.
80+data ExportType
81+ = RegularExport String
82+ | ForeignReexport
83+ deriving (Show, Eq, Ord)
84+
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.
94+data 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
100+
101+-- | A module is just a list of elements of the types listed above.
102+data Module = Module ModuleIdentifier [ModuleElement] deriving Show
103+
104+-- | Prepare an error message for consumption by humans.
105+printErrorMessage :: ErrorMessage -> [String]
106+printErrorMessage (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+ ]
112+printErrorMessage InvalidTopLevel =
113+ [ "Expected a list of source elements at the top level." ]
114+printErrorMessage UnableToParseModule =
115+ [ "The module could not be parsed." ]
116+printErrorMessage UnsupportedExport =
117+ [ "An export was unsupported. Exports can be defined in one of two ways: "
118+ , " 1) exports.name = ..."
119+ , " 2) exports = { ... }"
120+ ]
121+printErrorMessage (ErrorInFile filename e) =
122+ ("Error in file " ++ show filename ++ ":")
123+ : ""
124+ : map (" " ++) (printErrorMessage e)
125+
126+-- | Unpack the node inside a JSNode. This is useful when pattern matching.
127+node :: JSNode -> Node
128+node (NN n) = n
129+node (NT n _ _) = n
130+
131+-- | Calculate the ModuleIdentifier which a require(...) statement imports.
132+checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier
133+checkImportPath "./foreign" m _ =
134+ Just (ModuleIdentifier (moduleName m) Foreign)
135+checkImportPath name _ names
136+ | name `S.member` names = Just (ModuleIdentifier name Regular)
137+checkImportPath _ _ _ = Nothing
138+
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.
152+withDeps :: Module -> Module
153+withDeps (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
162+
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
170+
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
178+
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 _ = []
198+
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.
203+toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSNode -> m Module
204+toModule 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
260+
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
270+
271+ extractLabel :: Node -> m String
272+ extractLabel (JSStringLiteral _ nm) = pure nm
273+ extractLabel (JSIdentifier nm) = pure nm
274+ extractLabel _ = throwError UnsupportedExport
275+
276+ isSeparator :: Node -> Bool
277+ isSeparator (JSLiteral ",") = True
278+ isSeparator _ = False
279+ toModuleElement other = pure (Other other)
280+
281+-- | Eliminate unused code based on the specified entry point set.
282+compile :: [Module] -> [ModuleIdentifier] -> [Module]
283+compile modules [] = modules
284+compile modules entryPoints = filteredModules
285+ where
286+ (graph, _, vertexFor) = graphFromEdges verts
287+
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 _ _ = []
311+
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)
318+
319+ -- | The set of vertices reachable from an entry point
320+ reachableSet :: S.Set Vertex
321+ reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)
322+
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
338+
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
343+
344+ isDeclUsed :: ModuleElement -> Bool
345+ isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)
346+ isDeclUsed _ = True
347+
348+ isKeyUsed :: Key -> Bool
349+ isKeyUsed k
350+ | Just me <- vertexFor k = me `S.member` reachableSet
351+ | otherwise = False
352+
353+-- | Topologically sort the module dependency graph, so that when we generate code, modules can be
354+-- defined in the right order.
355+sortModules :: [Module] -> [Module]
356+sortModules 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)
361+
362+ getKey :: ModuleElement -> Maybe ModuleIdentifier
363+ getKey (Require _ _ mi) = Just mi
364+ getKey _ = Nothing
365+
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.
371+isModuleEmpty :: Module -> Bool
372+isModuleEmpty (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
379+
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).
393+codeGen :: Maybe String -- ^ main module
394+ -> String -- ^ namespace
395+ -> [Module] -- ^ input modules
396+ -> String
397+codeGen 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
414+
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+ ])
426+
427+ reindent :: JSNode -> JSNode
428+ reindent (NT n _ _) = sp n
429+ reindent nn = nn
430+
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
436+
437+ splat (CommentA pos s) = CommentA (keepCol pos) s
438+ splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
439+ splat ann = ann
440+
441+ keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)
442+
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+ ]
458+
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 "]")))
465+
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 "}")))
492+
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+ ]
506+
507+ nt :: Node -> JSNode
508+ nt n = NT n tokenPosnEmpty []
509+
510+ lf :: JSNode
511+ lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
512+
513+ sp :: Node -> JSNode
514+ sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
515+
516+ nl :: Node -> JSNode
517+ nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
518+
519+-- | The bundling function.
520+-- This function performs dead code elimination, filters empty modules
521+-- and generates and prints the final Javascript bundle.
522+bundle :: 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
528+bundle 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)
532+
533+ let mids = S.fromList (map (moduleName . fst) input)
534+
535+ modules <- mapM (fmap withDeps . uncurry (toModule mids)) input
536+
537+ let compiled = compile modules entryPoints
538+ sorted = sortModules (filter (not . isModuleEmpty) compiled)
539+
540+ return (codeGen mainModule namespace sorted)
src/Language/PureScript/Make.hsnew file+313
@@ -0,0 +1,313 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Make
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18+{-# LANGUAGE TupleSections #-}
19+{-# LANGUAGE RankNTypes #-}
20+{-# LANGUAGE RecordWildCards #-}
21+{-# LANGUAGE ScopedTypeVariables #-}
22+
23+module Language.PureScript.Make
24+ (
25+ -- * Make API
26+ RebuildPolicy(..)
27+ , MakeActions(..)
28+ , SupplyVar()
29+ , Externs()
30+ , make
31+
32+ -- * Implementation of Make API using files on disk
33+ , Make(..)
34+ , runMake
35+ , buildMakeActions
36+ ) where
37+
38+import Control.Applicative
39+import Control.Arrow ((&&&))
40+import Control.Monad
41+import Control.Monad.Error.Class (MonadError(..))
42+import Control.Monad.Trans.Except
43+import Control.Monad.Reader
44+import Control.Monad.Writer
45+import Control.Monad.Supply
46+import Control.Monad.Supply.Class (fresh)
47+
48+import Data.Function (on)
49+import Data.List (sortBy, groupBy)
50+import Data.Maybe (fromMaybe)
51+import Data.Time.Clock
52+import Data.Traversable (traverse)
53+import Data.Version (showVersion)
54+import qualified Data.Map as M
55+import qualified Data.Set as S
56+
57+import System.Directory
58+ (doesFileExist, getModificationTime, createDirectoryIfMissing)
59+import System.FilePath ((</>), takeDirectory)
60+import System.IO.Error (tryIOError)
61+
62+
63+import Language.PureScript.AST
64+import Language.PureScript.CodeGen.Externs (moduleToPs)
65+import Language.PureScript.Environment
66+import Language.PureScript.Errors
67+import Language.PureScript.Linter
68+import Language.PureScript.ModuleDependencies
69+import Language.PureScript.Names
70+import Language.PureScript.Options
71+import Language.PureScript.Parser
72+import Language.PureScript.Pretty
73+import Language.PureScript.Renamer
74+import Language.PureScript.Sugar
75+import Language.PureScript.TypeChecker
76+import qualified Language.PureScript.Constants as C
77+
78+import qualified Language.PureScript.CodeGen.JS as J
79+import qualified Language.PureScript.CoreFn as CF
80+import qualified Paths_purescript as Paths
81+
82+-- |
83+-- Actions that require implementations when running in "make" mode.
84+--
85+data MakeActions m = MakeActions {
86+ -- |
87+ -- Get the timestamp for the input file(s) for a module. If there are multiple
88+ -- files (.purs and foreign files, for example) the timestamp should be for
89+ -- the most recently modified file.
90+ --
91+ getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
92+ -- |
93+ -- Get the timestamp for the output files for a module. This should be the
94+ -- timestamp for the oldest modified file, or Nothing if any of the required
95+ -- output files are missing.
96+ --
97+ , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
98+ -- |
99+ -- Read the externs file for a module as a string and also return the actual
100+ -- path for the file.
101+ , readExterns :: ModuleName -> m (FilePath, String)
102+ -- |
103+ -- Run the code generator for the module and write any required output files.
104+ --
105+ , codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> m ()
106+ -- |
107+ -- Respond to a progress update.
108+ --
109+ , progress :: String -> m ()
110+ }
111+
112+-- |
113+-- Generated code for an externs file.
114+--
115+type Externs = String
116+
117+-- |
118+-- A value to be used in the Supply monad.
119+--
120+type SupplyVar = Integer
121+
122+-- |
123+-- Determines when to rebuild a module
124+--
125+data RebuildPolicy
126+ -- | Never rebuild this module
127+ = RebuildNever
128+ -- | Always rebuild this module
129+ | RebuildAlways deriving (Show, Eq, Ord)
130+
131+-- |
132+-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
133+--
134+-- If timestamps have not changed, the externs file can be used to provide the module's types without
135+-- having to typecheck the module again.
136+--
137+make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
138+ => MakeActions m
139+ -> [(Either RebuildPolicy FilePath, Module)]
140+ -> m Environment
141+make MakeActions{..} ms = do
142+ (sorted, graph) <- sortModules $ map (importPrim . snd) ms
143+ mapM_ lint sorted
144+ toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
145+ inputTimestamp <- getInputTimestamp moduleName'
146+ outputTimestamp <- getOutputTimestamp moduleName'
147+ return $ case (inputTimestamp, outputTimestamp) of
148+ (Right (Just t1), Just t2) | t1 < t2 -> s
149+ (Left RebuildNever, Just _) -> s
150+ _ -> S.insert moduleName' s) S.empty sorted
151+
152+ marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
153+ (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
154+ evalSupplyT nextVar $ go initEnvironment desugared
155+ where
156+
157+ go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
158+ go env [] = return env
159+ go env ((False, m) : ms') = do
160+ (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
161+ go env' ms'
162+ go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
163+ lift $ progress $ "Compiling " ++ runModuleName moduleName'
164+ (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
165+ regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
166+ let mod' = Module coms moduleName' regrouped exps
167+ corefn = CF.moduleToCoreFn env' mod'
168+ [renamed] = renameInModules [corefn]
169+ exts = moduleToPs mod' env'
170+ nextVar <- fresh
171+ lift $ codegen renamed env' nextVar exts
172+ go env' ms'
173+
174+ rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
175+ rebuildIfNecessary _ _ [] = return []
176+ rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
177+ let deps = fromMaybe [] $ moduleName' `M.lookup` graph
178+ toRebuild' = toRebuild `S.union` S.fromList deps
179+ (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
180+ rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
181+ (path, externs) <- readExterns moduleName'
182+ externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
183+ case externsModules of
184+ [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
185+ _ -> throwError . errorMessage . InvalidExternsFile $ path
186+ where
187+ alterErrors = flip catchError $ \(MultipleErrors errs) ->
188+ throwError . MultipleErrors $ flip map errs $ \e -> case e of
189+ SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
190+ _ -> e
191+
192+reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
193+reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
194+ where
195+ combine :: (Ord a) => [(a, b)] -> M.Map a [b]
196+ combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
197+
198+-- |
199+-- Add an import declaration for a module if it does not already explicitly import it.
200+--
201+addDefaultImport :: ModuleName -> Module -> Module
202+addDefaultImport toImport m@(Module coms mn decls exps) =
203+ if isExistingImport `any` decls || mn == toImport then m
204+ else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
205+ where
206+ isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
207+ isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
208+ isExistingImport _ = False
209+
210+importPrim :: Module -> Module
211+importPrim = addDefaultImport (ModuleName [ProperName C.prim])
212+
213+-- |
214+-- A monad for running make actions
215+--
216+newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
217+ deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
218+
219+-- |
220+-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
221+--
222+runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
223+runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
224+
225+makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
226+makeIO f io = do
227+ e <- liftIO $ tryIOError io
228+ either (throwError . singleError . f) return e
229+
230+-- Traverse (Either e) instance (base 4.7)
231+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
232+traverseEither _ (Left x) = pure (Left x)
233+traverseEither f (Right y) = Right <$> f y
234+
235+-- |
236+-- A set of make actions that read and write modules from the given directory.
237+--
238+buildMakeActions :: FilePath -- ^ the output directory
239+ -> M.Map ModuleName (Either RebuildPolicy String) -- ^ a map between module names and paths to the file containing the PureScript module
240+ -> M.Map ModuleName (FilePath, ForeignJS) -- ^ a map between module name and the file containing the foreign javascript for the module
241+ -> Bool -- ^ Generate a prefix comment?
242+ -> MakeActions Make
243+buildMakeActions outputDir filePathMap foreigns usePrefix =
244+ MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
245+ where
246+
247+ getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
248+ getInputTimestamp mn = do
249+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
250+ e1 <- traverseEither getTimestamp path
251+ fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
252+ return $ fmap (max fPath) e1
253+
254+ getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
255+ getOutputTimestamp mn = do
256+ let filePath = runModuleName mn
257+ jsFile = outputDir </> filePath </> "index.js"
258+ externsFile = outputDir </> filePath </> "externs.purs"
259+ min <$> getTimestamp jsFile <*> getTimestamp externsFile
260+
261+ readExterns :: ModuleName -> Make (FilePath, String)
262+ readExterns mn = do
263+ let path = outputDir </> runModuleName mn </> "externs.purs"
264+ (path, ) <$> readTextFile path
265+
266+ codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> Make ()
267+ codegen m _ nextVar exts = do
268+ let mn = CF.moduleName m
269+ foreignInclude <- case mn `M.lookup` foreigns of
270+ Just (path, _)
271+ | not $ requiresForeign m -> do
272+ tell $ errorMessage $ UnnecessaryFFIModule mn path
273+ return Nothing
274+ | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
275+ Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
276+ | otherwise -> return Nothing
277+ pjs <- evalSupplyT nextVar $ prettyPrintJS <$> J.moduleToJs m foreignInclude
278+ let filePath = runModuleName mn
279+ jsFile = outputDir </> filePath </> "index.js"
280+ externsFile = outputDir </> filePath </> "externs.purs"
281+ foreignFile = outputDir </> filePath </> "foreign.js"
282+ prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
283+ js = unlines $ map ("// " ++) prefix ++ [pjs]
284+ writeTextFile jsFile js
285+ maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
286+ writeTextFile externsFile exts
287+
288+ requiresForeign :: CF.Module a -> Bool
289+ requiresForeign = not . null . CF.moduleForeign
290+
291+ getTimestamp :: FilePath -> Make (Maybe UTCTime)
292+ getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
293+ exists <- doesFileExist path
294+ traverse (const $ getModificationTime path) $ guard exists
295+
296+ readTextFile :: FilePath -> Make String
297+ readTextFile path = do
298+ verboseErrorsEnabled <- asks optionsVerboseErrors
299+ makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ do
300+ when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
301+ readFile path
302+
303+ writeTextFile :: FilePath -> String -> Make ()
304+ writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
305+ mkdirp path
306+ putStrLn $ "Writing " ++ path
307+ writeFile path text
308+ where
309+ mkdirp :: FilePath -> IO ()
310+ mkdirp = createDirectoryIfMissing True . takeDirectory
311+
312+ progress :: String -> Make ()
313+ progress = liftIO . putStrLn