{-
(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))