#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
; return (NewTyCon { data_con = con,
nt_rhs = rhs_ty,
nt_etad_rhs = (etad_tvs, etad_rhs),
- nt_co = cocon_maybe,
+ nt_co = cocon_maybe } ) }
-- Coreview looks through newtypes with a Nothing
-- for nt_co, or uses explicit coercions otherwise
- nt_rep = mkNewTyConRep tycon rhs_ty }) }
where
-- If all_coercions is True then we use coercions for all newtypes
-- otherwise we use coercions for recursive newtypes and look through
eta_reduce tvs ty = (reverse tvs, ty)
-mkNewTyConRep :: TyCon -- The original type constructor
- -> Type -- The arg type of its constructor
- -> Type -- Chosen representation type
--- The "representation type" is guaranteed not to be another newtype
--- at the outermost level; but it might have newtypes in type arguments
-
--- Find the representation type for this newtype TyCon
--- Remember that the representation type is the *ultimate* representation
--- type, looking through other newtypes.
---
--- splitTyConApp_maybe no longer looks through newtypes, so we must
--- deal explicitly with this case
---
--- The trick is to to deal correctly with recursive newtypes
--- such as newtype T = MkT T
-
-mkNewTyConRep tc rhs_ty
- | null (tyConDataCons tc) = unitTy
- -- External Core programs can have newtypes with no data constructors
- | otherwise = go [tc] rhs_ty
- where
- -- Invariant: tcs have been seen before
- go tcs rep_ty
- = case splitTyConApp_maybe rep_ty of
- Just (tc, tys)
- | tc `elem` tcs -> unitTy -- Recursive loop
- | isNewTyCon tc ->
- if isRecursiveTyCon tc then
- go (tc:tcs) (substTyWith tvs tys rhs_ty)
- else
- substTyWith tvs tys rhs_ty
- where
- (tvs, rhs_ty) = newTyConRhs tc
-
- other -> rep_ty
-
------------------------------------------------------
buildDataCon :: Name -> Bool
-> [StrictnessMark]
stupid_ctxt dc_ids
dc_ids = mkDataConIds wrap_name work_name data_con
- ; returnM data_con }
+ ; return data_con }
-- The stupid context for a data constructor should be limited to
-- 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
------------------------------------------------------
\begin{code}
-buildClass :: Name -> [TyVar] -> ThetaType
+buildClass :: Bool -- True <=> do not include unfoldings
+ -- on dict selectors
+ -- Used when importing a class without -O
+ -> Name -> [TyVar] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
-> [TyThing] -- Associated types
-> [(Name, DefMeth, Type)] -- Method info
-> RecFlag -- Info for type constructor
-> TcRnIf m n Class
-buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
+buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
= do { traceIf (text "buildClass")
; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
let { rec_tycon = classTyCon rec_clas
; op_tys = [ty | (_,_,ty) <- sig_stuff]
- ; op_items = [ (mkDictSelId op_name rec_clas, dm_info)
+ ; op_items = [ (mkDictSelId no_unf op_name rec_clas, dm_info)
| (op_name, dm_info, _) <- sig_stuff ] }
-- Build the selector id and default method id
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 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
projects / ghc-hetmet.git / blobdiff