\begin{code}
module TcTyClsDecls (
- tcTyAndClassDecls, tcFamInstDecl
+ tcTyAndClassDecls, tcFamInstDecl, mkAuxBinds
) where
#include "HsVersions.h"
import HsSyn
-import HsTypes
-import BasicTypes
import HscTypes
import BuildTyCl
import TcUnify
import TcHsType
import TcMType
import TcType
-import FunDeps
+import TysWiredIn ( unitTy )
import Type
import Generics
import Class
import TyCon
import DataCon
import Id
+import MkId ( rEC_SEL_ERROR_ID )
+import IdInfo
import Var
import VarSet
import Name
-import OccName
import Outputable
import Maybes
-import Monad
import Unify
import Util
import SrcLoc
import Digraph
import DynFlags
import FastString
+import Unique ( mkBuiltinUnique )
+import BasicTypes
+import Bag
+import Control.Monad
import Data.List
-import Control.Monad ( mplus )
\end{code}
\begin{code}
tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
- -> TcM TcGblEnv -- Input env extended by types and classes
- -- and their implicit Ids,DataCons
+ -> TcM (TcGblEnv, -- Input env extended by types and classes
+ -- and their implicit Ids,DataCons
+ HsValBinds Name) -- Renamed bindings for record selectors
-- Fails if there are any errors
tcTyAndClassDecls boot_details allDecls
-- NB: All associated types and their implicit things will be added a
-- second time here. This doesn't matter as the definitions are
-- the same.
- ; let { implicit_things = concatMap implicitTyThings alg_tyclss }
+ ; let { implicit_things = concatMap implicitTyThings alg_tyclss
+ ; aux_binds = mkAuxBinds alg_tyclss }
; traceTc ((text "Adding" <+> ppr alg_tyclss)
$$ (text "and" <+> ppr implicit_things))
- ; tcExtendGlobalEnv implicit_things getGblEnv
- }}
+ ; env <- tcExtendGlobalEnv implicit_things getGblEnv
+ ; return (env, aux_binds) }
+ }
where
-- Pull associated types out of class declarations, to tie them into the
-- knot above.
%************************************************************************
%* *
-\subsection{Type checking family instances}
+ Type checking family instances
%* *
%************************************************************************
= -- Prime error recovery, set source location
setSrcSpan loc $
tcAddDeclCtxt decl $
- do { -- type families require -XTypeFamilies and can't be in an
- -- hs-boot file
+ do { -- type family instances require -XTypeFamilies
+ -- and can't (currently) be in an hs-boot file
; type_families <- doptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl (tcdLName decl)
tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
do { -- check that the family declaration is for a synonym
- unless (isSynTyCon family) $
- addErr (wrongKindOfFamily family)
+ checkTc (isOpenTyCon family) (notFamily family)
+ ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
; -- (1) kind check the right-hand side of the type equation
- ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
+ ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+ -- ToDo: the ExpKind could be better
-- we need the exact same number of type parameters as the family
-- declaration
; checkValidTypeInst t_typats t_rhs
-- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name loc
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
(typeKind t_rhs) (Just (family, t_typats))
}}
tcdCons = cons})
= kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
do { -- check that the family declaration is for the right kind
- unless (isAlgTyCon fam_tycon) $
- addErr (wrongKindOfFamily fam_tycon)
+ checkTc (isOpenTyCon fam_tycon) (notFamily fam_tycon)
+ ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
; -- (1) kind check the data declaration as usual
; k_decl <- kcDataDecl decl k_tvs
-- foralls earlier)
; mapM_ checkTyFamFreeness t_typats
+ -- Check that we don't use GADT syntax in H98 world
+ ; gadt_ok <- doptM Opt_GADTs
+ ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
+
-- (b) a newtype has exactly one constructor
; checkTc (new_or_data == DataType || isSingleton k_cons) $
newtypeConError tc_name (length k_cons)
-- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name loc
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; let ex_ok = True -- Existentials ok for type families!
; fixM (\ rep_tycon -> do
{ let orig_res_ty = mkTyConApp fam_tycon t_typats
-- * Here we check that a type instance matches its kind signature, but we do
-- not check whether there is a pattern for each type index; the latter
-- check is only required for type synonym instances.
---
+
kcIdxTyPats :: TyClDecl Name
-> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
-- ^^kinded tvs ^^kinded ty pats ^^res kind
-> TcM a
kcIdxTyPats decl thing_inside
= kcHsTyVars (tcdTyVars decl) $ \tvs ->
- do { fam_tycon <- tcLookupLocatedTyCon (tcdLName decl)
+ do { let tc_name = tcdLName decl
+ ; fam_tycon <- tcLookupLocatedTyCon tc_name
; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
; hs_typats = fromJust $ tcdTyPats decl }
-- type functions can have a higher-kinded result
; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
- ; typats <- zipWithM kcCheckHsType hs_typats kinds
+ ; typats <- zipWithM kcCheckLHsType hs_typats
+ [ EK kind (EkArg (ppr tc_name) n)
+ | (kind,n) <- kinds `zip` [1..]]
; thing_inside tvs typats resultKind fam_tycon
}
- where
\end{code}
; res_kind <- mk_res_kind decl
; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
where
- mk_arg_kind (UserTyVar _) = newKindVar
+ mk_arg_kind (UserTyVar _ _) = newKindVar
mk_arg_kind (KindedTyVar _ kind) = return kind
mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind
kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
<+> brackets (ppr k_tvs))
- ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl)
+ ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
- ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
+ ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
(unLoc (tcdLName decl), tc_kind)) })
= do { recSynErr decls; failM } -- Fail here to avoid error cascade
-- of out-of-scope tycons
-kindedTyVarKind :: LHsTyVarBndr Name -> Kind
-kindedTyVarKind (L _ (KindedTyVar _ k)) = k
-kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x)
-
------------------------------------------------------------------------
kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
-- Not used for type synonyms (see kcSynDecl)
= tcAddDeclCtxt decl $
do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
; let tc_kind = case tc_ty_thing of
- AThing k -> k
- _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
+ AThing k -> k
+ _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
(kinds, _) = splitKindFunTys tc_kind
hs_tvs = tcdTyVars decl
kinded_tvs = ASSERT( length kinds >= length hs_tvs )
- [ L loc (KindedTyVar (hsTyVarName tv) k)
- | (L loc tv, k) <- zip hs_tvs kinds]
- ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) }
+ zipWith add_kind hs_tvs kinds
+ ; tcExtendKindEnvTvs kinded_tvs thing_inside }
+ where
+ add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k)
+ add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
-- Kind check a data declaration, assuming that we already extended the
-- kind environment with the type variables of the left-hand side (these
; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
where
-- doc comments are typechecked to Nothing here
- kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) = do
- kcHsTyVars ex_tvs $ \ex_tvs' -> do
- ex_ctxt' <- kcHsContext ex_ctxt
- details' <- kc_con_details details
- res' <- case res of
- ResTyH98 -> return ResTyH98
- ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
- return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing)
+ kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
+ , con_cxt = ex_ctxt, con_details = details, con_res = res })
+ = addErrCtxt (dataConCtxt name) $
+ kcHsTyVars ex_tvs $ \ex_tvs' -> do
+ do { ex_ctxt' <- kcHsContext ex_ctxt
+ ; details' <- kc_con_details details
+ ; res' <- case res of
+ ResTyH98 -> return ResTyH98
+ ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
+ ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
+ , con_details = details', con_res = res' }) }
kc_con_details (PrefixCon btys)
= do { btys' <- mapM kc_larg_ty btys
-- default result kind is '*'
}
where
- unifyClassParmKinds (L _ (KindedTyVar n k))
- | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind
- | otherwise = return ()
- unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x)
- classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs]
+ unifyClassParmKinds (L _ tv)
+ | (n,k) <- hsTyVarNameKind tv
+ , Just classParmKind <- lookup n classTyKinds
+ = unifyKind k classParmKind
+ | otherwise = return ()
+ classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
+
kcFamilyDecl _ (TySynonym {}) -- type family defaults
= panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
; idx_tys <- doptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
- -- Check for no type indices
- ; checkTc (not (null tvs)) (noIndexTypes tc_name)
-
; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing
; return [ATyCon tycon]
}
; idx_tys <- doptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
- -- Check for no type indices
- ; checkTc (not (null tvs)) (noIndexTypes tc_name)
-
; tycon <- buildAlgTyCon tc_name final_tvs []
mkOpenDataTyConRhs Recursive False True Nothing
; return [ATyCon tycon]
}
where
is_rec = calc_isrec tc_name
- h98_syntax = case cons of -- All constructors have same shape
- L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
- _ -> True
+ h98_syntax = consUseH98Syntax cons
tcTyClDecl1 calc_isrec
(ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
-> TcM DataCon
tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
- (ConDecl name _ tvs ctxt details res_ty _)
+ (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt
+ , con_details = details, con_res = res_ty })
= addErrCtxt (dataConCtxt name) $
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
-- In this case orig_res_ty = T (e,e)
tcResultType :: ([TyVar], Type) -- Template for result type; e.g.
- -- data T a b c = ... gives ([a,b,c], T a b)
- -> [TyVar] -- where MkT :: forall a b c. ...
+ -- data instance T [a] b c = ...
+ -- gives template ([a,b,c], T [a] b c)
+ -> [TyVar] -- where MkT :: forall x y z. ...
-> ResType Name
-> TcM ([TyVar], -- Universal
[TyVar], -- Existential (distinct OccNames from univs)
-- b b~z
-- z
-- Existentials are the leftover type vars: [x,y]
+ -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)
= do { res_ty' <- tcHsKindedType res_ty
; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'
name = tyVarName tv
(env', occ') = tidyOccName env (getOccName name)
+consUseH98Syntax :: [LConDecl a] -> Bool
+consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
+consUseH98Syntax _ = True
+ -- All constructors have same shape
+
-------------------
tcConArg :: Bool -- True <=> -funbox-strict_fields
-> LHsType Name
- -> TcM (TcType, StrictnessMark)
+ -> TcM (TcType, HsBang)
tcConArg unbox_strict bty
= do { arg_ty <- tcHsBangType bty
; let bang = getBangStrictness bty
- ; return (arg_ty, chooseBoxingStrategy unbox_strict arg_ty bang) }
+ ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
+ ; return (arg_ty, strict_mark) }
-- We attempt to unbox/unpack a strict field when either:
-- (i) The field is marked '!!', or
--
-- We have turned off unboxing of newtypes because coercions make unboxing
-- and reboxing more complicated
-chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark
+chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
chooseBoxingStrategy unbox_strict_fields arg_ty bang
= case bang of
- HsNoBang -> NotMarkedStrict
- HsStrict | unbox_strict_fields
- && can_unbox arg_ty -> MarkedUnboxed
- HsUnbox | can_unbox arg_ty -> MarkedUnboxed
- _ -> MarkedStrict
+ HsNoBang -> HsNoBang
+ HsUnpack -> can_unbox HsUnpackFailed arg_ty
+ HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty
+ | otherwise -> HsStrict
+ HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
+ -- Source code never has shtes
where
- -- we can unbox if the type is a chain of newtypes with a product tycon
- -- at the end
- can_unbox arg_ty = case splitTyConApp_maybe arg_ty of
- Nothing -> False
- Just (arg_tycon, tycon_args) ->
- not (isRecursiveTyCon arg_tycon) && -- Note [Recusive unboxing]
- isProductTyCon arg_tycon &&
- (if isNewTyCon arg_tycon then
- can_unbox (newTyConInstRhs arg_tycon tycon_args)
- else True)
+ can_unbox :: HsBang -> TcType -> HsBang
+ -- Returns HsUnpack if we can unpack arg_ty
+ -- fail_bang if we know what arg_ty is but we can't unpack it
+ -- HsStrict if it's abstract, so we don't know whether or not we can unbox it
+ can_unbox fail_bang arg_ty
+ = case splitTyConApp_maybe arg_ty of
+ Nothing -> fail_bang
+
+ Just (arg_tycon, tycon_args)
+ | isAbstractTyCon arg_tycon -> HsStrict
+ -- See Note [Don't complain about UNPACK on abstract TyCons]
+ | not (isRecursiveTyCon arg_tycon) -- Note [Recusive unboxing]
+ , isProductTyCon arg_tycon
+ -- We can unbox if the type is a chain of newtypes
+ -- with a product tycon at the end
+ -> if isNewTyCon arg_tycon
+ then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
+ else HsUnpack
+
+ | otherwise -> fail_bang
\end{code}
+Note [Don't complain about UNPACK on abstract TyCons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are going to complain about UnpackFailed, but if we say
+ data T = MkT {-# UNPACK #-} !Wobble
+and Wobble is a newtype imported from a module that was compiled
+without optimisation, we don't want to complain. Because it might
+be fine when optimsation is on. I think this happens when Haddock
+is working over (say) GHC souce files.
+
Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
Be careful not to try to unbox this!
data S = MkS S !Int
because Int is non-recursive.
+
%************************************************************************
%* *
-\subsection{Dependency analysis}
+ Validity checking
%* *
%************************************************************************
checkValidDataCon tc con
= setSrcSpan (srcLocSpan (getSrcLoc con)) $
addErrCtxt (dataConCtxt con) $
- do { let tc_tvs = tyConTyVars tc
+ do { traceTc (ptext (sLit "Validity of data con") <+> ppr con)
+ ; let tc_tvs = tyConTyVars tc
res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
actual_res_ty = dataConOrigResTy con
; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
-- Reason: it's really the argument of an equality constraint
; checkValidType ctxt (dataConUserType con)
; when (isNewTyCon tc) (checkNewDataCon con)
+ ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
}
where
ctxt = ConArgCtxt (dataConName con)
+ check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
+ check_bang _ = return ()
+
+ cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
+ , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
-------------------------------
checkNewDataCon :: DataCon -> TcM ()
-- Return type is (T a b c)
; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
-- No existentials
- ; checkTc (not (any isMarkedStrict (dataConStrictMarks con)))
+ ; checkTc (not (any isBanged (dataConStrictMarks con)))
(newtypeStrictError con)
-- No strictness
}
-- class Error e => Game b mv e | b -> mv e where
-- newBoard :: MonadState b m => m ()
-- Here, MonadState has a fundep m->b, so newBoard is fine
- ; let grown_tyvars = grow theta (mkVarSet tyvars)
+ ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
(noClassTyVarErr cls sel_id)
-- forall has an (Eq a) constraint. Whereas in general, each constraint
-- in the context of a for-all must mention at least one quantified
-- type variable. What a mess!
+\end{code}
----------------------------------------------------------------------
+%************************************************************************
+%* *
+ Building record selectors
+%* *
+%************************************************************************
+
+\begin{code}
+mkAuxBinds :: [TyThing] -> HsValBinds Name
+-- NB We produce *un-typechecked* bindings, rather like 'deriving'
+-- This makes life easier, because the later type checking will add
+-- all necessary type abstractions and applications
+mkAuxBinds ty_things
+ = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
+ where
+ (sigs, binds) = unzip rec_sels
+ rec_sels = map mkRecSelBind [ (tc,fld)
+ | ATyCon tc <- ty_things
+ , fld <- tyConFields tc ]
+
+mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
+mkRecSelBind (tycon, sel_name)
+ = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
+ where
+ loc = getSrcSpan tycon
+ sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
+ rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
+
+ -- Find a representative constructor, con1
+ all_cons = tyConDataCons tycon
+ cons_w_field = [ con | con <- all_cons
+ , sel_name `elem` dataConFieldLabels con ]
+ con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
+
+ -- Selector type; Note [Polymorphic selectors]
+ field_ty = dataConFieldType con1 sel_name
+ data_ty = dataConOrigResTy con1
+ data_tvs = tyVarsOfType data_ty
+ is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
+ (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
+ sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
+ | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
+ mkPhiTy (dataConStupidTheta con1) $ -- Urgh!
+ mkPhiTy field_theta $ -- Urgh!
+ mkFunTy data_ty field_tau
+
+ -- Make the binding: sel (C2 { fld = x }) = x
+ -- sel (C7 { fld = x }) = x
+ -- where cons_w_field = [C2,C7]
+ sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
+ | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
+ mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
+ (L loc (HsVar field_var))
+ mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
+ rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
+ rec_field = HsRecField { hsRecFieldId = sel_lname
+ , hsRecFieldArg = nlVarPat field_var
+ , hsRecPun = False }
+ sel_lname = L loc sel_name
+ field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
+
+ -- Add catch-all default case unless the case is exhaustive
+ -- We do this explicitly so that we get a nice error message that
+ -- mentions this particular record selector
+ deflt | not (any is_unused all_cons) = []
+ | otherwise = [mkSimpleMatch [nlWildPat]
+ (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
+ (nlHsLit msg_lit))]
+
+ -- Do not add a default case unless there are unmatched
+ -- constructors. We must take account of GADTs, else we
+ -- get overlap warning messages from the pattern-match checker
+ is_unused con = not (con `elem` cons_w_field
+ || dataConCannotMatch inst_tys con)
+ inst_tys = tyConAppArgs data_ty
+
+ unit_rhs = mkLHsTupleExpr []
+ msg_lit = HsStringPrim $ mkFastString $
+ occNameString (getOccName sel_name)
+
+---------------
+tyConFields :: TyCon -> [FieldLabel]
+tyConFields tc
+ | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
+ | otherwise = []
+\end{code}
+
+Note [Polymorphic selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When a record has a polymorphic field, we pull the foralls out to the front.
+ data T = MkT { f :: forall a. [a] -> a }
+Then f :: forall a. T -> [a] -> a
+NOT f :: T -> forall a. [a] -> a
+
+This is horrid. It's only needed in deeply obscure cases, which I hate.
+The only case I know is test tc163, which is worth looking at. It's far
+from clear that this test should succeed at all!
+
+Note [Naughty record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "naughty" field is one for which we can't define a record
+selector, because an existential type variable would escape. For example:
+ data T = forall a. MkT { x,y::a }
+We obviously can't define
+ x (MkT v _) = v
+Nevertheless we *do* put a RecSelId into the type environment
+so that if the user tries to use 'x' as a selector we can bleat
+helpfully, rather than saying unhelpfully that 'x' is not in scope.
+Hence the sel_naughty flag, to identify record selectors that don't really exist.
+
+In general, a field is "naughty" if its type mentions a type variable that
+isn't in the result type of the constructor. Note that this *allows*
+GADT record selectors (Note [GADT record selectors]) whose types may look
+like sel :: T [a] -> a
+
+For naughty selectors we make a dummy binding
+ sel = ()
+for naughty selectors, so that the later type-check will add them to the
+environment, and they'll be exported. The function is never called, because
+the tyepchecker spots the sel_naughty field.
+
+Note [GADT record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For GADTs, we require that all constructors with a common field 'f' have the same
+result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
+E.g.
+ data T where
+ T1 { f :: Maybe a } :: T [a]
+ T2 { f :: Maybe a, y :: b } :: T [a]
+
+and now the selector takes that result type as its argument:
+ f :: forall a. T [a] -> Maybe a
+
+Details: the "real" types of T1,T2 are:
+ T1 :: forall r a. (r~[a]) => a -> T r
+ T2 :: forall r a b. (r~[a]) => a -> b -> T r
+
+So the selector loooks like this:
+ f :: forall a. T [a] -> Maybe a
+ f (a:*) (t:T [a])
+ = case t of
+ T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g))
+ T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
+
+Note the forall'd tyvars of the selector are just the free tyvars
+of the result type; there may be other tyvars in the constructor's
+type (e.g. 'b' in T2).
+
+Note the need for casts in the result!
+
+Note [Selector running example]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's OK to combine GADTs and type families. Here's a running example:
+
+ data instance T [a] where
+ T1 { fld :: b } :: T [Maybe b]
+
+The representation type looks like this
+ data :R7T a where
+ T1 { fld :: b } :: :R7T (Maybe b)
+
+and there's coercion from the family type to the representation type
+ :CoR7T a :: T [a] ~ :R7T a
+
+The selector we want for fld looks like this:
+
+ fld :: forall b. T [Maybe b] -> b
+ fld = /\b. \(d::T [Maybe b]).
+ case d `cast` :CoR7T (Maybe b) of
+ T1 (x::b) -> x
+
+The scrutinee of the case has type :R7T (Maybe b), which can be
+gotten by appying the eq_spec to the univ_tvs of the data con.
+
+%************************************************************************
+%* *
+ Error messages
+%* *
+%************************************************************************
+
+\begin{code}
resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
resultTypeMisMatch field_name con1 con2
= vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
-noIndexTypes :: Name -> SDoc
-noIndexTypes tc_name
- = ptext (sLit "Type family constructor") <+> quotes (ppr tc_name)
- <+> ptext (sLit "must have at least one type index parameter")
-
badFamInstDecl :: Outputable a => a -> SDoc
badFamInstDecl tc_name
= vcat [ ptext (sLit "Illegal family instance for") <+>
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
-{-
-badGadtIdxTyDecl :: Name -> SDoc
-badGadtIdxTyDecl tc_name
- = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+>
- quotes (ppr tc_name)
- , nest 2 (parens $ ptext (sLit "Family instances can not yet use GADT declarations")) ]
--}
tooManyParmsErr :: Located Name -> SDoc
tooManyParmsErr tc_name
= ptext (sLit "Family instance has too many parameters:") <+>
<+> ppr exp_arity
badBootFamInstDeclErr :: SDoc
-badBootFamInstDeclErr =
- ptext (sLit "Illegal family instance in hs-boot file")
-
+badBootFamInstDeclErr
+ = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+ = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+ , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+
wrongKindOfFamily :: TyCon -> SDoc
-wrongKindOfFamily family =
- ptext (sLit "Wrong category of family instance; declaration was for a") <+>
- kindOfFamily
+wrongKindOfFamily family
+ = ptext (sLit "Wrong category of family instance; declaration was for a")
+ <+> kindOfFamily
where
kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
| isAlgTyCon family = ptext (sLit "data type")
projects / ghc-hetmet.git / blobdiff