7016edd · rowtype-yoga/purescript-native

56 deriving Show

57

58-- | Modules are either "regular modules" (i.e. those generated by psc-make) or foreign modules.

59−data ModuleType

59+data ModuleType

60− = Regular

60+ = Regular

61− | Foreign

61+ | Foreign

62 deriving (Show, Eq, Ord)

63−

63+

64-- | A module is identified by its module name and its type.

65data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)

66

73

74-- | An export is either a "regular export", which exports a name from the regular module we are in,

75-- or a reexport of a declaration in the corresponding foreign module.

76−--

76+--

77−-- Regular exports are labelled, since they might re-export an operator with another name.

77+-- Regular exports are labelled, since they might re-export an operator with another name.

78−data ExportType

78+data ExportType

79− = RegularExport String

79+ = RegularExport String

80− | ForeignReexport

80+ | ForeignReexport

81 deriving (Show, Eq, Ord)

82

83-- | There are four types of module element we are interested in:

89--

90-- Each is labelled with the original AST node which generated it, so that we can dump it back

91-- into the output during codegen.

92−data ModuleElement

92+data ModuleElement

93 = Require JSNode String ModuleIdentifier

94 | Member JSNode Bool String [JSNode] [Key]

95 | ExportsList [(ExportType, String, JSNode, [Key])]

96 | Other JSNode

97 deriving Show

98

99−-- | A module is just a list of elements of the types listed above.

99+-- | A module is just a list of elements of the types listed above.

100data Module = Module ModuleIdentifier [ModuleElement] deriving Show

101−

101+

102-- | Prepare an error message for consumption by humans.

103printErrorMessage :: ErrorMessage -> [String]

104printErrorMessage (UnsupportedModulePath s) =

108 , " 2) foreign.js (psc-make foreign modules)"

109 ]

110printErrorMessage InvalidTopLevel =

111− [ "Expected a list of source elements at the top level." ]

111+ [ "Expected a list of source elements at the top level." ]

112printErrorMessage UnableToParseModule =

113 [ "The module could not be parsed." ]

114printErrorMessage UnsupportedExport =

128

129-- | Calculate the ModuleIdentifier which a require(...) statement imports.

130checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier

131−checkImportPath "./foreign" m _ =

131+checkImportPath "./foreign" m _ =

132 Just (ModuleIdentifier (moduleName m) Foreign)

133−checkImportPath name _ names

133+checkImportPath name _ names

134 | name `S.member` names = Just (ModuleIdentifier name Regular)

135checkImportPath _ _ _ = Nothing

136

137-- | Compute the dependencies of all elements in a module, and add them to the tree.

138−--

138+--

139-- Members and exports can have dependencies. A dependency is of one of the following forms:

140--

141-- 1) module.name or member["name"]

142−--

142+--

143-- where module was imported using

144--

145-- var module = require("Module.Name");

149-- where name is the name of a member defined in the current module.

150withDeps :: Module -> Module

151withDeps (Module modulePath es) = Module modulePath (map expandDeps es)

152− where

152+ where

153 -- | Collects all modules which are imported, so that we can identify dependencies of the first type.

154 imports :: [(String, ModuleIdentifier)]

155 imports = mapMaybe toImport es

157 toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)

158 toImport (Require _ nm mid) = Just (nm, mid)

159 toImport _ = Nothing

160−

160+

161 -- | Collects all member names in scope, so that we can identify dependencies of the second type.

162 boundNames :: [String]

163 boundNames = mapMaybe toBoundName es

173 where

174 expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))

175 expandDeps other = other

176−

176+

177 dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)]

178 dependencies m = everything (++) (mkQ [] toReference)

179 where

195 toReference _ = []

196

197-- | Attempt to create a Module from a Javascript AST.

198−--

198+--

199−-- Each type of module element is matched using pattern guards, and everything else is bundled into the

199+-- Each type of module element is matched using pattern guards, and everything else is bundled into the

200-- Other constructor.

201toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSNode -> m Module

202−toModule mids mid top

202+toModule mids mid top

203 | JSSourceElementsTop ns <- node top = Module mid <$> mapM toModuleElement ns

204 | otherwise = throwError InvalidTopLevel

205− where

205+ where

206 toModuleElement :: JSNode -> m ModuleElement

207 toModuleElement n

208 | JSVariables var [ varIntro ] _ <- node n

209− , JSLiteral "var" <- node var

209+ , JSLiteral "var" <- node var

210 , JSVarDecl impN [ eq, req, impP ] <- node varIntro

211 , JSIdentifier importName <- node impN

212 , JSLiteral "=" <- node eq

213 , JSIdentifier "require" <- node req

214− , JSArguments _ [ impS ] _ <- node impP

214+ , JSArguments _ [ impS ] _ <- node impP

215 , JSStringLiteral _ importPath <- node impS

216 , Just importPath' <- checkImportPath importPath mid mids

