compiler/typecheck/TcDefaults.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1993-1998
   4 %
   5 \section[TcDefaults]{Typechecking \tr{default} declarations}
   6
   7 \begin{code}
   8 {-# OPTIONS -w #-}
   9 -- The above warning supression flag is a temporary kludge.
  10 -- While working on this module you are encouraged to remove it and fix
  11 -- any warnings in the module. See
  12 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
  13 -- for details
  14
  15 module TcDefaults ( tcDefaults ) where
  16
  17 #include "HsVersions.h"
  18
  19 import HsSyn
  20 import Name
  21 import Class
  22 import TcRnMonad
  23 import TcEnv
  24 import TcHsType
  25 import TcSimplify
  26 import TcType
  27 import PrelNames
  28 import DynFlags
  29 import SrcLoc
  30 import Maybe
  31 import Outputable
  32 \end{code}
  33
  34 \begin{code}
  35 tcDefaults :: [LDefaultDecl Name]
  36            -> TcM (Maybe [Type])    -- Defaulting types to heave
  37                                     -- into Tc monad for later use
  38                                     -- in Disambig.
  39
  40 tcDefaults []
  41   = getDeclaredDefaultTys       -- No default declaration, so get the
  42                                 -- default types from the envt;
  43                                 -- i.e. use the curent ones
  44                                 -- (the caller will put them back there)
  45         -- It's important not to return defaultDefaultTys here (which
  46         -- we used to do) because in a TH program, tcDefaults [] is called
  47         -- repeatedly, once for each group of declarations between top-level
  48         -- splices.  We don't want to carefully set the default types in
  49         -- one group, only for the next group to ignore them and install
  50         -- defaultDefaultTys
  51
  52 tcDefaults [L locn (DefaultDecl [])]
  53   = returnM (Just [])           -- Default declaration specifying no types
  54
  55 tcDefaults [L locn (DefaultDecl mono_tys)]
  56   = setSrcSpan locn                     $
  57     addErrCtxt defaultDeclCtxt          $
  58     do  { ovl_str <- doptM Opt_OverloadedStrings
  59         ; num_class    <- tcLookupClass numClassName
  60         ; is_str_class <- tcLookupClass isStringClassName
  61         ; let deflt_clss | ovl_str   = [num_class, is_str_class]
  62                          | otherwise = [num_class]
  63
  64         ; tau_tys <- mappM (tc_default_ty deflt_clss) mono_tys
  65
  66         ; return (Just tau_tys) }
  67
  68 tcDefaults decls@(L locn (DefaultDecl _) : _)
  69   = setSrcSpan locn $
  70     failWithTc (dupDefaultDeclErr decls)
  71
  72
  73 tc_default_ty deflt_clss hs_ty
  74  = do   { ty <- tcHsSigType DefaultDeclCtxt hs_ty
  75         ; checkTc (isTauTy ty) (polyDefErr hs_ty)
  76
  77         -- Check that the type is an instance of at least one of the deflt_clss
  78         ; oks <- mapM (check_instance ty) deflt_clss
  79         ; checkTc (or oks) (badDefaultTy ty deflt_clss)
  80         ; return ty }
  81
  82 check_instance :: Type -> Class -> TcM Bool
  83   -- Check that ty is an instance of cls
  84   -- We only care about whether it worked or not; return a boolean
  85 check_instance ty cls
  86   = do  { (_, mb_res) <- tryTc (tcSimplifyDefault [mkClassPred cls [ty]])
  87         ; return (isJust mb_res) }
  88
  89 defaultDeclCtxt = ptext SLIT("When checking the types in a default declaration")
  90
  91 dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
  92   = hang (ptext SLIT("Multiple default declarations"))
  93       4  (vcat (map pp dup_things))
  94   where
  95     pp (L locn (DefaultDecl _)) = ptext SLIT("here was another default declaration") <+> ppr locn
  96
  97 polyDefErr ty
  98   = hang (ptext SLIT("Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty)
  99
 100 badDefaultTy ty deflt_clss
 101   = hang (ptext SLIT("The default type") <+> quotes (ppr ty) <+> ptext SLIT("is not an instance of"))
 102        2 (foldr1 (\a b -> a <+> ptext SLIT("or") <+> b) (map (quotes. ppr) deflt_clss))
 103 \end{code}
 104