-- |
-- The top-level type checker, which checks all declarations in a module.
--
module Language.PureScript.TypeChecker
  ( module T
  , typeCheckModule
  , checkNewtype
  ) where

import Prelude
import Protolude (headMay, maybeToLeft, ordNub)

import Control.Lens ((^..), _2)
import Control.Monad (when, unless, void, forM, zipWithM_)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), modify, gets)
import Control.Monad.Supply.Class (MonadSupply)
import Control.Monad.Writer.Class (MonadWriter, tell)

import Data.Foldable (for_, traverse_, toList)
import Data.List (nub, nubBy, (\\), sort, group)
import Data.Maybe
import Data.Either (partitionEithers)
import Data.Text (Text)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T

import Language.PureScript.AST
import Language.PureScript.AST.Declarations.ChainId (ChainId)
import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep
import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Linter
import Language.PureScript.Linter.Wildcards
import Language.PureScript.Names
import Language.PureScript.Roles
import Language.PureScript.Sugar.Names.Env (Exports(..))
import Language.PureScript.TypeChecker.Kinds as T
import Language.PureScript.TypeChecker.Monad as T
import Language.PureScript.TypeChecker.Roles as T
import Language.PureScript.TypeChecker.Synonyms as T
import Language.PureScript.TypeChecker.Types as T
import Language.PureScript.TypeChecker.Unify (varIfUnknown)
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types

addDataType
  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => ModuleName
  -> DataDeclType
  -> ProperName 'TypeName
  -> [(Text, Maybe SourceType, Role)]
  -> [(DataConstructorDeclaration, SourceType)]
  -> SourceType
  -> m ()
addDataType :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType, Role)]
-> [(DataConstructorDeclaration, SourceType)]
-> SourceType
-> m ()
addDataType ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name [(Text, Maybe SourceType, Role)]
args [(DataConstructorDeclaration, SourceType)]
dctors SourceType
ctorKind = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  let mapDataCtor :: DataConstructorDeclaration
-> (ProperName 'ConstructorName, [SourceType])
mapDataCtor (DataConstructorDeclaration SourceAnn
_ ProperName 'ConstructorName
ctorName [(Ident, SourceType)]
vars) = (ProperName 'ConstructorName
ctorName, forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Ident, SourceType)]
vars)
      qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
      hasSig :: Bool
hasSig = Qualified (ProperName 'TypeName)
qualName forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
ctorKind, DataDeclType
-> [(Text, Maybe SourceType, Role)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> TypeKind
DataType DataDeclType
dtype [(Text, Maybe SourceType, Role)]
args (forall a b. (a -> b) -> [a] -> [b]
map (DataConstructorDeclaration
-> (ProperName 'ConstructorName, [SourceType])
mapDataCtor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(DataConstructorDeclaration, SourceType)]
dctors)) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSig Bool -> Bool -> Bool
|| forall (a :: ProperNameType). ProperName a -> Bool
isDictTypeName ProperName 'TypeName
name Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Type a -> Bool
containsForAll SourceType
ctorKind)) forall a b. (a -> b) -> a -> b
$ do
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ KindSignatureFor
-> ProperName 'TypeName -> SourceType -> SimpleErrorMessage
MissingKindDeclaration (if DataDeclType
dtype forall a. Eq a => a -> a -> Bool
== DataDeclType
Newtype then KindSignatureFor
NewtypeSig else KindSignatureFor
DataSig) ProperName 'TypeName
name SourceType
ctorKind
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(DataConstructorDeclaration, SourceType)]
dctors forall a b. (a -> b) -> a -> b
$ \(DataConstructorDeclaration SourceAnn
_ ProperName 'ConstructorName
dctor [(Ident, SourceType)]
fields, SourceType
polyType) ->
    forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'ConstructorName -> ErrorMessageHint
ErrorInDataConstructor ProperName 'ConstructorName
dctor)) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> ProperName 'ConstructorName
-> [(Ident, SourceType)]
-> SourceType
-> m ()
addDataConstructor ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name ProperName 'ConstructorName
dctor [(Ident, SourceType)]
fields SourceType
polyType

