module Language.PureScript.Docs.Convert.ReExports
( updateReExports
) where
import Prelude.Compat
import Control.Arrow ((&&&), first, second)
import Control.Monad
import Control.Monad.Reader.Class (MonadReader, ask)
import Control.Monad.State.Class (MonadState, gets, modify)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Trans.State.Strict (execState)
import Data.Either
import Data.Map (Map)
import Data.Maybe (mapMaybe)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.Docs.Types
import qualified Language.PureScript as P
updateReExports ::
P.Env ->
[P.ModuleName] ->
(P.ModuleName -> InPackage P.ModuleName) ->
Map P.ModuleName Module ->
Map P.ModuleName Module
updateReExports env order withPackage = execState action
where
action =
void (traverse go order)
go mn = do
mdl <- lookup' mn
reExports <- getReExports env mn
let mdl' = mdl { modReExports = map (first withPackage) reExports }
modify (Map.insert mn mdl')
lookup' mn = do
v <- gets (Map.lookup mn)
case v of
Just v' ->
pure v'
Nothing ->
internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))
getReExports ::
(MonadState (Map P.ModuleName Module) m) =>
P.Env ->
P.ModuleName ->
m [(P.ModuleName, [Declaration])]
getReExports env mn =
case Map.lookup mn env of
Nothing ->
internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))
Just (_, _, exports) -> do
allExports <- runReaderT (collectDeclarations exports) mn
pure (filter notLocal allExports)
where
notLocal = (/= mn) . fst
collectDeclarations :: forall m.
(MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) =>
P.Exports ->
m [(P.ModuleName, [Declaration])]
collectDeclarations exports = do
valsAndMembers <- collect lookupValueDeclaration expVals
valOps <- collect lookupValueOpDeclaration expValOps
typeClasses <- collect lookupTypeClassDeclaration expTCs
types <- collect lookupTypeDeclaration expTypes
typeOps <- collect lookupTypeOpDeclaration expTypeOps
kinds <- collect lookupKindDeclaration expKinds
(vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses
let filteredTypes = filterDataConstructors expCtors types
let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes
pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps, kinds]))
where
collect
:: (Eq a, Show a)
=> (P.ModuleName -> a -> m (P.ModuleName, [b]))
-> Map a P.ExportSource
-> m (Map P.ModuleName [b])
collect lookup' exps = do
let reExps = Map.toList $ Map.mapMaybe P.exportSourceImportedFrom exps
decls <- traverse (uncurry (flip lookup')) reExps
return $ Map.fromListWith (<>) decls
expVals = P.exportedValues exports
expValOps = P.exportedValueOps exports
expTypes = Map.map snd (P.exportedTypes exports)
expTypeOps = P.exportedTypeOps exports
expCtors = concatMap fst (Map.elems (P.exportedTypes exports))
expTCs = P.exportedTypeClasses exports
expKinds = P.exportedKinds exports
lookupValueDeclaration ::
(MonadState (Map P.ModuleName Module) m,
MonadReader P.ModuleName m) =>
P.ModuleName ->
P.Ident ->
m (P.ModuleName, [Either (Text, Constraint', ChildDeclaration) Declaration])
lookupValueDeclaration importedFrom ident = do
decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom
let
rs =
filter (\d -> declTitle d == P.showIdent ident
&& (isValue d || isValueAlias d)) decls
errOther other =
internalErrorInModule
("lookupValueDeclaration: unexpected result:\n" ++
"other: " ++ show other ++ "\n" ++
"ident: " ++ show ident ++ "\n" ++
"decls: " ++ show decls)
case rs of
[r] ->
pure (importedFrom, [Right r])
[] ->
let
allTypeClassChildDecls =
decls
|> mapMaybe (\d -> (d,) <$> typeClassConstraintFor d)
|> concatMap (\(d, constr) ->
map (declTitle d, constr,)
(declChildren d))
matchesIdent cdecl =
cdeclTitle cdecl == P.showIdent ident
matchesAndIsTypeClassMember =
uncurry (&&) . (matchesIdent &&& isTypeClassMember)
in
case filter (matchesAndIsTypeClassMember . thd) allTypeClassChildDecls of
[r'] ->
pure (importedFrom, [Left r'])
other ->
errOther other
other -> errOther other
where
thd :: (a, b, c) -> c
thd (_, _, x) = x
lookupValueOpDeclaration
:: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m)
=> P.ModuleName
-> P.OpName 'P.ValueOpName
-> m (P.ModuleName, [Declaration])
lookupValueOpDeclaration importedFrom op = do
decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom
case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of
[d] ->
pure (importedFrom, [d])
other ->
internalErrorInModule
("lookupValueOpDeclaration: unexpected result for: " ++ show other)
lookupTypeDeclaration ::
(MonadState (Map P.ModuleName Module) m,
MonadReader P.ModuleName m) =>
P.ModuleName ->
P.ProperName 'P.TypeName ->
m (P.ModuleName, [Declaration])
lookupTypeDeclaration importedFrom ty = do
decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom
let
ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls
case ds of
[d] ->
pure (importedFrom, [d])
[] | P.isBuiltinModuleName importedFrom ->
pure (importedFrom, [])
other ->
internalErrorInModule
("lookupTypeDeclaration: unexpected result for " ++ show ty ++ ": " ++ show other)
lookupTypeOpDeclaration
:: (MonadState (Map P.ModuleName Module) m,MonadReader P.ModuleName m)
=> P.ModuleName
-> P.OpName 'P.TypeOpName
-> m (P.ModuleName, [Declaration])
lookupTypeOpDeclaration importedFrom tyOp = do
decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom
let
ds = filter (\d -> declTitle d == ("type " <> P.showOp tyOp) && isTypeAlias d) decls
case ds of
[d] ->
pure (importedFrom, [d])
other ->
internalErrorInModule
("lookupTypeOpDeclaration: unexpected result: " ++ show other)
lookupTypeClassDeclaration
:: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m)
=> P.ModuleName
-> P.ProperName 'P.ClassName
-> m (P.ModuleName, [Declaration])
lookupTypeClassDeclaration importedFrom tyClass = do
decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom
let
ds = filter (\d -> declTitle d == P.runProperName tyClass
&& isTypeClass d)
decls
case ds of
[d] ->
pure (importedFrom, [d])
other ->
internalErrorInModule
("lookupTypeClassDeclaration: unexpected result for "
++ show tyClass ++ ": "
++ (unlines . map show) other)
lookupKindDeclaration
:: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m)
=> P.ModuleName
-> P.ProperName 'P.KindName
-> m (P.ModuleName, [Declaration])
lookupKindDeclaration importedFrom kind = do
decls <- lookupModuleDeclarations "lookupKindDeclaration" importedFrom
let
ds = filter (\d -> declTitle d == P.runProperName kind
&& isKind d)
decls
case ds of
[d] ->
pure (importedFrom, [d])
other ->
internalErrorInModule
("lookupKindDeclaration: unexpected result: " ++ show other)
lookupModuleDeclarations ::
(MonadState (Map P.ModuleName Module) m,
MonadReader P.ModuleName m) =>
String ->
P.ModuleName ->
m [Declaration]
lookupModuleDeclarations definedIn moduleName = do
mmdl <- gets (Map.lookup moduleName)
case mmdl of
Nothing ->
internalErrorInModule
(definedIn ++ ": module missing: "
++ T.unpack (P.runModuleName moduleName))
Just mdl ->
pure (allDeclarations mdl)
handleTypeClassMembers ::
(MonadReader P.ModuleName m) =>
Map P.ModuleName [Either (Text, Constraint', ChildDeclaration) Declaration] ->
Map P.ModuleName [Declaration] ->
m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
handleTypeClassMembers valsAndMembers typeClasses =
let
moduleEnvs =
Map.unionWith (<>)
(fmap valsAndMembersToEnv valsAndMembers)
(fmap typeClassesToEnv typeClasses)
in
moduleEnvs
|> traverse handleEnv
|> fmap splitMap
valsAndMembersToEnv ::
[Either (Text, Constraint', ChildDeclaration) Declaration] -> TypeClassEnv
valsAndMembersToEnv xs =
let (envUnhandledMembers, envValues) = partitionEithers xs
envTypeClasses = []
in TypeClassEnv{..}
typeClassesToEnv :: [Declaration] -> TypeClassEnv
typeClassesToEnv classes =
TypeClassEnv
{ envUnhandledMembers = []
, envValues = []
, envTypeClasses = classes
}
data TypeClassEnv = TypeClassEnv
{
envUnhandledMembers :: [(Text, Constraint', ChildDeclaration)]
, envValues :: [Declaration]
, envTypeClasses :: [Declaration]
}
deriving (Show)
instance Semigroup TypeClassEnv where
(TypeClassEnv a1 b1 c1) <> (TypeClassEnv a2 b2 c2) =
TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)
instance Monoid TypeClassEnv where
mempty =
TypeClassEnv mempty mempty mempty
handleEnv
:: (MonadReader P.ModuleName m)
=> TypeClassEnv
-> m ([Declaration], [Declaration])
handleEnv TypeClassEnv{..} =
envUnhandledMembers
|> foldM go (envValues, mkMap envTypeClasses)
|> fmap (second Map.elems)
where
mkMap =
Map.fromList . map (declTitle &&& id)
go (values, tcs) (title, constraint, childDecl) =
case Map.lookup title tcs of
Just _ ->
pure (values, tcs)
Nothing -> do
c <- promoteChild constraint childDecl
pure (c : values, tcs)
promoteChild constraint ChildDeclaration{..} =
case cdeclInfo of
ChildTypeClassMember typ ->
pure Declaration
{ declTitle = cdeclTitle
, declComments = cdeclComments
, declSourceSpan = cdeclSourceSpan
, declChildren = []
, declInfo = ValueDeclaration (addConstraint constraint typ)
}
_ ->
internalErrorInModule
("handleEnv: Bad child declaration passed to promoteChild: "
++ T.unpack cdeclTitle)
addConstraint constraint =
P.quantify . P.moveQuantifiersToFront . P.ConstrainedType () constraint
splitMap :: Map k (v1, v2) -> (Map k v1, Map k v2)
splitMap = fmap fst &&& fmap snd
filterDataConstructors
:: [P.ProperName 'P.ConstructorName]
-> Map P.ModuleName [Declaration]
-> Map P.ModuleName [Declaration]
filterDataConstructors =
filterExportedChildren isDataConstructor P.runProperName
filterTypeClassMembers
:: [P.Ident]
-> Map P.ModuleName [Declaration]
-> Map P.ModuleName [Declaration]
filterTypeClassMembers =
filterExportedChildren isTypeClassMember P.showIdent
filterExportedChildren
:: (Functor f)
=> (ChildDeclaration -> Bool)
-> (name -> Text)
-> [name]
-> f [Declaration]
-> f [Declaration]
filterExportedChildren isTargetedKind runName expNames = fmap filterDecls
where
filterDecls =
map $ filterChildren $ \c ->
not (isTargetedKind c) || cdeclTitle c `elem` expNames'
expNames' = map runName expNames
allDeclarations :: Module -> [Declaration]
allDeclarations Module{..} =
modDeclarations ++ concatMap snd modReExports
(|>) :: a -> (a -> b) -> b
x |> f = f x
internalError :: String -> a
internalError = P.internalError . ("Docs.Convert.ReExports: " ++)
internalErrorInModule
:: (MonadReader P.ModuleName m)
=> String
-> m a
internalErrorInModule msg = do
mn <- ask
internalError
("while collecting re-exports for module: " ++ T.unpack (P.runModuleName mn) ++
", " ++ msg)
typeClassConstraintFor :: Declaration -> Maybe Constraint'
typeClassConstraintFor Declaration{..} =
case declInfo of
TypeClassDeclaration tyArgs _ _ ->
Just (P.Constraint () (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing)
_ ->
Nothing
where
mkConstraint = map (P.TypeVar () . fst)