@@ -43,6 +43,7 @@ import qualified Data.Set as S
4343import Control.Monad
4444import Control.Monad.Error.Class
4545import Language.JavaScript.Parser
46+import Language.JavaScript.Parser.AST
4647
4748import qualified Paths_purescript as Paths
4849
@@ -83,7 +84,7 @@ type Key = (ModuleIdentifier, String)
8384data ExportType
8485 = RegularExport String
8586 | ForeignReexport
86− deriving (Show, Read, Eq, Ord)
87+ deriving (Show, Eq, Ord)
8788
8889-- | There are four types of module element we are interested in:
8990--
@@ -95,14 +96,14 @@ data ExportType
9596-- Each is labelled with the original AST node which generated it, so that we can dump it back
9697-- into the output during codegen.
9798data ModuleElement
98− = Require JSNode String (Either String ModuleIdentifier)
99− | Member JSNode Bool String [JSNode] [Key]
100− | ExportsList [(ExportType, String, JSNode, [Key])]
101− | Other JSNode
102− deriving (Show, Read)
99+ = Require JSStatement String (Either String ModuleIdentifier)
100+ | Member JSStatement Bool String JSExpression [Key]
101+ | ExportsList [(ExportType, String, JSExpression, [Key])]
102+ | Other JSStatement
103+ deriving (Show)
103104
104105-- | A module is just a list of elements of the types listed above.
105−data Module = Module ModuleIdentifier [ModuleElement] deriving (Show, Read)
106+data Module = Module ModuleIdentifier [ModuleElement] deriving (Show)
106107
107108-- | Prepare an error message for consumption by humans.
108109printErrorMessage :: ErrorMessage -> [String]
@@ -131,11 +132,6 @@ printErrorMessage (ErrorInModule mid e) =
131132 displayIdentifier (ModuleIdentifier name ty) =
132133 name ++ " (" ++ showModuleType ty ++ ")"
133134
134−-- | Unpack the node inside a JSNode. This is useful when pattern matching.
135−node :: JSNode -> Node
136−node (NN n) = n
137−node (NT n _ _) = n
138−
139135-- | Calculate the ModuleIdentifier which a require(...) statement imports.
140136checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
141137checkImportPath _ "./foreign" m _ =
@@ -179,114 +175,124 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
179175
180176 -- | Calculate dependencies and add them to the current element.
181177 expandDeps :: ModuleElement -> ModuleElement
182− expandDeps (Member n f nm decl _) = Member n f nm decl (nub (concatMap (dependencies modulePath) decl))
178+ expandDeps (Member n f nm decl _) = Member n f nm decl (nub $ dependencies modulePath decl)
183179 expandDeps (ExportsList exps) = ExportsList (map expand exps)
184180 where
185181 expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
186182 expandDeps other = other
187183
188− dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)]
184+ dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)]
189185 dependencies m = everything (++) (mkQ [] toReference)
190186 where
191− toReference :: Node -> [(ModuleIdentifier, String)]
192− toReference (JSMemberDot [ mn ] _ nm)
193− | JSIdentifier mn' <- node mn
194− , JSIdentifier nm' <- node nm
187+ toReference :: JSExpression -> [(ModuleIdentifier, String)]
188+ toReference (JSMemberDot mn _ nm)
189+ | JSIdentifier _ mn' <- mn
190+ , JSIdentifier _ nm' <- nm
195191 , Just mid <- lookup mn' imports
196192 = [(mid, nm')]
197− toReference (JSMemberSquare [ mn ] _ nm _)
198− | JSIdentifier mn' <- node mn
199− , JSExpression [ s ] <- node nm
200− , JSStringLiteral _ nm' <- node s
193+ toReference (JSMemberSquare mn _ nm _)
194+ | JSIdentifier _ mn' <- mn
195+ , Just nm' <- fromStringLiteral nm
201196 , Just mid <- lookup mn' imports
202197 = [(mid, nm')]
203− toReference (JSIdentifier nm)
198+ toReference (JSIdentifier _ nm)
204199 | nm `elem` boundNames
205200 = [(m, nm)]
206201 toReference _ = []
207202
203+-- String literals include the quote chars
204+fromStringLiteral :: JSExpression -> Maybe String
205+fromStringLiteral (JSStringLiteral _ str) = Just $ trimStringQuotes str
206+fromStringLiteral _ = Nothing
207+
208+trimStringQuotes :: String -> String
209+trimStringQuotes str = reverse $ drop 1 $ reverse $ drop 1 $ str
210+
211+commaList :: JSCommaList a -> [a]
212+commaList JSLNil = []
213+commaList (JSLOne x) = [x]
214+commaList (JSLCons l _ x) = commaList l ++ [x]
215+
216+trailingCommaList :: JSCommaTrailingList a -> [a]
217+trailingCommaList (JSCTLComma l _) = commaList l
218+trailingCommaList (JSCTLNone l) = commaList l
219+
208220-- | Attempt to create a Module from a Javascript AST.
209221--
210222-- Each type of module element is matched using pattern guards, and everything else is bundled into the
211223-- Other constructor.
212−toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module
224+toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSAST -> m Module
213225toModule requirePath mids mid top
214− | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns
226+ | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts
215227 | otherwise = err InvalidTopLevel
216228 where
217229 err = throwError . ErrorInModule mid
218230
219− toModuleElement :: JSNode -> m ModuleElement
220− toModuleElement n
221− | JSVariables var [ varIntro ] _ <- node n
222− , JSLiteral "var" <- node var
223− , JSVarDecl impN [ eq, req, impP ] <- node varIntro
224− , JSIdentifier importName <- node impN
225− , JSLiteral "=" <- node eq
226− , JSIdentifier "require" <- node req
227− , JSArguments _ [ impS ] _ <- node impP
228− , JSStringLiteral _ importPath <- node impS
231+ toModuleElement :: JSStatement -> m ModuleElement
232+ -- var ModuleName = require("file");
233+ toModuleElement stmt
234+ | JSVariable _ jsInit _ <- stmt
235+ , [JSVarInitExpression var varInit] <- commaList jsInit
236+ , JSIdentifier _ importName <- var
237+ , JSVarInit _ jsInitEx <- varInit
238+ , JSMemberExpression req _ argsE _ <- jsInitEx
239+ , JSIdentifier _ "require" <- req
240+ , [ Just importPath ] <- map fromStringLiteral (commaList argsE)
229241 , importPath' <- checkImportPath requirePath importPath mid mids
230− = pure (Require n importName importPath')
231− toModuleElement n
232− | JSVariables var [ varIntro ] _ <- node n
233− , JSLiteral "var" <- node var
234− , JSVarDecl declN (eq : decl) <- node varIntro
235− , JSIdentifier name <- node declN
236− , JSLiteral "=" <- node eq
237− = pure (Member n False name decl [])
238− toModuleElement n
239− | JSExpression (e : op : decl) <- node n
240− , Just name <- accessor (node e)
241− , JSOperator eq <- node op
242− , JSLiteral "=" <- node eq
243− = pure (Member n True name decl [])
242+ = pure (Require stmt importName importPath')
243+ -- var foo = expr;
244+ toModuleElement stmt
245+ | JSVariable _ jsInit _ <- stmt
246+ , [JSVarInitExpression var varInit] <- commaList jsInit
247+ , JSIdentifier _ name <- var
248+ , JSVarInit _ decl <- varInit
249+ = pure (Member stmt False name decl [])
250+ -- exports.foo = expr; exports["foo"] = expr;
251+ toModuleElement stmt
252+ | JSAssignStatement e (JSAssign _) decl _ <- stmt
253+ , Just name <- accessor e
254+ = pure (Member stmt True name decl [])
244255 where
245− accessor :: Node -> Maybe String
246− accessor (JSMemberDot [ exports ] _ nm)
247− | JSIdentifier "exports" <- node exports
248− , JSIdentifier name <- node nm
256+ accessor :: JSExpression -> Maybe String
257+ accessor (JSMemberDot exports _ nm)
258+ | JSIdentifier _ "exports" <- exports
259+ , JSIdentifier _ name <- nm
249260 = Just name
250− accessor (JSMemberSquare [ exports ] _ nm _)
251− | JSIdentifier "exports" <- node exports
252− , JSExpression [e] <- node nm
253− , JSStringLiteral _ name <- node e
261+ accessor (JSMemberSquare exports _ nm _)
262+ | JSIdentifier _ "exports" <- exports
263+ , Just name <- fromStringLiteral nm
254264 = Just name
255265 accessor _ = Nothing
256− toModuleElement n
257− | JSExpression (mnExp : op : obj: _) <- node n
258− , JSMemberDot [ mn ] _ e <- node mnExp
259− , JSIdentifier "module" <- node mn
260− , JSIdentifier "exports" <- node e
261− , JSOperator eq <- node op
262− , JSLiteral "=" <- node eq
263− , JSObjectLiteral _ props _ <- node obj
264− = ExportsList <$> traverse toExport (filter (not . isSeparator) (map node props))
266+ -- module.exports = { ... }
267+ toModuleElement stmt
268+ | JSAssignStatement e (JSAssign _) decl _ <- stmt
269+ , JSMemberDot module' _ exports <- e
270+ , JSIdentifier _ "module" <- module'
271+ , JSIdentifier _ "exports" <- exports
272+ , JSObjectLiteral _ props _ <- decl
273+ = (ExportsList <$> traverse toExport (trailingCommaList props))
265274 where
266− toExport :: Node -> m (ExportType, String, JSNode, [Key])
267− toExport (JSPropertyNameandValue name _ [val] ) =
268− (,,val,[]) <$> exportType (node val)
269− <*> extractLabel (node name)
270− toExport _ = err UnsupportedExport
271−
272− exportType :: Node -> m ExportType
273− exportType (JSMemberDot [f] _ _)
274− | JSIdentifier "$foreign" <- node f
275− = pure ForeignReexport
276− exportType (JSMemberSquare [f] _ _ _)
277− | JSIdentifier "$foreign" <- node f
278− = pure ForeignReexport
279− exportType (JSIdentifier s) = pure (RegularExport s)
280− exportType _ = err UnsupportedExport
281−
282− extractLabel :: Node -> m String
283− extractLabel (JSStringLiteral _ nm) = pure nm
284− extractLabel (JSIdentifier nm) = pure nm
285− extractLabel _ = err UnsupportedExport
286−
287− isSeparator :: Node -> Bool
288− isSeparator (JSLiteral ",") = True
289− isSeparator _ = False
275+ toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])
276+ toExport (JSPropertyNameandValue name _ [val]) =
277+ (,,val,[]) <$> exportType val
278+ <*> extractLabel name
279+ toExport _ = err UnsupportedExport
280+
281+ exportType :: JSExpression -> m ExportType
282+ exportType (JSMemberDot f _ _)
283+ | JSIdentifier _ "$foreign" <- f
284+ = pure ForeignReexport
285+ exportType (JSMemberSquare f _ _ _)
286+ | JSIdentifier _ "$foreign" <- f
287+ = pure ForeignReexport
288+ exportType (JSIdentifier _ s) = pure (RegularExport s)
289+ exportType _ = err UnsupportedExport
290+--
291+ extractLabel :: JSPropertyName -> m String
292+ extractLabel (JSPropertyString _ nm) = pure (trimStringQuotes nm)
293+ extractLabel (JSPropertyIdent _ nm) = pure nm
294+ extractLabel _ = err UnsupportedExport
295+
290296 toModuleElement other = pure (Other other)
291297
292298-- | Eliminate unused code based on the specified entry point set.
@@ -339,10 +345,6 @@ compile modules entryPoints = filteredModules
339345 where
340346 go :: [ModuleElement] -> [ModuleElement]
341347 go [] = []
342− go (d : Other semi : rest)
343− | JSLiteral ";" <- node semi
344− , not (isDeclUsed d)
345− = go rest
346348 go (d : rest)
347349 | not (isDeclUsed d) = go rest
348350 | otherwise = d : go rest
@@ -405,130 +407,121 @@ codeGen :: Maybe String -- ^ main module
405407 -> String -- ^ namespace
406408 -> [Module] -- ^ input modules
407409 -> String
408−codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElementsTop (prelude ++ concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule)))
410+codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (prelude : concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule) JSNoAnnot)
409411 where
410− moduleToJS :: Module -> [JSNode]
412+ moduleToJS :: Module -> [JSStatement]
411413 moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
412414 where
413− declToJS :: ModuleElement -> [JSNode]
415+ declToJS :: ModuleElement -> [JSStatement]
414416 declToJS (Member n _ _ _ _) = [n]
415417 declToJS (Other n) = [n]
416418 declToJS (Require _ nm req) =
417− [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])
418− [ NN (JSVarDecl (sp (JSIdentifier nm))
419− (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req))
420− ]
421− (nt (JSLiteral ";"))) ]
419+ [
420+ JSVariable lfsp
421+ (cList [
422+ JSVarInitExpression (JSIdentifier sp nm)
423+ (JSVarInit sp $ either require (moduleReference sp . moduleName) req )
424+ ]) (JSSemi JSNoAnnot)
425+ ]
422426 declToJS (ExportsList exps) = map toExport exps
423427
424428 where
425− toExport :: (ExportType, String, JSNode, [Key]) -> JSNode
429+ toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement
426430 toExport (_, nm, val, _) =
427− NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]
428− (nt (JSLiteral "["))
429− (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))
430− (nt (JSLiteral "]")))
431− , NN (JSOperator (sp (JSLiteral "=")))
432− , reindent val
433− , nt (JSLiteral ";")
434− ])
435−
436− reindent :: JSNode -> JSNode
437− reindent (NT n _ _) = sp n
438− reindent nn = nn
439−
440− indent :: [JSNode] -> [JSNode]
431+ JSAssignStatement
432+ (JSMemberSquare (JSIdentifier lfsp "exports") JSNoAnnot
433+ (str nm) JSNoAnnot)
434+ (JSAssign sp)
435+ val
436+ (JSSemi JSNoAnnot)
437+
438+ -- comma lists are reverse-consed
439+ cList :: [a] -> JSCommaList a
440+ cList [] = JSLNil
441+ cList [x] = JSLOne x
442+ cList l = go $ reverse l
443+ where
444+ go [x] = JSLOne x
445+ go (h:t)= JSLCons (go t) JSNoAnnot h
446+ go [] = error "Invalid case in comma-list"
447+
448+ indent :: [JSStatement] -> [JSStatement]
441449 indent = everywhere (mkT squash)
442450 where
443− squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)
444− squash nn = nn
451+ squash JSNoAnnot = (JSAnnot (TokenPn 0 0 2) [])
452+ squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)
445453
446454 splat (CommentA pos s) = CommentA (keepCol pos) s
447455 splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
448456 splat ann = ann
449457
450− keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)
451−
452− prelude :: [JSNode]
453− prelude =
454− [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)
455− , WhiteSpace tokenPosnEmpty "\n"
456− ])
457− [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))
458− [ sp (JSLiteral "=")
459− , NN (JSObjectLiteral (sp (JSLiteral "{"))
460− []
461− (sp (JSLiteral "}")))
462− ])
463− ]
464− (nt (JSLiteral ";")))
465− , lf
466− ]
458+ keepCol (TokenPn _ _ c) = TokenPn 0 0 (if c >= 0 then c + 2 else 2)
459+
460+ prelude :: JSStatement
461+ prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by psc-bundle " ++ showVersion Paths.version
462+ , WhiteSpace tokenPosnEmpty "\n" ])
463+ (cList [
464+ JSVarInitExpression (JSIdentifier sp optionsNamespace)
465+ (JSVarInit sp (emptyObj sp))
466+ ]) (JSSemi JSNoAnnot)
467+
468+ require :: String -> JSExpression
469+ require mn =
470+ JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot (cList [ str mn ]) JSNoAnnot
471+
472+ moduleReference :: JSAnnot -> String -> JSExpression
473+ moduleReference a mn =
474+ JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot
475+ (str mn) JSNoAnnot
467476
468− require :: String -> [JSNode]
469− require mn = [ sp (JSIdentifier "require")
470− , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")")))
471− ]
477+ str :: String -> JSExpression
478+ str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\""
472479
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 "]")))
479480
480− wrap :: String -> [JSNode] -> [JSNode]
481+ emptyObj :: JSAnnot -> JSExpression
482+ emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot
483+
484+ wrap :: String -> [JSStatement] -> [JSStatement]
481485 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
486+ [
487+ JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot
488+ (JSLOne (JSIdentName JSNoAnnot "exports")) JSNoAnnot
489+ (JSBlock sp (lfHead ds) lf)) -- \n not quite in right place
490+ JSNoAnnot)
491+ JSNoAnnot
492+ (JSLOne (JSAssignExpression (moduleReference JSNoAnnot mn) (JSAssign sp)
493+ (JSExpressionBinary (moduleReference sp mn) (JSBinOpOr sp) (emptyObj sp))))
494+ JSNoAnnot
495+ (JSSemi JSNoAnnot)
503496 ]
504497 where
505− emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))
498+ lfHead (h:t) = (addAnn (WhiteSpace tokenPosnEmpty "\n ") h) : t
499+ lfHead x = x
500+
501+ addAnn :: CommentAnnotation -> JSStatement -> JSStatement
502+ addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) =
503+ (JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot))
504+ addAnn _ x = x
506505
507− runMain :: String -> [JSNode]
506+ appendAnn a JSNoAnnot = (JSAnnot tokenPosnEmpty [a])
507+ appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])
508+
509+ runMain :: String -> [JSStatement]
508510 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− ]
511+ [JSMethodCall
512+ (JSMemberDot (moduleReference lf mn) JSNoAnnot
513+ (JSIdentifier JSNoAnnot "main"))
514+ JSNoAnnot (cList []) JSNoAnnot (JSSemi JSNoAnnot)]
520515
521− nt :: Node -> JSNode
522− nt n = NT n tokenPosnEmpty []
516+ lf :: JSAnnot
517+ lf = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
523518
524− lf :: JSNode
525− lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
526519
527− sp :: Node -> JSNode
528− sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
520+ lfsp :: JSAnnot
521+ lfsp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ]
529522
530− nl :: Node -> JSNode
531− nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
523+ sp :: JSAnnot
524+ sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
532525
533526-- | The bundling function.
534527-- This function performs dead code elimination, filters empty modules