path: root/compiler/typecheck/TcClassDcl.hs

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Typechecking class declarations
-}

{-# LANGUAGE CPP #-}

module TcClassDcl ( tcClassSigs, tcClassDecl2,
                    findMethodBind, instantiateMethod, 
                    tcClassMinimalDef,
                    HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
                  ) where

#include "HsVersions.h"

import HsSyn
import TcEnv
import TcPat( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv )
import TcEvidence( idHsWrapper )
import TcBinds
import TcUnify
import TcHsType
import TcMType
import Type     ( getClassPredTys_maybe )
import TcType
import TcRnMonad
import BuildTyCl( TcMethInfo )
import Class
import Id
import Name
import NameEnv
import NameSet
import Var
import Outputable
import SrcLoc
import Maybes
import BasicTypes
import Bag
import FastString
import BooleanFormula
import Util

import Control.Monad

{-
Dictionary handling
~~~~~~~~~~~~~~~~~~~
Every class implicitly declares a new data type, corresponding to dictionaries
of that class. So, for example:

        class (D a) => C a where
          op1 :: a -> a
          op2 :: forall b. Ord b => a -> b -> b

would implicitly declare

        data CDict a = CDict (D a)
                             (a -> a)
                             (forall b. Ord b => a -> b -> b)

(We could use a record decl, but that means changing more of the existing apparatus.
One step at at time!)

For classes with just one superclass+method, we use a newtype decl instead:

        class C a where
          op :: forallb. a -> b -> b

generates

        newtype CDict a = CDict (forall b. a -> b -> b)

Now DictTy in Type is just a form of type synomym:
        DictTy c t = TyConTy CDict `AppTy` t

Death to "ExpandingDicts".


************************************************************************
*                                                                      *
                Type-checking the class op signatures
*                                                                      *
************************************************************************
-}

tcClassSigs :: Name                  -- Name of the class
            -> [LSig Name]
            -> LHsBinds Name
            -> TcM ([TcMethInfo],    -- Exactly one for each method
                    NameEnv Type)    -- Types of the generic-default methods
tcClassSigs clas sigs def_methods
  = do { traceTc "tcClassSigs 1" (ppr clas)

       ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
       ; let gen_dm_env = mkNameEnv gen_dm_prs

       ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs

       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
       ; sequence_ [ failWithTc (badMethodErr clas n)
                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
                   -- Value binding for non class-method (ie no TypeSig)

       ; sequence_ [ failWithTc (badGenericMethod clas n)
                   | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
                   -- Generic signature without value binding

       ; traceTc "tcClassSigs 2" (ppr clas)
       ; return (op_info, gen_dm_env) }
  where
    vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig    nm ty _) <- sigs]
    gen_sigs     = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
    dm_bind_names :: [Name]     -- These ones have a value binding in the class decl
    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]

    tc_sig genop_env (op_names, op_hs_ty)
      = do { traceTc "ClsSig 1" (ppr op_names)
           ; op_ty <- tcClassSigType op_hs_ty   -- Class tyvars already in scope
           ; traceTc "ClsSig 2" (ppr op_names)
           ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
           where
             f nm | nm `elemNameEnv` genop_env = GenericDM
                  | nm `elem` dm_bind_names    = VanillaDM
                  | otherwise                  = NoDM

    tc_gen_sig (op_names, gen_hs_ty)
      = do { gen_op_ty <- tcClassSigType gen_hs_ty
           ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }

{-
************************************************************************
*                                                                      *
                Class Declarations
*                                                                      *
************************************************************************
-}

tcClassDecl2 :: LTyClDecl Name          -- The class declaration
             -> TcM (LHsBinds Id)

tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
                                tcdMeths = default_binds}))
  = recoverM (return emptyLHsBinds)     $
    setSrcSpan loc                      $
    do  { clas <- tcLookupLocatedClass class_name

        -- We make a separate binding for each default method.
        -- At one time I used a single AbsBinds for all of them, thus
        -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
        -- But that desugars into
        --      ds = \d -> (..., ..., ...)
        --      dm1 = \d -> case ds d of (a,b,c) -> a
        -- And since ds is big, it doesn't get inlined, so we don't get good
        -- default methods.  Better to make separate AbsBinds for each
        ; let (tyvars, _, _, op_items) = classBigSig clas
              prag_fn     = mkPragEnv sigs default_binds
              sig_fn      = mkHsSigFun sigs
              clas_tyvars = snd (tcSuperSkolTyVars tyvars)
              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
        ; this_dict <- newEvVar pred

        ; let tc_item (sel_id, dm_info)
                = case dm_info of
                    DefMeth dm_name    -> tc_dm sel_id dm_name False
                    GenDefMeth dm_name -> tc_dm sel_id dm_name True
                       -- For GenDefMeth, warn if the user specifies a signature
                       -- with redundant constraints; but not for DefMeth, where
                       -- the default method may well be 'error' or something
                    NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id))
                                                     (lookupPragEnv prag_fn (idName sel_id))
                                             ; return emptyBag }
              tc_dm = tcDefMeth clas clas_tyvars this_dict
                                default_binds sig_fn prag_fn

        ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
                      mapM tc_item op_items

        ; return (unionManyBags dm_binds) }

tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)

tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
          -> HsSigFun -> TcPragEnv -> Id -> Name -> Bool
          -> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
-- This is incompatible with Hugs, which expects a polymorphic
-- default method for every class op, regardless of whether or not
-- the programmer supplied an explicit default decl for the class.
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
tcDefMeth clas tyvars this_dict binds_in
          hs_sig_fn prag_fn sel_id dm_name warn_redundant
  | Just (L bind_loc dm_bind, bndr_loc) <- findMethodBind sel_name binds_in
    -- First look up the default method -- it should be there!
  = do { global_dm_id  <- tcLookupId dm_name
       ; global_dm_id  <- addInlinePrags global_dm_id prags
       ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
            -- Base the local_dm_name on the selector name, because
            -- type errors from tcInstanceMethodBody come from here

       ; spec_prags <- tcSpecPrags global_dm_id prags
       ; warnTc (not (null spec_prags))
                (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
                 <+> quotes (ppr sel_name))

       ; let hs_ty       = lookupHsSig hs_sig_fn sel_name
                           `orElse` pprPanic "tc_dm" (ppr sel_name)
             -- We need the HsType so that we can bring the right
             -- type variables into scope
             --
             -- Eg.   class C a where
             --          op :: forall b. Eq b => a -> [b] -> a
             --          gen_op :: a -> a
             --          generic gen_op :: D a => a -> a
             -- The "local_dm_ty" is precisely the type in the above
             -- type signatures, ie with no "forall a. C a =>" prefix

             local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)

             lm_bind     = dm_bind { fun_id = L bind_loc local_dm_name }
                             -- Substitute the local_meth_name for the binder
                             -- NB: the binding is always a FunBind

       ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
       ; let local_dm_sig' = local_dm_sig { sig_warn_redundant = warn_redundant }
        ; (ev_binds, (tc_bind, _))
               <- checkConstraints (ClsSkol clas) tyvars [this_dict] $
                  tcPolyCheck NonRecursive no_prag_fn local_dm_sig'
                              (L bind_loc lm_bind)

        ; let export = ABE { abe_poly  = global_dm_id
                           -- We have created a complete type signature in
                           -- instTcTySig, hence it is safe to call
                           -- completeSigPolyId
                           , abe_mono  = completeSigPolyId local_dm_sig'
                           , abe_wrap  = idHsWrapper
                           , abe_prags = IsDefaultMethod }
              full_bind = AbsBinds { abs_tvs      = tyvars
                                   , abs_ev_vars  = [this_dict]
                                   , abs_exports  = [export]
                                   , abs_ev_binds = [ev_binds]
                                   , abs_binds    = tc_bind }

        ; return (unitBag (L bind_loc full_bind)) }

  | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
  where
    sel_name = idName sel_id
    prags    = lookupPragEnv prag_fn sel_name
    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
                                -- they are all for meth_id

---------------
tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef _clas sigs op_info
  = case findMinimalDef sigs of
      Nothing -> return defMindef
      Just mindef -> do
        -- Warn if the given mindef does not imply the default one
        -- That is, the given mindef should at least ensure that the
        -- class ops without default methods are required, since we
        -- have no way to fill them in otherwise
        whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
                   (\bf -> addWarnTc (warningMinimalDefIncomplete bf))
        return mindef
  where
    -- By default require all methods without a default
    -- implementation whose names don't start with '_'
    defMindef :: ClassMinimalDef
    defMindef = mkAnd [ mkVar name
                      | (name, NoDM, _) <- op_info
                      , not (startsWithUnderscore (getOccName name)) ]

