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 (fromMaybe, listToMaybe, mapMaybe)
import Data.Either (partitionEithers)
import Data.Text (Text)
import Data.List.NonEmpty qualified as NEL
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text qualified as T
import Language.PureScript.AST
import Language.PureScript.AST.Declarations.ChainId (ChainId)
import Language.PureScript.Constants.Libs qualified as Libs
import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency, NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), isDictTypeName, kindArity, makeTypeClassData, nominalRolesForKind, tyFunction)
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', positionedError, rethrow, warnAndRethrow)
import Language.PureScript.Linter (checkExhaustiveExpr)
import Language.PureScript.Linter.Wildcards (ignoreWildcardsUnderCompleteTypeSignatures)
import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified)
import Language.PureScript.Roles (Role)
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 (NamedDict, TypeClassDictionaryInScope(..))
import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, freeTypeVariables, overConstraintArgs, srcInstanceType, unapplyTypes)
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
_ TypeVarVisibility
_ 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 ()