217 = pure (Require n importName importPath')

218 toModuleElement n

219 | JSVariables var [ varIntro ] _ <- node n

220− , JSLiteral "var" <- node var

220+ , JSLiteral "var" <- node var

221 , JSVarDecl declN (eq : decl) <- node varIntro

222 , JSIdentifier name <- node declN

223 , JSLiteral "=" <- node eq

251 = ExportsList <$> mapM toExport (filter (not . isSeparator) (map node props))

252 where

253 toExport :: Node -> m (ExportType, String, JSNode, [Key])

254− toExport (JSPropertyNameandValue name _ [val] ) =

254+ toExport (JSPropertyNameandValue name _ [val] ) =

255− (,,val,[]) <$> exportType (node val)

255+ (,,val,[]) <$> exportType (node val)

256 <*> extractLabel (node name)

257 toExport _ = throwError UnsupportedExport

258−

258+

259 exportType :: Node -> m ExportType

260 exportType (JSMemberDot [f] _ _)

261 | JSIdentifier "$foreign" <- node f

265 = pure ForeignReexport

266 exportType (JSIdentifier s) = pure (RegularExport s)

267 exportType _ = throwError UnsupportedExport

268−

268+

269 extractLabel :: Node -> m String

270 extractLabel (JSStringLiteral _ nm) = pure nm

271 extractLabel (JSIdentifier nm) = pure nm

272 extractLabel _ = throwError UnsupportedExport

273−

273+

274 isSeparator :: Node -> Bool

275 isSeparator (JSLiteral ",") = True

276 isSeparator _ = False

280compile :: [Module] -> [ModuleIdentifier] -> [Module]

281compile modules [] = modules

282compile modules entryPoints = filteredModules

283− where

283+ where

284 (graph, _, vertexFor) = graphFromEdges verts

285−

285+

286 -- | The vertex set

287 verts :: [(ModuleElement, Key, [Key])]

288 verts = do

290 concatMap (toVertices mid) els

291 where

292 -- | Create a set of vertices for a module element.

293− --

293+ --

294 -- Some special cases worth commenting on:

295 --

296 -- 1) Regular exports which simply export their own name do not count as dependencies.

297 -- Regular exports which rename and reexport an operator do count, however.

298− --

298+ --

299 -- 2) Require statements don't contribute towards dependencies, since they effectively get

300 -- inlined wherever they are used inside other module elements.

301 toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])]

306 toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks)

307 toVertex _ = Nothing

308 toVertices _ _ = []

309−

309+

310 -- | The set of vertices whose connected components we are interested in keeping.

311 entryPointVertices :: [Vertex]

312 entryPointVertices = catMaybes $ do

313 (_, k@(mid, _), _) <- verts

314 guard $ mid `elem` entryPoints

315 return (vertexFor k)

316−

316+

317 -- | The set of vertices reachable from an entry point

318 reachableSet :: S.Set Vertex

319 reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)

320−

320+

321 filteredModules :: [Module]

322 filteredModules = map filterUsed modules

323 where

326 where

327 go :: [ModuleElement] -> [ModuleElement]

328 go [] = []

329− go (d : Other semi : rest)

329+ go (d : Other semi : rest)

330 | JSLiteral ";" <- node semi

331 , not (isDeclUsed d)

332 = go rest

333− go (d : rest)

333+ go (d : rest)

334 | not (isDeclUsed d) = go rest

335 | otherwise = d : go rest

336−

336+

337 -- | Filter out the exports for members which aren't used.

338 filterExports :: ModuleElement -> ModuleElement

339 filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps)

340 filterExports me = me

341−

341+

342 isDeclUsed :: ModuleElement -> Bool

343 isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)

344 isDeclUsed _ = True

345−

345+

346 isKeyUsed :: Key -> Bool

347− isKeyUsed k

347+ isKeyUsed k

348 | Just me <- vertexFor k = me `S.member` reachableSet

349 | otherwise = False

350−

350+

351−-- | Topologically sort the module dependency graph, so that when we generate code, modules can be

351+-- | Topologically sort the module dependency graph, so that when we generate code, modules can be

352-- defined in the right order.

353sortModules :: [Module] -> [Module]

354sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph))

356 (graph, nodeFor, _) = graphFromEdges $ do

357 m@(Module mid els) <- modules

358 return (m, mid, mapMaybe getKey els)

359−

359+

360 getKey :: ModuleElement -> Maybe ModuleIdentifier

361− getKey (Require _ _ mi) = Just mi

361+ getKey (Require _ _ mi) = Just mi

362 getKey _ = Nothing

363−

363+

364-- | A module is empty if it contains no exported members (in other words,

365-- if the only things left after dead code elimination are module imports and

366-- "other" foreign code).

374 isElementEmpty (Require _ _ _) = True

375 isElementEmpty (Other _) = True

376 isElementEmpty _ = False

377−

377+

378-- | Generate code for a set of modules, including a call to main().

379--

380-- Modules get defined on the global PS object, as follows:

384-- ...

385-- })(PS["Module.Name"] = PS["Module.Name"] || {});

386--

387−-- In particular, a module and its foreign imports share the same namespace inside PS.

387+-- In particular, a module and its foreign imports share the same namespace inside PS.

388-- This saves us from having to generate unique names for a module and its foreign imports,