instantiateMethod :: Class -> Id -> [TcType] -> TcType
-- Take a class operation, say
--      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
-- Instantiate it at [ty1,ty2]
-- Return the "local method type":
--      forall c. Ix x => (ty2,c) -> ty1
instantiateMethod clas sel_id inst_tys
  = ASSERT( ok_first_pred ) local_meth_ty
  where
    (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
    rho_ty = ASSERT( length sel_tyvars == length inst_tys )
             substTyWith sel_tyvars inst_tys sel_rho

    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
                `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)

    ok_first_pred = case getClassPredTys_maybe first_pred of
                      Just (clas1, _tys) -> clas == clas1
                      Nothing -> False
              -- The first predicate should be of form (C a b)
              -- where C is the class in question


---------------------------
type HsSigFun = NameEnv (LHsType Name)

emptyHsSigs :: HsSigFun
emptyHsSigs = emptyNameEnv

mkHsSigFun :: [LSig Name] -> HsSigFun
mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
                            | L _ (TypeSig ns hs_ty _) <- sigs
                            , L _ n <- ns ]

lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name)
lookupHsSig = lookupNameEnv

---------------------------
findMethodBind  :: Name                 -- Selector name
                -> LHsBinds Name        -- A group of bindings
                -> Maybe (LHsBind Name, SrcSpan)
                -- Returns the binding, and the binding
                -- site of the method binder
findMethodBind sel_name binds
  = foldlBag mplus Nothing (mapBag f binds)
  where
    f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
      | op_name == sel_name
             = Just (bind, bndr_loc)
    f _other = Nothing

---------------------------
findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
findMinimalDef = firstJusts . map toMinimalDef
  where
    toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
    toMinimalDef (L _ (MinimalSig _ bf)) = Just (fmap unLoc bf)
    toMinimalDef _                       = Nothing

{-
Note [Polymorphic methods]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
    class Foo a where
        op :: forall b. Ord b => a -> b -> b -> b
    instance Foo c => Foo [c] where
        op = e

When typechecking the binding 'op = e', we'll have a meth_id for op
whose type is
      op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b

So tcPolyBinds must be capable of dealing with nested polytypes;
and so it is. See TcBinds.tcMonoBinds (with type-sig case).

Note [Silly default-method bind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we pass the default method binding to the type checker, it must
look like    op2 = e
not          $dmop2 = e
otherwise the "$dm" stuff comes out error messages.  But we want the
"$dm" to come out in the interface file.  So we typecheck the former,
and wrap it in a let, thus
          $dmop2 = let op2 = e in op2
This makes the error messages right.


************************************************************************
*                                                                      *
                Error messages
*                                                                      *
************************************************************************
-}

tcMkDeclCtxt :: TyClDecl Name -> SDoc
tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
                      ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]

tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
tcAddDeclCtxt decl thing_inside
  = addErrCtxt (tcMkDeclCtxt decl) thing_inside

badMethodErr :: Outputable a => a -> Name -> SDoc
badMethodErr clas op
  = hsep [ptext (sLit "Class"), quotes (ppr clas),
          ptext (sLit "does not have a method"), quotes (ppr op)]

badGenericMethod :: Outputable a => a -> Name -> SDoc
badGenericMethod clas op
  = hsep [ptext (sLit "Class"), quotes (ppr clas),
          ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]

{-
badGenericInstanceType :: LHsBinds Name -> SDoc
badGenericInstanceType binds
  = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
          nest 2 (ppr binds)]

missingGenericInstances :: [Name] -> SDoc
missingGenericInstances missing
  = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing

dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
dupGenericInsts tc_inst_infos
  = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
          nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
          ptext (sLit "All the type patterns for a generic type constructor must be identical")
    ]
  where
    ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
-}
badDmPrag :: Id -> Sig Name -> TcM ()
badDmPrag sel_id prag
  = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
              <+> quotes (ppr sel_id)
              <+> ptext (sLit "lacks an accompanying binding"))

warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
warningMinimalDefIncomplete mindef
  = vcat [ ptext (sLit "The MINIMAL pragma does not require:")
         , nest 2 (pprBooleanFormulaNice mindef)
         , ptext (sLit "but there is no default implementation.") ]