@@ -0,0 +1,444 @@
1+{-# LANGUAGE ViewPatterns #-}
2+{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+
6+module Language.PureScript.Docs.Convert.ReExports
7+ ( updateReExports
8+ ) where
9+
10+import Prelude ()
11+import Prelude.Compat
12+
13+import Control.Monad
14+import Control.Monad.Trans.State.Strict (execState)
15+import Control.Monad.State.Class (MonadState, gets, modify)
16+import Control.Arrow ((&&&), first, second)
17+import Data.Either
18+import Data.Maybe (mapMaybe)
19+import Data.Map (Map)
20+import qualified Data.Map as Map
21+import Data.Monoid ((<>))
22+
23+import qualified Language.PureScript as P
24+
25+import Language.PureScript.Docs.Types
26+
27+-- |
28+-- Given:
29+--
30+-- * The Imports/Exports Env
31+-- * An order to traverse the modules (which must be topological)
32+-- * A map of modules, indexed by their names, which are assumed to not
33+-- have their re-exports listed yet
34+--
35+-- This function adds all the missing re-exports.
36+--
37+updateReExports ::
38+ P.Env ->
39+ [P.ModuleName] ->
40+ Map P.ModuleName Module ->
41+ Map P.ModuleName Module
42+updateReExports env order modules =
43+ execState action modules
44+ where
45+ action =
46+ void (traverse go order)
47+
48+ go mn = do
49+ mdl <- lookup' mn
50+ reExports <- getReExports env mn
51+ let mdl' = mdl { modReExports = reExports }
52+ modify (Map.insert mn mdl')
53+
54+ lookup' mn = do
55+ v <- gets (Map.lookup mn)
56+ case v of
57+ Just v' ->
58+ pure v'
59+ Nothing ->
60+ internalError ("Module missing: " ++ P.runModuleName mn)
61+
62+-- |
63+-- Collect all of the re-exported declarations for a single module.
64+--
65+-- We require that modules have already been sorted (P.sortModules) in order to
66+-- ensure that by the time we convert a particular module, all its dependencies
67+-- have already been converted.
68+--
69+getReExports ::
70+ (Functor m, Applicative m,
71+ MonadState (Map P.ModuleName Module) m) =>
72+ P.Env ->
73+ P.ModuleName ->
74+ m [(P.ModuleName, [Declaration])]
75+getReExports env mn =
76+ case Map.lookup mn env of
77+ Nothing ->
78+ internalError ("Module missing: " ++ P.runModuleName mn)
79+ Just (_, imports, exports) ->
80+ let notLocal = (/= mn) . fst
81+ in filter notLocal <$> collectDeclarations imports exports
82+
83+-- |
84+-- Assemble a list of declarations re-exported from a particular module, based
85+-- on the Imports and Exports value for that module, and by extracting the
86+-- declarations from the current state.
87+--
88+-- This function works by searching through the lists of exported declarations
89+-- in the Exports, and looking them up in the associated Imports value to find
90+-- the module they were imported from.
91+--
92+-- Additionally:
93+--
94+-- * Attempts to move re-exported type class members under their parent
95+-- type classes, if possible, or otherwise, "promote" them from
96+-- ChildDeclarations to proper Declarations.
97+-- * Filters data declarations to ensure that only re-exported data
98+-- constructors are listed.
99+-- * Filters type class declarations to ensure that only re-exported type
100+-- class members are listed.
101+--
102+collectDeclarations ::
103+ (Functor m, Applicative m, MonadState (Map P.ModuleName Module) m) =>
104+ P.Imports ->
105+ P.Exports ->
106+ m [(P.ModuleName, [Declaration])]
107+collectDeclarations imports exports = do
108+ valsAndMembers <- collect lookupValueDeclaration impVals expVals
109+ typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs
110+ types <- collect lookupTypeDeclaration impTypes expTypes
111+
112+ let (vals, classes) = handleTypeClassMembers valsAndMembers typeClasses
113+
114+ let filteredTypes = filterDataConstructors expCtors types
115+ let filteredClasses = filterTypeClassMembers (map fst expVals) classes
116+
117+ pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))
118+
119+ where
120+ collect lookup' imps exps =
121+ Map.fromListWith (<>) <$> traverse (uncurry lookup')
122+ (map (findImport imps) exps)
123+
124+ expVals = P.exportedValues exports
125+ impVals = concat (Map.elems (P.importedValues imports))
126+
127+ expTypes = map (first fst) (P.exportedTypes exports)
128+ impTypes = concat (Map.elems (P.importedTypes imports))
129+
130+ expCtors = concatMap (snd . fst) (P.exportedTypes exports)
131+
132+ expTCs = P.exportedTypeClasses exports
133+ impTCs = concat (Map.elems (P.importedTypeClasses imports))
134+
135+-- |
136+-- Given a list of imported declarations (of a particular kind, ie. type, data,
137+-- class, value, etc), and the name of an exported declaration of the same
138+-- kind, together with the module it was originally defined in, return a tuple
139+-- of:
140+--
141+-- * the module that exported declaration was imported from (note that
142+-- this can be different from the module it was originally defined in, if
143+-- it is a re-export),
144+-- * that same declaration's name.
145+--
146+-- This function uses a type variable for names because we want to be able to
147+-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.
148+--
149+findImport ::
150+ (Show name, Eq name) =>
151+ [(P.Qualified name, P.ModuleName)] ->
152+ (name, P.ModuleName) ->
153+ (P.ModuleName, name)
154+findImport 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)
160+
161+lookupValueDeclaration ::
162+ (MonadState (Map P.ModuleName Module) m, Applicative m) =>
163+ P.ModuleName ->
164+ P.Ident ->
165+ m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])
166+lookupValueDeclaration importedFrom ident = do
167+ decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom
168+ let
169+ rs =
170+ filter (\d -> declTitle d == P.showIdent ident
171+ && (isValue d || isAlias d)) decls
172+ errOther other =
173+ internalError
174+ ("lookupValueDeclaration: unexpected result:\n" ++
175+ "other: " ++ show other ++ "\n" ++
176+ "ident: " ++ show ident ++ "\n" ++
177+ "decls: " ++ show decls)
178+
179+ case rs of
180+ [r] ->
181+ pure (importedFrom, [Right r])
182+ [] ->
183+ -- It's a type class member.
184+ -- Note that we need to filter based on the child declaration info using
185+ -- `isTypeClassMember` anyway, because child declarations of type classes
186+ -- are not necessarily members; they could also be instances.
187+ let
188+ allTypeClassChildDecls =
189+ decls
190+ |> mapMaybe (\d -> (d,) <$> typeClassConstraintFor d)
191+ |> concatMap (\(d, constr) ->
192+ map (declTitle d, constr,)
193+ (declChildren d))
194+
195+ matchesIdent cdecl =
196+ cdeclTitle cdecl == P.showIdent ident
197+
198+ matchesAndIsTypeClassMember =
199+ uncurry (&&) . (matchesIdent &&& isTypeClassMember)
200+
201+ in
202+ case filter (matchesAndIsTypeClassMember . thd) allTypeClassChildDecls of
203+ [r'] ->
204+ pure (importedFrom, [Left r'])
205+ other ->
206+ errOther other
207+ other -> do
208+ errOther other
209+
210+ where
211+ thd :: (a, b, c) -> c
212+ thd (_, _, x) = x
213+
214+-- |
215+-- Extract a particular type declaration. For data declarations, constructors
216+-- are only included in the output if they are listed in the arguments.
217+--
218+lookupTypeDeclaration ::
219+ (MonadState (Map P.ModuleName Module) m, Applicative m) =>
220+ P.ModuleName ->
221+ P.ProperName 'P.TypeName ->
222+ m (P.ModuleName, [Declaration])
223+lookupTypeDeclaration importedFrom ty = do
224+ decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom
225+ let
226+ ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls
227+ case ds of
228+ [d] ->
229+ pure (importedFrom, [d])
230+ other ->
231+ internalError
232+ ("lookupTypeDeclaration: unexpected result: " ++ show other)
233+
234+lookupTypeClassDeclaration ::
235+ (MonadState (Map P.ModuleName Module) m, Applicative m) =>
236+ P.ModuleName ->
237+ P.ProperName 'P.ClassName ->
238+ m (P.ModuleName, [Declaration])
239+lookupTypeClassDeclaration importedFrom tyClass = do
240+ decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom
241+ let
242+ ds = filter (\d -> declTitle d == P.runProperName tyClass
243+ && isTypeClass d)
244+ decls
245+ case ds of
246+ [d] ->
247+ pure (importedFrom, [d])
248+ other ->
249+ internalError ("lookupTypeClassDeclaration: unexpected result: "
250+ ++ (unlines . map show) other)
251+
252+-- |
253+-- 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.
255+--
256+lookupModuleDeclarations ::
257+ (Applicative m, MonadState (Map P.ModuleName Module) m) =>
258+ String ->
259+ P.ModuleName ->
260+ m [Declaration]
261+lookupModuleDeclarations definedIn moduleName = do
262+ mmdl <- gets (Map.lookup moduleName)
263+ case mmdl of
264+ Nothing ->
265+ internalError (definedIn ++ ": module missing: "
266+ ++ P.runModuleName moduleName)
267+ Just mdl ->
268+ pure (allDeclarations mdl)
269+
270+handleTypeClassMembers ::
271+ Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->
272+ Map P.ModuleName [Declaration] ->
273+ (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
274+handleTypeClassMembers valsAndMembers typeClasses =
275+ let
276+ moduleEnvs =
277+ Map.unionWith (<>)
278+ (fmap valsAndMembersToEnv valsAndMembers)
279+ (fmap typeClassesToEnv typeClasses)
280+ in
281+ moduleEnvs
282+ |> fmap handleEnv
283+ |> splitMap
284+
285+valsAndMembersToEnv ::
286+ [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv
287+valsAndMembersToEnv xs =
288+ let (envUnhandledMembers, envValues) = partitionEithers xs
289+ envTypeClasses = []
290+ in TypeClassEnv{..}
291+
292+typeClassesToEnv :: [Declaration] -> TypeClassEnv
293+typeClassesToEnv classes =
294+ TypeClassEnv
295+ { envUnhandledMembers = []
296+ , envValues = []
297+ , envTypeClasses = classes
298+ }
299+
300+-- |
301+-- An intermediate data type, used for either moving type class members under
302+-- their parent type classes, or promoting them to normal Declaration values
303+-- if their parent type class has not been re-exported.
304+--
305+data TypeClassEnv = TypeClassEnv
306+ { -- |
307+ -- Type class members which have not yet been dealt with. The String is the
308+ -- name of the type class they belong to, and the constraint is used to
309+ -- make sure that they have the correct type if they get promoted.
310+ --
311+ envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)]
312+ -- |
313+ -- A list of normal value declarations. Type class members will be added to
314+ -- this list if their parent type class is not available.
315+ --
316+ , envValues :: [Declaration]
317+ -- |
318+ -- A list of type class declarations. Type class members will be added to
319+ -- their parents in this list, if they exist.
320+ --
321+ , envTypeClasses :: [Declaration]
322+ }
323+ deriving (Show)
324+
325+instance Monoid TypeClassEnv where
326+ mempty =
327+ TypeClassEnv mempty mempty mempty
328+ mappend (TypeClassEnv a1 b1 c1)
329+ (TypeClassEnv a2 b2 c2) =
330+ TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)
331+
332+-- |
333+-- Take a TypeClassEnv and handle all of the type class members in it, either
334+-- adding them to their parent classes, or promoting them to normal Declaration
335+-- values.
336+--
337+-- Returns a tuple of (values, type classes).
338+--
339+handleEnv :: TypeClassEnv -> ([Declaration], [Declaration])
340+handleEnv TypeClassEnv{..} =
341+ envUnhandledMembers
342+ |> foldl go (envValues, mkMap envTypeClasses)
343+ |> second Map.elems
344+
345+ where
346+ mkMap =
347+ Map.fromList . map (declTitle &&& id)
348+
349+ go (values, tcs) (title, constraint, childDecl) =
350+ case Map.lookup title tcs of
351+ Just _ ->
352+ -- Leave the state unchanged; if the type class is there, the child
353+ -- will be too.
354+ (values, tcs)
355+ Nothing ->
356+ (promoteChild constraint childDecl : values, tcs)
357+
358+ promoteChild constraint ChildDeclaration{..} =
359+ case cdeclInfo of
360+ ChildTypeClassMember typ ->
361+ Declaration
362+ { declTitle = cdeclTitle
363+ , declComments = cdeclComments
364+ , declSourceSpan = cdeclSourceSpan
365+ , declChildren = []
366+ , declFixity = Nothing
367+ , declInfo = ValueDeclaration (addConstraint constraint typ)
368+ }
369+ _ ->
370+ internalError
371+ ("handleEnv: Bad child declaration passed to promoteChild: "
372+ ++ cdeclTitle)
373+
374+ addConstraint constraint =
375+ P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]
376+
377+splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)
378+splitMap = foldl go (Map.empty, Map.empty) . Map.toList
379+ where
380+ go (m1, m2) (k, (v1, v2)) =
381+ (Map.insert k v1 m1, Map.insert k v2 m2)
382+
383+-- |
384+-- Given a list of exported constructor names, remove any data constructor
385+-- names in the provided Map of declarations which are not in the list.
386+--
387+filterDataConstructors ::
388+ [P.ProperName 'P.ConstructorName] ->
389+ Map P.ModuleName [Declaration] ->
390+ Map P.ModuleName [Declaration]
391+filterDataConstructors =
392+ filterExportedChildren isDataConstructor P.runProperName
393+
394+-- |
395+-- Given a list of exported type class member names, remove any data
396+-- type class member names in the provided Map of declarations which are not in
397+-- the list.
398+--
399+filterTypeClassMembers ::
400+ [P.Ident] ->
401+ Map P.ModuleName [Declaration] ->
402+ Map P.ModuleName [Declaration]
403+filterTypeClassMembers =
404+ filterExportedChildren isTypeClassMember P.showIdent
405+
406+filterExportedChildren ::
407+ (Functor f) =>
408+ (ChildDeclaration -> Bool) ->
409+ (name -> String) ->
410+ [name] ->
411+ f [Declaration] ->
412+ f [Declaration]
413+filterExportedChildren isTargetedKind runName expNames =
414+ fmap filterDecls
415+ where
416+ filterDecls =
417+ map (filterChildren (\c -> not (isTargetedKind c) ||
418+ cdeclTitle c `elem` expNames'))
419+
420+ expNames' = map runName expNames
421+
422+allDeclarations :: Module -> [Declaration]
423+allDeclarations Module{..} =
424+ modDeclarations ++ concatMap snd modReExports
425+
426+(|>) :: a -> (a -> b) -> b
427+x |> f = f x
428+
429+internalError :: String -> a
430+internalError = P.internalError . ("Docs.Convert.ReExports: " ++)
431+
432+-- |
433+-- If the provided Declaration is a TypeClassDeclaration, construct an
434+-- appropriate Constraint for use with the types of its members.
435+--
436+typeClassConstraintFor :: Declaration -> Maybe P.Constraint
437+typeClassConstraintFor Declaration{..} =
438+ case declInfo of
439+ TypeClassDeclaration tyArgs _ ->
440+ Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs)
441+ _ ->
442+ Nothing
443+ where
444+ mkConstraint = map (P.TypeVar . fst)