module Language.PureScript.TypeChecker
( module T
, typeCheckModule
, checkNewtype
) where
import Prelude
import Protolude (headMay, maybeToLeft, ordNub)
import Control.Lens ((^..), _2)
import Control.Monad (when, unless, void, forM, zipWithM_)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), modify, gets)
import Control.Monad.Supply.Class (MonadSupply)
import Control.Monad.Writer.Class (MonadWriter, tell)
import Data.Foldable (for_, traverse_, toList)
import Data.List (nub, nubBy, (\\), sort, group)
import Data.Maybe
import Data.Either (partitionEithers)
import Data.Text (Text)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Language.PureScript.AST
import Language.PureScript.AST.Declarations.ChainId (ChainId)
import qualified Language.PureScript.Constants.Libs as Libs
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Linter
import Language.PureScript.Linter.Wildcards
import Language.PureScript.Names
import Language.PureScript.Roles
import Language.PureScript.Sugar.Names.Env (Exports(..))
import Language.PureScript.TypeChecker.Kinds as T
import Language.PureScript.TypeChecker.Monad as T
import Language.PureScript.TypeChecker.Roles as T
import Language.PureScript.TypeChecker.Synonyms as T
import Language.PureScript.TypeChecker.Types as T
import Language.PureScript.TypeChecker.Unify (varIfUnknown)
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
addDataType
:: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType, Role)]
-> [(DataConstructorDeclaration, SourceType)]
-> SourceType
-> m ()
addDataType :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType, Role)]
-> [(DataConstructorDeclaration, SourceType)]
-> SourceType
-> m ()
addDataType ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType, Role)]
args [(DataConstructorDeclaration, SourceType)]
dctors SourceType
ctorKind = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
let mapDataCtor :: DataConstructorDeclaration
-> (ProperName 'ConstructorName, [SourceType])
mapDataCtor (DataConstructorDeclaration SourceAnn
_ ProperName 'ConstructorName
ctorName [(Ident, SourceType)]
vars) = (ProperName 'ConstructorName
ctorName, forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Ident, SourceType)]
vars)
qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
hasSig :: Bool
hasSig = Qualified (ProperName 'TypeName)
qualName forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
ctorKind, DataDeclType
-> [(Text, Maybe SourceType, Role)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> TypeKind
DataType DataDeclType
dtype [(Text, Maybe SourceType, Role)]
args (forall a b. (a -> b) -> [a] -> [b]
map (DataConstructorDeclaration
-> (ProperName 'ConstructorName, [SourceType])
mapDataCtor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(DataConstructorDeclaration, SourceType)]
dctors)) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSig Bool -> Bool -> Bool
|| forall (a :: ProperNameType). ProperName a -> Bool
isDictTypeName ProperName 'TypeName
name Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Type a -> Bool
containsForAll SourceType
ctorKind)) forall a b. (a -> b) -> a -> b
$ do
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ KindSignatureFor
-> ProperName 'TypeName -> SourceType -> SimpleErrorMessage
MissingKindDeclaration (if DataDeclType
dtype forall a. Eq a => a -> a -> Bool
== DataDeclType
Newtype then KindSignatureFor
NewtypeSig else KindSignatureFor
DataSig) ProperName 'TypeName
name SourceType
ctorKind
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(DataConstructorDeclaration, SourceType)]
dctors forall a b. (a -> b) -> a -> b
$ \(DataConstructorDeclaration SourceAnn
_ ProperName 'ConstructorName
dctor [(Ident, SourceType)]
fields, SourceType
polyType) ->
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'ConstructorName -> ErrorMessageHint
ErrorInDataConstructor ProperName 'ConstructorName
dctor)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> ProperName 'ConstructorName
-> [(Ident, SourceType)]
-> SourceType
-> m ()
addDataConstructor ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name ProperName 'ConstructorName
dctor [(Ident, SourceType)]
fields SourceType
polyType
addDataConstructor
:: (MonadState CheckState m, MonadError MultipleErrors m)
=> ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> ProperName 'ConstructorName
-> [(Ident, SourceType)]
-> SourceType
-> m ()
addDataConstructor :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> ProperName 'ConstructorName
-> [(Ident, SourceType)]
-> SourceType
-> m ()
addDataConstructor ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name ProperName 'ConstructorName
dctor [(Ident, SourceType)]
dctorArgs SourceType
polyType = do
let fields :: [Ident]
fields = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Ident, SourceType)]
dctorArgs
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceType -> m ()
checkTypeSynonyms SourceType
polyType
forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { dataConstructors :: Map
(Qualified (ProperName 'ConstructorName))
(DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'ConstructorName
dctor) (DataDeclType
dtype, ProperName 'TypeName
name, SourceType
polyType, [Ident]
fields) (Environment
-> Map
(Qualified (ProperName 'ConstructorName))
(DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Environment
env) }
checkRoleDeclaration
:: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> RoleDeclarationData
-> m ()
checkRoleDeclaration :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName -> RoleDeclarationData -> m ()
checkRoleDeclaration ModuleName
moduleName (RoleDeclarationData (SourceSpan
ss, [Comment]
_) ProperName 'TypeName
name [Role]
declaredRoles) = do
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInRoleDeclaration ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
let qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'TypeName)
qualName (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) of
Just (SourceType
kind, DataType DataDeclType
dtype [(Text, Maybe SourceType, Role)]
args [(ProperName 'ConstructorName, [SourceType])]
dctors) -> do
forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName -> [Role] -> Int -> m ()
checkRoleDeclarationArity ProperName 'TypeName
name [Role]
declaredRoles (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Maybe SourceType, Role)]
args)
forall (m :: * -> *).
MonadError MultipleErrors m =>
[(Text, Maybe SourceType, Role)] -> [Role] -> m ()
checkRoles [(Text, Maybe SourceType, Role)]
args [Role]
declaredRoles
let args' :: [(Text, Maybe SourceType, Role)]
args' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Text
v, Maybe SourceType
k, Role
_) Role
r -> (Text
v, Maybe SourceType
k, Role
r)) [(Text, Maybe SourceType, Role)]
args [Role]
declaredRoles
forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, DataDeclType
-> [(Text, Maybe SourceType, Role)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> TypeKind
DataType DataDeclType
dtype [(Text, Maybe SourceType, Role)]
args' [(ProperName 'ConstructorName, [SourceType])]
dctors) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
Just (SourceType
kind, ExternData [Role]
_) -> do
forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName -> [Role] -> Int -> m ()
checkRoleDeclarationArity ProperName 'TypeName
name [Role]
declaredRoles (forall a. Type a -> Int
kindArity SourceType
kind)
forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, [Role] -> TypeKind
ExternData [Role]
declaredRoles) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
Maybe (SourceType, TypeKind)
_ -> forall a. HasCallStack => String -> a
internalError String
"Unsupported role declaration"
addTypeSynonym
:: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> SourceType
-> m ()
addTypeSynonym :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> SourceType
-> m ()
addTypeSynonym ModuleName
moduleName ProperName 'TypeName
name [(Text, Maybe SourceType)]
args SourceType
ty SourceType
kind = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceType -> m ()
checkTypeSynonyms SourceType
ty
let qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
hasSig :: Bool
hasSig = Qualified (ProperName 'TypeName)
qualName forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSig Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Type a -> Bool
containsForAll SourceType
kind)) forall a b. (a -> b) -> a -> b
$ do
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ KindSignatureFor
-> ProperName 'TypeName -> SourceType -> SimpleErrorMessage
MissingKindDeclaration KindSignatureFor
TypeSynonymSig ProperName 'TypeName
name SourceType
kind
forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, TypeKind
TypeSynonym) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)
, typeSynonyms :: Map
(Qualified (ProperName 'TypeName))
([(Text, Maybe SourceType)], SourceType)
typeSynonyms = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName ([(Text, Maybe SourceType)]
args, SourceType
ty) (Environment
-> Map
(Qualified (ProperName 'TypeName))
([(Text, Maybe SourceType)], SourceType)
typeSynonyms Environment
env) }
valueIsNotDefined
:: (MonadState CheckState m, MonadError MultipleErrors m)
=> ModuleName
-> Ident
-> m ()
valueIsNotDefined :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName -> Ident -> m ()
valueIsNotDefined ModuleName
moduleName Ident
name = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) of
Just (SourceType, NameKind, NameVisibility)
_ -> 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
$ Ident -> SimpleErrorMessage
RedefinedIdent Ident
name
Maybe (SourceType, NameKind, NameVisibility)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
addValue
:: (MonadState CheckState m)
=> ModuleName
-> Ident
-> SourceType
-> NameKind
-> m ()
addValue :: forall (m :: * -> *).
MonadState CheckState m =>
ModuleName -> Ident -> SourceType -> NameKind -> m ()
addValue ModuleName
moduleName Ident
name SourceType
ty NameKind
nameKind = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv (Environment
env { names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (SourceType
ty, NameKind
nameKind, NameVisibility
Defined) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) })
addTypeClass
:: forall m
. (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> Qualified (ProperName 'ClassName)
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> [Declaration]
-> SourceType
-> m ()
addTypeClass :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> [Declaration]
-> SourceType
-> m ()
addTypeClass ModuleName
_ Qualified (ProperName 'ClassName)
qualifiedClassName [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [FunctionalDependency]
dependencies [Declaration]
ds SourceType
kind = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
TypeClassData
newClass <- m TypeClassData
mkNewClass
let qualName :: Qualified (ProperName 'TypeName)
qualName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName Qualified (ProperName 'ClassName)
qualifiedClassName
hasSig :: Bool
hasSig = Qualified (ProperName 'TypeName)
qualName forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSig Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Type a -> Bool
containsForAll SourceType
kind)) forall a b. (a -> b) -> a -> b
$ do
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ KindSignatureFor
-> ProperName 'TypeName -> SourceType -> SimpleErrorMessage
MissingKindDeclaration KindSignatureFor
ClassSig (forall a. Qualified a -> a
disqualify Qualified (ProperName 'TypeName)
qualName) SourceType
kind
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (TypeClassData
-> Map
(Qualified (ProperName 'TypeName))
([(Text, Maybe SourceType)], SourceType)
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> (Ident, SourceType)
-> m ()
checkMemberIsUsable TypeClassData
newClass (Environment
-> Map
(Qualified (ProperName 'TypeName))
([(Text, Maybe SourceType)], SourceType)
typeSynonyms Environment
env) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)) [(Ident, SourceType)]
classMembers
forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, [Role] -> TypeKind
ExternData (forall a. Type a -> [Role]
nominalRolesForKind SourceType
kind)) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)
, typeClasses :: Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'ClassName)
qualifiedClassName TypeClassData
newClass (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env) }
where
classMembers :: [(Ident, SourceType)]
classMembers :: [(Ident, SourceType)]
classMembers = forall a b. (a -> b) -> [a] -> [b]
map Declaration -> (Ident, SourceType)
toPair [Declaration]
ds
mkNewClass :: m TypeClassData
mkNewClass :: m TypeClassData
mkNewClass = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
[SourceConstraint]
implies' <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Functor f =>
([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)
overConstraintArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceConstraint]
implies
let ctIsEmpty :: Bool
ctIsEmpty = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, SourceType)]
classMembers Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TypeClassData -> Bool
typeClassIsEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Environment -> Constraint a -> TypeClassData
findSuperClass Environment
env) [SourceConstraint]
implies'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(Text, Maybe SourceType)]
-> [(Ident, SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> Bool
-> TypeClassData
makeTypeClassData [(Text, Maybe SourceType)]
args [(Ident, SourceType)]
classMembers [SourceConstraint]
implies' [FunctionalDependency]
dependencies Bool
ctIsEmpty
where
findSuperClass :: Environment -> Constraint a -> TypeClassData
findSuperClass Environment
env Constraint a
c = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Constraint a -> Qualified (ProperName 'ClassName)
constraintClass Constraint a
c) (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env) of
Just TypeClassData
tcd -> TypeClassData
tcd
Maybe TypeClassData
Nothing -> forall a. HasCallStack => String -> a
internalError String
"Unknown super class in TypeClassDeclaration"
coveringSets :: TypeClassData -> [S.Set Int]
coveringSets :: TypeClassData -> [Set Int]
coveringSets = forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeClassData -> Set (Set Int)
typeClassCoveringSets
argToIndex :: Text -> Maybe Int
argToIndex :: Text -> Maybe Int
argToIndex = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Maybe SourceType)]
args [Int
0..])
toPair :: Declaration -> (Ident, SourceType)
toPair (TypeDeclaration (TypeDeclarationData SourceAnn
_ Ident
ident SourceType
ty)) = (Ident
ident, SourceType
ty)
toPair Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid declaration in TypeClassDeclaration"
checkMemberIsUsable :: TypeClassData -> T.SynonymMap -> T.KindMap -> (Ident, SourceType) -> m ()
checkMemberIsUsable :: TypeClassData
-> Map
(Qualified (ProperName 'TypeName))
([(Text, Maybe SourceType)], SourceType)
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> (Ident, SourceType)
-> m ()
checkMemberIsUsable TypeClassData
newClass Map
(Qualified (ProperName 'TypeName))
([(Text, Maybe SourceType)], SourceType)
syns Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
kinds (Ident
ident, SourceType
memberTy) = do
SourceType
memberTy' <- forall (m :: * -> *).
MonadError MultipleErrors m =>
Map
(Qualified (ProperName 'TypeName))
([(Text, Maybe SourceType)], SourceType)
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> SourceType
-> m SourceType
T.replaceAllTypeSynonymsM Map
(Qualified (ProperName 'TypeName))
([(Text, Maybe SourceType)], SourceType)
syns Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
kinds SourceType
memberTy
let mentionedArgIndexes :: Set Int
mentionedArgIndexes = forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Int
argToIndex (forall a. Type a -> [Text]
freeTypeVariables SourceType
memberTy'))
let leftovers :: [Set Int]
leftovers = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Int
mentionedArgIndexes) (TypeClassData -> [Set Int]
coveringSets TypeClassData
newClass)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Set Int]
leftovers) 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
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$
let
solutions :: [[Text]]
solutions = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Text, Maybe SourceType)]
args forall a. [a] -> Int -> a
!!)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList) [Set Int]
leftovers
in
Ident -> [[Text]] -> SimpleErrorMessage
UnusableDeclaration Ident
ident (forall a. Eq a => [a] -> [a]
nub [[Text]]
solutions)
addTypeClassDictionaries
:: (MonadState CheckState m)
=> QualifiedBy
-> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
-> m ()
addTypeClassDictionaries :: forall (m :: * -> *).
MonadState CheckState m =>
QualifiedBy
-> Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict))
-> m ()
addTypeClassDictionaries QualifiedBy
mn Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict))
entries =
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkEnv :: Environment
checkEnv = (CheckState -> Environment
checkEnv CheckState
st) { typeClassDictionaries :: Map
QualifiedBy
(Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries = CheckState
-> Map
QualifiedBy
(Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict)))
insertState CheckState
st } }
where insertState :: CheckState
-> Map
QualifiedBy
(Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict)))
insertState CheckState
st = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Semigroup a => a -> a -> a
(<>))) QualifiedBy
mn Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict))
entries (Environment
-> Map
QualifiedBy
(Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv forall a b. (a -> b) -> a -> b
$ CheckState
st)
checkDuplicateTypeArguments
:: (MonadState CheckState m, MonadError MultipleErrors m)
=> [Text]
-> m ()
checkDuplicateTypeArguments :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments [Text]
args = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
firstDup forall a b. (a -> b) -> a -> b
$ \Text
dup ->
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
$ Text -> SimpleErrorMessage
DuplicateTypeArgument Text
dup
where
firstDup :: Maybe Text
firstDup :: Maybe Text
firstDup = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [Text]
args forall a. Eq a => [a] -> [a] -> [a]
\\ forall a. Ord a => [a] -> [a]
ordNub [Text]
args
checkTypeClassInstance
:: (MonadState CheckState m, MonadError MultipleErrors m)
=> TypeClassData
-> Int
-> SourceType
-> m ()
checkTypeClassInstance :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
TypeClassData -> Int -> SourceType -> m ()
checkTypeClassInstance TypeClassData
cls Int
i = SourceType -> m ()
check where
isFunDepDetermined :: Bool
isFunDepDetermined = forall a. Ord a => a -> Set a -> Bool
S.member Int
i (TypeClassData -> Set Int
typeClassDeterminedArguments TypeClassData
cls)
check :: SourceType -> m ()
check = \case
TypeVar SourceAnn
_ Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TypeLevelString SourceAnn
_ PSString
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TypeLevelInt SourceAnn
_ Integer
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TypeConstructor SourceAnn
_ Qualified (ProperName 'TypeName)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TypeApp SourceAnn
_ SourceType
t1 SourceType
t2 -> SourceType -> m ()
check SourceType
t1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SourceType -> m ()
check SourceType
t2
KindApp SourceAnn
_ SourceType
t SourceType
k -> SourceType -> m ()
check SourceType
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SourceType -> m ()
check SourceType
k
KindedType SourceAnn
_ SourceType
t SourceType
_ -> SourceType -> m ()
check SourceType
t
REmpty SourceAnn
_ | Bool
isFunDepDetermined -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RCons SourceAnn
_ Label
_ SourceType
hd SourceType
tl | Bool
isFunDepDetermined -> SourceType -> m ()
check SourceType
hd forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SourceType -> m ()
check SourceType
tl
SourceType
ty -> 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
$ SourceType -> SimpleErrorMessage
InvalidInstanceHead SourceType
ty
checkTypeSynonyms
:: (MonadState CheckState m, MonadError MultipleErrors m)
=> SourceType
-> m ()
checkTypeSynonyms :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceType -> m ()
checkTypeSynonyms = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms
typeCheckAll
:: forall m
. (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> [Declaration]
-> m [Declaration]
typeCheckAll :: forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
ModuleName -> [Declaration] -> m [Declaration]
typeCheckAll ModuleName
moduleName = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Declaration -> m Declaration
go
where
go :: Declaration -> m Declaration
go :: Declaration -> m Declaration
go (DataDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType)]
args [DataConstructorDeclaration]
dctors) = do
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInTypeConstructor ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DataDeclType
dtype forall a. Eq a => a -> a -> Bool
== DataDeclType
Newtype) 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 :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName
-> [DataConstructorDeclaration]
-> m (DataConstructorDeclaration, (Ident, SourceType))
checkNewtype ProperName 'TypeName
name [DataConstructorDeclaration]
dctors
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
args
([(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
ctorKind) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
[DataConstructorDeclaration])
-> m ([(DataConstructorDeclaration, SourceType)], SourceType)
kindOfData ModuleName
moduleName (SourceAnn
sa, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, [DataConstructorDeclaration]
dctors)
let args' :: [(Text, Maybe SourceType)]
args' = [(Text, Maybe SourceType)]
args [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
`withKinds` SourceType
ctorKind
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
[DataConstructorDeclaration]
dctors' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (DataConstructorDeclaration -> m DataConstructorDeclaration
replaceTypeSynonymsInDataConstructor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(DataConstructorDeclaration, SourceType)]
dataCtors
let args'' :: [(Text, Maybe SourceType, Role)]
args'' = [(Text, Maybe SourceType)]
args' [(Text, Maybe SourceType)]
-> [Role] -> [(Text, Maybe SourceType, Role)]
`withRoles` Environment
-> ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> [DataConstructorDeclaration]
-> [Role]
inferRoles Environment
env ModuleName
moduleName ProperName 'TypeName
name [(Text, Maybe SourceType)]
args' [DataConstructorDeclaration]
dctors'
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType, Role)]
-> [(DataConstructorDeclaration, SourceType)]
-> SourceType
-> m ()
addDataType ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType, Role)]
args'' [(DataConstructorDeclaration, SourceType)]
dataCtors SourceType
ctorKind
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> [DataConstructorDeclaration]
-> Declaration
DataDeclaration SourceAnn
sa DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType)]
args [DataConstructorDeclaration]
dctors
go d :: Declaration
d@(DataBindingGroupDeclaration NonEmpty Declaration
tys) = do
let tysList :: [Declaration]
tysList = forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Declaration
tys
syns :: [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
SourceType)]
syns = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration
-> Maybe
(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
SourceType)
toTypeSynonym [Declaration]
tysList
dataDecls :: [(DataDeclType,
(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
[DataConstructorDeclaration]))]
dataDecls = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration
-> Maybe
(DataDeclType,
(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
[DataConstructorDeclaration]))
toDataDecl [Declaration]
tysList
roleDecls :: [RoleDeclarationData]
roleDecls = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe RoleDeclarationData
toRoleDecl [Declaration]
tysList
clss :: [([FunctionalDependency],
(SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
[SourceConstraint], [Declaration]))]
clss = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration
-> Maybe
([FunctionalDependency],
(SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
[SourceConstraint], [Declaration]))
toClassDecl [Declaration]
tysList
bindingGroupNames :: [ProperName 'TypeName]
bindingGroupNames = forall a. Ord a => [a] -> [a]
ordNub (([(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
SourceType)]
syns forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) forall a. [a] -> [a] -> [a]
++ ([(DataDeclType,
(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
[DataConstructorDeclaration]))]
dataDecls forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ([([FunctionalDependency],
(SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
[SourceConstraint], [Declaration]))]
clss forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2))
sss :: NonEmpty SourceSpan
sss = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Declaration -> SourceSpan
declSourceSpan NonEmpty Declaration
tys
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint ([ProperName 'TypeName] -> ErrorMessageHint
ErrorInDataBindingGroup [ProperName 'TypeName]
bindingGroupNames) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (NonEmpty SourceSpan -> ErrorMessageHint
PositionedError NonEmpty SourceSpan
sss)) forall a b. (a -> b) -> a -> b
$ do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
([TypeDeclarationResult]
syn_ks, [([(DataConstructorDeclaration, SourceType)], SourceType)]
data_ks, [ClassDeclarationResult]
cls_ks) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
SourceType)]
-> [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
[DataConstructorDeclaration])]
-> [(SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
[SourceConstraint], [Declaration])]
-> m ([TypeDeclarationResult],
[([(DataConstructorDeclaration, SourceType)], SourceType)],
[ClassDeclarationResult])
kindsOfAll ModuleName
moduleName [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
SourceType)]
syns (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [(DataDeclType,
(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
[DataConstructorDeclaration]))]
dataDecls) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [([FunctionalDependency],
(SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
[SourceConstraint], [Declaration]))]
clss)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a b. [a] -> [b] -> [(a, b)]
zip [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
SourceType)]
syns [TypeDeclarationResult]
syn_ks) forall a b. (a -> b) -> a -> b
$ \((SourceAnn
_, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, SourceType
_), (SourceType
elabTy, SourceType
kind)) -> do
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
args
let args' :: [(Text, Maybe SourceType)]
args' = [(Text, Maybe SourceType)]
args [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
`withKinds` SourceType
kind
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> SourceType
-> m ()
addTypeSynonym ModuleName
moduleName ProperName 'TypeName
name [(Text, Maybe SourceType)]
args' SourceType
elabTy SourceType
kind
let dataDeclsWithKinds :: [(DataDeclType, ProperName 'TypeName, [(Text, Maybe SourceType)],
[(DataConstructorDeclaration, SourceType)], SourceType)]
dataDeclsWithKinds = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(DataDeclType
dtype, (SourceAnn
_, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, [DataConstructorDeclaration]
_)) ([(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
ctorKind) ->
(DataDeclType
dtype, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
`withKinds` SourceType
ctorKind, [(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
ctorKind)) [(DataDeclType,
(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
[DataConstructorDeclaration]))]
dataDecls [([(DataConstructorDeclaration, SourceType)], SourceType)]
data_ks
ProperName 'TypeName -> [(Text, Maybe SourceType)] -> [Role]
inferRoles' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Environment
-> ModuleName
-> [RoleDeclarationData]
-> [DataDeclaration]
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> [Role]
inferDataBindingGroupRoles Environment
env ModuleName
moduleName [RoleDeclarationData]
roleDecls) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(DataDeclType, ProperName 'TypeName, [(Text, Maybe SourceType)],
[(DataConstructorDeclaration, SourceType)], SourceType)]
dataDeclsWithKinds forall a b. (a -> b) -> a -> b
$ \(DataDeclType
_, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, [(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
_) ->
(ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (DataConstructorDeclaration -> m DataConstructorDeclaration
replaceTypeSynonymsInDataConstructor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(DataConstructorDeclaration, SourceType)]
dataCtors
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(DataDeclType, ProperName 'TypeName, [(Text, Maybe SourceType)],
[(DataConstructorDeclaration, SourceType)], SourceType)]
dataDeclsWithKinds forall a b. (a -> b) -> a -> b
$ \(DataDeclType
dtype, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args', [(DataConstructorDeclaration, SourceType)]
dataCtors, SourceType
ctorKind) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DataDeclType
dtype forall a. Eq a => a -> a -> Bool
== DataDeclType
Newtype) 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 :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName
-> [DataConstructorDeclaration]
-> m (DataConstructorDeclaration, (Ident, SourceType))
checkNewtype ProperName 'TypeName
name (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(DataConstructorDeclaration, SourceType)]
dataCtors)
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
args'
let args'' :: [(Text, Maybe SourceType, Role)]
args'' = [(Text, Maybe SourceType)]
args' [(Text, Maybe SourceType)]
-> [Role] -> [(Text, Maybe SourceType, Role)]
`withRoles` ProperName 'TypeName -> [(Text, Maybe SourceType)] -> [Role]
inferRoles' ProperName 'TypeName
name [(Text, Maybe SourceType)]
args'
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType, Role)]
-> [(DataConstructorDeclaration, SourceType)]
-> SourceType
-> m ()
addDataType ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType, Role)]
args'' [(DataConstructorDeclaration, SourceType)]
dataCtors SourceType
ctorKind
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [RoleDeclarationData]
roleDecls forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName -> RoleDeclarationData -> m ()
checkRoleDeclaration ModuleName
moduleName
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a b. [a] -> [b] -> [(a, b)]
zip [([FunctionalDependency],
(SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
[SourceConstraint], [Declaration]))]
clss [ClassDeclarationResult]
cls_ks) forall a b. (a -> b) -> a -> b
$ \(([FunctionalDependency]
deps, (SourceAnn
sa, ProperName 'ClassName
pn, [(Text, Maybe SourceType)]
_, [SourceConstraint]
_, [Declaration]
_)), ([(Text, SourceType)]
args', [SourceConstraint]
implies', [Declaration]
tys', SourceType
kind)) -> do
let qualifiedClassName :: Qualified (ProperName 'ClassName)
qualifiedClassName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'ClassName
pn
forall e (m :: * -> *). MonadError e m => e -> Bool -> m ()
guardWith (SimpleErrorMessage -> MultipleErrors
errorMessage (ProperName 'ClassName -> SourceSpan -> SimpleErrorMessage
DuplicateTypeClass ProperName 'ClassName
pn (forall a b. (a, b) -> a
fst SourceAnn
sa))) forall a b. (a -> b) -> a -> b
$
Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member Qualified (ProperName 'ClassName)
qualifiedClassName (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env))
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> [Declaration]
-> SourceType
-> m ()
addTypeClass ModuleName
moduleName Qualified (ProperName 'ClassName)
qualifiedClassName (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, SourceType)]
args') [SourceConstraint]
implies' [FunctionalDependency]
deps [Declaration]
tys' SourceType
kind
forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
where
toTypeSynonym :: Declaration
-> Maybe
(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
SourceType)
toTypeSynonym (TypeSynonymDeclaration SourceAnn
sa ProperName 'TypeName
nm [(Text, Maybe SourceType)]
args SourceType
ty) = forall a. a -> Maybe a
Just (SourceAnn
sa, ProperName 'TypeName
nm, [(Text, Maybe SourceType)]
args, SourceType
ty)
toTypeSynonym Declaration
_ = forall a. Maybe a
Nothing
toDataDecl :: Declaration
-> Maybe
(DataDeclType,
(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
[DataConstructorDeclaration]))
toDataDecl (DataDeclaration SourceAnn
sa DataDeclType
dtype ProperName 'TypeName
nm [(Text, Maybe SourceType)]
args [DataConstructorDeclaration]
dctors) = forall a. a -> Maybe a
Just (DataDeclType
dtype, (SourceAnn
sa, ProperName 'TypeName
nm, [(Text, Maybe SourceType)]
args, [DataConstructorDeclaration]
dctors))
toDataDecl Declaration
_ = forall a. Maybe a
Nothing
toRoleDecl :: Declaration -> Maybe RoleDeclarationData
toRoleDecl (RoleDeclaration RoleDeclarationData
rdd) = forall a. a -> Maybe a
Just RoleDeclarationData
rdd
toRoleDecl Declaration
_ = forall a. Maybe a
Nothing
toClassDecl :: Declaration
-> Maybe
([FunctionalDependency],
(SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
[SourceConstraint], [Declaration]))
toClassDecl (TypeClassDeclaration SourceAnn
sa ProperName 'ClassName
nm [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [FunctionalDependency]
deps [Declaration]
decls) = forall a. a -> Maybe a
Just ([FunctionalDependency]
deps, (SourceAnn
sa, ProperName 'ClassName
nm, [(Text, Maybe SourceType)]
args, [SourceConstraint]
implies, [Declaration]
decls))
toClassDecl Declaration
_ = forall a. Maybe a
Nothing
go (TypeSynonymDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) ProperName 'TypeName
name [(Text, Maybe SourceType)]
args SourceType
ty) = do
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInTypeSynonym ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss) ) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
[Text] -> m ()
checkDuplicateTypeArguments forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
args
(SourceType
elabTy, SourceType
kind) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> (SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceType)],
SourceType)
-> m TypeDeclarationResult
kindOfTypeSynonym ModuleName
moduleName (SourceAnn
sa, ProperName 'TypeName
name, [(Text, Maybe SourceType)]
args, SourceType
ty)
let args' :: [(Text, Maybe SourceType)]
args' = [(Text, Maybe SourceType)]
args [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
`withKinds` SourceType
kind
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> SourceType
-> m ()
addTypeSynonym ModuleName
moduleName ProperName 'TypeName
name [(Text, Maybe SourceType)]
args' SourceType
elabTy SourceType
kind
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> Declaration
TypeSynonymDeclaration SourceAnn
sa ProperName 'TypeName
name [(Text, Maybe SourceType)]
args SourceType
ty
go (KindDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) KindSignatureFor
kindFor ProperName 'TypeName
name SourceType
ty) = do
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInKindDeclaration ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
SourceType
elabTy <- forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withFreshSubstitution forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m,
MonadState CheckState m) =>
ModuleName -> SourceType -> m SourceType
checkKindDeclaration ModuleName
moduleName SourceType
ty
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name) (SourceType
elabTy, TypeKind
LocalTypeVariable) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> KindSignatureFor
-> ProperName 'TypeName
-> SourceType
-> Declaration
KindDeclaration SourceAnn
sa KindSignatureFor
kindFor ProperName 'TypeName
name SourceType
elabTy
go d :: Declaration
d@(RoleDeclaration RoleDeclarationData
rdd) = do
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName -> RoleDeclarationData -> m ()
checkRoleDeclaration ModuleName
moduleName RoleDeclarationData
rdd
forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
go TypeDeclaration{} =
forall a. HasCallStack => String -> a
internalError String
"Type declarations should have been removed before typeCheckAlld"
go (ValueDecl sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) Ident
name NameKind
nameKind [] [MkUnguarded Expr
val]) = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
let declHint :: MultipleErrors -> MultipleErrors
declHint = if Ident -> Bool
isPlainIdent Ident
name then ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (Ident -> ErrorMessageHint
ErrorInValueDeclaration Ident
name) else forall a. a -> a
id
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (MultipleErrors -> MultipleErrors
declHint forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
Expr
val' <- forall (m :: * -> *).
MonadWriter MultipleErrors m =>
SourceSpan -> Environment -> ModuleName -> Expr -> m Expr
checkExhaustiveExpr SourceSpan
ss Environment
env ModuleName
moduleName Expr
val
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName -> Ident -> m ()
valueIsNotDefined ModuleName
moduleName Ident
name
forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
BindingGroupType
-> ModuleName
-> [((SourceAnn, Ident), Expr)]
-> m [((SourceAnn, Ident), (Expr, SourceType))]
typesOf BindingGroupType
NonRecursiveBindingGroup ModuleName
moduleName [((SourceAnn
sa, Ident
name), Expr
val')] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[((SourceAnn, Ident)
_, (Expr
val'', SourceType
ty))] -> do
forall (m :: * -> *).
MonadState CheckState m =>
ModuleName -> Ident -> SourceType -> NameKind -> m ()
addValue ModuleName
moduleName Ident
name SourceType
ty NameKind
nameKind
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
name NameKind
nameKind [] [Expr -> GuardedExpr
MkUnguarded Expr
val'']
[((SourceAnn, Ident), (Expr, SourceType))]
_ -> forall a. HasCallStack => String -> a
internalError String
"typesOf did not return a singleton"
go ValueDeclaration{} = forall a. HasCallStack => String -> a
internalError String
"Binders were not desugared"
go BoundValueDeclaration{} = forall a. HasCallStack => String -> a
internalError String
"BoundValueDeclaration should be desugared"
go (BindingGroupDeclaration NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals) = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
let sss :: NonEmpty SourceSpan
sss = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(((SourceSpan
ss, [Comment]
_), Ident
_), NameKind
_, Expr
_) -> SourceSpan
ss) NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (NonEmpty Ident -> ErrorMessageHint
ErrorInBindingGroup (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((SourceAnn
_, Ident
ident), NameKind
_, Expr
_) -> Ident
ident) NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (NonEmpty SourceSpan -> ErrorMessageHint
PositionedError NonEmpty SourceSpan
sss)) forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals forall a b. (a -> b) -> a -> b
$ \((SourceAnn
_, Ident
ident), NameKind
_, Expr
_) -> forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName -> Ident -> m ()
valueIsNotDefined ModuleName
moduleName Ident
ident
[((SourceAnn, Ident), NameKind, Expr)]
vals' <- forall a. NonEmpty a -> [a]
NEL.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(sai :: (SourceAnn, Ident)
sai@((SourceSpan
ss, [Comment]
_), Ident
_), NameKind
nk, Expr
expr) -> ((SourceAnn, Ident)
sai, NameKind
nk,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadWriter MultipleErrors m =>
SourceSpan -> Environment -> ModuleName -> Expr -> m Expr
checkExhaustiveExpr SourceSpan
ss Environment
env ModuleName
moduleName Expr
expr) NonEmpty ((SourceAnn, Ident), NameKind, Expr)
vals
[((SourceAnn, Ident), (Expr, SourceType))]
tys <- forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
BindingGroupType
-> ModuleName
-> [((SourceAnn, Ident), Expr)]
-> m [((SourceAnn, Ident), (Expr, SourceType))]
typesOf BindingGroupType
RecursiveBindingGroup ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((SourceAnn, Ident)
sai, NameKind
_, Expr
ty) -> ((SourceAnn, Ident)
sai, Expr
ty)) [((SourceAnn, Ident), NameKind, Expr)]
vals'
[((SourceAnn, Ident), NameKind, Expr)]
vals'' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ ((SourceAnn, Ident)
sai, Expr
val, NameKind
nameKind, SourceType
ty)
| (sai :: (SourceAnn, Ident)
sai@(SourceAnn
_, Ident
name), NameKind
nameKind, Expr
_) <- [((SourceAnn, Ident), NameKind, Expr)]
vals'
, ((SourceAnn
_, Ident
name'), (Expr
val, SourceType
ty)) <- [((SourceAnn, Ident), (Expr, SourceType))]
tys
, Ident
name forall a. Eq a => a -> a -> Bool
== Ident
name'
] forall a b. (a -> b) -> a -> b
$ \(sai :: (SourceAnn, Ident)
sai@(SourceAnn
_, Ident
name), Expr
val, NameKind
nameKind, SourceType
ty) -> do
forall (m :: * -> *).
MonadState CheckState m =>
ModuleName -> Ident -> SourceType -> NameKind -> m ()
addValue ModuleName
moduleName Ident
name SourceType
ty NameKind
nameKind
forall (m :: * -> *) a. Monad m => a -> m a
return ((SourceAnn, Ident)
sai, NameKind
nameKind, Expr
val)
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ((SourceAnn, Ident), NameKind, Expr) -> Declaration
BindingGroupDeclaration forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NEL.fromList [((SourceAnn, Ident), NameKind, Expr)]
vals''
go d :: Declaration
d@(ExternDataDeclaration (SourceSpan
ss, [Comment]
_) ProperName 'TypeName
name SourceType
kind) = do
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInForeignImportData ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
SourceType
elabKind <- forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withFreshSubstitution forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m,
MonadState CheckState m) =>
ModuleName -> SourceType -> m SourceType
checkKindDeclaration ModuleName
moduleName SourceType
kind
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
let qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
roles :: [Role]
roles = forall a. Type a -> [Role]
nominalRolesForKind SourceType
elabKind
forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
elabKind, [Role] -> TypeKind
ExternData [Role]
roles) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
go d :: Declaration
d@(ExternDeclaration (SourceSpan
ss, [Comment]
_) Ident
name SourceType
ty) = do
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (Ident -> ErrorMessageHint
ErrorInForeignImport Ident
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
(SourceType
elabTy, SourceType
kind) <- forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withFreshSubstitution forall a b. (a -> b) -> a -> b
$ do
(([(Int, SourceType)]
unks, SourceType
ty'), SourceType
kind) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
HasCallStack) =>
SourceType -> m (([(Int, SourceType)], SourceType), SourceType)
kindOfWithUnknowns SourceType
ty
SourceType
ty'' <- forall (m :: * -> *).
MonadState CheckState m =>
[(Int, SourceType)] -> SourceType -> m SourceType
varIfUnknown [(Int, SourceType)]
unks SourceType
ty'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceType
ty'', SourceType
kind)
forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
HasCallStack) =>
SourceType -> SourceType -> m ()
checkTypeKind SourceType
elabTy SourceType
kind
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) of
Just (SourceType, NameKind, NameVisibility)
_ -> 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
$ Ident -> SimpleErrorMessage
RedefinedIdent Ident
name
Maybe (SourceType, NameKind, NameVisibility)
Nothing -> forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv (Environment
env { names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (SourceType
elabTy, NameKind
External, NameVisibility
Defined) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) })
forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
go d :: Declaration
d@FixityDeclaration{} = forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
go d :: Declaration
d@ImportDeclaration{} = forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
go d :: Declaration
d@(TypeClassDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) ProperName 'ClassName
pn [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [FunctionalDependency]
deps [Declaration]
tys) = do
forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'ClassName -> ErrorMessageHint
ErrorInTypeClassDeclaration ProperName 'ClassName
pn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
let qualifiedClassName :: Qualified (ProperName 'ClassName)
qualifiedClassName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'ClassName
pn
forall e (m :: * -> *). MonadError e m => e -> Bool -> m ()
guardWith (SimpleErrorMessage -> MultipleErrors
errorMessage (ProperName 'ClassName -> SourceSpan -> SimpleErrorMessage
DuplicateTypeClass ProperName 'ClassName
pn SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$
Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member Qualified (ProperName 'ClassName)
qualifiedClassName (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env))
([(Text, SourceType)]
args', [SourceConstraint]
implies', [Declaration]
tys', SourceType
kind) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> (SourceAnn, ProperName 'ClassName, [(Text, Maybe SourceType)],
[SourceConstraint], [Declaration])
-> m ClassDeclarationResult
kindOfClass ModuleName
moduleName (SourceAnn
sa, ProperName 'ClassName
pn, [(Text, Maybe SourceType)]
args, [SourceConstraint]
implies, [Declaration]
tys)
forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> [Declaration]
-> SourceType
-> m ()
addTypeClass ModuleName
moduleName Qualified (ProperName 'ClassName)
qualifiedClassName (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, SourceType)]
args') [SourceConstraint]
implies' [FunctionalDependency]
deps [Declaration]
tys' SourceType
kind
forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
go (TypeInstanceDeclaration SourceAnn
_ SourceAnn
_ ChainId
_ Integer
_ (Left Text
_) [SourceConstraint]
_ Qualified (ProperName 'ClassName)
_ [SourceType]
_ TypeInstanceBody
_) = forall a. HasCallStack => String -> a
internalError String
"typeCheckAll: type class instance generated name should have been desugared"
go d :: Declaration
d@(TypeInstanceDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) SourceAnn
_ ChainId
ch Integer
idx (Right Ident
dictName) [SourceConstraint]
deps Qualified (ProperName 'ClassName)
className [SourceType]
tys TypeInstanceBody
body) =
forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (Qualified (ProperName 'ClassName)
-> [SourceType] -> ErrorMessageHint
ErrorInInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
let qualifiedDictName :: Qualified Ident
qualifiedDictName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
dictName
forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_) (Environment
-> Map
QualifiedBy
(Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries Environment
env) forall a b. (a -> b) -> a -> b
$ \Map (Qualified Ident) (NonEmpty NamedDict)
dictionaries ->
forall e (m :: * -> *). MonadError e m => e -> Bool -> m ()
guardWith (SimpleErrorMessage -> MultipleErrors
errorMessage (Ident -> SourceSpan -> SimpleErrorMessage
DuplicateInstance Ident
dictName SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$
Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member Qualified Ident
qualifiedDictName Map (Qualified Ident) (NonEmpty NamedDict)
dictionaries)
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
className (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env) of
Maybe TypeClassData
Nothing -> forall a. HasCallStack => String -> a
internalError String
"typeCheckAll: Encountered unknown type class in instance declaration"
Just TypeClassData
typeClass -> do
Ident
-> Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> m ()
checkInstanceArity Ident
dictName Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys
([SourceConstraint]
deps', [SourceType]
kinds', [SourceType]
tys', [(Text, SourceType)]
vars) <- forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withFreshSubstitution forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> InstanceDeclarationArgs
-> m ([SourceConstraint], [SourceType], [SourceType],
[(Text, SourceType)])
checkInstanceDeclaration ModuleName
moduleName (SourceAnn
sa, [SourceConstraint]
deps, Qualified (ProperName 'ClassName)
className, [SourceType]
tys)
[SourceType]
tys'' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceType]
tys'
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
TypeClassData -> Int -> SourceType -> m ()
checkTypeClassInstance TypeClassData
typeClass) [Int
0..] [SourceType]
tys''
let nonOrphanModules :: Set ModuleName
nonOrphanModules = Qualified (ProperName 'ClassName)
-> TypeClassData -> [SourceType] -> Set ModuleName
findNonOrphanModules Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys''
Ident
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> Set ModuleName
-> m ()
checkOrphanInstance Ident
dictName Qualified (ProperName 'ClassName)
className [SourceType]
tys'' Set ModuleName
nonOrphanModules
let chainId :: Maybe ChainId
chainId = forall a. a -> Maybe a
Just ChainId
ch
SourceSpan
-> Maybe ChainId
-> Ident
-> [(Text, SourceType)]
-> Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> Set ModuleName
-> m ()
checkOverlappingInstance SourceSpan
ss Maybe ChainId
chainId Ident
dictName [(Text, SourceType)]
vars Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys'' Set ModuleName
nonOrphanModules
TypeInstanceBody
_ <- forall (f :: * -> *).
Applicative f =>
([Declaration] -> f [Declaration])
-> TypeInstanceBody -> f TypeInstanceBody
traverseTypeInstanceBody [Declaration] -> m [Declaration]
checkInstanceMembers TypeInstanceBody
body
[SourceConstraint]
deps'' <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Functor f =>
([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)
overConstraintArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceConstraint]
deps'
let dict :: NamedDict
dict =
forall v.
Maybe ChainId
-> Integer
-> v
-> [(Qualified (ProperName 'ClassName), Integer)]
-> Qualified (ProperName 'ClassName)
-> [(Text, SourceType)]
-> [SourceType]
-> [SourceType]
-> Maybe [SourceConstraint]
-> Maybe SourceType
-> TypeClassDictionaryInScope v
TypeClassDictionaryInScope Maybe ChainId
chainId Integer
idx Qualified Ident
qualifiedDictName [] Qualified (ProperName 'ClassName)
className [(Text, SourceType)]
vars [SourceType]
kinds' [SourceType]
tys'' (forall a. a -> Maybe a
Just [SourceConstraint]
deps'') forall a b. (a -> b) -> a -> b
$
if Ident -> Bool
isPlainIdent Ident
dictName then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SourceSpan
-> [(Text, SourceType)]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> SourceType
srcInstanceType SourceSpan
ss [(Text, SourceType)]
vars Qualified (ProperName 'ClassName)
className [SourceType]
tys''
forall (m :: * -> *).
MonadState CheckState m =>
QualifiedBy
-> Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict))
-> m ()
addTypeClassDictionaries (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. k -> a -> Map k a
M.singleton Qualified (ProperName 'ClassName)
className forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
M.singleton (forall v. TypeClassDictionaryInScope v -> v
tcdValue NamedDict
dict) (forall (f :: * -> *) a. Applicative f => a -> f a
pure NamedDict
dict)
forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> m ()
checkInstanceArity :: Ident
-> Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> m ()
checkInstanceArity Ident
dictName Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys = do
let typeClassArity :: Int
typeClassArity = forall (t :: * -> *) a. Foldable t => t a -> Int
length (TypeClassData -> [(Text, Maybe SourceType)]
typeClassArguments TypeClassData
typeClass)
instanceArity :: Int
instanceArity = forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
typeClassArity forall a. Eq a => a -> a -> Bool
/= Int
instanceArity) forall a b. (a -> b) -> a -> b
$
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
$ Ident
-> Qualified (ProperName 'ClassName)
-> Int
-> Int
-> SimpleErrorMessage
ClassInstanceArityMismatch Ident
dictName Qualified (ProperName 'ClassName)
className Int
typeClassArity Int
instanceArity
checkInstanceMembers :: [Declaration] -> m [Declaration]
checkInstanceMembers :: [Declaration] -> m [Declaration]
checkInstanceMembers [Declaration]
instDecls = do
let idents :: [Ident]
idents = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [[a]]
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Ident
memberName forall a b. (a -> b) -> a -> b
$ [Declaration]
instDecls
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. Eq a => [a] -> Maybe a
firstDuplicate [Ident]
idents) forall a b. (a -> b) -> a -> b
$ \Ident
ident ->
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
$ Ident -> SimpleErrorMessage
DuplicateValueDeclaration Ident
ident
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
instDecls
where
memberName :: Declaration -> Ident
memberName :: Declaration -> Ident
memberName (ValueDeclaration ValueDeclarationData [GuardedExpr]
vd) = forall a. ValueDeclarationData a -> Ident
valdeclIdent ValueDeclarationData [GuardedExpr]
vd
memberName Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"checkInstanceMembers: Invalid declaration in type instance definition"
firstDuplicate :: (Eq a) => [a] -> Maybe a
firstDuplicate :: forall a. Eq a => [a] -> Maybe a
firstDuplicate (a
x : xs :: [a]
xs@(a
y : [a]
_))
| a
x forall a. Eq a => a -> a -> Bool
== a
y = forall a. a -> Maybe a
Just a
x
| Bool
otherwise = forall a. Eq a => [a] -> Maybe a
firstDuplicate [a]
xs
firstDuplicate [a]
_ = forall a. Maybe a
Nothing
findNonOrphanModules
:: Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> S.Set ModuleName
findNonOrphanModules :: Qualified (ProperName 'ClassName)
-> TypeClassData -> [SourceType] -> Set ModuleName
findNonOrphanModules (Qualified (ByModuleName ModuleName
mn') ProperName 'ClassName
_) TypeClassData
typeClass [SourceType]
tys' = Set ModuleName
nonOrphanModules
where
nonOrphanModules :: S.Set ModuleName
nonOrphanModules :: Set ModuleName
nonOrphanModules = forall a. Ord a => a -> Set a -> Set a
S.insert ModuleName
mn' Set ModuleName
nonOrphanModules'
typeModule :: SourceType -> Maybe ModuleName
typeModule :: SourceType -> Maybe ModuleName
typeModule (TypeVar SourceAnn
_ Text
_) = forall a. Maybe a
Nothing
typeModule (TypeLevelString SourceAnn
_ PSString
_) = forall a. Maybe a
Nothing
typeModule (TypeLevelInt SourceAnn
_ Integer
_) = forall a. Maybe a
Nothing
typeModule (TypeConstructor SourceAnn
_ (Qualified (ByModuleName ModuleName
mn'') ProperName 'TypeName
_)) = forall a. a -> Maybe a
Just ModuleName
mn''
typeModule (TypeConstructor SourceAnn
_ (Qualified (BySourcePos SourcePos
_) ProperName 'TypeName
_)) = forall a. HasCallStack => String -> a
internalError String
"Unqualified type name in findNonOrphanModules"
typeModule (TypeApp SourceAnn
_ SourceType
t1 SourceType
_) = SourceType -> Maybe ModuleName
typeModule SourceType
t1
typeModule (KindApp SourceAnn
_ SourceType
t1 SourceType
_) = SourceType -> Maybe ModuleName
typeModule SourceType
t1
typeModule (KindedType SourceAnn
_ SourceType
t1 SourceType
_) = SourceType -> Maybe ModuleName
typeModule SourceType
t1
typeModule SourceType
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid type in instance in findNonOrphanModules"
modulesByTypeIndex :: M.Map Int (Maybe ModuleName)
modulesByTypeIndex :: Map Int (Maybe ModuleName)
modulesByTypeIndex = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (SourceType -> Maybe ModuleName
typeModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SourceType]
tys'))
lookupModule :: Int -> S.Set ModuleName
lookupModule :: Int -> Set ModuleName
lookupModule Int
idx = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idx Map Int (Maybe ModuleName)
modulesByTypeIndex of
Just Maybe ModuleName
ms -> forall a. Ord a => [a] -> Set a
S.fromList (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe ModuleName
ms)
Maybe (Maybe ModuleName)
Nothing -> forall a. HasCallStack => String -> a
internalError String
"Unknown type index in findNonOrphanModules"
nonOrphanModules' :: S.Set ModuleName
nonOrphanModules' :: Set ModuleName
nonOrphanModules' = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Ord a => Set a -> Set a -> Set a
S.intersection (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> Set ModuleName
lookupModule forall b a. Ord b => (a -> b) -> Set a -> Set b
`S.map` TypeClassData -> Set (Set Int)
typeClassCoveringSets TypeClassData
typeClass)
findNonOrphanModules Qualified (ProperName 'ClassName)
_ TypeClassData
_ [SourceType]
_ = forall a. HasCallStack => String -> a
internalError String
"Unqualified class name in findNonOrphanModules"
checkOverlappingInstance
:: SourceSpan
-> Maybe ChainId
-> Ident
-> [(Text, SourceType)]
-> Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> S.Set ModuleName
-> m ()
checkOverlappingInstance :: SourceSpan
-> Maybe ChainId
-> Ident
-> [(Text, SourceType)]
-> Qualified (ProperName 'ClassName)
-> TypeClassData
-> [SourceType]
-> Set ModuleName
-> m ()
checkOverlappingInstance SourceSpan
ss Maybe ChainId
ch Ident
dictName [(Text, SourceType)]
vars Qualified (ProperName 'ClassName)
className TypeClassData
typeClass [SourceType]
tys' Set ModuleName
nonOrphanModules = do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set ModuleName
nonOrphanModules forall a b. (a -> b) -> a -> b
$ \ModuleName
m -> do
[(Qualified Ident, NonEmpty NamedDict)]
dicts <- forall k a. Map k a -> [(k, a)]
M.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadState CheckState m =>
QualifiedBy
-> Qualified (ProperName 'ClassName)
-> m (Map (Qualified Ident) (NonEmpty NamedDict))
lookupTypeClassDictionariesForClass (ModuleName -> QualifiedBy
ByModuleName ModuleName
m) Qualified (ProperName 'ClassName)
className
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Qualified Ident, NonEmpty NamedDict)]
dicts forall a b. (a -> b) -> a -> b
$ \(Qualified QualifiedBy
mn' Ident
ident, NonEmpty NamedDict
dictNel) -> do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty NamedDict
dictNel forall a b. (a -> b) -> a -> b
$ \NamedDict
dict -> do
if Maybe ChainId
ch forall a. Eq a => a -> a -> Bool
== forall v. TypeClassDictionaryInScope v -> Maybe ChainId
tcdChain NamedDict
dict Bool -> Bool -> Bool
||
Set (Set Int) -> [SourceType] -> [SourceType] -> Bool
instancesAreApart (TypeClassData -> Set (Set Int)
typeClassCoveringSets TypeClassData
typeClass) [SourceType]
tys' (forall v. TypeClassDictionaryInScope v -> [SourceType]
tcdInstanceTypes NamedDict
dict)
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
let this :: Either SourceType Ident
this = if Ident -> Bool
isPlainIdent Ident
dictName then forall a b. b -> Either a b
Right Ident
dictName else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SourceSpan
-> [(Text, SourceType)]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> SourceType
srcInstanceType SourceSpan
ss [(Text, SourceType)]
vars Qualified (ProperName 'ClassName)
className [SourceType]
tys'
let that :: Qualified (Either SourceType Ident)
that = forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
mn' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r l. r -> Maybe l -> Either l r
maybeToLeft Ident
ident forall a b. (a -> b) -> a -> b
$ forall v. TypeClassDictionaryInScope v -> Maybe SourceType
tcdDescription NamedDict
dict
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
$
Qualified (ProperName 'ClassName)
-> [SourceType]
-> [Qualified (Either SourceType Ident)]
-> SimpleErrorMessage
OverlappingInstances Qualified (ProperName 'ClassName)
className
[SourceType]
tys'
[Qualified (Either SourceType Ident)
that, forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Either SourceType Ident
this]
instancesAreApart
:: S.Set (S.Set Int)
-> [SourceType]
-> [SourceType]
-> Bool
instancesAreApart :: Set (Set Int) -> [SourceType] -> [SourceType] -> Bool
instancesAreApart Set (Set Int)
sets [SourceType]
lhs [SourceType]
rhs = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Int -> Bool
typesApart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList) (forall a. Set a -> [a]
S.toList Set (Set Int)
sets)
where
typesApart :: Int -> Bool
typesApart :: Int -> Bool
typesApart Int
i = SourceType -> SourceType -> Bool
typeHeadsApart ([SourceType]
lhs forall a. [a] -> Int -> a
!! Int
i) ([SourceType]
rhs forall a. [a] -> Int -> a
!! Int
i)
typeHeadsApart :: SourceType -> SourceType -> Bool
typeHeadsApart :: SourceType -> SourceType -> Bool
typeHeadsApart SourceType
l SourceType
r | forall a b. Type a -> Type b -> Bool
eqType SourceType
l SourceType
r = Bool
False
typeHeadsApart (TypeVar SourceAnn
_ Text
_) SourceType
_ = Bool
False
typeHeadsApart SourceType
_ (TypeVar SourceAnn
_ Text
_) = Bool
False
typeHeadsApart (KindedType SourceAnn
_ SourceType
t1 SourceType
_) SourceType
t2 = SourceType -> SourceType -> Bool
typeHeadsApart SourceType
t1 SourceType
t2
typeHeadsApart SourceType
t1 (KindedType SourceAnn
_ SourceType
t2 SourceType
_) = SourceType -> SourceType -> Bool
typeHeadsApart SourceType
t1 SourceType
t2
typeHeadsApart (TypeApp SourceAnn
_ SourceType
h1 SourceType
t1) (TypeApp SourceAnn
_ SourceType
h2 SourceType
t2) = SourceType -> SourceType -> Bool
typeHeadsApart SourceType
h1 SourceType
h2 Bool -> Bool -> Bool
|| SourceType -> SourceType -> Bool
typeHeadsApart SourceType
t1 SourceType
t2
typeHeadsApart SourceType
_ SourceType
_ = Bool
True
checkOrphanInstance
:: Ident
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> S.Set ModuleName
-> m ()
checkOrphanInstance :: Ident
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> Set ModuleName
-> m ()
checkOrphanInstance Ident
dictName Qualified (ProperName 'ClassName)
className [SourceType]
tys' Set ModuleName
nonOrphanModules
| ModuleName
moduleName forall a. Ord a => a -> Set a -> Bool
`S.member` Set ModuleName
nonOrphanModules = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = 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
$ Ident
-> Qualified (ProperName 'ClassName)
-> Set ModuleName
-> [SourceType]
-> SimpleErrorMessage
OrphanInstance Ident
dictName Qualified (ProperName 'ClassName)
className Set ModuleName
nonOrphanModules [SourceType]
tys'
withKinds :: [(Text, Maybe SourceType)] -> SourceType -> [(Text, Maybe SourceType)]
withKinds :: [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [] SourceType
_ = []
withKinds [(Text, Maybe SourceType)]
ss (ForAll SourceAnn
_ Text
_ Maybe SourceType
_ SourceType
k Maybe SkolemScope
_) = [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [(Text, Maybe SourceType)]
ss SourceType
k
withKinds (s :: (Text, Maybe SourceType)
s@(Text
_, Just SourceType
_):[(Text, Maybe SourceType)]
ss) (TypeApp SourceAnn
_ (TypeApp SourceAnn
_ SourceType
tyFn SourceType
_) SourceType
k2) | forall a b. Type a -> Type b -> Bool
eqType SourceType
tyFn SourceType
tyFunction = (Text, Maybe SourceType)
s forall a. a -> [a] -> [a]
: [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [(Text, Maybe SourceType)]
ss SourceType
k2
withKinds ((Text
s, Maybe SourceType
Nothing):[(Text, Maybe SourceType)]
ss) (TypeApp SourceAnn
_ (TypeApp SourceAnn
_ SourceType
tyFn SourceType
k1) SourceType
k2) | forall a b. Type a -> Type b -> Bool
eqType SourceType
tyFn SourceType
tyFunction = (Text
s, forall a. a -> Maybe a
Just SourceType
k1) forall a. a -> [a] -> [a]
: [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [(Text, Maybe SourceType)]
ss SourceType
k2
withKinds [(Text, Maybe SourceType)]
_ SourceType
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid arguments to withKinds"
withRoles :: [(Text, Maybe SourceType)] -> [Role] -> [(Text, Maybe SourceType, Role)]
withRoles :: [(Text, Maybe SourceType)]
-> [Role] -> [(Text, Maybe SourceType, Role)]
withRoles = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
$ \(Text
v, Maybe SourceType
k) Role
r -> (Text
v, Maybe SourceType
k, Role
r)
replaceTypeSynonymsInDataConstructor :: DataConstructorDeclaration -> m DataConstructorDeclaration
replaceTypeSynonymsInDataConstructor :: DataConstructorDeclaration -> m DataConstructorDeclaration
replaceTypeSynonymsInDataConstructor DataConstructorDeclaration{[(Ident, SourceType)]
SourceAnn
ProperName 'ConstructorName
dataCtorFields :: DataConstructorDeclaration -> [(Ident, SourceType)]
dataCtorName :: DataConstructorDeclaration -> ProperName 'ConstructorName
dataCtorAnn :: DataConstructorDeclaration -> SourceAnn
dataCtorFields :: [(Ident, SourceType)]
dataCtorName :: ProperName 'ConstructorName
dataCtorAnn :: SourceAnn
..} = do
[(Ident, SourceType)]
dataCtorFields' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms) [(Ident, SourceType)]
dataCtorFields
forall (m :: * -> *) a. Monad m => a -> m a
return DataConstructorDeclaration
{ dataCtorFields :: [(Ident, SourceType)]
dataCtorFields = [(Ident, SourceType)]
dataCtorFields'
, SourceAnn
ProperName 'ConstructorName
dataCtorName :: ProperName 'ConstructorName
dataCtorAnn :: SourceAnn
dataCtorName :: ProperName 'ConstructorName
dataCtorAnn :: SourceAnn
..
}
checkNewtype
:: forall m
. MonadError MultipleErrors m
=> ProperName 'TypeName
-> [DataConstructorDeclaration]
-> m (DataConstructorDeclaration, (Ident, SourceType))
checkNewtype :: forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName
-> [DataConstructorDeclaration]
-> m (DataConstructorDeclaration, (Ident, SourceType))
checkNewtype ProperName 'TypeName
_ [decl :: DataConstructorDeclaration
decl@(DataConstructorDeclaration SourceAnn
_ ProperName 'ConstructorName
_ [(Ident, SourceType)
field])] = forall (m :: * -> *) a. Monad m => a -> m a
return (DataConstructorDeclaration
decl, (Ident, SourceType)
field)
checkNewtype ProperName 'TypeName
name [DataConstructorDeclaration]
_ = 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
$ ProperName 'TypeName -> SimpleErrorMessage
InvalidNewtype ProperName 'TypeName
name
typeCheckModule
:: forall m
. (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> M.Map ModuleName Exports
-> Module
-> m Module
typeCheckModule :: forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Map ModuleName Exports -> Module -> m Module
typeCheckModule Map ModuleName Exports
_ (Module SourceSpan
_ [Comment]
_ ModuleName
_ [Declaration]
_ Maybe [DeclarationRef]
Nothing) =
forall a. HasCallStack => String -> a
internalError String
"exports should have been elaborated before typeCheckModule"
typeCheckModule Map ModuleName Exports
modulesExports (Module SourceSpan
ss [Comment]
coms ModuleName
mn [Declaration]
decls (Just [DeclarationRef]
exps)) =
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
let ([Declaration]
decls', [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))]
imports) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ Declaration
-> Either
Declaration
(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))
fromImportDecl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration]
decls
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CheckState
s -> CheckState
s { checkCurrentModule :: Maybe ModuleName
checkCurrentModule = forall a. a -> Maybe a
Just ModuleName
mn, checkCurrentModuleImports :: [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))]
checkCurrentModuleImports = [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))]
imports })
[Declaration]
decls'' <- forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
ModuleName -> [Declaration] -> m [Declaration]
typeCheckAll ModuleName
mn forall a b. (a -> b) -> a -> b
$ Declaration -> Declaration
ignoreWildcardsUnderCompleteTypeSignatures forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration]
decls'
DeclarationRef -> m ()
checkSuperClassesAreExported <- m (DeclarationRef -> m ())
getSuperClassExportCheck
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [DeclarationRef]
exps forall a b. (a -> b) -> a -> b
$ \DeclarationRef
e -> do
DeclarationRef -> m ()
checkTypesAreExported DeclarationRef
e
DeclarationRef -> m ()
checkClassMembersAreExported DeclarationRef
e
DeclarationRef -> m ()
checkClassesAreExported DeclarationRef
e
DeclarationRef -> m ()
checkSuperClassesAreExported DeclarationRef
e
DeclarationRef -> m ()
checkDataConstructorsAreExported DeclarationRef
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
mn (forall a b. (a -> b) -> [a] -> [b]
map (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))
-> Declaration
toImportDecl [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))]
imports forall a. [a] -> [a] -> [a]
++ [Declaration]
decls'') (forall a. a -> Maybe a
Just [DeclarationRef]
exps)
where
fromImportDecl
:: Declaration
-> Either Declaration
( SourceAnn
, ModuleName
, ImportDeclarationType
, Maybe ModuleName
, M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
)
fromImportDecl :: Declaration
-> Either
Declaration
(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))
fromImportDecl (ImportDeclaration SourceAnn
sa ModuleName
moduleName ImportDeclarationType
importDeclarationType Maybe ModuleName
asModuleName) =
forall a b. b -> Either a b
Right (SourceAnn
sa, ModuleName
moduleName, ImportDeclarationType
importDeclarationType, Maybe ModuleName
asModuleName, forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exports
-> Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
exportedTypes forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
moduleName Map ModuleName Exports
modulesExports)
fromImportDecl Declaration
decl = forall a b. a -> Either a b
Left Declaration
decl
toImportDecl
:: ( SourceAnn
, ModuleName
, ImportDeclarationType
, Maybe ModuleName
, M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
)
-> Declaration
toImportDecl :: (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))
-> Declaration
toImportDecl (SourceAnn
sa, ModuleName
moduleName, ImportDeclarationType
importDeclarationType, Maybe ModuleName
asModuleName, Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource)
_) =
SourceAnn
-> ModuleName
-> ImportDeclarationType
-> Maybe ModuleName
-> Declaration
ImportDeclaration SourceAnn
sa ModuleName
moduleName ImportDeclarationType
importDeclarationType Maybe ModuleName
asModuleName
qualify' :: a -> Qualified a
qualify' :: forall a. a -> Qualified a
qualify' = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn)
getSuperClassExportCheck :: m (DeclarationRef -> m ())
getSuperClassExportCheck = do
Map
(Qualified (ProperName 'ClassName))
(Set (Qualified (ProperName 'ClassName)))
classesToSuperClasses <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets
( forall a b k. (a -> b) -> Map k a -> Map k b
M.map
( forall a. Ord a => [a] -> Set a
S.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\(Qualified QualifiedBy
mn' ProperName 'ClassName
_) -> QualifiedBy
mn' forall a. Eq a => a -> a -> Bool
== ModuleName -> QualifiedBy
ByModuleName ModuleName
mn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Constraint a -> Qualified (ProperName 'ClassName)
constraintClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeClassData -> [SourceConstraint]
typeClassSuperclasses
)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv
)
let
transitiveSuperClassesFor
:: Qualified (ProperName 'ClassName)
-> S.Set (Qualified (ProperName 'ClassName))
transitiveSuperClassesFor :: Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
transitiveSuperClassesFor Qualified (ProperName 'ClassName)
qname =
forall a. Eq a => (a -> a) -> a -> a
untilSame
(\Set (Qualified (ProperName 'ClassName))
s -> Set (Qualified (ProperName 'ClassName))
s forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Qualified (ProperName 'ClassName)
n -> forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
S.empty (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
n Map
(Qualified (ProperName 'ClassName))
(Set (Qualified (ProperName 'ClassName)))
classesToSuperClasses)) Set (Qualified (ProperName 'ClassName))
s)
(forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
S.empty (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
qname Map
(Qualified (ProperName 'ClassName))
(Set (Qualified (ProperName 'ClassName)))
classesToSuperClasses))
superClassesFor :: Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
superClassesFor Qualified (ProperName 'ClassName)
qname =
forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
S.empty (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
qname Map
(Qualified (ProperName 'ClassName))
(Set (Qualified (ProperName 'ClassName)))
classesToSuperClasses)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName)))
-> (Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName)))
-> DeclarationRef
-> m ()
checkSuperClassExport Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
superClassesFor Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
transitiveSuperClassesFor
moduleClassExports :: S.Set (Qualified (ProperName 'ClassName))
moduleClassExports :: Set (Qualified (ProperName 'ClassName))
moduleClassExports = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case
TypeClassRef SourceSpan
_ ProperName 'ClassName
name -> forall a. a -> Maybe a
Just (forall a. a -> Qualified a
qualify' ProperName 'ClassName
name)
DeclarationRef
_ -> forall a. Maybe a
Nothing) [DeclarationRef]
exps
untilSame :: Eq a => (a -> a) -> a -> a
untilSame :: forall a. Eq a => (a -> a) -> a -> a
untilSame a -> a
f a
a = let a' :: a
a' = a -> a
f a
a in if a
a forall a. Eq a => a -> a -> Bool
== a
a' then a
a else forall a. Eq a => (a -> a) -> a -> a
untilSame a -> a
f a
a'
checkMemberExport :: (SourceType -> [DeclarationRef]) -> DeclarationRef -> m ()
checkMemberExport :: (SourceType -> [DeclarationRef]) -> DeclarationRef -> m ()
checkMemberExport SourceType -> [DeclarationRef]
extract dr :: DeclarationRef
dr@(TypeRef SourceSpan
_ ProperName 'TypeName
name Maybe [ProperName 'ConstructorName]
dctors) = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. a -> Qualified a
qualify' ProperName 'TypeName
name) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)) forall a b. (a -> b) -> a -> b
$ \(SourceType
k, TypeKind
_) -> do
DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr (SourceType -> [DeclarationRef]
extract SourceType
k)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. a -> Qualified a
qualify' ProperName 'TypeName
name) (Environment
-> Map
(Qualified (ProperName 'TypeName))
([(Text, Maybe SourceType)], SourceType)
typeSynonyms Environment
env)) forall a b. (a -> b) -> a -> b
$ \([(Text, Maybe SourceType)]
_, SourceType
ty) ->
DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr (SourceType -> [DeclarationRef]
extract SourceType
ty)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe [ProperName 'ConstructorName]
dctors forall a b. (a -> b) -> a -> b
$ \[ProperName 'ConstructorName]
dctors' ->
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ProperName 'ConstructorName]
dctors' forall a b. (a -> b) -> a -> b
$ \ProperName 'ConstructorName
dctor ->
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. a -> Qualified a
qualify' ProperName 'ConstructorName
dctor) (Environment
-> Map
(Qualified (ProperName 'ConstructorName))
(DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Environment
env)) forall a b. (a -> b) -> a -> b
$ \(DataDeclType
_, ProperName 'TypeName
_, SourceType
ty, [Ident]
_) ->
DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr (SourceType -> [DeclarationRef]
extract SourceType
ty)
checkMemberExport SourceType -> [DeclarationRef]
extract dr :: DeclarationRef
dr@(ValueRef SourceSpan
_ Ident
name) = do
SourceType
ty <- forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
Qualified Ident -> m SourceType
lookupVariable (forall a. a -> Qualified a
qualify' Ident
name)
DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr (SourceType -> [DeclarationRef]
extract SourceType
ty)
checkMemberExport SourceType -> [DeclarationRef]
_ DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkSuperClassExport
:: (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName)))
-> (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName)))
-> DeclarationRef
-> m ()
checkSuperClassExport :: (Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName)))
-> (Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName)))
-> DeclarationRef
-> m ()
checkSuperClassExport Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
superClassesFor Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
transitiveSuperClassesFor dr :: DeclarationRef
dr@(TypeClassRef SourceSpan
drss ProperName 'ClassName
className) = do
let superClasses :: Set (Qualified (ProperName 'ClassName))
superClasses = Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
superClassesFor (forall a. a -> Qualified a
qualify' ProperName 'ClassName
className)
transitiveSuperClasses :: Set (Qualified (ProperName 'ClassName))
transitiveSuperClasses = Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
transitiveSuperClassesFor (forall a. a -> Qualified a
qualify' ProperName 'ClassName
className)
unexported :: Set (Qualified (ProperName 'ClassName))
unexported = forall a. Ord a => Set a -> Set a -> Set a
S.difference Set (Qualified (ProperName 'ClassName))
superClasses Set (Qualified (ProperName 'ClassName))
moduleClassExports
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set (Qualified (ProperName 'ClassName))
unexported)
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
drss
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationRef -> [DeclarationRef] -> SimpleErrorMessage
TransitiveExportError DeclarationRef
dr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (SourceSpan -> ProperName 'ClassName -> DeclarationRef
TypeClassRef SourceSpan
drss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Qualified a -> a
disqualify)
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (Qualified (ProperName 'ClassName))
transitiveSuperClasses
checkSuperClassExport Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
_ Qualified (ProperName 'ClassName)
-> Set (Qualified (ProperName 'ClassName))
_ DeclarationRef
_ =
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkExport :: DeclarationRef -> [DeclarationRef] -> m ()
checkExport :: DeclarationRef -> [DeclarationRef] -> m ()
checkExport DeclarationRef
dr [DeclarationRef]
drs = case forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationRef -> Bool
exported) [DeclarationRef]
drs of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[DeclarationRef]
hidden -> 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
dr) forall a b. (a -> b) -> a -> b
$ DeclarationRef -> [DeclarationRef] -> SimpleErrorMessage
TransitiveExportError DeclarationRef
dr (forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy DeclarationRef -> DeclarationRef -> Bool
nubEq [DeclarationRef]
hidden)
where
exported :: DeclarationRef -> Bool
exported DeclarationRef
e = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (DeclarationRef -> DeclarationRef -> Bool
exports DeclarationRef
e) [DeclarationRef]
exps
exports :: DeclarationRef -> DeclarationRef -> Bool
exports (TypeRef SourceSpan
_ ProperName 'TypeName
pn1 Maybe [ProperName 'ConstructorName]
_) (TypeRef SourceSpan
_ ProperName 'TypeName
pn2 Maybe [ProperName 'ConstructorName]
_) = ProperName 'TypeName
pn1 forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
pn2
exports (ValueRef SourceSpan
_ Ident
id1) (ValueRef SourceSpan
_ Ident
id2) = Ident
id1 forall a. Eq a => a -> a -> Bool
== Ident
id2
exports (TypeClassRef SourceSpan
_ ProperName 'ClassName
pn1) (TypeClassRef SourceSpan
_ ProperName 'ClassName
pn2) = ProperName 'ClassName
pn1 forall a. Eq a => a -> a -> Bool
== ProperName 'ClassName
pn2
exports DeclarationRef
_ DeclarationRef
_ = Bool
False
nubEq :: DeclarationRef -> DeclarationRef -> Bool
nubEq (TypeRef SourceSpan
_ ProperName 'TypeName
pn1 Maybe [ProperName 'ConstructorName]
_) (TypeRef SourceSpan
_ ProperName 'TypeName
pn2 Maybe [ProperName 'ConstructorName]
_) = ProperName 'TypeName
pn1 forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
pn2
nubEq DeclarationRef
r1 DeclarationRef
r2 = DeclarationRef
r1 forall a. Eq a => a -> a -> Bool
== DeclarationRef
r2
checkTypesAreExported :: DeclarationRef -> m ()
checkTypesAreExported :: DeclarationRef -> m ()
checkTypesAreExported DeclarationRef
ref = (SourceType -> [DeclarationRef]) -> DeclarationRef -> m ()
checkMemberExport SourceType -> [DeclarationRef]
findTcons DeclarationRef
ref
where
findTcons :: SourceType -> [DeclarationRef]
findTcons :: SourceType -> [DeclarationRef]
findTcons = forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall a. [a] -> [a] -> [a]
(++) SourceType -> [DeclarationRef]
go
where
go :: SourceType -> [DeclarationRef]
go (TypeConstructor SourceAnn
_ (Qualified (ByModuleName ModuleName
mn') ProperName 'TypeName
name)) | ModuleName
mn' forall a. Eq a => a -> a -> Bool
== ModuleName
mn =
[SourceSpan
-> ProperName 'TypeName
-> Maybe [ProperName 'ConstructorName]
-> DeclarationRef
TypeRef (DeclarationRef -> SourceSpan
declRefSourceSpan DeclarationRef
ref) ProperName 'TypeName
name (forall a. HasCallStack => String -> a
internalError String
"Data constructors unused in checkTypesAreExported")]
go SourceType
_ = []
checkClassesAreExported :: DeclarationRef -> m ()
checkClassesAreExported :: DeclarationRef -> m ()
checkClassesAreExported DeclarationRef
ref = (SourceType -> [DeclarationRef]) -> DeclarationRef -> m ()
checkMemberExport SourceType -> [DeclarationRef]
findClasses DeclarationRef
ref
where
findClasses :: SourceType -> [DeclarationRef]
findClasses :: SourceType -> [DeclarationRef]
findClasses = forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall a. [a] -> [a] -> [a]
(++) SourceType -> [DeclarationRef]
go
where
go :: SourceType -> [DeclarationRef]
go (ConstrainedType SourceAnn
_ SourceConstraint
c SourceType
_) = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceSpan -> ProperName 'ClassName -> DeclarationRef
TypeClassRef (DeclarationRef -> SourceSpan
declRefSourceSpan DeclarationRef
ref)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified (ProperName 'ClassName) -> [ProperName 'ClassName]
extractCurrentModuleClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Constraint a -> Qualified (ProperName 'ClassName)
constraintClass) SourceConstraint
c
go SourceType
_ = []
extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName]
extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName]
extractCurrentModuleClass (Qualified (ByModuleName ModuleName
mn') ProperName 'ClassName
name) | ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
mn' = [ProperName 'ClassName
name]
extractCurrentModuleClass Qualified (ProperName 'ClassName)
_ = []
checkClassMembersAreExported :: DeclarationRef -> m ()
checkClassMembersAreExported :: DeclarationRef -> m ()
checkClassMembersAreExported dr :: DeclarationRef
dr@(TypeClassRef SourceSpan
ss' ProperName 'ClassName
name) = do
let members :: [DeclarationRef]
members = SourceSpan -> Ident -> DeclarationRef
ValueRef SourceSpan
ss' forall a b. (a -> b) -> [a] -> [b]
`map` forall a. [a] -> a
head (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe [Ident]
findClassMembers [Declaration]
decls)
let missingMembers :: [DeclarationRef]
missingMembers = [DeclarationRef]
members forall a. Eq a => [a] -> [a] -> [a]
\\ [DeclarationRef]
exps
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DeclarationRef]
missingMembers) 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
$ DeclarationRef -> [DeclarationRef] -> SimpleErrorMessage
TransitiveExportError DeclarationRef
dr [DeclarationRef]
missingMembers
where
findClassMembers :: Declaration -> Maybe [Ident]
findClassMembers :: Declaration -> Maybe [Ident]
findClassMembers (TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
name' [(Text, Maybe SourceType)]
_ [SourceConstraint]
_ [FunctionalDependency]
_ [Declaration]
ds) | ProperName 'ClassName
name forall a. Eq a => a -> a -> Bool
== ProperName 'ClassName
name' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Ident
extractMemberName [Declaration]
ds
findClassMembers (DataBindingGroupDeclaration NonEmpty Declaration
decls') = forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe [Ident]
findClassMembers forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Declaration
decls'
findClassMembers Declaration
_ = forall a. Maybe a
Nothing
extractMemberName :: Declaration -> Ident
extractMemberName :: Declaration -> Ident
extractMemberName (TypeDeclaration TypeDeclarationData
td) = TypeDeclarationData -> Ident
tydeclIdent TypeDeclarationData
td
extractMemberName Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Unexpected declaration in typeclass member list"
checkClassMembersAreExported DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataConstructorsAreExported :: DeclarationRef -> m ()
checkDataConstructorsAreExported :: DeclarationRef -> m ()
checkDataConstructorsAreExported dr :: DeclarationRef
dr@(TypeRef SourceSpan
ss' ProperName 'TypeName
name (forall a. a -> Maybe a -> a
fromMaybe [] -> [ProperName 'ConstructorName]
exportedDataConstructorsNames))
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProperName 'ConstructorName]
exportedDataConstructorsNames = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
[ Qualified (ProperName 'ClassName)
Libs.Generic
, Qualified (ProperName 'ClassName)
Libs.Newtype
] forall a b. (a -> b) -> a -> b
$ \Qualified (ProperName 'ClassName)
className -> do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
let dicts :: [NamedDict]
dicts = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. NonEmpty a -> [a]
NEL.toList) forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) (Environment
-> Map
QualifiedBy
(Map
(Qualified (ProperName 'ClassName))
(Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries Environment
env) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
className
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. TypeClassDictionaryInScope a -> Bool
isDictOfTypeRef [NamedDict]
dicts) forall a b. (a -> b) -> a -> b
$
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
$ DeclarationRef
-> Qualified (ProperName 'ClassName) -> SimpleErrorMessage
HiddenConstructors DeclarationRef
dr Qualified (ProperName 'ClassName)
className
| Bool
otherwise = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
let dataConstructorNames :: [ProperName 'ConstructorName]
dataConstructorNames = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. a -> ModuleName -> Qualified a
mkQualified ProperName 'TypeName
name ModuleName
mn) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeKind -> Maybe [ProperName 'ConstructorName]
getDataConstructorNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
missingDataConstructorsNames :: [ProperName 'ConstructorName]
missingDataConstructorsNames = [ProperName 'ConstructorName]
dataConstructorNames forall a. Eq a => [a] -> [a] -> [a]
\\ [ProperName 'ConstructorName]
exportedDataConstructorsNames
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProperName 'ConstructorName]
missingDataConstructorsNames) forall a b. (a -> b) -> a -> b
$
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
$ DeclarationRef
-> [ProperName 'ConstructorName] -> SimpleErrorMessage
TransitiveDctorExportError DeclarationRef
dr [ProperName 'ConstructorName]
missingDataConstructorsNames
where
isDictOfTypeRef :: TypeClassDictionaryInScope a -> Bool
isDictOfTypeRef :: forall a. TypeClassDictionaryInScope a -> Bool
isDictOfTypeRef TypeClassDictionaryInScope a
dict
| (TypeConstructor SourceAnn
_ Qualified (ProperName 'TypeName)
qualTyName, [SourceType]
_, [SourceType]
_) : [(SourceType, [SourceType], [SourceType])]
_ <- forall a. Type a -> (Type a, [Type a], [Type a])
unapplyTypes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. TypeClassDictionaryInScope v -> [SourceType]
tcdInstanceTypes TypeClassDictionaryInScope a
dict
, Qualified (ProperName 'TypeName)
qualTyName forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'TypeName
name
= Bool
True
isDictOfTypeRef TypeClassDictionaryInScope a
_ = Bool
False
getDataConstructorNames :: TypeKind -> Maybe [ProperName 'ConstructorName]
getDataConstructorNames :: TypeKind -> Maybe [ProperName 'ConstructorName]
getDataConstructorNames (DataType DataDeclType
_ [(Text, Maybe SourceType, Role)]
_ [(ProperName 'ConstructorName, [SourceType])]
constructors) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ProperName 'ConstructorName, [SourceType])]
constructors
getDataConstructorNames TypeKind
_ = forall a. Maybe a
Nothing
checkDataConstructorsAreExported DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()