{-
(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.Zonk.Type
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 qualified GHC.LanguageExtensions as LangExt

import Data.List.NonEmpty ( NonEmpty (..) )

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. HasLoc a => 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  { ovl_str   <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings
        ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
        ; num_class    <- tcLookupClass numClassName
        ; deflt_str <- if ovl_str
                       then mapM tcLookupClass [isStringClassName]
                       else return []
        ; deflt_interactive <- if ext_deflt
                               then mapM tcLookupClass interactiveClassNames
                               else return []
        ; let 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

        ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys

        ; return (Just tau_tys) }

tcDefaults (decl :: LDefaultDecl GhcRn
decl@(L SrcSpanAnnA
locn (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
_)) : [LDefaultDecl GhcRn]
decls)
  = SrcSpan -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => 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 (NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr (LDefaultDecl GhcRn
GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
declGenLocated SrcSpanAnnA (DefaultDecl GhcRn)
-> [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
-> NonEmpty (GenLocated SrcSpanAnnA (DefaultDecl GhcRn))
forall a. a -> [a] -> NonEmpty a
:|[LDefaultDecl GhcRn]
[GenLocated SrcSpanAnnA (DefaultDecl 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   { 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
        ; ty <- zonkTcTypeToType ty   -- establish Type invariants
        ; checkValidType DefaultDeclCtxt ty

        -- Check that the type is an instance of at least one of the deflt_clss
        ; oks <- mapM (check_instance ty) deflt_clss
        ; checkTc (or oks) (TcRnBadDefaultType ty deflt_clss)
        ; return 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 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
forall doc. IsLine doc => String -> doc
text String
"When checking the types in a default declaration"

dupDefaultDeclErr :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr (L SrcSpanAnnA
_ (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
_) :| [LDefaultDecl GhcRn]
dup_things)
  = [LDefaultDecl GhcRn] -> TcRnMessage
TcRnMultipleDefaultDeclarations [LDefaultDecl GhcRn]
dup_things