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