addDataConstructor
  :: (MonadState CheckState m, MonadError MultipleErrors m)
  => ModuleName
  -> DataDeclType
  -> ProperName 'TypeName
  -> ProperName 'ConstructorName
  -> [(Ident, SourceType)]
  -> SourceType
  -> m ()
addDataConstructor :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName
-> DataDeclType
-> ProperName 'TypeName
-> ProperName 'ConstructorName
-> [(Ident, SourceType)]
-> SourceType
-> m ()
addDataConstructor ModuleName
moduleName DataDeclType
dtype ProperName 'TypeName
name ProperName 'ConstructorName
dctor [(Ident, SourceType)]
dctorArgs SourceType
polyType = do
  let fields :: [Ident]
fields = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Ident, SourceType)]
dctorArgs
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceType -> m ()
checkTypeSynonyms SourceType
polyType
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { dataConstructors :: Map
  (Qualified (ProperName 'ConstructorName))
  (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'ConstructorName
dctor) (DataDeclType
dtype, ProperName 'TypeName
name, SourceType
polyType, [Ident]
fields) (Environment
-> Map
     (Qualified (ProperName 'ConstructorName))
     (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Environment
env) }

checkRoleDeclaration
  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => ModuleName
  -> RoleDeclarationData
  -> m ()
checkRoleDeclaration :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName -> RoleDeclarationData -> m ()
checkRoleDeclaration ModuleName
moduleName (RoleDeclarationData (SourceSpan
ss, [Comment]
_) ProperName 'TypeName
name [Role]
declaredRoles) = do
  forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ProperName 'TypeName -> ErrorMessageHint
ErrorInRoleDeclaration ProperName 'TypeName
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss)) forall a b. (a -> b) -> a -> b
$ do
    Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
    let qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'TypeName)
qualName (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) of
      Just (SourceType
kind, DataType DataDeclType
dtype [(Text, Maybe SourceType, Role)]
args [(ProperName 'ConstructorName, [SourceType])]
dctors) -> do
        forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName -> [Role] -> Int -> m ()
checkRoleDeclarationArity ProperName 'TypeName
name [Role]
declaredRoles (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Maybe SourceType, Role)]
args)
        forall (m :: * -> *).
MonadError MultipleErrors m =>
[(Text, Maybe SourceType, Role)] -> [Role] -> m ()
checkRoles [(Text, Maybe SourceType, Role)]
args [Role]
declaredRoles
        let args' :: [(Text, Maybe SourceType, Role)]
args' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Text
v, Maybe SourceType
k, Role
_) Role
r -> (Text
v, Maybe SourceType
k, Role
r)) [(Text, Maybe SourceType, Role)]
args [Role]
declaredRoles
        forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, DataDeclType
-> [(Text, Maybe SourceType, Role)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> TypeKind
DataType DataDeclType
dtype [(Text, Maybe SourceType, Role)]
args' [(ProperName 'ConstructorName, [SourceType])]
dctors) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
      Just (SourceType
kind, ExternData [Role]
_) -> do
        forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName -> [Role] -> Int -> m ()
checkRoleDeclarationArity ProperName 'TypeName
name [Role]
declaredRoles (forall a. Type a -> Int
kindArity SourceType
kind)
        forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, [Role] -> TypeKind
ExternData [Role]
declaredRoles) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) }
      Maybe (SourceType, TypeKind)
_ -> forall a. HasCallStack => String -> a
internalError String
"Unsupported role declaration"

addTypeSynonym
  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => ModuleName
  -> ProperName 'TypeName
  -> [(Text, Maybe SourceType)]
  -> SourceType
  -> SourceType
  -> m ()
addTypeSynonym :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> SourceType
-> m ()
addTypeSynonym ModuleName
moduleName ProperName 'TypeName
name [(Text, Maybe SourceType)]
args SourceType
ty SourceType
kind = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceType -> m ()
checkTypeSynonyms SourceType
ty
  let qualName :: Qualified (ProperName 'TypeName)
qualName = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
name
      hasSig :: Bool
hasSig = Qualified (ProperName 'TypeName)
qualName forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSig Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Type a -> Bool
containsForAll SourceType
kind)) forall a b. (a -> b) -> a -> b
$ do
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ KindSignatureFor
-> ProperName 'TypeName -> SourceType -> SimpleErrorMessage
MissingKindDeclaration KindSignatureFor
TypeSynonymSig ProperName 'TypeName
name SourceType
kind
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, TypeKind
TypeSynonym) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)
               , typeSynonyms :: Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
