%
\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 BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
#include "HsVersions.h"
import IfaceEnv
-import TcRnMonad
import DataCon
import Var
import VarSet
-import TysWiredIn
import BasicTypes
import Name
import OccName
import Coercion
import TcRnMonad
+import Util ( count )
import Outputable
import Data.List
------------------------------------------------------
buildSynTyCon :: Name -> [TyVar]
-> SynTyConRhs
+ -> Kind -- Kind of the RHS
-> Maybe (TyCon, [Type]) -- family instance if applicable
-> TcRnIf m n TyCon
-buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
+buildSynTyCon tc_name tvs rhs@(OpenSynTyCon {}) rhs_kind _
= let
- kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
+ kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
in
return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
-buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family
+buildSynTyCon tc_name tvs rhs@(SynonymTyCon {}) rhs_kind mb_family
= do { -- We need to tie a knot as the coercion of a data instance depends
-- on the instance representation tycon and vice versa.
; tycon <- fixM (\ tycon_rec -> do
{ parent <- mkParentInfo mb_family tc_name tvs tycon_rec
; let { tycon = mkSynTyCon tc_name kind tvs rhs parent
- ; kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
+ ; kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
}
; return tycon
})
--
-- (1) create a coercion that identifies the family instance type and the
-- representation type from Step (1); ie, it is of the form
--- `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion,
+-- `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion,
-- `F' the family tycon and `R' the (derived) representation tycon,
-- and
-- (2) produce a `TyConParent' value containing the parent and coercion
-- non-recursive newtypes
all_coercions = True
tvs = tyConTyVars tycon
- rhs_ty = ASSERT(not (null (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))))
- -- head (dataConInstOrigArgTys con (mkTyVarTys tvs))
- head (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))
+ inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
+ rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
-- Instantiate the data con with the
-- type variables from the tycon
- -- NB: a newtype DataCon has no existentials; hence the
- -- call to dataConInstOrigArgTys has the right type args
+ -- NB: a newtype DataCon has a type that must look like
+ -- forall tvs. <arg-ty> -> T tvs
+ -- Note that we *can't* use dataConInstOrigArgTys here because
+ -- the newtype arising from class Foo a => Bar a where {}
+ -- has a single argument (Foo a) that is a *type class*, so
+ -- dataConInstOrigArgTys returns [].
etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
etad_rhs :: Type -- return a TyCon without pulling on rhs_ty
-- the type variables mentioned in the arg_tys
-- ToDo: Or functionally dependent on?
-- This whole stupid theta thing is, well, stupid.
+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
mkDataConStupidTheta tycon arg_tys univ_tvs
| null stupid_theta = [] -- The common case
| otherwise = filter in_arg_tys stupid_theta
op_tys
rec_tycon
- ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc)
- [1..length (dataConDictTheta dict_con)]
+ ; let n_value_preds = count (not . isEqPred) sc_theta
+ all_value_preds = n_value_preds == length sc_theta
+ -- We only make selectors for the *value* superclasses,
+ -- not equality predicates
+
+ ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc)
+ [1..n_value_preds]
+ ; let sc_sel_ids = [mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names]
-- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
- -- can construct names for the selectors. Thus
+ -- can construct names for the selectors. Thus
-- class (C a, C b) => D a b where ...
-- gives superclass selectors
-- D_sc1, D_sc2
-- (We used to call them D_C, but now we can have two different
-- superclasses both called C!)
- ; let sc_sel_ids = [mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names]
-
- -- Use a newtype if the class constructor has exactly one field:
+ --
+
+ ; let use_newtype = (n_value_preds + length sig_stuff == 1) && all_value_preds
+ -- Use a newtype if the data constructor has
+ -- (a) exactly one value field
+ -- (b) no existential or equality-predicate fields
-- i.e. exactly one operation or superclass taken together
- -- Watch out: the sc_theta includes equality predicates,
- -- which don't count for this purpose; hence dataConDictTheta
- ; rhs <- if ((length $ dataConDictTheta dict_con) + length sig_stuff) == 1
+ -- See note [Class newtypes and equality predicates]
+
+ ; rhs <- if use_newtype
then mkNewTyConRhs tycon_name rec_tycon dict_con
else return (mkDataTyConRhs [dict_con])
})}
\end{code}
+Note [Class newtypes and equality predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ class (a ~ F b) => C a b where
+ op :: a -> b
+
+We cannot represent this by a newtype, even though it's not
+existential, and there's only one value field, because we do
+capture an equality predicate:
+
+ data C a b where
+ MkC :: forall a b. (a ~ F b) => (a->b) -> C a b
+
+We need to access this equality predicate when we get passes a C
+dictionary. See Trac #2238