{-
(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
_ [])]
  = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [])            -- Default declaration specifying no types

tcDefaults [L SrcSpanAnnA
locn (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
mono_tys)]
  = forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
locn)              forall a b. (a -> b) -> a -> b
$
    forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
defaultDeclCtxt          forall a b. (a -> b) -> a -> b
$
    do  { Bool
ovl_str   <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings
        ; Bool
ext_deflt <- 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 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 forall (m :: * -> *) a. Monad m => a -> m a
return []
        ; [Class]
deflt_interactive <- if Bool
ext_deflt
                               then 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 forall (m :: * -> *) a. Monad m => a -> m a
return []
        ; let deflt_clss :: [Class]
deflt_clss = Class
num_class forall a. a -> [a] -> [a]
: [Class]
deflt_str forall a. [a] -> [a] -> [a]
++ [Class]
deflt_interactive

        ; [Type]
tau_tys <- forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM ([Class] -> LHsType GhcRn -> TcM Type
tc_default_ty [Class]
deflt_clss) [LHsType GhcRn]
mono_tys

        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [Type]
tau_tys) }

tcDefaults decls :: [LDefaultDecl GhcRn]
decls@(L SrcSpanAnnA
locn (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
_) : [LDefaultDecl GhcRn]
_)
  = forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
locn) forall a b. (a -> b) -> a -> b
$
    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 -> TcM Type
tc_default_ty [Class]
deflt_clss LHsType GhcRn
hs_ty
 = do   { Type
ty <- forall a. String -> TcM a -> TcM a
solveEqualities String
"tc_default_ty" forall a b. (a -> b) -> a -> b
$
                LHsType GhcRn -> TcM Type
tcInferLHsType LHsType GhcRn
hs_ty
        ; Type
ty <- Type -> TcM 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Class -> TcM Bool
check_instance Type
ty) [Class]
deflt_clss
        ; Bool -> SDoc -> TcM ()
checkTc (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
oks) (Type -> [Class] -> SDoc
badDefaultTy Type
ty [Class]
deflt_clss)
        ; 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 -> TcM 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
`tcEqType` HasDebugCallStack => Type -> Type
typeKind Type
ty
  = [Type] -> TcM Bool
simplifyDefault [Class -> [Type] -> Type
mkClassPred Class
cls [Type
ty]]
  | Bool
otherwise
  = 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 (forall a b. (a -> b) -> [a] -> [b]
map LDefaultDecl GhcRn -> SDoc
pp [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
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
locn)
dupDefaultDeclErr [] = 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 (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 (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) (forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
quotesforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr) [Class]
deflt_clss))