typeSynonyms = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName ([(Text, Maybe SourceType)]
args, SourceType
ty) (Environment
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
typeSynonyms Environment
env) }

valueIsNotDefined
  :: (MonadState CheckState m, MonadError MultipleErrors m)
  => ModuleName
  -> Ident
  -> m ()
valueIsNotDefined :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
ModuleName -> Ident -> m ()
valueIsNotDefined ModuleName
moduleName Ident
name = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) of
    Just (SourceType, NameKind, NameVisibility)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
RedefinedIdent Ident
name
    Maybe (SourceType, NameKind, NameVisibility)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

addValue
  :: (MonadState CheckState m)
  => ModuleName
  -> Ident
  -> SourceType
  -> NameKind
  -> m ()
addValue :: forall (m :: * -> *).
MonadState CheckState m =>
ModuleName -> Ident -> SourceType -> NameKind -> m ()
addValue ModuleName
moduleName Ident
name SourceType
ty NameKind
nameKind = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv (Environment
env { names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) Ident
name) (SourceType
ty, NameKind
nameKind, NameVisibility
Defined) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) })

addTypeClass
  :: forall m
   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => ModuleName
  -> Qualified (ProperName 'ClassName)
  -> [(Text, Maybe SourceType)]
  -> [SourceConstraint]
  -> [FunctionalDependency]
  -> [Declaration]
  -> SourceType
  -> m ()
addTypeClass :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> [Declaration]
-> SourceType
-> m ()
addTypeClass ModuleName
_ Qualified (ProperName 'ClassName)
qualifiedClassName [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [FunctionalDependency]
dependencies [Declaration]
ds SourceType
kind = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  TypeClassData
newClass <- m TypeClassData
mkNewClass
  let qualName :: Qualified (ProperName 'TypeName)
qualName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName Qualified (ProperName 'ClassName)
qualifiedClassName
      hasSig :: Bool
hasSig = Qualified (ProperName 'TypeName)
qualName forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSig Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Type a -> Bool
containsForAll SourceType
kind)) forall a b. (a -> b) -> a -> b
$ do
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ KindSignatureFor
-> ProperName 'TypeName -> SourceType -> SimpleErrorMessage
MissingKindDeclaration KindSignatureFor
ClassSig (forall a. Qualified a -> a
disqualify Qualified (ProperName 'TypeName)
qualName) SourceType
kind
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (TypeClassData
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> (Ident, SourceType)
-> m ()
checkMemberIsUsable TypeClassData
newClass (Environment
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
typeSynonyms Environment
env) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)) [(Ident, SourceType)]
classMembers
  forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv forall a b. (a -> b) -> a -> b
$ Environment
env { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'TypeName)
qualName (SourceType
kind, [Role] -> TypeKind
ExternData (forall a. Type a -> [Role]
nominalRolesForKind SourceType
kind)) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env)
               , typeClasses :: Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Qualified (ProperName 'ClassName)
qualifiedClassName TypeClassData
newClass (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env) }
  where
    classMembers :: [(Ident, SourceType)]
    classMembers :: [(Ident, SourceType)]
classMembers = forall a b. (a -> b) -> [a] -> [b]
map Declaration -> (Ident, SourceType)
toPair [Declaration]
ds

    mkNewClass :: m TypeClassData
    mkNewClass :: m TypeClassData
mkNewClass = do
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      [SourceConstraint]
implies' <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Functor f =>
([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)
overConstraintArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceConstraint]
implies
      let ctIsEmpty :: Bool
ctIsEmpty = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, SourceType)]
classMembers Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TypeClassData -> Bool
typeClassIsEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Environment -> Constraint a -> TypeClassData
findSuperClass Environment
env) [SourceConstraint]
implies'
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(Text, Maybe SourceType)]
-> [(Ident, SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> Bool
-> TypeClassData
makeTypeClassData [(Text, Maybe SourceType)]
args [(Ident, SourceType)]
classMembers [SourceConstraint]
implies' [FunctionalDependency]
dependencies Bool
ctIsEmpty
      where
      findSuperClass :: Environment -> Constraint a -> TypeClassData
findSuperClass Environment
env Constraint a
c = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Constraint a -> Qualified (ProperName 'ClassName)
constraintClass Constraint a
c) (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env) of
        Just TypeClassData
tcd -> TypeClassData
tcd
        Maybe TypeClassData
Nothing -> forall a. HasCallStack => String -> a
internalError String
"Unknown super class in TypeClassDeclaration"

    coveringSets :: TypeClassData -> [S.Set Int]
    coveringSets :: TypeClassData -> [Set Int]
coveringSets = forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeClassData -> Set (Set Int)
typeClassCoveringSets

    argToIndex :: Text -> Maybe Int
    argToIndex :: Text -> Maybe Int
argToIndex = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Maybe SourceType)]
args [Int
0..])

    toPair :: Declaration -> (Ident, SourceType)
