Commit 91c750cb authored by simonpj's avatar simonpj

[project @ 2001-12-20 11:19:05 by simonpj]

---------------------------------------------
	More type system extensions (for John Hughes)
	---------------------------------------------

1.  Added a brand-new extension that lets you derive ARBITRARY CLASSES
for newtypes.  Thus

	newtype Age = Age Int deriving( Eq, Ord, Shape, Ix )

The idea is that the dictionary for the user-defined class Shape Age
is *identical* to that for Shape Int, so there is really no deriving
work to do.   This saves you writing the very tiresome instance decl:

	instance Shape Age where
	   shape_op1 (Age x) = shape_op1 x
	   shape_op2 (Age x1) (Age x2) = shape_op2 x1 x2
	   ...etc...

It's more efficient, too, becuase the Shape Age dictionary really
will be identical to the Shape Int dictionary.

There's an exception for Read and Show, because the derived instance
*isn't* the same.

There is a complication where higher order stuff is involved.  Here is
the example John gave:

   class StateMonad s m | m -> s where ...

   newtype Parser tok m a = Parser (State [tok] (Failure m) a)
			  deriving( Monad, StateMonad )

Then we want the derived instance decls to be

   instance Monad (State [tok] (Failure m)) => Monad (Parser tok m)
   instance StateMonad [tok] (State [tok] (Failure m))
	 => StateMonad [tok] (Parser tok m)

John is writing up manual entry for all of this, but this commit
implements it.   I think.


2.  Added -fallow-incoherent-instances, and documented it.  The idea
is that sometimes GHC is over-protective about not committing to a
particular instance, and the programmer may want to say "commit anyway".
Here's the example:

    class Sat a where
      dict :: a

    data EqD a = EqD {eq :: a->a->Bool}

    instance Sat (EqD a) => Eq a where
      (==) = eq dict

    instance Sat (EqD Integer) where
      dict = EqD{eq=(==)}

    instance Eq a => Sat (EqD a) where
      dict = EqD{eq=(==)}

    class Collection c cxt | c -> cxt where
      empty :: Sat (cxt a) => c a
      single :: Sat (cxt a) => a -> c a
      union :: Sat (cxt a) => c a -> c a -> c a
      member :: Sat (cxt a) => a -> c a -> Bool

    instance Collection [] EqD where
      empty = []
      single x = [x]
      union = (++)
      member = elem

It's an updated attempt to model "Restricted Data Types", if you
remember my Haskell workshop paper. In the end, though, GHC rejects
the program (even with fallow-overlapping-instances and
fallow-undecideable-instances), because there's more than one way to
construct the Eq instance needed by elem.

