Handles @deriving@ clauses on @data@ declarations.
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module TcDeriv ( tcDeriving ) where
#include "HsVersions.h"
import ListSetOps
import Outputable
import Bag
-
-import Monad (unless)
\end{code}
%************************************************************************
; gen_binds <- mkGenericBinds tycl_decls
-- Rename these extra bindings, discarding warnings about unused bindings etc
- -- Set -fglasgow exts so that we can have type signatures in patterns,
- -- which is used in the generic binds
+ -- Type signatures in patterns are used in the generic binds
; rn_binds
- <- discardWarnings $ setOptM Opt_GlasgowExts $ do
+ <- discardWarnings $
+ setOptM Opt_PatternSignatures $
+ do
{ (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn deriv_binds [])
; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds [])
; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM (Maybe DerivEqn, Maybe InstInfo)
-- Standalone deriving declarations
--- e.g. derive instance Show T
+-- e.g. deriving instance show a => Show (T a)
-- Rather like tcLocalInstDecl
deriveStandalone (L loc (DerivDecl deriv_ty))
= setSrcSpan loc $
addErrCtxt (standaloneCtxt deriv_ty) $
- do { (tvs, theta, tau) <- tcHsInstHead deriv_ty
- ; (cls, inst_tys) <- checkValidInstHead tau
- ; let cls_tys = take (length inst_tys - 1) inst_tys
- inst_ty = last inst_tys
-
- ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty }
+ do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty)
+ ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
+ ; traceTc (text "standalone deriving;"
+ <+> text "tvs:" <+> ppr tvs
+ <+> text "theta:" <+> ppr theta
+ <+> text "tau:" <+> ppr tau)
+ ; (cls, inst_tys) <- checkValidInstHead tau
+ ; let cls_tys = take (length inst_tys - 1) inst_tys
+ inst_ty = last inst_tys
+
+ ; traceTc (text "standalone deriving;"
+ <+> text "class:" <+> ppr cls
+ <+> text "class types:" <+> ppr cls_tys
+ <+> text "type:" <+> ppr inst_ty)
+ ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
+ (Just theta) }
------------------------------------------------------------------
deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
-- The "deriv_pred" is a LHsType to take account of the fact that for
-- newtype deriving we allow deriving (forall a. C [a]).
- ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app } }
+ ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app Nothing } }
deriveTyData (deriv_pred, other_decl)
= panic "derivTyData" -- Caller ensures that only TyData can happen
------------------------------------------------------------------
-mkEqnHelp orig tvs cls cls_tys tc_app
+mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
+ -> Maybe DerivRhs
+ -> TcRn (Maybe DerivEqn, Maybe InstInfo)
+mkEqnHelp orig tvs cls cls_tys tc_app mtheta
| Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
= do { -- Make tc_app saturated, because that's what the
-- mkDataTypeEqn things expect
; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
- ; mayDeriveDataTypeable <- doptM Opt_GlasgowExts
+ ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
; overlap_flag <- getOverlapFlag
-- to check the instance tycon, not the family tycon
; if isDataTyCon rep_tc then
mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys
- tycon full_tc_args rep_tc rep_tc_args
+ tycon full_tc_args rep_tc rep_tc_args mtheta
else
mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag
full_tvs cls cls_tys
- tycon full_tc_args rep_tc rep_tc_args }
+ tycon full_tc_args rep_tc rep_tc_args mtheta }
| otherwise
= baleOut (derivingThingErr cls cls_tys tc_app
(ptext SLIT("Last argument of the instance must be a type application")))
\end{code}
Auxiliary lookup wrapper which requires that looked up family instances are
-not type instances.
+not type instances. If called with a vanilla tycon, the old type application
+is simply returned.
\begin{code}
tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
tcLookupFamInstExact tycon tys
- = do { result@(rep_tycon, rep_tys) <- tcLookupFamInst tycon tys
- ; let { tvs = map (Type.getTyVar
- "TcDeriv.tcLookupFamInstExact")
- rep_tys
- ; variable_only_subst = all Type.isTyVarTy rep_tys &&
- sizeVarSet (mkVarSet tvs) == length tvs
+ | not (isOpenTyCon tycon)
+ = return (tycon, tys)
+ | otherwise
+ = do { maybeFamInst <- tcLookupFamInst tycon tys
+ ; case maybeFamInst of
+ Nothing -> famInstNotFound tycon tys False
+ Just famInst@(_, rep_tys)
+ | not variable_only_subst -> famInstNotFound tycon tys True
+ | otherwise -> return famInst
+ where
+ tvs = map (Type.getTyVar
+ "TcDeriv.tcLookupFamInstExact")
+ rep_tys
+ variable_only_subst = all Type.isTyVarTy rep_tys &&
+ sizeVarSet (mkVarSet tvs) == length tvs
-- renaming may have no repetitions
- }
- ; unless variable_only_subst $
- famInstNotFound tycon tys [result]
- ; return result
}
-
\end{code}
%************************************************************************
\begin{code}
+mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type]
+ -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe DerivRhs
+ -> TcRn (Maybe DerivEqn, Maybe InstInfo)
mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
- tycon tc_args rep_tc rep_tc_args
+ tycon tc_args rep_tc rep_tc_args mtheta
| Just err <- checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
-- NB: pass the *representation* tycon to checkSideConditions
= baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err)
| otherwise
= ASSERT( null cls_tys )
do { loc <- getSrcSpanM
- ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args
+ ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tc
+ rep_tc_args mtheta
; return (Just eqn, Nothing) }
mk_data_eqn :: SrcSpan -> InstOrigin -> [TyVar] -> Class
- -> TyCon -> [TcType] -> TyCon -> [TcType] -> TcM DerivEqn
-mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args
+ -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe DerivRhs
+ -> TcM DerivEqn
+mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
| cls `hasKey` typeableClassKey
= -- The Typeable class is special in several ways
-- data T a b = ... deriving( Typeable )
-- Typeable; it depends on the arity of the type
do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
; dfun_name <- new_dfun_name real_clas tycon
- ; return (loc, orig, dfun_name, [], real_clas, mkTyConApp tycon [], []) }
+ ; let theta = fromMaybe [] mtheta
+ ; return (loc, orig, dfun_name, [], real_clas, mkTyConApp tycon [], theta)
+ }
| otherwise
= do { dfun_name <- new_dfun_name cls tycon
arg_ty <- ASSERT( isVanillaDataCon data_con )
dataConInstOrigArgTys data_con rep_tc_args,
not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
+ theta = fromMaybe ordinary_constraints mtheta
tiresome_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
stupid_constraints = substTheta tiresome_subst (tyConStupidTheta rep_tc)
-- see note [Data decl contexts] above
; return (loc, orig, dfun_name, tvs, cls, mkTyConApp tycon tc_args,
- stupid_constraints ++ ordinary_constraints)
+ stupid_constraints ++ theta)
}
------------------------------------------------------------------
\begin{code}
mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> OverlapFlag -> [Var] -> Class
-> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
+ -> Maybe DerivRhs
-> TcRn (Maybe DerivEqn, Maybe InstInfo)
-mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag tvs cls cls_tys
- tycon tc_args
- rep_tycon rep_tc_args
+mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag tvs
+ cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
| can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
= do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
; -- Go ahead and use the isomorphism
| isNothing mb_std_err -- Use the standard H98 method
= do { loc <- getSrcSpanM
- ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tycon rep_tc_args
+ ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tycon
+ rep_tc_args mtheta
; return (Just eqn, Nothing) }
-- Otherwise we can't derive
= vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
ptext SLIT("type variables that are not data type parameters"),
nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
-\end{code}
-
+famInstNotFound tycon tys notExact
+ = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
+ where
+ msg = ptext $ if notExact
+ then SLIT("No family instance exactly matching")
+ else SLIT("More than one family instance for")
+\end{code}
projects / ghc-hetmet.git / blobdiff