@@ -13,6 +13,8 @@ import Prelude.Compat
1313import Control.Monad
1414import Control.Monad.Trans.State.Strict (execState)
1515import Control.Monad.State.Class (MonadState, gets, modify)
16+import Control.Monad.Trans.Reader (runReaderT)
17+import Control.Monad.Reader.Class (MonadReader, ask)
1618import Control.Arrow ((&&&), first, second)
1719import Data.Either
1820import Data.Maybe (mapMaybe)
@@ -76,9 +78,12 @@ getReExports env mn =
7678 case Map.lookup mn env of
7779 Nothing ->
7880 internalError ("Module missing: " ++ P.runModuleName mn)
79− Just (_, imports, exports) ->
80− let notLocal = (/= mn) . fst
81− in filter notLocal <$> collectDeclarations imports exports
81+ Just (_, imports, exports) -> do
82+ allExports <- runReaderT (collectDeclarations imports exports) mn
83+ pure (filter notLocal allExports)
84+
85+ where
86+ notLocal = (/= mn) . fst
8287
8388-- |
8489-- Assemble a list of declarations re-exported from a particular module, based
@@ -100,7 +105,9 @@ getReExports env mn =
100105-- class members are listed.
101106--
102107collectDeclarations ::
103− (Functor m, Applicative m, MonadState (Map P.ModuleName Module) m) =>
108+ (Functor m, Applicative m,
109+ MonadState (Map P.ModuleName Module) m,
110+ MonadReader P.ModuleName m) =>
104111 P.Imports ->
105112 P.Exports ->
106113 m [(P.ModuleName, [Declaration])]
@@ -109,7 +116,7 @@ collectDeclarations imports exports = do
109116 typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs
110117 types <- collect lookupTypeDeclaration impTypes expTypes
111118
112− let (vals, classes) = handleTypeClassMembers valsAndMembers typeClasses
119+ (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses
113120
114121 let filteredTypes = filterDataConstructors expCtors types
115122 let filteredClasses = filterTypeClassMembers (map fst expVals) classes
@@ -117,9 +124,9 @@ collectDeclarations imports exports = do
117124 pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))
118125
119126 where
120− collect lookup' imps exps =
121− Map.fromListWith (<>) <$> traverse (uncurry lookup')
122− (map (findImport imps) exps)
127+ collect lookup' imps exps = do
128+ imps' <- traverse (findImport imps) exps
129+ Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'
123130
124131 expVals = P.exportedValues exports
125132 impVals = concat (Map.elems (P.importedValues imports))
@@ -147,19 +154,21 @@ collectDeclarations imports exports = do
147154-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.
148155--
149156findImport ::
150− (Show name, Eq name) =>
157+ (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) =>
151158 [(P.Qualified name, P.ModuleName)] ->
152159 (name, P.ModuleName) ->
153− (P.ModuleName, name)
160+ m (P.ModuleName, name)
154161findImport imps (name, orig) =
155162 case filter (\(qual, mn) -> P.disqualify qual == name && mn == orig) imps of
156163 [(P.Qualified (Just importedFrom) _, _)] ->
157− (importedFrom, name)
164+ pure (importedFrom, name)
158165 other ->
159− internalError ("findImport: unexpected result: " ++ show other)
166+ internalErrorInModule ("findImport: unexpected result: " ++ show other)
160167
161168lookupValueDeclaration ::
162− (MonadState (Map P.ModuleName Module) m, Applicative m) =>
169+ (Applicative m,
170+ MonadState (Map P.ModuleName Module) m,
171+ MonadReader P.ModuleName m) =>
163172 P.ModuleName ->
164173 P.Ident ->
165174 m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])
@@ -170,7 +179,7 @@ lookupValueDeclaration importedFrom ident = do
170179 filter (\d -> declTitle d == P.showIdent ident
171180 && (isValue d || isAlias d)) decls
172181 errOther other =
173− internalError
182+ internalErrorInModule
174183 ("lookupValueDeclaration: unexpected result:\n" ++
175184 "other: " ++ show other ++ "\n" ++
176185 "ident: " ++ show ident ++ "\n" ++
@@ -216,7 +225,9 @@ lookupValueDeclaration importedFrom ident = do
216225-- are only included in the output if they are listed in the arguments.
217226--
218227lookupTypeDeclaration ::
219− (MonadState (Map P.ModuleName Module) m, Applicative m) =>
228+ (Applicative m,
229+ MonadState (Map P.ModuleName Module) m,
230+ MonadReader P.ModuleName m) =>
220231 P.ModuleName ->
221232 P.ProperName 'P.TypeName ->
222233 m (P.ModuleName, [Declaration])
@@ -228,11 +239,13 @@ lookupTypeDeclaration importedFrom ty = do
228239 [d] ->
229240 pure (importedFrom, [d])
230241 other ->
231− internalError
242+ internalErrorInModule
232243 ("lookupTypeDeclaration: unexpected result: " ++ show other)
233244
234245lookupTypeClassDeclaration ::
235− (MonadState (Map P.ModuleName Module) m, Applicative m) =>
246+ (Applicative m,
247+ MonadState (Map P.ModuleName Module) m,
248+ MonadReader P.ModuleName m) =>
236249 P.ModuleName ->
237250 P.ProperName 'P.ClassName ->
238251 m (P.ModuleName, [Declaration])
@@ -246,15 +259,18 @@ lookupTypeClassDeclaration importedFrom tyClass = do
246259 [d] ->
247260 pure (importedFrom, [d])
248261 other ->
249− internalError ("lookupTypeClassDeclaration: unexpected result: "
250− ++ (unlines . map show) other)
262+ internalErrorInModule
263+ ("lookupTypeClassDeclaration: unexpected result: "
264+ ++ (unlines . map show) other)
251265
252266-- |
253267-- Get the full list of declarations for a particular module out of the
254268-- state, or raise an internal error if it is not there.
255269--
256270lookupModuleDeclarations ::
257− (Applicative m, MonadState (Map P.ModuleName Module) m) =>
271+ (Applicative m,
272+ MonadState (Map P.ModuleName Module) m,
273+ MonadReader P.ModuleName m) =>
258274 String ->
259275 P.ModuleName ->
260276 m [Declaration]
@@ -262,15 +278,18 @@ lookupModuleDeclarations definedIn moduleName = do
262278 mmdl <- gets (Map.lookup moduleName)
263279 case mmdl of
264280 Nothing ->
265− internalError (definedIn ++ ": module missing: "
266− ++ P.runModuleName moduleName)
281+ internalErrorInModule
282+ (definedIn ++ ": module missing: "
283+ ++ P.runModuleName moduleName)
267284 Just mdl ->
268285 pure (allDeclarations mdl)
269286
270287handleTypeClassMembers ::
288+ (Functor m, Applicative m,
289+ MonadReader P.ModuleName m) =>
271290 Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->
272291 Map P.ModuleName [Declaration] ->
273− (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
292+ m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
274293handleTypeClassMembers valsAndMembers typeClasses =
275294 let
276295 moduleEnvs =
@@ -279,8 +298,8 @@ handleTypeClassMembers valsAndMembers typeClasses =
279298 (fmap typeClassesToEnv typeClasses)
280299 in
281300 moduleEnvs
282− |> fmap handleEnv
283− |> splitMap
301+ |> traverse handleEnv
302+ |> fmap splitMap
284303
285304valsAndMembersToEnv ::
286305 [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv
@@ -336,11 +355,15 @@ instance Monoid TypeClassEnv where
336355--
337356-- Returns a tuple of (values, type classes).
338357--
339−handleEnv :: TypeClassEnv -> ([Declaration], [Declaration])
358+handleEnv ::
359+ (Functor m, Applicative m,
360+ MonadReader P.ModuleName m) =>
361+ TypeClassEnv ->
362+ m ([Declaration], [Declaration])
340363handleEnv TypeClassEnv{..} =
341364 envUnhandledMembers
342− |> foldl go (envValues, mkMap envTypeClasses)
343− |> second Map.elems
365+ |> foldM go (envValues, mkMap envTypeClasses)
366+ |> fmap (second Map.elems)
344367
345368 where
346369 mkMap =
@@ -351,14 +374,15 @@ handleEnv TypeClassEnv{..} =
351374 Just _ ->
352375 -- Leave the state unchanged; if the type class is there, the child
353376 -- will be too.
354− (values, tcs)
355− Nothing ->
356− (promoteChild constraint childDecl : values, tcs)
377+ pure (values, tcs)
378+ Nothing -> do
379+ c <- promoteChild constraint childDecl
380+ pure (c : values, tcs)
357381
358382 promoteChild constraint ChildDeclaration{..} =
359383 case cdeclInfo of
360384 ChildTypeClassMember typ ->
361− Declaration
385+ pure $ Declaration
362386 { declTitle = cdeclTitle
363387 , declComments = cdeclComments
364388 , declSourceSpan = cdeclSourceSpan
@@ -367,7 +391,7 @@ handleEnv TypeClassEnv{..} =
367391 , declInfo = ValueDeclaration (addConstraint constraint typ)
368392 }
369393 _ ->
370− internalError
394+ internalErrorInModule
371395 ("handleEnv: Bad child declaration passed to promoteChild: "
372396 ++ cdeclTitle)
373397
@@ -429,6 +453,16 @@ x |> f = f x
429453internalError :: String -> a
430454internalError = P.internalError . ("Docs.Convert.ReExports: " ++)
431455
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+
432466-- |
433467-- If the provided Declaration is a TypeClassDeclaration, construct an
434468-- appropriate Constraint for use with the types of its members.