@@ -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,29 @@ 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) =
155− case filter (\(qual, mn) -> P.disqualify qual == name && mn == orig) imps of
156− [(P.Qualified (Just importedFrom) _, _)] ->
157− (importedFrom, name)
158− other ->
159− internalError ("findImport: unexpected result: " ++ show other)
162+ let
163+ matches (qual, mn) = P.disqualify qual == name && mn == orig
164+ matching = filter matches imps
165+ getQualified (P.Qualified mname _) = mname
166+ in
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))
160175
161176lookupValueDeclaration ::
162− (MonadState (Map P.ModuleName Module) m, Applicative m) =>
177+ (Applicative m,
178+ MonadState (Map P.ModuleName Module) m,
179+ MonadReader P.ModuleName m) =>
163180 P.ModuleName ->
164181 P.Ident ->
165182 m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])
@@ -170,7 +187,7 @@ lookupValueDeclaration importedFrom ident = do
170187 filter (\d -> declTitle d == P.showIdent ident
171188 && (isValue d || isAlias d)) decls
172189 errOther other =
173− internalError
190+ internalErrorInModule
174191 ("lookupValueDeclaration: unexpected result:\n" ++
175192 "other: " ++ show other ++ "\n" ++
176193 "ident: " ++ show ident ++ "\n" ++
@@ -216,7 +233,9 @@ lookupValueDeclaration importedFrom ident = do
216233-- are only included in the output if they are listed in the arguments.
217234--
218235lookupTypeDeclaration ::
219− (MonadState (Map P.ModuleName Module) m, Applicative m) =>
236+ (Applicative m,
237+ MonadState (Map P.ModuleName Module) m,
238+ MonadReader P.ModuleName m) =>
220239 P.ModuleName ->
221240 P.ProperName 'P.TypeName ->
222241 m (P.ModuleName, [Declaration])
@@ -228,11 +247,13 @@ lookupTypeDeclaration importedFrom ty = do
228247 [d] ->
229248 pure (importedFrom, [d])
230249 other ->
231− internalError
250+ internalErrorInModule
232251 ("lookupTypeDeclaration: unexpected result: " ++ show other)
233252
234253lookupTypeClassDeclaration ::
235− (MonadState (Map P.ModuleName Module) m, Applicative m) =>
254+ (Applicative m,
255+ MonadState (Map P.ModuleName Module) m,
256+ MonadReader P.ModuleName m) =>
236257 P.ModuleName ->
237258 P.ProperName 'P.ClassName ->
238259 m (P.ModuleName, [Declaration])
@@ -246,15 +267,18 @@ lookupTypeClassDeclaration importedFrom tyClass = do
246267 [d] ->
247268 pure (importedFrom, [d])
248269 other ->
249− internalError ("lookupTypeClassDeclaration: unexpected result: "
250− ++ (unlines . map show) other)
270+ internalErrorInModule
271+ ("lookupTypeClassDeclaration: unexpected result: "
272+ ++ (unlines . map show) other)
251273
252274-- |
253275-- Get the full list of declarations for a particular module out of the
254276-- state, or raise an internal error if it is not there.
255277--
256278lookupModuleDeclarations ::
257− (Applicative m, MonadState (Map P.ModuleName Module) m) =>
279+ (Applicative m,
280+ MonadState (Map P.ModuleName Module) m,
281+ MonadReader P.ModuleName m) =>
258282 String ->
259283 P.ModuleName ->
260284 m [Declaration]
@@ -262,15 +286,18 @@ lookupModuleDeclarations definedIn moduleName = do
262286 mmdl <- gets (Map.lookup moduleName)
263287 case mmdl of
264288 Nothing ->
265− internalError (definedIn ++ ": module missing: "
266− ++ P.runModuleName moduleName)
289+ internalErrorInModule
290+ (definedIn ++ ": module missing: "
291+ ++ P.runModuleName moduleName)
267292 Just mdl ->
268293 pure (allDeclarations mdl)
269294
270295handleTypeClassMembers ::
296+ (Functor m, Applicative m,
297+ MonadReader P.ModuleName m) =>
271298 Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->
272299 Map P.ModuleName [Declaration] ->
273− (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
300+ m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
274301handleTypeClassMembers valsAndMembers typeClasses =
275302 let
276303 moduleEnvs =
@@ -279,8 +306,8 @@ handleTypeClassMembers valsAndMembers typeClasses =
279306 (fmap typeClassesToEnv typeClasses)
280307 in
281308 moduleEnvs
282− |> fmap handleEnv
283− |> splitMap
309+ |> traverse handleEnv
310+ |> fmap splitMap
284311
285312valsAndMembersToEnv ::
286313 [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv
@@ -336,11 +363,15 @@ instance Monoid TypeClassEnv where
336363--
337364-- Returns a tuple of (values, type classes).
338365--
339−handleEnv :: TypeClassEnv -> ([Declaration], [Declaration])
366+handleEnv ::
367+ (Functor m, Applicative m,
368+ MonadReader P.ModuleName m) =>
369+ TypeClassEnv ->
370+ m ([Declaration], [Declaration])
340371handleEnv TypeClassEnv{..} =
341372 envUnhandledMembers
342− |> foldl go (envValues, mkMap envTypeClasses)
343− |> second Map.elems
373+ |> foldM go (envValues, mkMap envTypeClasses)
374+ |> fmap (second Map.elems)
344375
345376 where
346377 mkMap =
@@ -351,14 +382,15 @@ handleEnv TypeClassEnv{..} =
351382 Just _ ->
352383 -- Leave the state unchanged; if the type class is there, the child
353384 -- will be too.
354− (values, tcs)
355− Nothing ->
356− (promoteChild constraint childDecl : values, tcs)
385+ pure (values, tcs)
386+ Nothing -> do
387+ c <- promoteChild constraint childDecl
388+ pure (c : values, tcs)
357389
358390 promoteChild constraint ChildDeclaration{..} =
359391 case cdeclInfo of
360392 ChildTypeClassMember typ ->
361− Declaration
393+ pure $ Declaration
362394 { declTitle = cdeclTitle
363395 , declComments = cdeclComments
364396 , declSourceSpan = cdeclSourceSpan
@@ -367,7 +399,7 @@ handleEnv TypeClassEnv{..} =
367399 , declInfo = ValueDeclaration (addConstraint constraint typ)
368400 }
369401 _ ->
370− internalError
402+ internalErrorInModule
371403 ("handleEnv: Bad child declaration passed to promoteChild: "
372404 ++ cdeclTitle)
373405
@@ -429,6 +461,16 @@ x |> f = f x
429461internalError :: String -> a
430462internalError = P.internalError . ("Docs.Convert.ReExports: " ++)
431463
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+
432474-- |
433475-- If the provided Declaration is a TypeClassDeclaration, construct an
434476-- appropriate Constraint for use with the types of its members.