{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1993-1998

\section[TcDefaults]{Typechecking \tr{default} declarations}
-}
{-# LANGUAGE TypeFamilies #-}

module TcDefaults ( tcDefaults ) where

import GhcPrelude

import GHC.Hs
import Class
import TcRnMonad
import TcEnv
import TcHsType
import TcHsSyn
import TcSimplify
import TcValidity
import TcType
import PrelNames
import SrcLoc
import Outputable
import 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)
tcDefaults (L SrcSpan
_ (XDefaultDecl XXDefaultDecl GhcRn
nec):[LDefaultDecl GhcRn]
_) = NoExtCon -> TcM (Maybe [Type])
forall a. NoExtCon -> a
noExtCon XXDefaultDecl GhcRn
NoExtCon
nec


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, Type
_kind) <- TcM (Type, Type) -> TcM (Type, Type)
forall a. TcM a -> TcM a
solveEqualities (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
                         LHsType GhcRn -> TcM (Type, Type)
tcLHsType 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
forall a pass.
(Outputable a, XXDefaultDecl pass ~ NoExtCon) =>
GenLocated a (DefaultDecl pass) -> MsgDoc
pp [LDefaultDecl GhcRn]
dup_things))
  where
    pp :: GenLocated a (DefaultDecl pass) -> MsgDoc
pp (L a
locn (DefaultDecl XCDefaultDecl pass
_ [LHsType pass]
_))
      = String -> MsgDoc
text String
"here was another default declaration" MsgDoc -> MsgDoc -> MsgDoc
<+> a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
locn
    pp (L a
_ (XDefaultDecl XXDefaultDecl pass
nec)) = NoExtCon -> MsgDoc
forall a. NoExtCon -> a
noExtCon XXDefaultDecl pass
NoExtCon
nec
dupDefaultDeclErr (L SrcSpan
_ (XDefaultDecl XXDefaultDecl GhcRn
nec) : [LDefaultDecl GhcRn]
_) = NoExtCon -> MsgDoc
forall a. NoExtCon -> a
noExtCon XXDefaultDecl GhcRn
NoExtCon
nec
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))