1b948d0 · rowtype-yoga/purescript-native

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

on golang help sign in

Include module name in re-exports internal errors

1b948d0Harry Garrood11 years ago

src/Language/PureScript/Docs/Convert/ReExports.hs+67−33

compare with golang

unifiedsplit

@@ -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,21 @@ 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) =

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

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

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

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

157− (importedFrom, name)

164+ pure (importedFrom, name)

158 other ->

165 other ->

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

166+ internalErrorInModule ("findImport: unexpected result: " ++ show other)

160

167

161lookupValueDeclaration ::

168lookupValueDeclaration ::

169+ (Applicative m,

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

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

171+ MonadReader P.ModuleName m) =>

163 P.ModuleName ->

172 P.ModuleName ->

164 P.Ident ->

173 P.Ident ->

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

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

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

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

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

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

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

172 errOther other =

181 errOther other =

173− internalError

182+ internalErrorInModule

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

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

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

184 "other: " ++ show other ++ "\n" ++

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

185 "ident: " ++ show ident ++ "\n" ++

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

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

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

217--

226--

218lookupTypeDeclaration ::

227lookupTypeDeclaration ::

228+ (Applicative m,

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

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

230+ MonadReader P.ModuleName m) =>

220 P.ModuleName ->

231 P.ModuleName ->

221 P.ProperName 'P.TypeName ->

232 P.ProperName 'P.TypeName ->

222 m (P.ModuleName, [Declaration])

233 m (P.ModuleName, [Declaration])

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

228 [d] ->

239 [d] ->

229 pure (importedFrom, [d])

240 pure (importedFrom, [d])

230 other ->

241 other ->

231− internalError

242+ internalErrorInModule

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

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

233

244

234lookupTypeClassDeclaration ::

245lookupTypeClassDeclaration ::

246+ (Applicative m,

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

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

248+ MonadReader P.ModuleName m) =>

236 P.ModuleName ->

249 P.ModuleName ->

237 P.ProperName 'P.ClassName ->

250 P.ProperName 'P.ClassName ->

238 m (P.ModuleName, [Declaration])

251 m (P.ModuleName, [Declaration])

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

246 [d] ->

259 [d] ->

247 pure (importedFrom, [d])

260 pure (importedFrom, [d])

248 other ->

261 other ->

262+ internalErrorInModule

249− internalError ("lookupTypeClassDeclaration: unexpected result: "

263+ ("lookupTypeClassDeclaration: unexpected result: "

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

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

251

265

252-- |

266-- |

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

267-- 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.

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

255--

269--

256lookupModuleDeclarations ::

270lookupModuleDeclarations ::

271+ (Applicative m,

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

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

273+ MonadReader P.ModuleName m) =>

258 String ->

274 String ->

259 P.ModuleName ->

275 P.ModuleName ->

260 m [Declaration]

276 m [Declaration]

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

262 mmdl <- gets (Map.lookup moduleName)

278 mmdl <- gets (Map.lookup moduleName)

263 case mmdl of

279 case mmdl of

264 Nothing ->

280 Nothing ->

281+ internalErrorInModule

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

282+ (definedIn ++ ": module missing: "

266− ++ P.runModuleName moduleName)

283+ ++ P.runModuleName moduleName)

267 Just mdl ->

284 Just mdl ->

268 pure (allDeclarations mdl)

285 pure (allDeclarations mdl)

269

286

270handleTypeClassMembers ::

287handleTypeClassMembers ::

288+ (Functor m, Applicative m,

289+ MonadReader P.ModuleName m) =>

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

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

272 Map P.ModuleName [Declaration] ->

291 Map P.ModuleName [Declaration] ->

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

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

274handleTypeClassMembers valsAndMembers typeClasses =

293handleTypeClassMembers valsAndMembers typeClasses =

275 let

294 let

276 moduleEnvs =

295 moduleEnvs =

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

279 (fmap typeClassesToEnv typeClasses)

298 (fmap typeClassesToEnv typeClasses)

280 in

299 in

281 moduleEnvs

300 moduleEnvs

282− |> fmap handleEnv

301+ |> traverse handleEnv

283− |> splitMap

302+ |> fmap splitMap

284

303

285valsAndMembersToEnv ::

304valsAndMembersToEnv ::

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

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

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

336--

355--

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

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

338--

357--

358+handleEnv ::

359+ (Functor m, Applicative m,

360+ MonadReader P.ModuleName m) =>

361+ TypeClassEnv ->

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

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

340handleEnv TypeClassEnv{..} =

363handleEnv TypeClassEnv{..} =

341 envUnhandledMembers

364 envUnhandledMembers

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

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

343− |> second Map.elems

366+ |> fmap (second Map.elems)

344

367

345 where

368 where

346 mkMap =

369 mkMap =

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

351 Just _ ->

374 Just _ ->

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

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

353 -- will be too.

376 -- will be too.

354− (values, tcs)

377+ pure (values, tcs)

355− Nothing ->

378+ Nothing -> do

356− (promoteChild constraint childDecl : values, tcs)

379+ c <- promoteChild constraint childDecl

380+ pure (c : values, tcs)

357

381

358 promoteChild constraint ChildDeclaration{..} =

382 promoteChild constraint ChildDeclaration{..} =

359 case cdeclInfo of

383 case cdeclInfo of

360 ChildTypeClassMember typ ->

384 ChildTypeClassMember typ ->

361− Declaration

385+ pure $ Declaration

362 { declTitle = cdeclTitle

386 { declTitle = cdeclTitle

363 , declComments = cdeclComments

387 , declComments = cdeclComments

364 , declSourceSpan = cdeclSourceSpan

388 , declSourceSpan = cdeclSourceSpan

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

367 , declInfo = ValueDeclaration (addConstraint constraint typ)

391 , declInfo = ValueDeclaration (addConstraint constraint typ)

368 }

392 }

369 _ ->

393 _ ->

370− internalError

394+ internalErrorInModule

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

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

372 ++ cdeclTitle)

396 ++ cdeclTitle)

373

397

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

429internalError :: String -> a

453internalError :: String -> a

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

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

431

455

456+internalErrorInModule ::

457+ (MonadReader P.ModuleName m) =>

458+ String ->

459+ m a

460+internalErrorInModule msg = do

461+ mn <- ask

462+ internalError

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

464+ ", " ++ msg)

465+

432-- |

466-- |

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

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

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

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