toPair (TypeDeclaration (TypeDeclarationData SourceAnn
_ Ident
ident SourceType
ty)) = (Ident
ident, SourceType
ty)
    toPair Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid declaration in TypeClassDeclaration"

    -- Currently we are only checking usability based on the type class currently
    -- being defined.  If the mentioned arguments don't include a covering set,
    -- then we won't be able to find a instance.
    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 -- ^ index of type class argument
  -> SourceType
  -> m ()
checkTypeClassInstance :: forall (m :: * -> *).
(MonadState CheckState m, MonadError MultipleErrors m) =>
TypeClassData -> Int -> SourceType -> m ()
checkTypeClassInstance TypeClassData
cls Int
i = SourceType -> m ()
check where
  -- If the argument is determined via fundeps then we are less restrictive in
  -- what type is allowed. This is because the type cannot be used to influence
  -- which instance is selected. Currently the only weakened restriction is that
  -- row types are allowed in determined type class arguments.
  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

-- |
-- Check that type synonyms are fully-applied in a type
--
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

-- |
-- Type check all declarations in a module
--
-- At this point, many declarations will have been desugared, but it is still necessary to
--
--  * Kind-check all types and add them to the @Environment@
--
--  * Type-check all values and add them to the @Environment@
--
--  * Infer all type roles and add them to the @Environment@
--
--  * Bring type class instances into scope
--
--  * Process module imports
--
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, MonadSupply 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, MonadSupply 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"

    -- If the instance is declared in a module that wouldn't be found based on a covering set
    -- then it is considered an orphan - because we'd have a situation in which we expect an
    -- instance but can't find it. So a valid module must be applicable across *all* covering
    -- sets - therefore we take the intersection of covering set modules.
    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"

  -- Check that the instance currently being declared doesn't overlap with any
  -- other instance in any module that this instance wouldn't be considered an
  -- orphan in.  There are overlapping instance situations that won't be caught
  -- by this, for example when combining multiparameter type classes with
  -- flexible instances: the instances `Cls X y` and `Cls x Y` overlap and
  -- could live in different modules but won't be caught here.
  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
          -- ignore instances in the same instance chain
          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)

      -- Note: implementation doesn't need to care about all possible cases:
      -- TUnknown, Skolem, etc.
      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'

  -- |
  -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
  -- extracted from the kind of the type constructor itself.
  --
  withKinds :: [(Text, Maybe SourceType)] -> SourceType -> [(Text, Maybe SourceType)]
  withKinds :: [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [] SourceType
_ = []
  withKinds [(Text, Maybe SourceType)]
ss (ForAll SourceAnn
_ Text
_ Maybe SourceType
_ SourceType
k Maybe SkolemScope
_) = [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [(Text, Maybe SourceType)]
ss SourceType
k
  withKinds (s :: (Text, Maybe SourceType)
s@(Text
_, Just SourceType
_):[(Text, Maybe SourceType)]
ss) (TypeApp SourceAnn
_ (TypeApp SourceAnn
_ SourceType
tyFn SourceType
_) SourceType
k2) | forall a b. Type a -> Type b -> Bool
eqType SourceType
tyFn SourceType
tyFunction = (Text, Maybe SourceType)
s forall a. a -> [a] -> [a]
: [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [(Text, Maybe SourceType)]
ss SourceType
k2
  withKinds ((Text
s, Maybe SourceType
Nothing):[(Text, Maybe SourceType)]
ss) (TypeApp SourceAnn
_ (TypeApp SourceAnn
_ SourceType
tyFn SourceType
k1) SourceType
k2) | forall a b. Type a -> Type b -> Bool
eqType SourceType
tyFn SourceType
tyFunction = (Text
s, forall a. a -> Maybe a
Just SourceType
k1) forall a. a -> [a] -> [a]
: [(Text, Maybe SourceType)]
-> SourceType -> [(Text, Maybe SourceType)]
withKinds [(Text, Maybe SourceType)]
ss SourceType
k2
  withKinds [(Text, Maybe SourceType)]
_ SourceType
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid arguments to withKinds"

  withRoles :: [(Text, Maybe SourceType)] -> [Role] -> [(Text, Maybe SourceType, Role)]
  withRoles :: [(Text, Maybe SourceType)]
-> [Role] -> [(Text, Maybe SourceType, Role)]
withRoles = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
$ \(Text
v, Maybe SourceType
k) Role
r -> (Text
v, Maybe SourceType
k, Role
r)

  replaceTypeSynonymsInDataConstructor :: DataConstructorDeclaration -> m DataConstructorDeclaration
  replaceTypeSynonymsInDataConstructor :: DataConstructorDeclaration -> m DataConstructorDeclaration
replaceTypeSynonymsInDataConstructor DataConstructorDeclaration{[(Ident, SourceType)]
SourceAnn
ProperName 'ConstructorName
dataCtorFields :: DataConstructorDeclaration -> [(Ident, SourceType)]
dataCtorName :: DataConstructorDeclaration -> ProperName 'ConstructorName
dataCtorAnn :: DataConstructorDeclaration -> SourceAnn
dataCtorFields :: [(Ident, SourceType)]
dataCtorName :: ProperName 'ConstructorName
dataCtorAnn :: SourceAnn
..} = do
    [(Ident, SourceType)]
dataCtorFields' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms) [(Ident, SourceType)]
dataCtorFields
    forall (m :: * -> *) a. Monad m => a -> m a
return DataConstructorDeclaration
      { dataCtorFields :: [(Ident, SourceType)]
dataCtorFields = [(Ident, SourceType)]
dataCtorFields'
      , SourceAnn
ProperName 'ConstructorName
dataCtorName :: ProperName 'ConstructorName
dataCtorAnn :: SourceAnn
dataCtorName :: ProperName 'ConstructorName
dataCtorAnn :: SourceAnn
..
      }

-- | Check that a newtype has just one data constructor with just one field, or
-- throw an error. If the newtype is valid, this function returns the single
-- data constructor declaration and the single field, as a 'proof' that the
-- newtype was indeed a valid newtype.
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

-- |
-- Type check an entire module and ensure all types and classes defined within the module that are
-- required by exported members are also exported.
--
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
      -- A function that, given a class name, returns the set of
      -- transitive class dependencies that are defined in this
      -- module.
      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
      -- TODO: remove?
      -- let findModuleKinds = everythingOnTypes (++) $ \case
      --       TypeConstructor _ (Qualified (ByModuleName mn') kindName) | mn' == mn -> [kindName]
      --       _ -> []
      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)
        -- thanks to laziness, the computation of the transitive
        -- superclasses defined in-module will only occur if we actually
        -- throw the error. Constructing the full set of transitive
        -- superclasses is likely to be costly for every single term.
        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
    -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to
    -- `error` for the values generated here (we don't need them anyway)
    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


  -- Check that all the type constructors defined in the current module that appear in member types
  -- have also been exported from the module
  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
_ = []

  -- Check that all the classes defined in the current module that appear in member types have also
  -- been exported from the module
  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 ()

  -- If a type is exported without data constructors, we warn on `Generic` or `Newtype` instances.
  -- On the other hand if any data constructors are exported, we require all of them to be exported.
  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)
DataGenericRep.Generic
      , Qualified (ProperName 'ClassName)
DataNewtype.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 ()