389-- and is safe since a module shares a namespace with its foreign imports in PureScript as well

390-- (so there is no way to have overlaps in code generated by psc-make).

399 where

400 declToJS :: ModuleElement -> [JSNode]

401 declToJS (Member n _ _ _ _) = [n]

402− declToJS (Other n) = [n]

402+ declToJS (Other n) = [n]

403− declToJS (Require _ nm req) =

403+ declToJS (Require _ nm req) =

404− [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])

404+ [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])

405− [ NN (JSVarDecl (sp (JSIdentifier nm))

405+ [ NN (JSVarDecl (sp (JSIdentifier nm))

406 [ sp (JSLiteral "=")

407 , moduleReference sp (moduleName req)

408 ])

409 ]

410 (nt (JSLiteral ";"))) ]

411 declToJS (ExportsList exps) = map toExport exps

412−

412+

413− where

413+ where

414 toExport :: (ExportType, String, JSNode, [Key]) -> JSNode

415 toExport (_, nm, val, _) =

416− NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]

416+ NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]

417− (nt (JSLiteral "["))

417+ (nt (JSLiteral "["))

418 (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))

419 (nt (JSLiteral "]")))

420 , NN (JSOperator (sp (JSLiteral "=")))

421 , reindent val

422 , nt (JSLiteral ";")

423 ])

424−

424+

425 reindent :: JSNode -> JSNode

426 reindent (NT n _ _) = sp n

427 reindent nn = nn

428−

428+

429 indent :: [JSNode] -> [JSNode]

430 indent = everywhere (mkT squash)

431 where

432 squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)

433 squash nn = nn

434−

434+

435 splat (CommentA pos s) = CommentA (keepCol pos) s

436 splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w

437 splat ann = ann

438−

438+

439 keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)

440−

440+

441 prelude :: [JSNode]

442− prelude =

442+ prelude =

443 [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)

444 , WhiteSpace tokenPosnEmpty "\n"

445− ])

445+ ])

446− [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))

446+ [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))

447 [ sp (JSLiteral "=")

448− , NN (JSObjectLiteral (sp (JSLiteral "{"))

448+ , NN (JSObjectLiteral (sp (JSLiteral "{"))

449 []

450 (sp (JSLiteral "}")))

451 ])

452− ]

452+ ]

453 (nt (JSLiteral ";")))

454 , lf

455 ]

456−

456+

457 moduleReference :: (Node -> JSNode) -> String -> JSNode

458− moduleReference f mn =

458+ moduleReference f mn =

459− NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]

459+ NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]

460− (nt (JSLiteral "["))

460+ (nt (JSLiteral "["))

461 (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))

462 (nt (JSLiteral "]")))

463−

463+

464 wrap :: String -> [JSNode] -> [JSNode]

465− wrap mn ds =

465+ wrap mn ds =

466− [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))

466+ [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))

467− (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))

467+ (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))

468− []

468+ []

469− (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))

469+ (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))

470− (NN (JSBlock [sp (JSLiteral "{")]

470+ (NN (JSBlock [sp (JSLiteral "{")]

471 (lf : ds)

472 [nl (JSLiteral "}")])))]))

473 (nt (JSLiteral ")")))

474− , NN (JSArguments (nt (JSLiteral "("))

474+ , NN (JSArguments (nt (JSLiteral "("))

475 [ NN (JSExpression [ moduleReference nt mn

476 , NN (JSOperator (sp (JSLiteral "=")))

477 , NN (JSExpressionBinary "||"

478− [ moduleReference sp mn ]

478+ [ moduleReference sp mn ]

479− (sp (JSLiteral "||"))

479+ (sp (JSLiteral "||"))

480− [ emptyObj ])

480+ [ emptyObj ])

481 ])

482 ]

483 (nt (JSLiteral ")")))

487 ]

488 where

489 emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))

490−

490+

491 runMain :: String -> [JSNode]

492− runMain mn =

492+ runMain mn =

493− [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]

493+ [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]

494− (nt (JSLiteral "["))

494+ (nt (JSLiteral "["))

495− (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))

495+ (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))

496 (nt (JSLiteral "]")))

497− ]

497+ ]

498− (nt (JSLiteral "."))

498+ (nt (JSLiteral "."))

499 (nt (JSIdentifier "main")))

500 , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")")))

501 ])

502 , nt (JSLiteral ";")

503 ]

504−

504+

505 nt :: Node -> JSNode

506 nt n = NT n tokenPosnEmpty []

507−

507+

508 lf :: JSNode

509 lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]

510−

510+

511 sp :: Node -> JSNode

512 sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]

513−

513+

514 nl :: Node -> JSNode

515 nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]

516

529 return (ident, ast)

530

531 let mids = S.fromList (map (moduleName . fst) input)

532−

532+

533 modules <- mapM (fmap withDeps . uncurry (toModule mids)) input

534−

534+

535 let compiled = compile modules entryPoints

536 sorted = sortModules (filter (not . isModuleEmpty) compiled)

537−

537+

538 return (codeGen mainModule namespace sorted)