Yet all the ways are equivalent! So GHC is being a bit over-protective
of me, really: I know what I'm doing and I would LIKE it to pick an
arbitrary one. Maybe a flag fallow-incoherent-instances would be a
useful thing to add?
parent 32e08a78
......@@ -277,10 +277,8 @@ data TyClDecl name pat
tcdTyVars :: [HsTyVarBndr name], -- type variables
tcdCons :: [ConDecl name], -- data constructors (empty if abstract)
tcdNCons :: Int, -- Number of data constructors (valid even if type is abstract)
tcdDerivs :: Maybe [name], -- derivings; Nothing => not specified
-- (i.e., derive default); Just [] => derive
-- *nothing*; Just <list> => as you would
-- expect...
tcdDerivs :: Maybe (HsContext name), -- derivings; Nothing => not specified
-- Just [] => derive exactly what is asked
tcdSysNames :: DataSysNames name, -- Generic converter functions
tcdLoc :: SrcLoc
}
......@@ -515,7 +513,7 @@ pp_tydecl pp_head pp_decl_rhs derivings
pp_decl_rhs,
case derivings of
Nothing -> empty
Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
Just ds -> hsep [ptext SLIT("deriving"), ppr_hs_context ds]
])
\end{code}
......
......@@ -18,7 +18,7 @@ module HsTypes (
, PostTcType, placeHolderType,
-- Printing
, pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
, pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
-- Equality over Hs things
, EqHsEnv, emptyEqHsEnv, extendEqHsEnv,
......@@ -229,21 +229,17 @@ pprHsForAll tvs cxt
ptext SLIT("forall") <+> interppSP tvs <> dot <+>
-- **! ToDo: want to hide uvars from user, but not enough info
-- in a HsTyVarBndr name (see PprType). KSW 2000-10.
(if null cxt then
empty
else
ppr_context cxt <+> ptext SLIT("=>")
)
pprHsContext cxt
else -- Used in interfaces
ptext SLIT("__forall") <+> interppSP tvs <+>
ppr_context cxt <+> ptext SLIT("=>")
ppr_hs_context cxt <+> ptext SLIT("=>")
pprHsContext :: (Outputable name) => HsContext name -> SDoc
pprHsContext [] = empty
pprHsContext cxt = ppr_context cxt <+> ptext SLIT("=>")
pprHsContext cxt = ppr_hs_context cxt <+> ptext SLIT("=>")
ppr_context [] = empty
ppr_context cxt = parens (interpp'SP cxt)
ppr_hs_context [] = empty
ppr_hs_context cxt = parens (interpp'SP cxt)
\end{code}
\begin{code}
......
......@@ -282,6 +282,7 @@ data DynFlag
-- language opts
| Opt_AllowOverlappingInstances
| Opt_AllowUndecidableInstances
| Opt_AllowIncoherentInstances
| Opt_GlasgowExts
| Opt_Generics
| Opt_NoImplicitPrelude
......
{-# OPTIONS -#include "hschooks.h" #-}
-----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.82 2001/12/10 14:08:14 simonmar Exp $
-- $Id: DriverFlags.hs,v 1.83 2001/12/20 11:19:07 simonpj Exp $
--
-- Driver flags
--
......@@ -427,6 +427,7 @@ fFlags = [
( "glasgow-exts", Opt_GlasgowExts ),
( "allow-overlapping-instances", Opt_AllowOverlappingInstances ),
( "allow-undecidable-instances", Opt_AllowUndecidableInstances ),
( "allow-incoherent-instances", Opt_AllowIncoherentInstances ),
( "generics", Opt_Generics )
]
......
......@@ -135,8 +135,12 @@ where the object file will reside if/when it is created.
A @ModIface@ plus a @ModDetails@ summarises everything we know
about a compiled module. The @ModIface@ is the stuff *before* linking,
and can be written out to an interface file. The @ModDetails@ is after
linking; it is the "linked" form of the mi_decls field.
and can be written out to an interface file. (The @ModDetails@ is after
linking; it is the "linked" form of the mi_decls field.)
When we *read* an interface file, we also construct a @ModIface@ from it,
except that the mi_decls part is empty; when reading we consolidate
the declarations into a single indexed map in the @PersistentRenamerState@.
\begin{code}
data ModIface
......@@ -514,6 +518,24 @@ type IsExported = Name -> Bool -- True for names that are exported from this mo
%* *
%************************************************************************
The @PersistentCompilerState@ persists across successive calls to the
compiler.
* A ModIface for each non-home-package module
* An accumulated TypeEnv from all the modules in imported packages
* An accumulated InstEnv from all the modules in imported packages
The point is that we don't want to keep recreating it whenever
we compile a new module. The InstEnv component of pcPST is empty.
(This means we might "see" instances that we shouldn't "really" see;
but the Haskell Report is vague on what is meant to be visible,
so we just take the easy road here.)
* Ditto for rules
* The persistent renamer state
\begin{code}
data PersistentCompilerState
= PCS {
......@@ -532,24 +554,12 @@ data PersistentCompilerState
}
\end{code}
The @PersistentRenamerState@ persists across successive calls to the
compiler.
It contains:
The persistent renamer state contains:
* A name supply, which deals with allocating unique names to
(Module,OccName) original names,
* An accumulated TypeEnv from all the modules in imported packages
* An accumulated InstEnv from all the modules in imported packages
The point is that we don't want to keep recreating it whenever
we compile a new module. The InstEnv component of pcPST is empty.
(This means we might "see" instances that we shouldn't "really" see;
but the Haskell Report is vague on what is meant to be visible,
so we just take the easy road here.)
* Ditto for rules
* A "holding pen" for declarations that have been read out of
interface files but not yet sucked in, renamed, and typechecked
......@@ -561,6 +571,9 @@ type PackageInstEnv = InstEnv
data PersistentRenamerState
= PRS { prsOrig :: !NameSupply,
prsImpMods :: !ImportedModuleInfo,
-- Holding pens for stuff that has been read in
-- but not yet slurped into the renamer
prsDecls :: !DeclsMap,
prsInsts :: !IfaceInsts,
prsRules :: !IfaceRules
......
......@@ -99,18 +99,19 @@ checkInstType t
returnP (HsForAllTy Nothing [] dict_ty)
checkContext :: RdrNameHsType -> P RdrNameContext
checkContext (HsTupleTy _ ts)
checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
= mapP (\t -> checkPred t []) ts `thenP` \ps ->
returnP ps
checkContext (HsTyVar t) -- empty contexts are allowed
checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
| t == unitTyCon_RDR = returnP []
checkContext t
= checkPred t [] `thenP` \p ->
returnP [p]
checkPred :: RdrNameHsType -> [RdrNameHsType]
-> P (HsPred RdrName)
checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName)
checkPred (HsTyVar t) args | not (isRdrTyVar t)
= returnP (HsClassP t args)
checkPred (HsAppTy l r) args = checkPred l (r:args)
checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty)
......
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.79 2001/11/29 13:47:10 simonpj Exp $
$Id: Parser.y,v 1.80 2001/12/20 11:19:08 simonpj Exp $
Haskell grammar.
......@@ -538,7 +538,7 @@ sig_vars :: { [RdrName] }
-- A ctype is a for-all type
ctype :: { RdrNameHsType }
: 'forall' tyvars '.' ctype { mkHsForAllTy (Just $2) [] $4 }
| context type { mkHsForAllTy Nothing $1 $2 }
| context '=>' type { mkHsForAllTy Nothing $1 $3 }
-- A type of form (context => type) is an *implicit* HsForAllTy
| type { $1 }
......@@ -620,8 +620,8 @@ constrs1 :: { [RdrNameConDecl] }
| constr { [$1] }
constr :: { RdrNameConDecl }
: srcloc forall context constr_stuff
{ mkConDecl (fst $4) $2 $3 (snd $4) $1 }
: srcloc forall context '=>' constr_stuff
{ mkConDecl (fst $5) $2 $3 (snd $5) $1 }
| srcloc forall constr_stuff
{ mkConDecl (fst $3) $2 [] (snd $3) $1 }
......@@ -630,7 +630,7 @@ forall :: { [RdrNameHsTyVar] }
| {- empty -} { [] }
context :: { RdrNameContext }
: btype '=>' {% checkContext $1 }
: btype {% checkContext $1 }
constr_stuff :: { (RdrName, RdrNameConDetails) }
: btype {% mkVanillaCon $1 [] }
......@@ -658,15 +658,11 @@ stype :: { RdrNameBangType }
: ctype { unbangedType $1 }
| '!' atype { BangType MarkedUserStrict $2 }
deriving :: { Maybe [RdrName] }
deriving :: { Maybe RdrNameContext }
: {- empty -} { Nothing }
| 'deriving' qtycls { Just [$2] }
| 'deriving' '(' ')' { Just [] }
| 'deriving' '(' dclasses ')' { Just (reverse $3) }
dclasses :: { [RdrName] }
: dclasses ',' qtycls { $3 : $1 }
| qtycls { [$1] }
| 'deriving' context { Just $2 }
-- Glasgow extension: allow partial
-- applications in derivings
-----------------------------------------------------------------------------
-- Value definitions
......
......@@ -212,7 +212,6 @@ mkClassDecl cxt cname tyvars fds sigs mbinds loc
-- superclasses both called C!)
new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
-- mkTyData :: ??
mkTyData new_or_data context tname list_var list_con i maybe src
= let t_occ = rdrNameOcc tname
name1 = mkRdrUnqual (mkGenOcc1 t_occ)
......
......@@ -424,8 +424,12 @@ getImplicitModuleFVs mod_name decls -- Compiling a module
|| mod_name == pREL_MAIN_Name = unitFV ioTyConName
| otherwise = emptyFVs
-- deriv_classes is now a list of HsTypes, so a "normal" one
-- appears as a (HsClassP c []). The non-normal ones for the new
-- newtype-deriving extension, and they don't require any
-- implicit names, so we can silently filter them out.
deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls,
cls <- deriv_classes,
HsClassP cls [] <- deriv_classes,
occ <- lookupWithDefaultUFM derivingOccurrences [] cls ]
-- ubiquitous_names are loaded regardless, because
......
......@@ -612,7 +612,11 @@ lookupFixityRn name
-- loadHomeInterface, and consulting the Ifaces that comes back
-- from that, because the interface file for the Name might not
-- have been loaded yet. Why not? Suppose you import module A,
-- which exports a function 'f', which is defined in module B.
-- which exports a function 'f', thus;
-- module CurrentModule where
-- import A( f )
-- module A( f ) where
-- import B( f )
-- Then B isn't loaded right away (after all, it's possible that
-- nothing from B will be used). When we come across a use of
-- 'f', we need to know its fixity, and it's then, and only
......
......@@ -129,7 +129,10 @@ tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos})
tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls, tcdDerivs = derivings})
= delFVs (map hsTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
extractHsCtxtTyNames context `plusFV`
(case derivings of
Nothing -> emptyFVs
Just ds -> extractHsCtxtTyNames ds) `plusFV`
plusFVs (map conDeclFVs condecls)
tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty})
......
......@@ -290,11 +290,12 @@ rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_n
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
tcdLoc = src_loc, tcdSysNames = sys_names})
tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names})
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
rnContext data_doc context `thenRn` \ context' ->
rn_derivs derivs `thenRn` \ derivs' ->
checkDupOrQualNames data_doc con_names `thenRn_`
-- Check that there's at least one condecl,
......@@ -311,11 +312,14 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'})
tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'})
where
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName condecls
rn_derivs Nothing = returnRn Nothing
rn_derivs (Just ds) = rnContext data_doc ds `thenRn` \ ds' -> returnRn (Just ds')
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
= pushSrcLocRn src_loc $
lookupTopBndrRn name `thenRn` \ name' ->
......@@ -400,13 +404,6 @@ rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
-- Used for source file decls only
-- Renames the default-bindings of a class decl
-- the derivings of a data decl
finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc}) -- Derivings in here
rn_ty_decl -- Everything else is here
= pushSrcLocRn src_loc $
mapRn rnDeriv derivs `thenRn` \ derivs' ->
returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs')
finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here
rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here
-- There are some default-method bindings (abeit possibly empty) so
......@@ -436,7 +433,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G
meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
-- Not a class or data type declaration
-- Not a class declaration
\end{code}
......@@ -446,15 +443,6 @@ finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
%* *
%*********************************************************
\begin{code}
rnDeriv :: RdrName -> RnMS Name
rnDeriv cls
= lookupOccRn cls `thenRn` \ clas_name ->
checkRn (getUnique clas_name `elem` derivableClassKeys)
(derivingNonStdClassErr clas_name) `thenRn_`
returnRn clas_name
\end{code}
\begin{code}
conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
conDeclName (ConDecl n _ _ _ _ l) = (n,l)
......@@ -702,11 +690,9 @@ validRuleLhs foralls lhs
%*********************************************************
\begin{code}
derivingNonStdClassErr clas
= hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
badRuleLhsErr name lhs
= sep [ptext SLIT("Rule") <+> ptext name <> colon,
nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
......
......@@ -592,8 +592,9 @@ lookupInst :: Inst
-- Dictionaries
lookupInst dict@(Dict _ (ClassP clas tys) loc)
= tcGetInstEnv `thenNF_Tc` \ inst_env ->
case lookupInstEnv inst_env clas tys of
= getDOptsTc `thenNF_Tc` \ dflags ->
tcGetInstEnv `thenNF_Tc` \ inst_env ->
case lookupInstEnv dflags inst_env clas tys of
FoundInst tenv dfun_id
-> let
......@@ -670,8 +671,9 @@ lookupSimpleInst :: Class
-> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s
lookupSimpleInst clas tys
= tcGetInstEnv `thenNF_Tc` \ inst_env ->
case lookupInstEnv inst_env clas tys of
= getDOptsTc `thenNF_Tc` \ dflags ->
tcGetInstEnv `thenNF_Tc` \ inst_env ->
case lookupInstEnv dflags inst_env clas tys of
FoundInst tenv dfun
-> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
where
......
......@@ -13,7 +13,7 @@ module TcDeriv ( tcDeriving ) where
import HsSyn ( HsBinds(..), MonoBinds(..), TyClDecl(..),
collectLocatedMonoBinders )
import RdrHsSyn ( RdrNameMonoBinds )
import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl )
import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPred )
import CmdLineOpts ( DynFlag(..), DynFlags )
import TcMonad
......@@ -22,6 +22,7 @@ import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv )
import TcMonoType ( tcHsPred )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
......@@ -29,29 +30,33 @@ import RnEnv ( bindLocatedLocalsRn )
import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn )
import HscTypes ( DFunId, PersistentRenamerState )
import BasicTypes ( Fixity )
import Class ( className, classKey, Class )
import BasicTypes ( Fixity, NewOrData(..) )
import Class ( className, classKey, classTyVars, Class )
import ErrUtils ( dumpIfSet_dyn, Message )
import MkId ( mkDictFunId )
import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
import DataCon ( dataConRepArgTys, isNullaryDataCon, isExistentialDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool, catMaybes )
import Module ( Module )
import Name ( Name, getSrcLoc, nameUnique )
import RdrName ( RdrName )
import TyCon ( tyConTyVars, tyConDataCons,
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, newTyConRep,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
isEnumerationTyCon, TyCon
)
import TcType ( ThetaType, mkTyVarTys, mkTyConApp,
isUnLiftedType, mkClassPred )
import Var ( TyVar )
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys,
tcSplitTyConApp_maybe )
import Var ( TyVar, tyVarKind )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
import Util ( zipWithEqual, sortLt )
import ListSetOps ( removeDups, assoc )
import Outputable
import Maybe ( isJust )
import List ( nub )
import FastString ( FastString )
\end{code}
%************************************************************************
......@@ -187,17 +192,37 @@ tcDeriving :: PersistentRenamerState
-> TcM ([InstInfo], -- The generated "instance decls".
RenamedHsBinds) -- Extra generated bindings
tcDeriving prs mod inst_env_in get_fixity tycl_decls
tcDeriving prs mod inst_env get_fixity tycl_decls
= recoverTc (returnTc ([], EmptyBinds)) $
-- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
makeDerivEqns tycl_decls `thenTc` \ eqns ->
if null eqns then
returnTc ([], EmptyBinds)
else
makeDerivEqns tycl_decls `thenTc` \ (ordinary_eqns, inst_info2) ->
deriveOrdinaryStuff mod prs inst_env get_fixity
ordinary_eqns `thenTc` \ (inst_info1, binds) ->
let
inst_info = inst_info2 ++ inst_info1 -- info2 usually empty
in
getDOptsTc `thenNF_Tc` \ dflags ->
ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info binds)) `thenTc_`
returnTc (inst_info, binds)
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
ddump_deriving inst_infos extra_binds
= vcat (map pprInstInfo inst_infos) $$ ppr extra_binds
-- Take the equation list and solve it, to deliver a list of
-----------------------------------------
deriveOrdinaryStuff mod prs inst_env_in get_fixity [] -- Short cut
= returnTc ([], EmptyBinds)
deriveOrdinaryStuff mod prs inst_env_in get_fixity eqns
= -- Take the equation list and solve it, to deliver a list of
-- solutions, a.k.a. the contexts for the instance decls
-- required for the corresponding equations.
solveDerivEqns inst_env_in eqns `thenTc` \ new_dfuns ->
......@@ -207,11 +232,10 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls
-- generate extra not-one-inst-decl-specific binds, notably
-- "con2tag" and/or "tag2con" functions. We do these
-- separately.
gen_taggery_Names new_dfuns `thenTc` \ nm_alist_etc ->
tcGetEnv `thenNF_Tc` \ env ->
getDOptsTc `thenTc` \ dflags ->
getDOptsTc `thenNF_Tc` \ dflags ->
let
extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
......@@ -228,20 +252,11 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls
mapRn rn_meths method_binds_s `thenRn` \ rn_method_binds_s ->
returnRn (rn_method_binds_s, rn_extra_binds)
)
new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s
in
ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving new_inst_infos rn_extra_binds)) `thenTc_`
returnTc (new_inst_infos, rn_extra_binds)
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
ddump_deriving inst_infos extra_binds
= vcat (map pprInstInfo inst_infos) $$ ppr extra_binds
where
where
-- Make a Real dfun instead of the dummy one we have so far
gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
gen_inst_info dfun binds
......@@ -274,68 +289,138 @@ or} has just one data constructor (e.g., tuples).
all those.
\begin{code}
makeDerivEqns :: [RenamedTyClDecl] -> TcM [DerivEqn]
makeDerivEqns :: [RenamedTyClDecl]
-> TcM ([DerivEqn], -- Ordinary derivings
[InstInfo]) -- Special newtype derivings
makeDerivEqns tycl_decls
= mapTc mk_eqn derive_these `thenTc` \ maybe_eqns ->
returnTc (catMaybes maybe_eqns)
= mapAndUnzipTc mk_eqn derive_these `thenTc` \ (maybe_ordinaries, maybe_newtypes) ->
returnTc (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
where
------------------------------------------------------------------
derive_these :: [(Name, Name)]
-- Find the (Class,TyCon) pairs that must be `derived'
derive_these :: [(NewOrData, Name, RenamedHsPred)]
-- Find the (nd, TyCon, Pred) pairs that must be `derived'
-- NB: only source-language decls have deriving, no imported ones do
derive_these = [ (clas,tycon)
| TyData {tcdName = tycon, tcdDerivs = Just classes} <- tycl_decls,
clas <- nub classes ]
derive_these = [ (nd, tycon, pred)
| TyData {tcdND = nd, tcdName = tycon, tcdDerivs = Just preds} <- tycl_decls,
pred <- preds ]
------------------------------------------------------------------
mk_eqn :: (Name, Name) -> NF_TcM (Maybe DerivEqn)
-- we swizzle the tyvars and datacons out of the tycon
mk_eqn :: (NewOrData, Name, RenamedHsPred) -> NF_TcM (Maybe DerivEqn, Maybe InstInfo)
-- We swizzle the tyvars and datacons out of the tycon
-- to make the rest of the equation
mk_eqn (clas_name, tycon_name)
= tcLookupClass clas_name `thenNF_Tc` \ clas ->
tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
let
clas_key = classKey clas
tyvars = tyConTyVars tycon
tyvar_tys = mkTyVarTys tyvars
ty = mkTyConApp tycon tyvar_tys
data_cons = tyConDataCons tycon
locn = getSrcLoc tycon
constraints = extra_constraints ++ concat (map mk_constraints data_cons)
mk_eqn (new_or_data, tycon_name, pred)
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
tcAddSrcLoc (getSrcLoc tycon) $
tcAddErrCtxt (derivCtxt tycon) $
tcHsPred pred `thenTc` \ pred' ->
case getClassPredTys_maybe pred' of
Nothing -> bale_out (malformedPredErr tycon pred)
Just (clas, tys) -> mk_eqn_help new_or_data tycon clas tys
-- "extra_constraints": see notes above about contexts on data decls
extra_constraints
| offensive_class = tyConTheta tycon
| otherwise = []
------------------------------------------------------------------
mk_eqn_help DataType tycon clas tys
| Just err <- chk_out clas tycon tys
= bale_out (derivingThingErr clas tys tycon tyvars err)
| otherwise
= new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing)
where
tyvars = tyConTyVars tycon
data_cons = tyConDataCons tycon
constraints = extra_constraints ++
[ mkClassPred clas [arg_ty]
| data_con <- tyConDataCons tycon,
arg_ty <- dataConRepArgTys data_con,
-- Use the same type variables
-- as the type constructor,
-- hence no need to instantiate
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys
mk_constraints data_con
= [ mkClassPred clas [arg_ty]
| arg_ty <- dataConArgTys data_con tyvar_tys,
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
in
case chk_out clas tycon of
Just err -> tcAddSrcLoc (getSrcLoc tycon) $
addErrTc err `thenNF_Tc_`
returnNF_Tc Nothing
Nothing -> newDFunName clas [ty] locn `thenNF_Tc` \ dfun_name ->
returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints))
-- "extra_constraints": see notes above about contexts on data decls
extra_constraints | offensive_class = tyConTheta tycon
| otherwise = []
offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
mk_eqn_help NewType tycon clas []
| clas `hasKey` readClassKey || clas `hasKey` showClassKey
= mk_eqn_help DataType tycon clas [] -- Use the generate-full-code mechanism for Read and Show
mk_eqn_help NewType tycon clas tys
= doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
if not gla_exts then -- Not glasgow-exts?
mk_eqn_help DataType tycon clas tys -- revert to ordinary mechanism
else if not can_derive then
bale_out cant_derive_err
else
new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
returnTc (Nothing, Just (NewTypeDerived (mk_dfun dfun_name)))
where
-- Here is the plan for newtype derivings. We see
-- newtype T a1...an = T (t ak...an) deriving (C1...Cm)
-- where aj...an do not occur free in t, and the Ci are *partial applications* of
-- classes with the last parameter missing
--
-- We generate the instances
-- instance Ci (t ak...aj) => Ci (T a1...aj)
-- where T a1...aj is the partial application of the LHS of the correct kind
--
-- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
kind = tyVarKind (last (classTyVars clas))
-- Kind of the thing we want to instance
-- e.g. argument kind of Monad, *->*
(arg_kinds, _) = tcSplitFunTys kind
n_args_to_drop = length arg_kinds
-- Want to drop 1 arg from (T s a) and (ST s a)
-- to get instance Monad (ST s) => Monad (T s)