module Language.PureScript.Sugar.Names.Exports
( findExportable
, resolveExports
) where
import Prelude
import Control.Monad (filterM, foldM, liftM2, unless, void, when)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Error.Class (MonadError(..))
import Data.Function (on)
import Data.Foldable (traverse_)
import Data.List (intersect, groupBy, sortOn)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Map qualified as M
import Language.PureScript.AST
import Language.PureScript.Crash (internalError)
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow, rethrowWithPosition, warnAndRethrow)
import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), disqualifyFor, isQualifiedWith, isUnqualified)
import Language.PureScript.Sugar.Names.Env (Env, ExportMode(..), Exports(..), ImportRecord(..), Imports(..), checkImportConflicts, envModuleExports, exportType, exportTypeClass, exportTypeOp, exportValue, exportValueOp, nullExports)
import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs)
findExportable :: forall m. (MonadError MultipleErrors m) => Module -> m Exports
findExportable :: forall (m :: * -> *).
MonadError MultipleErrors m =>
Module -> m Exports
findExportable (Module SourceSpan
_ [Comment]
_ ModuleName
mn [Declaration]
ds Maybe [DeclarationRef]
_) =
forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
mn)) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Exports -> Declaration -> m Exports
updateExports' Exports
nullExports [Declaration]
ds
where
updateExports' :: Exports -> Declaration -> m Exports
updateExports' :: Exports -> Declaration -> m Exports
updateExports' Exports
exps Declaration
decl = forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition (Declaration -> SourceSpan
declSourceSpan Declaration
decl) forall a b. (a -> b) -> a -> b
$ Exports -> Declaration -> m Exports
updateExports Exports
exps Declaration
decl
source :: ExportSource
source =
ExportSource
{ exportSourceDefinedIn :: ModuleName
exportSourceDefinedIn = ModuleName
mn
, exportSourceImportedFrom :: Maybe ModuleName
exportSourceImportedFrom = forall a. Maybe a
Nothing
}
updateExports :: Exports -> Declaration -> m Exports
updateExports :: Exports -> Declaration -> m Exports
updateExports Exports
exps (TypeClassDeclaration (SourceSpan
ss, [Comment]
_) ProperName 'ClassName
tcn [(Text, Maybe SourceType)]
_ [SourceConstraint]
_ [FunctionalDependency]
_ [Declaration]
ds') = do
Exports
exps' <- forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
ss forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ExportMode
-> Exports
-> ProperName 'ClassName
-> ExportSource
-> m Exports
exportTypeClass SourceSpan
ss ExportMode
Internal Exports
exps ProperName 'ClassName
tcn ExportSource
source
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Exports -> Declaration -> m Exports
go Exports
exps' [Declaration]
ds'
where
go :: Exports -> Declaration -> m Exports
go Exports
exps'' (TypeDeclaration (TypeDeclarationData (SourceSpan
ss', [Comment]
_) Ident
name SourceType
_)) = forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan -> Exports -> Ident -> ExportSource -> m Exports
exportValue SourceSpan
ss' Exports
exps'' Ident
name ExportSource
source
go Exports
_ Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid declaration in TypeClassDeclaration"
updateExports Exports
exps (DataDeclaration (SourceSpan
ss, [Comment]
_) DataDeclType
_ ProperName 'TypeName
tn [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration]
dcs) =
forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ExportMode
-> Exports
-> ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ExportSource
-> m Exports
exportType SourceSpan
ss ExportMode
Internal Exports
exps ProperName 'TypeName
tn (forall a b. (a -> b) -> [a] -> [b]
map DataConstructorDeclaration -> ProperName 'ConstructorName
dataCtorName [DataConstructorDeclaration]
dcs) ExportSource
source
updateExports Exports
exps (TypeSynonymDeclaration (SourceSpan
ss, [Comment]
_) ProperName 'TypeName
tn [(Text, Maybe SourceType)]
_ SourceType
_) =
forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ExportMode
-> Exports
-> ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ExportSource
-> m Exports
exportType SourceSpan
ss ExportMode
Internal Exports
exps ProperName 'TypeName
tn [] ExportSource
source
updateExports Exports
exps (ExternDataDeclaration (SourceSpan
ss, [Comment]
_) ProperName 'TypeName
tn SourceType
_) =
forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ExportMode
-> Exports
-> ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ExportSource
-> m Exports
exportType SourceSpan
ss ExportMode
Internal Exports
exps ProperName 'TypeName
tn [] ExportSource
source
updateExports Exports
exps (ValueDeclaration ValueDeclarationData [GuardedExpr]
vd) =
forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan -> Exports -> Ident -> ExportSource -> m Exports
exportValue (forall a b. (a, b) -> a
fst (forall a. ValueDeclarationData a -> (SourceSpan, [Comment])
valdeclSourceAnn ValueDeclarationData [GuardedExpr]
vd)) Exports
exps (forall a. ValueDeclarationData a -> Ident
valdeclIdent ValueDeclarationData [GuardedExpr]
vd) ExportSource
source
updateExports Exports
exps (ValueFixityDeclaration (SourceSpan
ss, [Comment]
_) Fixity
_ Qualified (Either Ident (ProperName 'ConstructorName))
_ OpName 'ValueOpName
op) =
forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> Exports -> OpName 'ValueOpName -> ExportSource -> m Exports
exportValueOp SourceSpan
ss Exports
exps OpName 'ValueOpName
op ExportSource
source
updateExports Exports
exps (TypeFixityDeclaration (SourceSpan
ss, [Comment]
_) Fixity
_ Qualified (ProperName 'TypeName)
_ OpName 'TypeOpName
op) =
forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> Exports -> OpName 'TypeOpName -> ExportSource -> m Exports
exportTypeOp SourceSpan
ss Exports
exps OpName 'TypeOpName
op ExportSource
source
updateExports Exports
exps (ExternDeclaration (SourceSpan
ss, [Comment]
_) Ident
name SourceType
_) =
forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan -> Exports -> Ident -> ExportSource -> m Exports
exportValue SourceSpan
ss Exports
exps Ident
name ExportSource
source
updateExports Exports
exps Declaration
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Exports
exps
resolveExports
:: forall m
. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Env
-> SourceSpan
-> ModuleName
-> Imports
-> Exports
-> [DeclarationRef]
-> m Exports
resolveExports :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Env
-> SourceSpan
-> ModuleName
-> Imports
-> Exports
-> [DeclarationRef]
-> m Exports
resolveExports Env
env SourceSpan
ss ModuleName
mn Imports
imps Exports
exps [DeclarationRef]
refs =
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
mn)) forall a b. (a -> b) -> a -> b
$ do
Exports
filtered <- forall (m :: * -> *).
MonadError MultipleErrors m =>
ModuleName -> Exports -> [DeclarationRef] -> m Exports
filterModule ModuleName
mn Exports
exps [DeclarationRef]
refs
Exports
exps' <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Exports -> DeclarationRef -> m Exports
elaborateModuleExports Exports
filtered [DeclarationRef]
refs
forall (m :: * -> *).
MonadWriter MultipleErrors m =>
SourceSpan
-> (Name -> SimpleErrorMessage) -> [DeclarationRef] -> m ()
warnDuplicateRefs SourceSpan
ss Name -> SimpleErrorMessage
DuplicateExportRef [DeclarationRef]
refs
forall (m :: * -> *) a. Monad m => a -> m a
return Exports
exps'
where
elaborateModuleExports :: Exports -> DeclarationRef -> m Exports
elaborateModuleExports :: Exports -> DeclarationRef -> m Exports
elaborateModuleExports Exports
result (ModuleRef SourceSpan
_ ModuleName
name) | ModuleName
name forall a. Eq a => a -> a -> Bool
== ModuleName
mn = do
let types' :: Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
types' = Exports
-> Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes Exports
result forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Exports
-> Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes Exports
exps
let typeOps' :: Map (OpName 'TypeOpName) ExportSource
typeOps' = Exports -> Map (OpName 'TypeOpName) ExportSource
exportedTypeOps Exports
result forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Exports -> Map (OpName 'TypeOpName) ExportSource
exportedTypeOps Exports
exps
let classes' :: Map (ProperName 'ClassName) ExportSource
classes' = Exports -> Map (ProperName 'ClassName) ExportSource
exportedTypeClasses Exports
result forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Exports -> Map (ProperName 'ClassName) ExportSource
exportedTypeClasses Exports
exps
let values' :: Map Ident ExportSource
values' = Exports -> Map Ident ExportSource
exportedValues Exports
result forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Exports -> Map Ident ExportSource
exportedValues Exports
exps
let valueOps' :: Map (OpName 'ValueOpName) ExportSource
valueOps' = Exports -> Map (OpName 'ValueOpName) ExportSource
exportedValueOps Exports
result forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Exports -> Map (OpName 'ValueOpName) ExportSource
exportedValueOps Exports
exps
forall (m :: * -> *) a. Monad m => a -> m a
return Exports
result
{ exportedTypes :: Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes = Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
types'
, exportedTypeOps :: Map (OpName 'TypeOpName) ExportSource
exportedTypeOps = Map (OpName 'TypeOpName) ExportSource
typeOps'
, exportedTypeClasses :: Map (ProperName 'ClassName) ExportSource
exportedTypeClasses = Map (ProperName 'ClassName) ExportSource
classes'
, exportedValues :: Map Ident ExportSource
exportedValues = Map Ident ExportSource
values'
, exportedValueOps :: Map (OpName 'ValueOpName) ExportSource
exportedValueOps = Map (OpName 'ValueOpName) ExportSource
valueOps'
}
elaborateModuleExports Exports
result (ModuleRef SourceSpan
ss' ModuleName
name) = do
let isPseudo :: Bool
isPseudo = ModuleName -> Bool
isPseudoModule ModuleName
name
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isPseudo Bool -> Bool -> Bool
&& Bool -> Bool
not (ModuleName -> Bool
isImportedModule ModuleName
name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SimpleErrorMessage
UnknownExport forall a b. (a -> b) -> a -> b
$ ModuleName -> Name
ModName ModuleName
name
[Qualified (ProperName 'TypeName)]
reTypes <- forall a.
SourceSpan
-> Bool
-> ModuleName
-> (a -> Name)
-> Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
extract SourceSpan
ss' Bool
isPseudo ModuleName
name ProperName 'TypeName -> Name
TyName (Imports -> ImportMap (ProperName 'TypeName)
importedTypes Imports
imps)
[Qualified (OpName 'TypeOpName)]
reTypeOps <- forall a.
SourceSpan
-> Bool
-> ModuleName
-> (a -> Name)
-> Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
extract SourceSpan
ss' Bool
isPseudo ModuleName
name OpName 'TypeOpName -> Name
TyOpName (Imports -> ImportMap (OpName 'TypeOpName)
importedTypeOps Imports
imps)
[Qualified (ProperName 'ConstructorName)]
reDctors <- forall a.
SourceSpan
-> Bool
-> ModuleName
-> (a -> Name)
-> Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
extract SourceSpan
ss' Bool
isPseudo ModuleName
name ProperName 'ConstructorName -> Name
DctorName (Imports -> ImportMap (ProperName 'ConstructorName)
importedDataConstructors Imports
imps)
[Qualified (ProperName 'ClassName)]
reClasses <- forall a.
SourceSpan
-> Bool
-> ModuleName
-> (a -> Name)
-> Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
extract SourceSpan
ss' Bool
isPseudo ModuleName
name ProperName 'ClassName -> Name
TyClassName (Imports -> ImportMap (ProperName 'ClassName)
importedTypeClasses Imports
imps)
[Qualified Ident]
reValues <- forall a.
SourceSpan
-> Bool
-> ModuleName
-> (a -> Name)
-> Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
extract SourceSpan
ss' Bool
isPseudo ModuleName
name Ident -> Name
IdentName (Imports -> ImportMap Ident
importedValues Imports
imps)
[Qualified (OpName 'ValueOpName)]
reValueOps <- forall a.
SourceSpan
-> Bool
-> ModuleName
-> (a -> Name)
-> Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
extract SourceSpan
ss' Bool
isPseudo ModuleName
name OpName 'ValueOpName -> Name
ValOpName (Imports -> ImportMap (OpName 'ValueOpName)
importedValueOps Imports
imps)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Exports
exps' ((ProperName 'TypeName
tctor, [ProperName 'ConstructorName]
dctors), ExportSource
src) -> forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ExportMode
-> Exports
-> ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ExportSource
-> m Exports
exportType SourceSpan
ss' ExportMode
ReExport Exports
exps' ProperName 'TypeName
tctor [ProperName 'ConstructorName]
dctors ExportSource
src) Exports
result ([Qualified (ProperName 'TypeName)]
-> [Qualified (ProperName 'ConstructorName)]
-> [((ProperName 'TypeName, [ProperName 'ConstructorName]),
ExportSource)]
resolveTypeExports [Qualified (ProperName 'TypeName)]
reTypes [Qualified (ProperName 'ConstructorName)]
reDctors)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> Exports -> OpName 'TypeOpName -> ExportSource -> m Exports
exportTypeOp SourceSpan
ss')) (forall a b. (a -> b) -> [a] -> [b]
map Qualified (OpName 'TypeOpName)
-> (OpName 'TypeOpName, ExportSource)
resolveTypeOp [Qualified (OpName 'TypeOpName)]
reTypeOps)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ExportMode
-> Exports
-> ProperName 'ClassName
-> ExportSource
-> m Exports
exportTypeClass SourceSpan
ss' ExportMode
ReExport)) (forall a b. (a -> b) -> [a] -> [b]
map Qualified (ProperName 'ClassName)
-> (ProperName 'ClassName, ExportSource)
resolveClass [Qualified (ProperName 'ClassName)]
reClasses)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan -> Exports -> Ident -> ExportSource -> m Exports
exportValue SourceSpan
ss')) (forall a b. (a -> b) -> [a] -> [b]
map Qualified Ident -> (Ident, ExportSource)
resolveValue [Qualified Ident]
reValues)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> Exports -> OpName 'ValueOpName -> ExportSource -> m Exports
exportValueOp SourceSpan
ss')) (forall a b. (a -> b) -> [a] -> [b]
map Qualified (OpName 'ValueOpName)
-> (OpName 'ValueOpName, ExportSource)
resolveValueOp [Qualified (OpName 'ValueOpName)]
reValueOps)
elaborateModuleExports Exports
result DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Exports
result
extract
:: SourceSpan
-> Bool
-> ModuleName
-> (a -> Name)
-> M.Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
extract :: forall a.
SourceSpan
-> Bool
-> ModuleName
-> (a -> Name)
-> Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
extract SourceSpan
ss' Bool
useQual ModuleName
name a -> Name
toName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall a. ImportRecord a -> Qualified a
importName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Qualified a, [ImportRecord a])]
-> m [(Qualified a, [ImportRecord a])]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList
where
go :: [(Qualified a, [ImportRecord a])]
-> m [(Qualified a, [ImportRecord a])]
go = forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall a b. (a -> b) -> a -> b
$ \(Qualified a
name', [ImportRecord a]
options) -> do
let isMatch :: Bool
isMatch = if Bool
useQual then forall a. ModuleName -> Qualified a -> Bool
isQualifiedWith ModuleName
name Qualified a
name' else forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Qualified a -> ImportRecord a -> Bool
checkUnqual Qualified a
name') [ImportRecord a]
options
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isMatch Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [ImportRecord a]
options forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
SourceSpan
-> ModuleName
-> (a -> Name)
-> [ImportRecord a]
-> m (ModuleName, ModuleName)
checkImportConflicts SourceSpan
ss' ModuleName
mn a -> Name
toName [ImportRecord a]
options
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
isMatch
checkUnqual :: Qualified a -> ImportRecord a -> Bool
checkUnqual Qualified a
name' ImportRecord a
ir = forall a. Qualified a -> Bool
isUnqualified Qualified a
name' Bool -> Bool -> Bool
&& forall a. ModuleName -> Qualified a -> Bool
isQualifiedWith ModuleName
name (forall a. ImportRecord a -> Qualified a
importName ImportRecord a
ir)
isPseudoModule :: ModuleName -> Bool
isPseudoModule :: ModuleName -> Bool
isPseudoModule = (forall a b. Map (Qualified a) b -> [Qualified a])
-> ModuleName -> Bool
testQuals forall k a. Map k a -> [k]
M.keys
where
testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool
testQuals :: (forall a b. Map (Qualified a) b -> [Qualified a])
-> ModuleName -> Bool
testQuals forall a b. Map (Qualified a) b -> [Qualified a]
f ModuleName
mn' = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. ModuleName -> Qualified a -> Bool
isQualifiedWith ModuleName
mn') (forall a b. Map (Qualified a) b -> [Qualified a]
f (Imports -> ImportMap (ProperName 'TypeName)
importedTypes Imports
imps))
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. ModuleName -> Qualified a -> Bool
isQualifiedWith ModuleName
mn') (forall a b. Map (Qualified a) b -> [Qualified a]
f (Imports -> ImportMap (OpName 'TypeOpName)
importedTypeOps Imports
imps))
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. ModuleName -> Qualified a -> Bool
isQualifiedWith ModuleName
mn') (forall a b. Map (Qualified a) b -> [Qualified a]
f (Imports -> ImportMap (ProperName 'ConstructorName)
importedDataConstructors Imports
imps))
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. ModuleName -> Qualified a -> Bool
isQualifiedWith ModuleName
mn') (forall a b. Map (Qualified a) b -> [Qualified a]
f (Imports -> ImportMap (ProperName 'ClassName)
importedTypeClasses Imports
imps))
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. ModuleName -> Qualified a -> Bool
isQualifiedWith ModuleName
mn') (forall a b. Map (Qualified a) b -> [Qualified a]
f (Imports -> ImportMap Ident
importedValues Imports
imps))
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. ModuleName -> Qualified a -> Bool
isQualifiedWith ModuleName
mn') (forall a b. Map (Qualified a) b -> [Qualified a]
f (Imports -> ImportMap (OpName 'ValueOpName)
importedValueOps Imports
imps))
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. ModuleName -> Qualified a -> Bool
isQualifiedWith ModuleName
mn') (forall a b. Map (Qualified a) b -> [Qualified a]
f (Imports -> ImportMap (ProperName 'TypeName)
importedKinds Imports
imps))
isImportedModule :: ModuleName -> Bool
isImportedModule :: ModuleName -> Bool
isImportedModule = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Imports -> Set ModuleName
importedModules Imports
imps)
resolveTypeExports
:: [Qualified (ProperName 'TypeName)]
-> [Qualified (ProperName 'ConstructorName)]
-> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ExportSource)]
resolveTypeExports :: [Qualified (ProperName 'TypeName)]
-> [Qualified (ProperName 'ConstructorName)]
-> [((ProperName 'TypeName, [ProperName 'ConstructorName]),
ExportSource)]
resolveTypeExports [Qualified (ProperName 'TypeName)]
tctors [Qualified (ProperName 'ConstructorName)]
dctors = forall a b. (a -> b) -> [a] -> [b]
map Qualified (ProperName 'TypeName)
-> ((ProperName 'TypeName, [ProperName 'ConstructorName]),
ExportSource)
go [Qualified (ProperName 'TypeName)]
tctors
where
go
:: Qualified (ProperName 'TypeName)
-> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ExportSource)
go :: Qualified (ProperName 'TypeName)
-> ((ProperName 'TypeName, [ProperName 'ConstructorName]),
ExportSource)
go (Qualified (ByModuleName ModuleName
mn'') ProperName 'TypeName
name) =
forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
internalError String
"Missing value in resolveTypeExports") forall a b. (a -> b) -> a -> b
$ do
Exports
exps' <- forall a b. (a, b, Exports) -> Exports
envModuleExports forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName
mn'' forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Env
env
([ProperName 'ConstructorName]
dctors', ExportSource
src) <- ProperName 'TypeName
name forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Exports
-> Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes Exports
exps'
let relevantDctors :: [ProperName 'ConstructorName]
relevantDctors = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. Maybe ModuleName -> Qualified a -> Maybe a
disqualifyFor (forall a. a -> Maybe a
Just ModuleName
mn'')) [Qualified (ProperName 'ConstructorName)]
dctors
forall (m :: * -> *) a. Monad m => a -> m a
return
( (ProperName 'TypeName
name, [ProperName 'ConstructorName]
relevantDctors forall a. Eq a => [a] -> [a] -> [a]
`intersect` [ProperName 'ConstructorName]
dctors')
, ExportSource
src { exportSourceImportedFrom :: Maybe ModuleName
exportSourceImportedFrom = forall a. a -> Maybe a
Just ModuleName
mn'' }
)
go (Qualified QualifiedBy
_ ProperName 'TypeName
_) = forall a. HasCallStack => String -> a
internalError String
"Unqualified value in resolveTypeExports"
resolveTypeOp :: Qualified (OpName 'TypeOpName) -> (OpName 'TypeOpName, ExportSource)
resolveTypeOp :: Qualified (OpName 'TypeOpName)
-> (OpName 'TypeOpName, ExportSource)
resolveTypeOp Qualified (OpName 'TypeOpName)
op
= forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
internalError String
"Missing value in resolveValue")
forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
(Exports -> Map a ExportSource)
-> Qualified a -> Maybe (a, ExportSource)
resolve Exports -> Map (OpName 'TypeOpName) ExportSource
exportedTypeOps Qualified (OpName 'TypeOpName)
op
resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ExportSource)
resolveClass :: Qualified (ProperName 'ClassName)
-> (ProperName 'ClassName, ExportSource)
resolveClass Qualified (ProperName 'ClassName)
className
= forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
internalError String
"Missing value in resolveClass")
forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
(Exports -> Map a ExportSource)
-> Qualified a -> Maybe (a, ExportSource)
resolve Exports -> Map (ProperName 'ClassName) ExportSource
exportedTypeClasses Qualified (ProperName 'ClassName)
className
resolveValue :: Qualified Ident -> (Ident, ExportSource)
resolveValue :: Qualified Ident -> (Ident, ExportSource)
resolveValue Qualified Ident
ident
= forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
internalError String
"Missing value in resolveValue")
forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
(Exports -> Map a ExportSource)
-> Qualified a -> Maybe (a, ExportSource)
resolve Exports -> Map Ident ExportSource
exportedValues Qualified Ident
ident
resolveValueOp :: Qualified (OpName 'ValueOpName) -> (OpName 'ValueOpName, ExportSource)
resolveValueOp :: Qualified (OpName 'ValueOpName)
-> (OpName 'ValueOpName, ExportSource)
resolveValueOp Qualified (OpName 'ValueOpName)
op
= forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
internalError String
"Missing value in resolveValueOp")
forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
(Exports -> Map a ExportSource)
-> Qualified a -> Maybe (a, ExportSource)
resolve Exports -> Map (OpName 'ValueOpName) ExportSource
exportedValueOps Qualified (OpName 'ValueOpName)
op
resolve
:: Ord a
=> (Exports -> M.Map a ExportSource)
-> Qualified a
-> Maybe (a, ExportSource)
resolve :: forall a.
Ord a =>
(Exports -> Map a ExportSource)
-> Qualified a -> Maybe (a, ExportSource)
resolve Exports -> Map a ExportSource
f (Qualified (ByModuleName ModuleName
mn'') a
a) = do
Exports
exps' <- forall a b. (a, b, Exports) -> Exports
envModuleExports forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName
mn'' forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Env
env
ExportSource
src <- a
a forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Exports -> Map a ExportSource
f Exports
exps'
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, ExportSource
src { exportSourceImportedFrom :: Maybe ModuleName
exportSourceImportedFrom = forall a. a -> Maybe a
Just ModuleName
mn'' })
resolve Exports -> Map a ExportSource
_ Qualified a
_ = forall a. HasCallStack => String -> a
internalError String
"Unqualified value in resolve"
filterModule
:: forall m
. MonadError MultipleErrors m
=> ModuleName
-> Exports
-> [DeclarationRef]
-> m Exports
filterModule :: forall (m :: * -> *).
MonadError MultipleErrors m =>
ModuleName -> Exports -> [DeclarationRef] -> m Exports
filterModule ModuleName
mn Exports
exps [DeclarationRef]
refs = do
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
types <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
-> DeclarationRef
-> m (Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))
filterTypes forall k a. Map k a
M.empty ([DeclarationRef] -> [DeclarationRef]
combineTypeRefs [DeclarationRef]
refs)
Map (OpName 'TypeOpName) ExportSource
typeOps <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a.
Ord a =>
(a -> Name)
-> (DeclarationRef -> Maybe a)
-> (Exports -> Map a ExportSource)
-> Map a ExportSource
-> DeclarationRef
-> m (Map a ExportSource)
filterExport OpName 'TypeOpName -> Name
TyOpName DeclarationRef -> Maybe (OpName 'TypeOpName)
getTypeOpRef Exports -> Map (OpName 'TypeOpName) ExportSource
exportedTypeOps) forall k a. Map k a
M.empty [DeclarationRef]
refs
Map (ProperName 'ClassName) ExportSource
classes <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a.
Ord a =>
(a -> Name)
-> (DeclarationRef -> Maybe a)
-> (Exports -> Map a ExportSource)
-> Map a ExportSource
-> DeclarationRef
-> m (Map a ExportSource)
filterExport ProperName 'ClassName -> Name
TyClassName DeclarationRef -> Maybe (ProperName 'ClassName)
getTypeClassRef Exports -> Map (ProperName 'ClassName) ExportSource
exportedTypeClasses) forall k a. Map k a
M.empty [DeclarationRef]
refs
Map Ident ExportSource
values <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a.
Ord a =>
(a -> Name)
-> (DeclarationRef -> Maybe a)
-> (Exports -> Map a ExportSource)
-> Map a ExportSource
-> DeclarationRef
-> m (Map a ExportSource)
filterExport Ident -> Name
IdentName DeclarationRef -> Maybe Ident
getValueRef Exports -> Map Ident ExportSource
exportedValues) forall k a. Map k a
M.empty [DeclarationRef]
refs
Map (OpName 'ValueOpName) ExportSource
valueOps <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a.
Ord a =>
(a -> Name)
-> (DeclarationRef -> Maybe a)
-> (Exports -> Map a ExportSource)
-> Map a ExportSource
-> DeclarationRef
-> m (Map a ExportSource)
filterExport OpName 'ValueOpName -> Name
ValOpName DeclarationRef -> Maybe (OpName 'ValueOpName)
getValueOpRef Exports -> Map (OpName 'ValueOpName) ExportSource
exportedValueOps) forall k a. Map k a
M.empty [DeclarationRef]
refs
forall (m :: * -> *) a. Monad m => a -> m a
return Exports
{ exportedTypes :: Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes = Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
types
, exportedTypeOps :: Map (OpName 'TypeOpName) ExportSource
exportedTypeOps = Map (OpName 'TypeOpName) ExportSource
typeOps
, exportedTypeClasses :: Map (ProperName 'ClassName) ExportSource
exportedTypeClasses = Map (ProperName 'ClassName) ExportSource
classes
, exportedValues :: Map Ident ExportSource
exportedValues = Map Ident ExportSource
values
, exportedValueOps :: Map (OpName 'ValueOpName) ExportSource
exportedValueOps = Map (OpName 'ValueOpName) ExportSource
valueOps
}
where
combineTypeRefs :: [DeclarationRef] -> [DeclarationRef]
combineTypeRefs :: [DeclarationRef] -> [DeclarationRef]
combineTypeRefs
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(SourceSpan
ss', (ProperName 'TypeName
tc, Maybe [ProperName 'ConstructorName]
dcs)) -> SourceSpan
-> ProperName 'TypeName
-> Maybe [ProperName 'ConstructorName]
-> DeclarationRef
TypeRef SourceSpan
ss' ProperName 'TypeName
tc Maybe [ProperName 'ConstructorName]
dcs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a b. (a -> b) -> a -> b
$ \(SourceSpan
ss, (ProperName 'TypeName
tc, Maybe [ProperName 'ConstructorName]
dcs1)) (SourceSpan
_, (ProperName 'TypeName
_, Maybe [ProperName 'ConstructorName]
dcs2)) -> (SourceSpan
ss, (ProperName 'TypeName
tc, forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. [a] -> [a] -> [a]
(++) Maybe [ProperName 'ConstructorName]
dcs1 Maybe [ProperName 'ConstructorName]
dcs2)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\DeclarationRef
ref -> (DeclarationRef -> SourceSpan
declRefSourceSpan DeclarationRef
ref,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DeclarationRef
-> Maybe
(ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
getTypeRef DeclarationRef
ref)
filterTypes
:: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
-> DeclarationRef
-> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource))
filterTypes :: Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
-> DeclarationRef
-> m (Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))
filterTypes Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
result (TypeRef SourceSpan
ss ProperName 'TypeName
name Maybe [ProperName 'ConstructorName]
expDcons) =
case ProperName 'TypeName
name forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Exports
-> Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes Exports
exps of
Maybe ([ProperName 'ConstructorName], ExportSource)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SimpleErrorMessage
UnknownExport forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> Name
TyName ProperName 'TypeName
name
Just ([ProperName 'ConstructorName]
dcons, ExportSource
src) -> do
let expDcons' :: [ProperName 'ConstructorName]
expDcons' = forall a. a -> Maybe a -> a
fromMaybe [ProperName 'ConstructorName]
dcons Maybe [ProperName 'ConstructorName]
expDcons
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ProperName 'ConstructorName
-> m ()
checkDcon ProperName 'TypeName
name [ProperName 'ConstructorName]
dcons) [ProperName 'ConstructorName]
expDcons'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ProperName 'TypeName
name ([ProperName 'ConstructorName]
expDcons', ExportSource
src) Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
result
where
checkDcon
:: ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ProperName 'ConstructorName
-> m ()
checkDcon :: ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ProperName 'ConstructorName
-> m ()
checkDcon ProperName 'TypeName
tcon [ProperName 'ConstructorName]
dcons ProperName 'ConstructorName
dcon =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProperName 'ConstructorName
dcon forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ProperName 'ConstructorName]
dcons) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName
-> ProperName 'ConstructorName -> SimpleErrorMessage
UnknownExportDataConstructor ProperName 'TypeName
tcon ProperName 'ConstructorName
dcon
filterTypes Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
result DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
result
filterExport
:: Ord a
=> (a -> Name)
-> (DeclarationRef -> Maybe a)
-> (Exports -> M.Map a ExportSource)
-> M.Map a ExportSource
-> DeclarationRef
-> m (M.Map a ExportSource)
filterExport :: forall a.
Ord a =>
(a -> Name)
-> (DeclarationRef -> Maybe a)
-> (Exports -> Map a ExportSource)
-> Map a ExportSource
-> DeclarationRef
-> m (Map a ExportSource)
filterExport a -> Name
toName DeclarationRef -> Maybe a
get Exports -> Map a ExportSource
fromExps Map a ExportSource
result DeclarationRef
ref
| Just a
name <- DeclarationRef -> Maybe a
get DeclarationRef
ref =
case a
name forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Exports -> Map a ExportSource
fromExps Exports
exps of
Just ExportSource
source' | ModuleName
mn forall a. Eq a => a -> a -> Bool
== ExportSource -> ModuleName
exportSourceDefinedIn ExportSource
source' ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
name ExportSource
source' Map a ExportSource
result
Maybe ExportSource
_ ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (DeclarationRef -> SourceSpan
declRefSourceSpan DeclarationRef
ref) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SimpleErrorMessage
UnknownExport forall a b. (a -> b) -> a -> b
$ a -> Name
toName a
name
filterExport a -> Name
_ DeclarationRef -> Maybe a
_ Exports -> Map a ExportSource
_ Map a ExportSource
result DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Map a ExportSource
result