    {-
    (c) The University of Glasgow 2006
    (c) The AQUA Project, Glasgow University, 1993-1998

    -}
    {-# LANGUAGE TypeFamilies #-}

    -- | Typechecking @default@ declarations
    module GHC.Tc.Gen.Default ( tcDefaults ) where

    import GHC.Prelude

    import GHC.Hs
    import GHC.Core.Class
    import GHC.Core.Type ( typeKind )
    import GHC.Types.Var( tyVarKind )
    import GHC.Tc.Errors.Types
    import GHC.Tc.Utils.Monad
    import GHC.Tc.Utils.Env
    import GHC.Tc.Gen.HsType
    import GHC.Tc.Utils.Zonk
    import GHC.Tc.Solver
    import GHC.Tc.Validity
    import GHC.Tc.Utils.TcType
    import GHC.Builtin.Names
    import GHC.Types.Error
    import GHC.Types.SrcLoc
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import qualified GHC.LanguageExtensions as LangExt

    tcDefaults :: [LDefaultDecl GhcRn]
               -> TcM (Maybe [Type])    -- Defaulting types to heave
                                        -- into Tc monad for later use
                                        -- in Disambig.

    tcDefaults :: [LDefaultDecl GhcRn] -> TcM (Maybe [Type])
    tcDefaults []
      = TcM (Maybe [Type])
    getDeclaredDefaultTys       -- No default declaration, so get the
                                    -- default types from the envt;
                                    -- i.e. use the current ones
                                    -- (the caller will put them back there)
            -- It's important not to return defaultDefaultTys here (which
            -- we used to do) because in a TH program, tcDefaults [] is called
            -- repeatedly, once for each group of declarations between top-level
            -- splices.  We don't want to carefully set the default types in
            -- one group, only for the next group to ignore them and install
            -- defaultDefaultTys

    tcDefaults [L SrcSpanAnnA
    _ (DefaultDecl XCDefaultDecl GhcRn
    _ [])]
      = Maybe [Type] -> TcM (Maybe [Type])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Type] -> Maybe [Type]
    forall a. a -> Maybe a
    Just [])            -- Default declaration specifying no types

    tcDefaults [L SrcSpanAnnA
    locn (DefaultDecl XCDefaultDecl GhcRn
    _ [LHsType GhcRn]
    mono_tys)]
      = SrcSpan -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a. SrcSpan -> TcRn a -> TcRn a
    setSrcSpan (SrcSpanAnnA -> SrcSpan
    forall a. SrcSpanAnn' a -> SrcSpan
    locA SrcSpanAnnA
    locn)              (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
    -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a b. (a -> b) -> a -> b
    $
        SDoc -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a. SDoc -> TcM a -> TcM a
    addErrCtxt SDoc
    defaultDeclCtxt          (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
    -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a b. (a -> b) -> a -> b
    $
        do  { Bool
    ovl_str   <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
    forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
    xoptM Extension
    LangExt.OverloadedStrings
            ; Bool
    ext_deflt <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
    forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
    xoptM Extension
    LangExt.ExtendedDefaultRules
            ; Class
    num_class    <- Name -> TcM Class
    tcLookupClass Name
    numClassName
            ; [Class]
    deflt_str <- if Bool
    ovl_str
                           then (Name -> TcM Class)
    -> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Name -> TcM Class
    tcLookupClass [Name
    isStringClassName]
                           else [Class] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            ; [Class]
    deflt_interactive <- if Bool
    ext_deflt
                                   then (Name -> TcM Class)
    -> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Name -> TcM Class
    tcLookupClass [Name]
    interactiveClassNames
                                   else [Class] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            ; let deflt_clss :: [Class]
    deflt_clss = Class
    num_class Class -> [Class] -> [Class]
    forall a. a -> [a] -> [a]
    : [Class]
    deflt_str [Class] -> [Class] -> [Class]
    forall a. [a] -> [a] -> [a]
    ++ [Class]
    deflt_interactive

            ; [Type]
    tau_tys <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcRn Type)
    -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcRn [Type]
    forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
    mapAndReportM ([Class] -> LHsType GhcRn -> TcRn Type
    tc_default_ty [Class]
    deflt_clss) [LHsType GhcRn]
    [GenLocated SrcSpanAnnA (HsType GhcRn)]
    mono_tys

            ; Maybe [Type] -> TcM (Maybe [Type])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Type] -> Maybe [Type]
    forall a. a -> Maybe a
    Just [Type]
    tau_tys) }

    tcDefaults decls :: [LDefaultDecl GhcRn]
    decls@(L SrcSpanAnnA
    locn (DefaultDecl XCDefaultDecl GhcRn
    _ [LHsType GhcRn]
    _) : [LDefaultDecl GhcRn]
    _)
      = SrcSpan -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a. SrcSpan -> TcRn a -> TcRn a
    setSrcSpan (SrcSpanAnnA -> SrcSpan
    forall a. SrcSpanAnn' a -> SrcSpan
    locA SrcSpanAnnA
    locn) (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
    -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a b. (a -> b) -> a -> b
    $
        TcRnMessage -> TcM (Maybe [Type])
    forall a. TcRnMessage -> TcM a
    failWithTc ([LDefaultDecl GhcRn] -> TcRnMessage
    dupDefaultDeclErr [LDefaultDecl GhcRn]
    decls)

    tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
    tc_default_ty :: [Class] -> LHsType GhcRn -> TcRn Type
    tc_default_ty [Class]
    deflt_clss LHsType GhcRn
    hs_ty
     = do   { Type
    ty <- String -> TcRn Type -> TcRn Type
    forall a. String -> TcM a -> TcM a
    solveEqualities String
    "tc_default_ty" (TcRn Type -> TcRn Type) -> TcRn Type -> TcRn Type
    forall a b. (a -> b) -> a -> b
    $
                    LHsType GhcRn -> TcRn Type
    tcInferLHsType LHsType GhcRn
    hs_ty
            ; Type
    ty <- Type -> TcRn Type
    zonkTcTypeToType Type
    ty   -- establish Type invariants
            ; UserTypeCtxt -> Type -> TcM ()
    checkValidType UserTypeCtxt
    DefaultDeclCtxt Type
    ty

            -- Check that the type is an instance of at least one of the deflt_clss
            ; [Bool]
    oks <- (Class -> TcRnIf TcGblEnv TcLclEnv Bool)
    -> [Class] -> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (Type -> Class -> TcRnIf TcGblEnv TcLclEnv Bool
    check_instance Type
    ty) [Class]
    deflt_clss
            ; Bool -> TcRnMessage -> TcM ()
    checkTc ([Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or [Bool]
    oks) (Type -> [Class] -> TcRnMessage
    TcRnBadDefaultType Type
    ty [Class]
    deflt_clss)
            ; Type -> TcRn Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty }

    check_instance :: Type -> Class -> TcM Bool
    -- Check that ty is an instance of cls
    -- We only care about whether it worked or not; return a boolean
    -- This checks that  cls :: k -> Constraint
    -- with just one argument and no polymorphism; if we need to add
    -- polymorphism we can make it more complicated.  For now we are
    -- concerned with classes like
    --    Num      :: Type -> Constraint
    --    Foldable :: (Type->Type) -> Constraint
    check_instance :: Type -> Class -> TcRnIf TcGblEnv TcLclEnv Bool
    check_instance Type
    ty Class
    cls
      | [TyVar
    cls_tv] <- Class -> [TyVar]
    classTyVars Class
    cls
      , TyVar -> Type
    tyVarKind TyVar
    cls_tv (() :: Constraint) => Type -> Type -> Bool
    Type -> Type -> Bool
    `tcEqType` (() :: Constraint) => Type -> Type
    Type -> Type
    typeKind Type
    ty
      = [Type] -> TcRnIf TcGblEnv TcLclEnv Bool
    simplifyDefault [Class -> [Type] -> Type
    mkClassPred Class
    cls [Type
    ty]]
      | Bool
    otherwise
      = Bool -> TcRnIf TcGblEnv TcLclEnv Bool
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    defaultDeclCtxt :: SDoc
    defaultDeclCtxt :: SDoc
    defaultDeclCtxt = String -> SDoc
    text String
    "When checking the types in a default declaration"

    dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage
    dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage
    dupDefaultDeclErr (L SrcSpanAnnA
    _ (DefaultDecl XCDefaultDecl GhcRn
    _ [LHsType GhcRn]
    _) : [LDefaultDecl GhcRn]
    dup_things)
      = [LDefaultDecl GhcRn] -> TcRnMessage
    TcRnMultipleDefaultDeclarations [LDefaultDecl GhcRn]
    dup_things
    dupDefaultDeclErr [] = String -> TcRnMessage
    forall a. String -> a
    panic String
    "dupDefaultDeclErr []"