{-
(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 HsSyn
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 _ (DefaultDecl _ [])]
  = 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 locn :: SrcSpan
locn (DefaultDecl _ mono_tys :: [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 locn :: SrcSpan
locn (DefaultDecl _ _) : _)
  = 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 _ (XDefaultDecl _):_) = String -> TcM (Maybe [Type])
forall a. String -> a
panic "tcDefaults"


tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
tc_default_ty :: [Class] -> LHsType GhcRn -> TcRn Type
tc_default_ty deflt_clss :: [Class]
deflt_clss hs_ty :: LHsType GhcRn
hs_ty
 = do   { (ty :: Type
ty, _kind :: 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 ty :: Type
ty cls :: Class
cls
  = do  { (_, success :: 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 "When checking the types in a default declaration"

dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc
dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> MsgDoc
dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things :: [LDefaultDecl GhcRn]
dup_things)
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text "Multiple default declarations")
       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 =>
GenLocated a (DefaultDecl pass) -> MsgDoc
pp [LDefaultDecl GhcRn]
dup_things))
  where
    pp :: GenLocated a (DefaultDecl pass) -> MsgDoc
pp (L locn :: a
locn (DefaultDecl _ _))
      = String -> MsgDoc
text "here was another default declaration" MsgDoc -> MsgDoc -> MsgDoc
<+> a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
locn
    pp (L _ (XDefaultDecl _)) = String -> MsgDoc
forall a. String -> a
panic "dupDefaultDeclErr"
dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = String -> MsgDoc
forall a. String -> a
panic "dupDefaultDeclErr"
dupDefaultDeclErr [] = String -> MsgDoc
forall a. String -> a
panic "dupDefaultDeclErr []"

badDefaultTy :: Type -> [Class] -> SDoc
badDefaultTy :: Type -> [Class] -> MsgDoc
badDefaultTy ty :: Type
ty deflt_clss :: [Class]
deflt_clss
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text "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 "is not an instance of"))
       2 ((MsgDoc -> MsgDoc -> MsgDoc) -> [MsgDoc] -> MsgDoc
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\a :: MsgDoc
a b :: MsgDoc
b -> MsgDoc
a MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "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))