    {-
    (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.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.SrcLoc
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Data.FastString
    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 (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)
    mapM Name -> TcM Class
    tcLookupClass [Name
    isStringClassName]
                           else [Class] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
    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)
    mapM Name -> TcM Class
    tcLookupClass [Name]
    interactiveClassNames
                                   else [Class] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
    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) [GenLocated SrcSpanAnnA (HsType GhcRn)]
    [LHsType GhcRn]
    mono_tys

            ; Maybe [Type] -> TcM (Maybe [Type])
    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
    $
        SDoc -> TcM (Maybe [Type])
    forall a. SDoc -> TcM a
    failWithTc ([LDefaultDecl GhcRn] -> SDoc
    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)
    mapM (Type -> Class -> TcRnIf TcGblEnv TcLclEnv Bool
    check_instance Type
    ty) [Class]
    deflt_clss
            ; Bool -> SDoc -> TcM ()
    checkTc ([Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or [Bool]
    oks) (Type -> [Class] -> SDoc
    badDefaultTy Type
    ty [Class]
    deflt_clss)
            ; Type -> TcRn Type
    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 HasDebugCallStack => Type -> Type -> Bool
    Type -> Type -> Bool
    `tcEqType` HasDebugCallStack => 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 (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] -> SDoc
    dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> SDoc
    dupDefaultDeclErr (L SrcSpanAnnA
    _ (DefaultDecl XCDefaultDecl GhcRn
    _ [LHsType GhcRn]
    _) : [LDefaultDecl GhcRn]
    dup_things)
      = SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Multiple default declarations")
           Int
    2 ([SDoc] -> SDoc
    vcat ((GenLocated SrcSpanAnnA (DefaultDecl GhcRn) -> SDoc)
    -> [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map GenLocated SrcSpanAnnA (DefaultDecl GhcRn) -> SDoc
    LDefaultDecl GhcRn -> SDoc
    pp [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
    [LDefaultDecl GhcRn]
    dup_things))
      where
        pp :: LDefaultDecl GhcRn -> SDoc
        pp :: LDefaultDecl GhcRn -> SDoc
    pp (L SrcSpanAnnA
    locn (DefaultDecl XCDefaultDecl GhcRn
    _ [LHsType GhcRn]
    _))
          = String -> SDoc
    text String
    "here was another default declaration" SDoc -> SDoc -> SDoc
    <+> SrcSpan -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (SrcSpanAnnA -> SrcSpan
    forall a. SrcSpanAnn' a -> SrcSpan
    locA SrcSpanAnnA
    locn)
    dupDefaultDeclErr [] = String -> SDoc
    forall a. String -> a
    panic String
    "dupDefaultDeclErr []"

    badDefaultTy :: Type -> [Class] -> SDoc
    badDefaultTy :: Type -> [Class] -> SDoc
    badDefaultTy Type
    ty [Class]
    deflt_clss
      = SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "The default type" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty) SDoc -> SDoc -> SDoc
    <+> PtrString -> SDoc
    ptext (String -> PtrString
    sLit String
    "is not an instance of"))
           Int
    2 ((SDoc -> SDoc -> SDoc) -> [SDoc] -> SDoc
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldr1 (\SDoc
    a SDoc
    b -> SDoc
    a SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "or" SDoc -> SDoc -> SDoc
    <+> SDoc
    b) ((Class -> SDoc) -> [Class] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map (SDoc -> SDoc
    quotes(SDoc -> SDoc) -> (Class -> SDoc) -> Class -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Class -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr) [Class]
    deflt_clss))