module Language.PureScript.Docs.Convert.ReExports
( updateReExports
) where
import Prelude ()
import Prelude.Compat
import Control.Monad
import Control.Monad.Trans.State.Strict (execState)
import Control.Monad.State.Class (MonadState, gets, modify)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Reader.Class (MonadReader, ask)
import Control.Arrow ((&&&), first, second)
import Data.Either
import Data.Maybe (mapMaybe)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import qualified Language.PureScript as P
import Language.PureScript.Docs.Types
updateReExports ::
P.Env ->
[P.ModuleName] ->
Map P.ModuleName Module ->
Map P.ModuleName Module
updateReExports env order modules =
execState action modules
where
action =
void (traverse go order)
go mn = do
mdl <- lookup' mn
reExports <- getReExports env mn
let mdl' = mdl { modReExports = 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: " ++ 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: " ++ P.runModuleName mn)
Just (_, imports, exports) -> do
allExports <- runReaderT (collectDeclarations imports exports) mn
pure (filter notLocal allExports)
where
notLocal = (/= mn) . fst
collectDeclarations ::
(MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) =>
P.Imports ->
P.Exports ->
m [(P.ModuleName, [Declaration])]
collectDeclarations imports exports = do
valsAndMembers <- collect lookupValueDeclaration impVals expVals
typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs
types <- collect lookupTypeDeclaration impTypes expTypes
(vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses
let filteredTypes = filterDataConstructors expCtors types
let filteredClasses = filterTypeClassMembers (map fst expVals) classes
pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))
where
collect lookup' imps exps = do
imps' <- traverse (findImport imps) exps
Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'
expVals = P.exportedValues exports
impVals = concat (Map.elems (P.importedValues imports))
expTypes = map (first fst) (P.exportedTypes exports)
impTypes = concat (Map.elems (P.importedTypes imports))
expCtors = concatMap (snd . fst) (P.exportedTypes exports)
expTCs = P.exportedTypeClasses exports
impTCs = concat (Map.elems (P.importedTypeClasses imports))
findImport ::
(Show name, Eq name, MonadReader P.ModuleName m) =>
[P.ImportRecord name] ->
(name, P.ModuleName) ->
m (P.ModuleName, name)
findImport imps (name, orig) =
let
matches (P.ImportRecord qual mn _) = P.disqualify qual == name && mn == orig
matching = filter matches imps
getQualified (P.Qualified mname _) = mname
in
case mapMaybe (getQualified . P.importName) matching of
(importedFrom:_) ->
pure (importedFrom, name)
[] ->
internalErrorInModule ("findImport: not found: " ++ show (name, orig))
lookupValueDeclaration ::
(MonadState (Map P.ModuleName Module) m,
MonadReader P.ModuleName m) =>
P.ModuleName ->
P.Ident ->
m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])
lookupValueDeclaration importedFrom ident = do
decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom
let
rs =
filter (\d -> declTitle d == P.showIdent ident
&& (isValue d || isAlias 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
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])
other ->
internalErrorInModule
("lookupTypeDeclaration: 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: "
++ (unlines . map 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: "
++ P.runModuleName moduleName)
Just mdl ->
pure (allDeclarations mdl)
handleTypeClassMembers ::
(MonadReader P.ModuleName m) =>
Map P.ModuleName [Either (String, P.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 (String, P.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 :: [(String, P.Constraint, ChildDeclaration)]
, envValues :: [Declaration]
, envTypeClasses :: [Declaration]
}
deriving (Show)
instance Monoid TypeClassEnv where
mempty =
TypeClassEnv mempty mempty mempty
mappend (TypeClassEnv a1 b1 c1)
(TypeClassEnv a2 b2 c2) =
TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)
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 = []
, declFixity = Nothing
, declInfo = ValueDeclaration (addConstraint constraint typ)
}
_ ->
internalErrorInModule
("handleEnv: Bad child declaration passed to promoteChild: "
++ cdeclTitle)
addConstraint constraint =
P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]
splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)
splitMap = foldl go (Map.empty, Map.empty) . Map.toList
where
go (m1, m2) (k, (v1, v2)) =
(Map.insert k v1 m1, Map.insert k v2 m2)
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 -> String) ->
[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: " ++ P.runModuleName mn ++
", " ++ msg)
typeClassConstraintFor :: Declaration -> Maybe P.Constraint
typeClassConstraintFor Declaration{..} =
case declInfo of
TypeClassDeclaration tyArgs _ ->
Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs)
_ ->
Nothing
where
mkConstraint = map (P.TypeVar . fst)