64350ef · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #1832 from hdgarrood/reexports-docs-improvements

64350efPhil Freeman11 years ago

examples/docs/src/ImportedTwice.pursnew file+27

compare with golang

unifiedsplit

@@ -0,0 +1,27 @@

1+-- See also an example in the wild: purescript-transformers v0.8.4.

2+-- Control.Monad.RWS.Trans re-exports `lift` from both Control.Monad.Trans

3+-- (where it is originally defined) and Control.Monad.RWS.Class (which

4+-- re-exports it from Control.Monad.Trans).

6+module ImportedTwice

7+ ( module A

8+ , module B

9+ )

10+ where

11+

12+import A

13+import B

14+

15+module A

16+ ( module B )

17+ where

18+

19+import B

20+

21+bar :: Int

22+bar = 1

23+

24+module B where

25+

26+foo :: Int

27+foo = 0

src/Language/PureScript/Docs/Convert/ReExports.hs+78−36

@@ -13,6 +13,8 @@ import Prelude.Compat

13import Control.Monad

14import Control.Monad.Trans.State.Strict (execState)

15import Control.Monad.State.Class (MonadState, gets, modify)

16+import Control.Monad.Trans.Reader (runReaderT)

17+import Control.Monad.Reader.Class (MonadReader, ask)

16import Control.Arrow ((&&&), first, second)

18import Control.Arrow ((&&&), first, second)

17import Data.Either

19import Data.Either

18import Data.Maybe (mapMaybe)

20import Data.Maybe (mapMaybe)

@@ -76,9 +78,12 @@ getReExports env mn =

76 case Map.lookup mn env of

78 case Map.lookup mn env of

77 Nothing ->

79 Nothing ->

78 internalError ("Module missing: " ++ P.runModuleName mn)

80 internalError ("Module missing: " ++ P.runModuleName mn)

79− Just (_, imports, exports) ->

81+ Just (_, imports, exports) -> do

82+ allExports <- runReaderT (collectDeclarations imports exports) mn

83+ pure (filter notLocal allExports)

84+

85+ where

80− let notLocal = (/= mn) . fst

86+ notLocal = (/= mn) . fst

81− in filter notLocal <$> collectDeclarations imports exports

83-- |

88-- |

84-- Assemble a list of declarations re-exported from a particular module, based

89-- Assemble a list of declarations re-exported from a particular module, based

@@ -100,7 +105,9 @@ getReExports env mn =

100-- class members are listed.

105-- class members are listed.

101--

106--

102collectDeclarations ::

107collectDeclarations ::

108+ (Functor m, Applicative m,

103− (Functor m, Applicative m, MonadState (Map P.ModuleName Module) m) =>

109+ MonadState (Map P.ModuleName Module) m,

110+ MonadReader P.ModuleName m) =>

104 P.Imports ->

111 P.Imports ->

105 P.Exports ->

112 P.Exports ->

106 m [(P.ModuleName, [Declaration])]

113 m [(P.ModuleName, [Declaration])]

@@ -109,7 +116,7 @@ collectDeclarations imports exports = do

109 typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

116 typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

110 types <- collect lookupTypeDeclaration impTypes expTypes

117 types <- collect lookupTypeDeclaration impTypes expTypes

111

118

112− let (vals, classes) = handleTypeClassMembers valsAndMembers typeClasses

119+ (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

113

120

114 let filteredTypes = filterDataConstructors expCtors types

121 let filteredTypes = filterDataConstructors expCtors types

115 let filteredClasses = filterTypeClassMembers (map fst expVals) classes

122 let filteredClasses = filterTypeClassMembers (map fst expVals) classes

@@ -117,9 +124,9 @@ collectDeclarations imports exports = do

117 pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))

124 pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))

118

125

119 where

126 where

120− collect lookup' imps exps =

127+ collect lookup' imps exps = do

128+ imps' <- traverse (findImport imps) exps

