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/Commentary/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 import FastString
  33 \end{code}
  34
  35 \begin{code}
  36 tcDefaults :: [LDefaultDecl Name]
  37            -> TcM (Maybe [Type])    -- Defaulting types to heave
  38                                     -- into Tc monad for later use
  39                                     -- in Disambig.
  40
  41 tcDefaults []
  42   = getDeclaredDefaultTys       -- No default declaration, so get the
  43                                 -- default types from the envt;
  44                                 -- i.e. use the curent ones
  45                                 -- (the caller will put them back there)
  46         -- It's important not to return defaultDefaultTys here (which
  47         -- we used to do) because in a TH program, tcDefaults [] is called
  48         -- repeatedly, once for each group of declarations between top-level
  49         -- splices.  We don't want to carefully set the default types in
  50         -- one group, only for the next group to ignore them and install
  51         -- defaultDefaultTys
  52
  53 tcDefaults [L locn (DefaultDecl [])]
  54   = return (Just [])            -- Default declaration specifying no types
  55
  56 tcDefaults [L locn (DefaultDecl mono_tys)]
  57   = setSrcSpan locn                     $
  58     addErrCtxt defaultDeclCtxt          $
  59     do  { ovl_str <- doptM Opt_OverloadedStrings
  60         ; num_class    <- tcLookupClass numClassName
  61         ; is_str_class <- tcLookupClass isStringClassName
  62         ; let deflt_clss | ovl_str   = [num_class, is_str_class]
  63                          | otherwise = [num_class]
  64
  65         ; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys
  66
  67         ; return (Just tau_tys) }
  68
  69 tcDefaults decls@(L locn (DefaultDecl _) : _)
  70   = setSrcSpan locn $
  71     failWithTc (dupDefaultDeclErr decls)
  72
  73
  74 tc_default_ty deflt_clss hs_ty
  75  = do   { ty <- tcHsSigType DefaultDeclCtxt hs_ty
  76         ; checkTc (isTauTy ty) (polyDefErr hs_ty)
  77
  78         -- Check that the type is an instance of at least one of the deflt_clss
  79         ; oks <- mapM (check_instance ty) deflt_clss
  80         ; checkTc (or oks) (badDefaultTy ty deflt_clss)
  81         ; return ty }
  82
  83 check_instance :: Type -> Class -> TcM Bool
  84   -- Check that ty is an instance of cls
  85   -- We only care about whether it worked or not; return a boolean
  86 check_instance ty cls
  87   = do  { (_, mb_res) <- tryTc (tcSimplifyDefault [mkClassPred cls [ty]])
  88         ; return (isJust mb_res) }
  89
  90 defaultDeclCtxt = ptext SLIT("When checking the types in a default declaration")
  91
  92 dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
  93   = hang (ptext SLIT("Multiple default declarations"))
  94       4  (vcat (map pp dup_things))
  95   where
  96     pp (L locn (DefaultDecl _)) = ptext SLIT("here was another default declaration") <+> ppr locn
  97
  98 polyDefErr ty
  99   = hang (ptext SLIT("Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty)
 100
 101 badDefaultTy ty deflt_clss
 102   = hang (ptext SLIT("The default type") <+> quotes (ppr ty) <+> ptext SLIT("is not an instance of"))
 103        2 (foldr1 (\a b -> a <+> ptext SLIT("or") <+> b) (map (quotes. ppr) deflt_clss))
 104 \end{code}
 105