content: {-
  (c) The University of Glasgow 2006
  (c) The AQUA Project, Glasgow University, 1993-1998
  
  \section[TcDefaults]{Typechecking \tr{default} declarations}
  -}
  
  module Eta.TypeCheck.TcDefaults ( tcDefaults ) where
  
  import Eta.HsSyn.HsSyn
  import Eta.BasicTypes.Name
  import Eta.Types.Class
  import Eta.TypeCheck.TcRnMonad
  import Eta.TypeCheck.TcEnv
  import Eta.TypeCheck.TcHsType
  import Eta.TypeCheck.TcSimplify
  import Eta.TypeCheck.TcType
  import Eta.Prelude.PrelNames
  import Eta.BasicTypes.SrcLoc
  import Data.Maybe
  import Eta.Utils.Outputable
  import Eta.Utils.FastString
  import qualified Eta.LanguageExtensions as LangExt
  
  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 LangExt.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))
  