121− Map.fromListWith (<>) <$> traverse (uncurry lookup')

129+ Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'

122− (map (findImport imps) exps)

123

130

124 expVals = P.exportedValues exports

131 expVals = P.exportedValues exports

125 impVals = concat (Map.elems (P.importedValues imports))

132 impVals = concat (Map.elems (P.importedValues imports))

@@ -147,19 +154,29 @@ collectDeclarations imports exports = do

147-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.

154-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.

148--

155--

149findImport ::

156findImport ::

150− (Show name, Eq name) =>

157+ (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) =>

151 [(P.Qualified name, P.ModuleName)] ->

158 [(P.Qualified name, P.ModuleName)] ->

152 (name, P.ModuleName) ->

159 (name, P.ModuleName) ->

153− (P.ModuleName, name)

160+ m (P.ModuleName, name)

154findImport imps (name, orig) =

161findImport imps (name, orig) =

162+ let

155− case filter (\(qual, mn) -> P.disqualify qual == name && mn == orig) imps of

163+ matches (qual, mn) = P.disqualify qual == name && mn == orig

156− [(P.Qualified (Just importedFrom) _, _)] ->

164+ matching = filter matches imps

157− (importedFrom, name)

165+ getQualified (P.Qualified mname _) = mname

158− other ->

166+ in

159− internalError ("findImport: unexpected result: " ++ show other)

167+ case mapMaybe (getQualified . fst) matching of

168+ -- A value can occur more than once if it is imported twice (eg, if it is

169+ -- exported by A, re-exported from A by B, and C imports it from both A

170+ -- and B). In this case, we just take its first appearance.

171+ (importedFrom:_) ->

172+ pure (importedFrom, name)

173+ [] ->

174+ internalErrorInModule ("findImport: not found: " ++ show (name, orig))

160

175

161lookupValueDeclaration ::

176lookupValueDeclaration ::

177+ (Applicative m,

162− (MonadState (Map P.ModuleName Module) m, Applicative m) =>

178+ MonadState (Map P.ModuleName Module) m,

179+ MonadReader P.ModuleName m) =>

163 P.ModuleName ->

180 P.ModuleName ->

164 P.Ident ->

181 P.Ident ->

165 m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])

182 m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])

@@ -170,7 +187,7 @@ lookupValueDeclaration importedFrom ident = do

170 filter (\d -> declTitle d == P.showIdent ident

187 filter (\d -> declTitle d == P.showIdent ident

171 && (isValue d || isAlias d)) decls

188 && (isValue d || isAlias d)) decls

172 errOther other =

189 errOther other =

173− internalError

190+ internalErrorInModule

174 ("lookupValueDeclaration: unexpected result:\n" ++

191 ("lookupValueDeclaration: unexpected result:\n" ++

175 "other: " ++ show other ++ "\n" ++

192 "other: " ++ show other ++ "\n" ++

176 "ident: " ++ show ident ++ "\n" ++

193 "ident: " ++ show ident ++ "\n" ++

@@ -216,7 +233,9 @@ lookupValueDeclaration importedFrom ident = do

216-- are only included in the output if they are listed in the arguments.

233-- are only included in the output if they are listed in the arguments.

217--

234--

218lookupTypeDeclaration ::

235lookupTypeDeclaration ::

236+ (Applicative m,

219− (MonadState (Map P.ModuleName Module) m, Applicative m) =>

237+ MonadState (Map P.ModuleName Module) m,

238+ MonadReader P.ModuleName m) =>

220 P.ModuleName ->

239 P.ModuleName ->

221 P.ProperName 'P.TypeName ->

240 P.ProperName 'P.TypeName ->

222 m (P.ModuleName, [Declaration])

241 m (P.ModuleName, [Declaration])

@@ -228,11 +247,13 @@ lookupTypeDeclaration importedFrom ty = do

228 [d] ->

247 [d] ->

229 pure (importedFrom, [d])

248 pure (importedFrom, [d])

230 other ->

249 other ->

231− internalError

250+ internalErrorInModule

232 ("lookupTypeDeclaration: unexpected result: " ++ show other)

251 ("lookupTypeDeclaration: unexpected result: " ++ show other)

233

252

234lookupTypeClassDeclaration ::

253lookupTypeClassDeclaration ::

254+ (Applicative m,

235− (MonadState (Map P.ModuleName Module) m, Applicative m) =>

255+ MonadState (Map P.ModuleName Module) m,

256+ MonadReader P.ModuleName m) =>

236 P.ModuleName ->

257 P.ModuleName ->

237 P.ProperName 'P.ClassName ->

258 P.ProperName 'P.ClassName ->

238 m (P.ModuleName, [Declaration])

259 m (P.ModuleName, [Declaration])

@@ -246,15 +267,18 @@ lookupTypeClassDeclaration importedFrom tyClass = do

246 [d] ->

267 [d] ->

247 pure (importedFrom, [d])

268 pure (importedFrom, [d])

248 other ->

269 other ->

270+ internalErrorInModule

249− internalError ("lookupTypeClassDeclaration: unexpected result: "

271+ ("lookupTypeClassDeclaration: unexpected result: "

250− ++ (unlines . map show) other)

272+ ++ (unlines . map show) other)

251

273

252-- |

274-- |

253-- Get the full list of declarations for a particular module out of the

275-- Get the full list of declarations for a particular module out of the

254-- state, or raise an internal error if it is not there.

276-- state, or raise an internal error if it is not there.

255--

277--

256lookupModuleDeclarations ::

278lookupModuleDeclarations ::

279+ (Applicative m,

257− (Applicative m, MonadState (Map P.ModuleName Module) m) =>

280+ MonadState (Map P.ModuleName Module) m,

281+ MonadReader P.ModuleName m) =>

258 String ->

282 String ->

259 P.ModuleName ->

283 P.ModuleName ->

260 m [Declaration]

284 m [Declaration]

@@ -262,15 +286,18 @@ lookupModuleDeclarations definedIn moduleName = do

262 mmdl <- gets (Map.lookup moduleName)

286 mmdl <- gets (Map.lookup moduleName)

263 case mmdl of

287 case mmdl of

264 Nothing ->

288 Nothing ->

289+ internalErrorInModule

265− internalError (definedIn ++ ": module missing: "

290+ (definedIn ++ ": module missing: "

266− ++ P.runModuleName moduleName)

291+ ++ P.runModuleName moduleName)

267 Just mdl ->

292 Just mdl ->

268 pure (allDeclarations mdl)

293 pure (allDeclarations mdl)

269

294

270handleTypeClassMembers ::

295handleTypeClassMembers ::

296+ (Functor m, Applicative m,

297+ MonadReader P.ModuleName m) =>

271 Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->

298 Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->

272 Map P.ModuleName [Declaration] ->

299 Map P.ModuleName [Declaration] ->

273− (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])

300+ m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])

