module Language.PureScript.Sugar.Names.Exports
( findExportable
, resolveExports
) where
import Prelude
import Control.Monad
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 qualified Data.Map as M
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Errors
import Language.PureScript.Names
import Language.PureScript.Sugar.Names.Env
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