    {-
    (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.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.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 SrcSpan
    _ (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 SrcSpan
    locn (DefaultDecl XCDefaultDecl GhcRn
    _ [LHsType GhcRn]
    mono_tys)]
      = SrcSpan -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a. SrcSpan -> TcRn a -> TcRn a
    setSrcSpan SrcSpan
    locn                     (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
    -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a b. (a -> b) -> a -> b
    $
        MsgDoc -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a. MsgDoc -> TcM a -> TcM a
    addErrCtxt MsgDoc
    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 <- (LHsType GhcRn -> TcRn Type) -> [LHsType 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]
    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 SrcSpan
    locn (DefaultDecl XCDefaultDecl GhcRn
    _ [LHsType GhcRn]
    _) : [LDefaultDecl GhcRn]
    _)
      = SrcSpan -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a. SrcSpan -> TcRn a -> TcRn a
    setSrcSpan SrcSpan
    locn (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
    -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
    forall a b. (a -> b) -> a -> b
    $
        MsgDoc -> TcM (Maybe [Type])
    forall a. MsgDoc -> TcM a
    failWithTc ([LDefaultDecl GhcRn] -> MsgDoc
    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 <- TcRn Type -> TcRn Type
    forall a. TcM a -> TcM a
    solveEqualities (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 -> MsgDoc -> TcM ()
    checkTc ([Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or [Bool]
    oks) (Type -> [Class] -> MsgDoc
    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
    check_instance :: Type -> Class -> TcRnIf TcGblEnv TcLclEnv Bool
    check_instance Type
    ty Class
    cls
      = do  { (()
    _, Bool
    success) <- TcRn ((), Bool) -> TcRn ((), Bool)
    forall a. TcM a -> TcM a
    discardErrs (TcRn ((), Bool) -> TcRn ((), Bool))
    -> TcRn ((), Bool) -> TcRn ((), Bool)
    forall a b. (a -> b) -> a -> b
    $
                              TcM () -> TcRn ((), Bool)
    forall a. TcRn a -> TcRn (a, Bool)
    askNoErrs (TcM () -> TcRn ((), Bool)) -> TcM () -> TcRn ((), Bool)
    forall a b. (a -> b) -> a -> b
    $
                              [Type] -> TcM ()
    simplifyDefault [Class -> [Type] -> Type
    mkClassPred Class
    cls [Type
    ty]]
            ; Bool -> TcRnIf TcGblEnv TcLclEnv Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    success }

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

    dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc
    dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> MsgDoc
    dupDefaultDeclErr (L SrcSpan
    _ (DefaultDecl XCDefaultDecl GhcRn
    _ [LHsType GhcRn]
    _) : [LDefaultDecl GhcRn]
    dup_things)
      = MsgDoc -> Int -> MsgDoc -> MsgDoc
    hang (String -> MsgDoc
    text String
    "Multiple default declarations")
           Int
    2 ([MsgDoc] -> MsgDoc
    vcat ((LDefaultDecl GhcRn -> MsgDoc) -> [LDefaultDecl GhcRn] -> [MsgDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map LDefaultDecl GhcRn -> MsgDoc
    pp [LDefaultDecl GhcRn]
    dup_things))
      where
        pp :: Located (DefaultDecl GhcRn) -> SDoc
        pp :: LDefaultDecl GhcRn -> MsgDoc
    pp (L SrcSpan
    locn (DefaultDecl XCDefaultDecl GhcRn
    _ [LHsType GhcRn]
    _))
          = String -> MsgDoc
    text String
    "here was another default declaration" MsgDoc -> MsgDoc -> MsgDoc
    <+> SrcSpan -> MsgDoc
    forall a. Outputable a => a -> MsgDoc
    ppr SrcSpan
    locn
    dupDefaultDeclErr [] = String -> MsgDoc
    forall a. String -> a
    panic String
    "dupDefaultDeclErr []"

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