274handleTypeClassMembers valsAndMembers typeClasses =

301handleTypeClassMembers valsAndMembers typeClasses =

275 let

302 let

276 moduleEnvs =

303 moduleEnvs =

@@ -279,8 +306,8 @@ handleTypeClassMembers valsAndMembers typeClasses =

279 (fmap typeClassesToEnv typeClasses)

306 (fmap typeClassesToEnv typeClasses)

280 in

307 in

281 moduleEnvs

308 moduleEnvs

282− |> fmap handleEnv

309+ |> traverse handleEnv

283− |> splitMap

310+ |> fmap splitMap

284

311

285valsAndMembersToEnv ::

312valsAndMembersToEnv ::

286 [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv

313 [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv

@@ -336,11 +363,15 @@ instance Monoid TypeClassEnv where

336--

363--

337-- Returns a tuple of (values, type classes).

364-- Returns a tuple of (values, type classes).

338--

365--

366+handleEnv ::

367+ (Functor m, Applicative m,

368+ MonadReader P.ModuleName m) =>

369+ TypeClassEnv ->

339−handleEnv :: TypeClassEnv -> ([Declaration], [Declaration])

370+ m ([Declaration], [Declaration])

340handleEnv TypeClassEnv{..} =

371handleEnv TypeClassEnv{..} =

341 envUnhandledMembers

372 envUnhandledMembers

342− |> foldl go (envValues, mkMap envTypeClasses)

373+ |> foldM go (envValues, mkMap envTypeClasses)

343− |> second Map.elems

374+ |> fmap (second Map.elems)

344

375

345 where

376 where

346 mkMap =

377 mkMap =

@@ -351,14 +382,15 @@ handleEnv TypeClassEnv{..} =

351 Just _ ->

382 Just _ ->

352 -- Leave the state unchanged; if the type class is there, the child

383 -- Leave the state unchanged; if the type class is there, the child

353 -- will be too.

384 -- will be too.

354− (values, tcs)

385+ pure (values, tcs)

355− Nothing ->

386+ Nothing -> do

356− (promoteChild constraint childDecl : values, tcs)

387+ c <- promoteChild constraint childDecl

388+ pure (c : values, tcs)

357

389

358 promoteChild constraint ChildDeclaration{..} =

390 promoteChild constraint ChildDeclaration{..} =

359 case cdeclInfo of

391 case cdeclInfo of

360 ChildTypeClassMember typ ->

392 ChildTypeClassMember typ ->

361− Declaration

393+ pure $ Declaration

362 { declTitle = cdeclTitle

394 { declTitle = cdeclTitle

363 , declComments = cdeclComments

395 , declComments = cdeclComments

364 , declSourceSpan = cdeclSourceSpan

396 , declSourceSpan = cdeclSourceSpan

@@ -367,7 +399,7 @@ handleEnv TypeClassEnv{..} =

367 , declInfo = ValueDeclaration (addConstraint constraint typ)

399 , declInfo = ValueDeclaration (addConstraint constraint typ)

368 }

400 }

369 _ ->

401 _ ->

370− internalError

402+ internalErrorInModule

371 ("handleEnv: Bad child declaration passed to promoteChild: "

403 ("handleEnv: Bad child declaration passed to promoteChild: "

372 ++ cdeclTitle)

404 ++ cdeclTitle)

373

405

@@ -429,6 +461,16 @@ x |> f = f x

429internalError :: String -> a

461internalError :: String -> a

430internalError = P.internalError . ("Docs.Convert.ReExports: " ++)

462internalError = P.internalError . ("Docs.Convert.ReExports: " ++)

431

463

464+internalErrorInModule ::

465+ (MonadReader P.ModuleName m) =>

466+ String ->

467+ m a

468+internalErrorInModule msg = do

469+ mn <- ask

470+ internalError

471+ ("while collecting re-exports for module: " ++ P.runModuleName mn ++

472+ ", " ++ msg)

473+

432-- |

474-- |

433-- If the provided Declaration is a TypeClassDeclaration, construct an

475-- If the provided Declaration is a TypeClassDeclaration, construct an

434-- appropriate Constraint for use with the types of its members.

476-- appropriate Constraint for use with the types of its members.