import TcMType
import TcType
import TysWiredIn ( unitTy )
-import FunDeps
import Type
import Generics
import Class
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 <- kcCheckLHsType (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
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)
-> 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 kcCheckLHsType 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}
}
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,
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
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)
-- 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)
\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
| 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
+ 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
+ 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
- (field_tvs, field_theta, field_tau)
- | is_naughty = ([], [], unitTy)
- | otherwise = tcSplitSigmaTy field_ty
+ field_ty = dataConFieldType con1 sel_name
data_ty = dataConOrigResTy con1
data_tvs = tyVarsOfType data_ty
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
- sel_ty = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
- mkPhiTy (dataConStupidTheta con1) $ -- Urgh!
- mkPhiTy field_theta $ -- Urgh!
- mkFunTy data_ty field_tau
+ (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
+ sel_ty | is_naughty = unitTy
+ | 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 = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
+ 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 match_body)
+ (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 }
- match_body | is_naughty = ExplicitTuple [] Boxed
- | otherwise = HsVar field_var
sel_lname = L loc sel_name
field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
| otherwise = [mkSimpleMatch [nlWildPat]
(nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
(nlHsLit msg_lit))]
+
+ unit_rhs = L loc $ ExplicitTuple [] Boxed
msg_lit = HsStringPrim $ mkFastString $
occNameString (getOccName sel_name)
In general, a field is naughty if its type mentions a type variable that
isn't in the result type of the constructor.
-We make a dummy binding for naughty selectors, so that they can be treated
-uniformly, apart from their sel_naughty field. The function is never called.
+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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
<+> 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