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