module Language.PureScript.Sugar.Names.Env
( ImportRecord(..)
, ImportProvenance(..)
, Imports(..)
, nullImports
, Exports(..)
, nullExports
, Env
, primEnv
, primExports
, envModuleExports
, ExportMode(..)
, exportType
, exportTypeOp
, exportTypeClass
, exportValue
, exportValueOp
, checkImportConflicts
) where
import Prelude
import Control.Monad (forM_, when)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Function (on)
import Data.Foldable (find)
import Data.List (groupBy, sortOn, delete)
import Data.Maybe (mapMaybe)
import Safe (headMay)
import Data.Map qualified as M
import Data.Set qualified as S
import Language.PureScript.Constants.Prim qualified as C
import Language.PureScript.AST (ExportSource(..), SourceSpan, internalModuleSourceSpan, nullSourceSpan)
import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage')
import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, getQual)
data ImportRecord a =
ImportRecord
{ forall a. ImportRecord a -> Qualified a
importName :: Qualified a
, forall a. ImportRecord a -> ModuleName
importSourceModule :: ModuleName
, forall a. ImportRecord a -> SourceSpan
importSourceSpan :: SourceSpan
, forall a. ImportRecord a -> ImportProvenance
importProvenance :: ImportProvenance
}
deriving (ImportRecord a -> ImportRecord a -> Bool
forall a. Eq a => ImportRecord a -> ImportRecord a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportRecord a -> ImportRecord a -> Bool
$c/= :: forall a. Eq a => ImportRecord a -> ImportRecord a -> Bool
== :: ImportRecord a -> ImportRecord a -> Bool
$c== :: forall a. Eq a => ImportRecord a -> ImportRecord a -> Bool
Eq, ImportRecord a -> ImportRecord a -> Bool
ImportRecord a -> ImportRecord a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (ImportRecord a)
forall a. Ord a => ImportRecord a -> ImportRecord a -> Bool
forall a. Ord a => ImportRecord a -> ImportRecord a -> Ordering
forall a.
Ord a =>
ImportRecord a -> ImportRecord a -> ImportRecord a
min :: ImportRecord a -> ImportRecord a -> ImportRecord a
$cmin :: forall a.
Ord a =>
ImportRecord a -> ImportRecord a -> ImportRecord a
max :: ImportRecord a -> ImportRecord a -> ImportRecord a
$cmax :: forall a.
Ord a =>
ImportRecord a -> ImportRecord a -> ImportRecord a
>= :: ImportRecord a -> ImportRecord a -> Bool
$c>= :: forall a. Ord a => ImportRecord a -> ImportRecord a -> Bool
> :: ImportRecord a -> ImportRecord a -> Bool
$c> :: forall a. Ord a => ImportRecord a -> ImportRecord a -> Bool
<= :: ImportRecord a -> ImportRecord a -> Bool
$c<= :: forall a. Ord a => ImportRecord a -> ImportRecord a -> Bool
< :: ImportRecord a -> ImportRecord a -> Bool
$c< :: forall a. Ord a => ImportRecord a -> ImportRecord a -> Bool
compare :: ImportRecord a -> ImportRecord a -> Ordering
$ccompare :: forall a. Ord a => ImportRecord a -> ImportRecord a -> Ordering
Ord, Int -> ImportRecord a -> ShowS
forall a. Show a => Int -> ImportRecord a -> ShowS
forall a. Show a => [ImportRecord a] -> ShowS
forall a. Show a => ImportRecord a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImportRecord a] -> ShowS
$cshowList :: forall a. Show a => [ImportRecord a] -> ShowS
show :: ImportRecord a -> String
$cshow :: forall a. Show a => ImportRecord a -> String
showsPrec :: Int -> ImportRecord a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ImportRecord a -> ShowS
Show)
data ImportProvenance
= FromImplicit
| FromExplicit
| Local
| Prim
deriving (ImportProvenance -> ImportProvenance -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportProvenance -> ImportProvenance -> Bool
$c/= :: ImportProvenance -> ImportProvenance -> Bool
== :: ImportProvenance -> ImportProvenance -> Bool
$c== :: ImportProvenance -> ImportProvenance -> Bool
Eq, Eq ImportProvenance
ImportProvenance -> ImportProvenance -> Bool
ImportProvenance -> ImportProvenance -> Ordering
ImportProvenance -> ImportProvenance -> ImportProvenance
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ImportProvenance -> ImportProvenance -> ImportProvenance
$cmin :: ImportProvenance -> ImportProvenance -> ImportProvenance
max :: ImportProvenance -> ImportProvenance -> ImportProvenance
$cmax :: ImportProvenance -> ImportProvenance -> ImportProvenance
>= :: ImportProvenance -> ImportProvenance -> Bool
$c>= :: ImportProvenance -> ImportProvenance -> Bool
> :: ImportProvenance -> ImportProvenance -> Bool
$c> :: ImportProvenance -> ImportProvenance -> Bool
<= :: ImportProvenance -> ImportProvenance -> Bool
$c<= :: ImportProvenance -> ImportProvenance -> Bool
< :: ImportProvenance -> ImportProvenance -> Bool
$c< :: ImportProvenance -> ImportProvenance -> Bool
compare :: ImportProvenance -> ImportProvenance -> Ordering
$ccompare :: ImportProvenance -> ImportProvenance -> Ordering
Ord, Int -> ImportProvenance -> ShowS
[ImportProvenance] -> ShowS
ImportProvenance -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImportProvenance] -> ShowS
$cshowList :: [ImportProvenance] -> ShowS
show :: ImportProvenance -> String
$cshow :: ImportProvenance -> String
showsPrec :: Int -> ImportProvenance -> ShowS
$cshowsPrec :: Int -> ImportProvenance -> ShowS
Show)
type ImportMap a = M.Map (Qualified a) [ImportRecord a]
data Imports = Imports
{
Imports -> ImportMap (ProperName 'TypeName)
importedTypes :: ImportMap (ProperName 'TypeName)
, Imports -> ImportMap (OpName 'TypeOpName)
importedTypeOps :: ImportMap (OpName 'TypeOpName)
, Imports -> ImportMap (ProperName 'ConstructorName)
importedDataConstructors :: ImportMap (ProperName 'ConstructorName)
, Imports -> ImportMap (ProperName 'ClassName)
importedTypeClasses :: ImportMap (ProperName 'ClassName)
, Imports -> ImportMap Ident
importedValues :: ImportMap Ident
, Imports -> ImportMap (OpName 'ValueOpName)
importedValueOps :: ImportMap (OpName 'ValueOpName)
, Imports -> Set ModuleName
importedModules :: S.Set ModuleName
, Imports -> Set ModuleName
importedQualModules :: S.Set ModuleName
, Imports -> ImportMap (ProperName 'TypeName)
importedKinds :: ImportMap (ProperName 'TypeName)
} deriving (Int -> Imports -> ShowS
[Imports] -> ShowS
Imports -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Imports] -> ShowS
$cshowList :: [Imports] -> ShowS
show :: Imports -> String
$cshow :: Imports -> String
showsPrec :: Int -> Imports -> ShowS
$cshowsPrec :: Int -> Imports -> ShowS
Show)
nullImports :: Imports
nullImports :: Imports
nullImports = ImportMap (ProperName 'TypeName)
-> ImportMap (OpName 'TypeOpName)
-> ImportMap (ProperName 'ConstructorName)
-> ImportMap (ProperName 'ClassName)
-> ImportMap Ident
-> ImportMap (OpName 'ValueOpName)
-> Set ModuleName
-> Set ModuleName
-> ImportMap (ProperName 'TypeName)
-> Imports
Imports forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall a. Set a
S.empty forall a. Set a
S.empty forall k a. Map k a
M.empty
data Exports = Exports
{
Exports
-> Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
, Exports -> Map (OpName 'TypeOpName) ExportSource
exportedTypeOps :: M.Map (OpName 'TypeOpName) ExportSource
, Exports -> Map (ProperName 'ClassName) ExportSource
exportedTypeClasses :: M.Map (ProperName 'ClassName) ExportSource
, Exports -> Map Ident ExportSource
exportedValues :: M.Map Ident ExportSource
, Exports -> Map (OpName 'ValueOpName) ExportSource
exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource
} deriving (Int -> Exports -> ShowS
[Exports] -> ShowS
Exports -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exports] -> ShowS
$cshowList :: [Exports] -> ShowS
show :: Exports -> String
$cshow :: Exports -> String
showsPrec :: Int -> Exports -> ShowS
$cshowsPrec :: Int -> Exports -> ShowS
Show)
nullExports :: Exports
nullExports :: Exports
nullExports = Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
-> Map (OpName 'TypeOpName) ExportSource
-> Map (ProperName 'ClassName) ExportSource
-> Map Ident ExportSource
-> Map (OpName 'ValueOpName) ExportSource
-> Exports
Exports forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty
type Env = M.Map ModuleName (SourceSpan, Imports, Exports)
envModuleExports :: (a, b, Exports) -> Exports
envModuleExports :: forall a b. (a, b, Exports) -> Exports
envModuleExports (a
_, b
_, Exports
exps) = Exports
exps
primExports :: Exports
primExports :: Exports
primExports = forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
primTypes Map (Qualified (ProperName 'ClassName)) TypeClassData
primClasses
primBooleanExports :: Exports
primBooleanExports :: Exports
primBooleanExports = forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
primBooleanTypes forall a. Monoid a => a
mempty
primCoerceExports :: Exports
primCoerceExports :: Exports
primCoerceExports = forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
primCoerceTypes Map (Qualified (ProperName 'ClassName)) TypeClassData
primCoerceClasses
primOrderingExports :: Exports
primOrderingExports :: Exports
primOrderingExports = forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
primOrderingTypes forall a. Monoid a => a
mempty
primRowExports :: Exports
primRowExports :: Exports
primRowExports = forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
primRowTypes Map (Qualified (ProperName 'ClassName)) TypeClassData
primRowClasses
primRowListExports :: Exports
primRowListExports :: Exports
primRowListExports = forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
primRowListTypes Map (Qualified (ProperName 'ClassName)) TypeClassData
primRowListClasses
primSymbolExports :: Exports
primSymbolExports :: Exports
primSymbolExports = forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
primSymbolTypes Map (Qualified (ProperName 'ClassName)) TypeClassData
primSymbolClasses
primIntExports :: Exports
primIntExports :: Exports
primIntExports = forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
primIntTypes Map (Qualified (ProperName 'ClassName)) TypeClassData
primIntClasses
primTypeErrorExports :: Exports
primTypeErrorExports :: Exports
primTypeErrorExports = forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
primTypeErrorTypes Map (Qualified (ProperName 'ClassName)) TypeClassData
primTypeErrorClasses
mkPrimExports
:: M.Map (Qualified (ProperName 'TypeName)) a
-> M.Map (Qualified (ProperName 'ClassName)) b
-> Exports
mkPrimExports :: forall a b.
Map (Qualified (ProperName 'TypeName)) a
-> Map (Qualified (ProperName 'ClassName)) b -> Exports
mkPrimExports Map (Qualified (ProperName 'TypeName)) a
ts Map (Qualified (ProperName 'ClassName)) b
cs =
Exports
nullExports
{ exportedTypes :: Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall {a} {a}. Qualified a -> (a, ([a], ExportSource))
mkTypeEntry forall a b. (a -> b) -> [a] -> [b]
`map` forall k a. Map k a -> [k]
M.keys Map (Qualified (ProperName 'TypeName)) a
ts
, exportedTypeClasses :: Map (ProperName 'ClassName) ExportSource
exportedTypeClasses = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall {a}. Qualified a -> (a, ExportSource)
mkClassEntry forall a b. (a -> b) -> [a] -> [b]
`map` forall k a. Map k a -> [k]
M.keys Map (Qualified (ProperName 'ClassName)) b
cs
}
where
mkTypeEntry :: Qualified a -> (a, ([a], ExportSource))
mkTypeEntry (Qualified (ByModuleName ModuleName
mn) a
name) = (a
name, ([], ModuleName -> ExportSource
primExportSource ModuleName
mn))
mkTypeEntry Qualified a
_ = forall a. HasCallStack => String -> a
internalError
String
"mkPrimExports.mkTypeEntry: a name is qualified BySourcePos instead of ByModuleName"
mkClassEntry :: Qualified a -> (a, ExportSource)
mkClassEntry (Qualified (ByModuleName ModuleName
mn) a
name) = (a
name, ModuleName -> ExportSource
primExportSource ModuleName
mn)
mkClassEntry Qualified a
_ = forall a. HasCallStack => String -> a
internalError
String
"mkPrimExports.mkClassEntry: a name is qualified BySourcePos instead of ByModuleName"
primExportSource :: ModuleName -> ExportSource
primExportSource ModuleName
mn =
ExportSource
{ exportSourceImportedFrom :: Maybe ModuleName
exportSourceImportedFrom = forall a. Maybe a
Nothing
, exportSourceDefinedIn :: ModuleName
exportSourceDefinedIn = ModuleName
mn
}
primEnv :: Env
primEnv :: Env
primEnv = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ ( ModuleName
C.M_Prim
, (String -> SourceSpan
internalModuleSourceSpan String
"<Prim>", Imports
nullImports, Exports
primExports)
)
, ( ModuleName
C.M_Prim_Boolean
, (String -> SourceSpan
internalModuleSourceSpan String
"<Prim.Boolean>", Imports
nullImports, Exports
primBooleanExports)
)
, ( ModuleName
C.M_Prim_Coerce
, (String -> SourceSpan
internalModuleSourceSpan String
"<Prim.Coerce>", Imports
nullImports, Exports
primCoerceExports)
)
, ( ModuleName
C.M_Prim_Ordering
, (String -> SourceSpan
internalModuleSourceSpan String
"<Prim.Ordering>", Imports
nullImports, Exports
primOrderingExports)
)
, ( ModuleName
C.M_Prim_Row
, (String -> SourceSpan
internalModuleSourceSpan String
"<Prim.Row>", Imports
nullImports, Exports
primRowExports)
)
, ( ModuleName
C.M_Prim_RowList
, (String -> SourceSpan
internalModuleSourceSpan String
"<Prim.RowList>", Imports
nullImports, Exports
primRowListExports)
)
, ( ModuleName
C.M_Prim_Symbol
, (String -> SourceSpan
internalModuleSourceSpan String
"<Prim.Symbol>", Imports
nullImports, Exports
primSymbolExports)
)
, ( ModuleName
C.M_Prim_Int
, (String -> SourceSpan
internalModuleSourceSpan String
"<Prim.Int>", Imports
nullImports, Exports
primIntExports)
)
, ( ModuleName
C.M_Prim_TypeError
, (String -> SourceSpan
internalModuleSourceSpan String
"<Prim.TypeError>", Imports
nullImports, Exports
primTypeErrorExports)
)
]
data ExportMode = Internal | ReExport
deriving (ExportMode -> ExportMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExportMode -> ExportMode -> Bool
$c/= :: ExportMode -> ExportMode -> Bool
== :: ExportMode -> ExportMode -> Bool
$c== :: ExportMode -> ExportMode -> Bool
Eq, Int -> ExportMode -> ShowS
[ExportMode] -> ShowS
ExportMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExportMode] -> ShowS
$cshowList :: [ExportMode] -> ShowS
show :: ExportMode -> String
$cshow :: ExportMode -> String
showsPrec :: Int -> ExportMode -> ShowS
$cshowsPrec :: Int -> ExportMode -> ShowS
Show)
exportType
:: MonadError MultipleErrors m
=> SourceSpan
-> ExportMode
-> Exports
-> ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ExportSource
-> m Exports
exportType :: forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ExportMode
-> Exports
-> ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ExportSource
-> m Exports
exportType SourceSpan
ss ExportMode
exportMode Exports
exps ProperName 'TypeName
name [ProperName 'ConstructorName]
dctors ExportSource
src = do
let exTypes :: Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exTypes = Exports
-> Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes Exports
exps
exClasses :: Map (ProperName 'ClassName) ExportSource
exClasses = Exports -> Map (ProperName 'ClassName) ExportSource
exportedTypeClasses Exports
exps
dctorNameCounts :: [(ProperName 'ConstructorName, Int)]
dctorNameCounts :: [(ProperName 'ConstructorName, Int)]
dctorNameCounts = forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Num a => a -> a -> a
(+) (forall a b. (a -> b) -> [a] -> [b]
map (,Int
1) [ProperName 'ConstructorName]
dctors)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(ProperName 'ConstructorName, Int)]
dctorNameCounts forall a b. (a -> b) -> a -> b
$ \(ProperName 'ConstructorName
dctorName, Int
count) ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
Name -> Name -> m a
throwDeclConflict (ProperName 'ConstructorName -> Name
DctorName ProperName 'ConstructorName
dctorName) (ProperName 'ConstructorName -> Name
DctorName ProperName 'ConstructorName
dctorName)
case ExportMode
exportMode of
ExportMode
Internal -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProperName 'TypeName
name forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exTypes) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
Name -> Name -> m a
throwDeclConflict (ProperName 'TypeName -> Name
TyName ProperName 'TypeName
name) (ProperName 'TypeName -> Name
TyName ProperName 'TypeName
name)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'TypeName
name forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map (ProperName 'ClassName) ExportSource
exClasses) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
Name -> Name -> m a
throwDeclConflict (ProperName 'TypeName -> Name
TyName ProperName 'TypeName
name) (ProperName 'ClassName -> Name
TyClassName (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'TypeName
name))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProperName 'ConstructorName]
dctors forall a b. (a -> b) -> a -> b
$ \ProperName 'ConstructorName
dctor -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ProperName 'ConstructorName
dctor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exTypes) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
Name -> Name -> m a
throwDeclConflict (ProperName 'ConstructorName -> Name
DctorName ProperName 'ConstructorName
dctor) (ProperName 'ConstructorName -> Name
DctorName ProperName 'ConstructorName
dctor)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ConstructorName
dctor forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map (ProperName 'ClassName) ExportSource
exClasses) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
Name -> Name -> m a
throwDeclConflict (ProperName 'ConstructorName -> Name
DctorName ProperName 'ConstructorName
dctor) (ProperName 'ClassName -> Name
TyClassName (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ConstructorName
dctor))
ExportMode
ReExport -> do
let mn :: ModuleName
mn = ExportSource -> ModuleName
exportSourceDefinedIn ExportSource
src
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'TypeName
name forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map (ProperName 'ClassName) ExportSource
exClasses) forall a b. (a -> b) -> a -> b
$ \ExportSource
src' ->
let mn' :: ModuleName
mn' = ExportSource -> ModuleName
exportSourceDefinedIn ExportSource
src' in
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> ModuleName -> ModuleName -> Name -> Name -> m a
throwExportConflict' SourceSpan
ss ModuleName
mn ModuleName
mn' (ProperName 'TypeName -> Name
TyName ProperName 'TypeName
name) (ProperName 'ClassName -> Name
TyClassName (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'TypeName
name))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProperName 'TypeName
name forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exTypes) forall a b. (a -> b) -> a -> b
$ \([ProperName 'ConstructorName]
_, ExportSource
src') ->
let mn' :: ModuleName
mn' = ExportSource -> ModuleName
exportSourceDefinedIn ExportSource
src' in
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
mn forall a. Eq a => a -> a -> Bool
/= ModuleName
mn') forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> ModuleName -> ModuleName -> Name -> m a
throwExportConflict SourceSpan
ss ModuleName
mn ModuleName
mn' (ProperName 'TypeName -> Name
TyName ProperName 'TypeName
name)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProperName 'ConstructorName]
dctors forall a b. (a -> b) -> a -> b
$ \ProperName 'ConstructorName
dctor ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ProperName 'ConstructorName
dctor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
`find` Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exTypes) forall a b. (a -> b) -> a -> b
$ \([ProperName 'ConstructorName]
_, ExportSource
src') ->
let mn' :: ModuleName
mn' = ExportSource -> ModuleName
exportSourceDefinedIn ExportSource
src' in
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
mn forall a. Eq a => a -> a -> Bool
/= ModuleName
mn') forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> ModuleName -> ModuleName -> Name -> m a
throwExportConflict SourceSpan
ss ModuleName
mn ModuleName
mn' (ProperName 'ConstructorName -> Name
DctorName ProperName 'ConstructorName
dctor)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exports
exps { exportedTypes :: Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter Maybe ([ProperName 'ConstructorName], ExportSource)
-> Maybe ([ProperName 'ConstructorName], ExportSource)
updateOrInsert ProperName 'TypeName
name Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exTypes }
where
updateOrInsert :: Maybe ([ProperName 'ConstructorName], ExportSource)
-> Maybe ([ProperName 'ConstructorName], ExportSource)
updateOrInsert Maybe ([ProperName 'ConstructorName], ExportSource)
Nothing = forall a. a -> Maybe a
Just ([ProperName 'ConstructorName]
dctors, ExportSource
src)
updateOrInsert (Just ([ProperName 'ConstructorName]
dctors', ExportSource
_)) = forall a. a -> Maybe a
Just ([ProperName 'ConstructorName]
dctors forall a. [a] -> [a] -> [a]
++ [ProperName 'ConstructorName]
dctors', ExportSource
src)
exportTypeOp
:: MonadError MultipleErrors m
=> SourceSpan
-> Exports
-> OpName 'TypeOpName
-> ExportSource
-> m Exports
exportTypeOp :: forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> Exports -> OpName 'TypeOpName -> ExportSource -> m Exports
exportTypeOp SourceSpan
ss Exports
exps OpName 'TypeOpName
op ExportSource
src = do
Map (OpName 'TypeOpName) ExportSource
typeOps <- forall (m :: * -> *) a.
(MonadError MultipleErrors m, Ord a) =>
SourceSpan
-> (a -> Name)
-> a
-> ExportSource
-> Map a ExportSource
-> m (Map a ExportSource)
addExport SourceSpan
ss OpName 'TypeOpName -> Name
TyOpName OpName 'TypeOpName
op ExportSource
src (Exports -> Map (OpName 'TypeOpName) ExportSource
exportedTypeOps Exports
exps)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exports
exps { exportedTypeOps :: Map (OpName 'TypeOpName) ExportSource
exportedTypeOps = Map (OpName 'TypeOpName) ExportSource
typeOps }
exportTypeClass
:: MonadError MultipleErrors m
=> SourceSpan
-> ExportMode
-> Exports
-> ProperName 'ClassName
-> ExportSource
-> m Exports
exportTypeClass :: forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ExportMode
-> Exports
-> ProperName 'ClassName
-> ExportSource
-> m Exports
exportTypeClass SourceSpan
ss ExportMode
exportMode Exports
exps ProperName 'ClassName
name ExportSource
src = do
let exTypes :: Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exTypes = Exports
-> Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes Exports
exps
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExportMode
exportMode forall a. Eq a => a -> a -> Bool
== ExportMode
Internal) forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ClassName
name forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exTypes) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
Name -> Name -> m a
throwDeclConflict (ProperName 'ClassName -> Name
TyClassName ProperName 'ClassName
name) (ProperName 'TypeName -> Name
TyName (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ClassName
name))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ClassName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exTypes) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
Name -> Name -> m a
throwDeclConflict (ProperName 'ClassName -> Name
TyClassName ProperName 'ClassName
name) (ProperName 'ConstructorName -> Name
DctorName (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ClassName
name))
Map (ProperName 'ClassName) ExportSource
classes <- forall (m :: * -> *) a.
(MonadError MultipleErrors m, Ord a) =>
SourceSpan
-> (a -> Name)
-> a
-> ExportSource
-> Map a ExportSource
-> m (Map a ExportSource)
addExport SourceSpan
ss ProperName 'ClassName -> Name
TyClassName ProperName 'ClassName
name ExportSource
src (Exports -> Map (ProperName 'ClassName) ExportSource
exportedTypeClasses Exports
exps)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exports
exps { exportedTypeClasses :: Map (ProperName 'ClassName) ExportSource
exportedTypeClasses = Map (ProperName 'ClassName) ExportSource
classes }
exportValue
:: MonadError MultipleErrors m
=> SourceSpan
-> Exports
-> Ident
-> ExportSource
-> m Exports
exportValue :: forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan -> Exports -> Ident -> ExportSource -> m Exports
exportValue SourceSpan
ss Exports
exps Ident
name ExportSource
src = do
Map Ident ExportSource
values <- forall (m :: * -> *) a.
(MonadError MultipleErrors m, Ord a) =>
SourceSpan
-> (a -> Name)
-> a
-> ExportSource
-> Map a ExportSource
-> m (Map a ExportSource)
addExport SourceSpan
ss Ident -> Name
IdentName Ident
name ExportSource
src (Exports -> Map Ident ExportSource
exportedValues Exports
exps)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exports
exps { exportedValues :: Map Ident ExportSource
exportedValues = Map Ident ExportSource
values }
exportValueOp
:: MonadError MultipleErrors m
=> SourceSpan
-> Exports
-> OpName 'ValueOpName
-> ExportSource
-> m Exports
exportValueOp :: forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> Exports -> OpName 'ValueOpName -> ExportSource -> m Exports
exportValueOp SourceSpan
ss Exports
exps OpName 'ValueOpName
op ExportSource
src = do
Map (OpName 'ValueOpName) ExportSource
valueOps <- forall (m :: * -> *) a.
(MonadError MultipleErrors m, Ord a) =>
SourceSpan
-> (a -> Name)
-> a
-> ExportSource
-> Map a ExportSource
-> m (Map a ExportSource)
addExport SourceSpan
ss OpName 'ValueOpName -> Name
ValOpName OpName 'ValueOpName
op ExportSource
src (Exports -> Map (OpName 'ValueOpName) ExportSource
exportedValueOps Exports
exps)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exports
exps { exportedValueOps :: Map (OpName 'ValueOpName) ExportSource
exportedValueOps = Map (OpName 'ValueOpName) ExportSource
valueOps }
addExport
:: (MonadError MultipleErrors m, Ord a)
=> SourceSpan
-> (a -> Name)
-> a
-> ExportSource
-> M.Map a ExportSource
-> m (M.Map a ExportSource)
addExport :: forall (m :: * -> *) a.
(MonadError MultipleErrors m, Ord a) =>
SourceSpan
-> (a -> Name)
-> a
-> ExportSource
-> Map a ExportSource
-> m (Map a ExportSource)
addExport SourceSpan
ss a -> Name
toName a
name ExportSource
src Map a ExportSource
exports =
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
name Map a ExportSource
exports of
Just ExportSource
src' ->
let
mn :: ModuleName
mn = ExportSource -> ModuleName
exportSourceDefinedIn ExportSource
src
mn' :: ModuleName
mn' = ExportSource -> ModuleName
exportSourceDefinedIn ExportSource
src'
in
if ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
mn'
then forall (m :: * -> *) a. Monad m => a -> m a
return Map a ExportSource
exports
else forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> ModuleName -> ModuleName -> Name -> m a
throwExportConflict SourceSpan
ss ModuleName
mn ModuleName
mn' (a -> Name
toName a
name)
Maybe ExportSource
Nothing ->
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
src Map a ExportSource
exports
throwDeclConflict
:: MonadError MultipleErrors m
=> Name
-> Name
-> m a
throwDeclConflict :: forall (m :: * -> *) a.
MonadError MultipleErrors m =>
Name -> Name -> m a
throwDeclConflict Name
new Name
existing =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Name -> Name -> SimpleErrorMessage
DeclConflict Name
new Name
existing
throwExportConflict
:: MonadError MultipleErrors m
=> SourceSpan
-> ModuleName
-> ModuleName
-> Name
-> m a
throwExportConflict :: forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> ModuleName -> ModuleName -> Name -> m a
throwExportConflict SourceSpan
ss ModuleName
new ModuleName
existing Name
name =
forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> ModuleName -> ModuleName -> Name -> Name -> m a
throwExportConflict' SourceSpan
ss ModuleName
new ModuleName
existing Name
name Name
name
throwExportConflict'
:: MonadError MultipleErrors m
=> SourceSpan
-> ModuleName
-> ModuleName
-> Name
-> Name
-> m a
throwExportConflict' :: forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> ModuleName -> ModuleName -> Name -> Name -> m a
throwExportConflict' SourceSpan
ss ModuleName
new ModuleName
existing Name
newName Name
existingName =
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
$
Qualified Name -> Qualified Name -> SimpleErrorMessage
ExportConflict (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
new) Name
newName) (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
existing) Name
existingName)
checkImportConflicts
:: forall m a
. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> SourceSpan
-> ModuleName
-> (a -> Name)
-> [ImportRecord a]
-> m (ModuleName, ModuleName)
checkImportConflicts :: forall (m :: * -> *) a.
(MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
SourceSpan
-> ModuleName
-> (a -> Name)
-> [ImportRecord a]
-> m (ModuleName, ModuleName)
checkImportConflicts SourceSpan
ss ModuleName
currentModule a -> Name
toName [ImportRecord a]
xs =
let
byOrig :: [ImportRecord a]
byOrig = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. ImportRecord a -> ModuleName
importSourceModule [ImportRecord a]
xs
groups :: [[ImportRecord a]]
groups = 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. ImportRecord a -> ModuleName
importSourceModule) [ImportRecord a]
byOrig
nonImplicit :: [ImportRecord a]
nonImplicit = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= ImportProvenance
FromImplicit) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ImportRecord a -> ImportProvenance
importProvenance) [ImportRecord a]
xs
name :: Name
name = a -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Qualified a -> a
disqualify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ImportRecord a -> Qualified a
importName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [ImportRecord a]
xs
conflictModules :: [ModuleName]
conflictModules = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. Qualified a -> Maybe ModuleName
getQual forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ImportRecord a -> Qualified a
importName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) [[ImportRecord a]]
groups
in
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [[ImportRecord a]]
groups forall a. Ord a => a -> a -> Bool
> Int
1
then case [ImportRecord a]
nonImplicit of
[ImportRecord (Qualified (ByModuleName ModuleName
mnNew) a
_) ModuleName
mnOrig SourceSpan
_ ImportProvenance
_] -> do
let warningModule :: Maybe ModuleName
warningModule = if ModuleName
mnNew forall a. Eq a => a -> a -> Bool
== ModuleName
currentModule then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ModuleName
mnNew
ss' :: SourceSpan
ss' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe SourceSpan
nullSourceSpan forall a. ImportRecord a -> SourceSpan
importSourceSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== ImportProvenance
FromImplicit) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ImportRecord a -> ImportProvenance
importProvenance) forall a b. (a -> b) -> a -> b
$ [ImportRecord a]
xs
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss' forall a b. (a -> b) -> a -> b
$ Name -> Maybe ModuleName -> [ModuleName] -> SimpleErrorMessage
ScopeShadowing Name
name Maybe ModuleName
warningModule forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> [a]
delete ModuleName
mnNew [ModuleName]
conflictModules
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
mnNew, ModuleName
mnOrig)
[ImportRecord a]
_ -> 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
$ Name -> [ModuleName] -> SimpleErrorMessage
ScopeConflict Name
name [ModuleName]
conflictModules
else
case forall a. [a] -> a
head [ImportRecord a]
byOrig of
ImportRecord (Qualified (ByModuleName ModuleName
mnNew) a
_) ModuleName
mnOrig SourceSpan
_ ImportProvenance
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
mnNew, ModuleName
mnOrig)
ImportRecord a
_ ->
forall a. HasCallStack => String -> a
internalError String
"checkImportConflicts: ImportRecord should be qualified"