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

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

module TcDefaults ( tcDefaults ) where

import HsSyn
import Name
import Class
import TcRnMonad
import TcEnv
import TcHsType
import TcSimplify
import TcType
import PrelNames
import DynFlags
import SrcLoc
import Data.Maybe
import Outputable
import FastString

tcDefaults :: [LDefaultDecl Name]
           -> TcM (Maybe [Type])    -- Defaulting types to heave
                                    -- into Tc monad for later use
                                    -- in Disambig.

tcDefaults []
  = 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 [])]
  = return (Just [])            -- Default declaration specifying no types

tcDefaults [L locn (DefaultDecl mono_tys)]
  = setSrcSpan locn                     $
    addErrCtxt defaultDeclCtxt          $
    do  { ovl_str <- xoptM Opt_OverloadedStrings
        ; num_class    <- tcLookupClass numClassName
        ; is_str_class <- tcLookupClass isStringClassName
        ; let deflt_clss | ovl_str   = [num_class, is_str_class]
                         | otherwise = [num_class]

        ; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys

        ; return (Just tau_tys) }

tcDefaults decls@(L locn (DefaultDecl _) : _)
  = setSrcSpan locn $
    failWithTc (dupDefaultDeclErr decls)


tc_default_ty :: [Class] -> LHsType Name -> TcM Type
tc_default_ty deflt_clss hs_ty
 = do   { ty <- tcHsSigType DefaultDeclCtxt hs_ty
        ; checkTc (isTauTy ty) (polyDefErr hs_ty)

        -- Check that the type is an instance of at least one of the deflt_clss
        ; oks <- mapM (check_instance ty) deflt_clss
        ; checkTc (or oks) (badDefaultTy ty deflt_clss)
        ; return 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 ty cls
  = do  { (_, mb_res) <- tryTc (simplifyDefault [mkClassPred cls [ty]])
        ; return (isJust mb_res) }

defaultDeclCtxt :: SDoc
defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration")

dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc
dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
  = hang (ptext (sLit "Multiple default declarations"))
       2 (vcat (map pp dup_things))
  where
    pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn
dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"

polyDefErr :: LHsType Name -> SDoc
polyDefErr ty
  = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 2 (ppr ty)

badDefaultTy :: Type -> [Class] -> SDoc
badDefaultTy ty deflt_clss
  = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
       2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss))