#include "HsVersions.h"
import HsSyn
-import HsTypes
import HscTypes
import BuildTyCl
import TcUnify
import Var
import VarSet
import Name
-import OccName
import Outputable
import Maybes
-import Monad
import Unify
import Util
import SrcLoc
import BasicTypes
import Bag
+import Control.Monad
import Data.List
-import Control.Monad ( mplus )
\end{code}
= -- 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)
; 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
; 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))
}}
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
-> 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}
; 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
<+> brackets (ppr k_tvs))
; (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 _)
+ 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
; 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) }
+ ; 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]
-> 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
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
+ 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!
-- 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 | length cons_w_field == length all_cons = []
+ deflt | not (any is_unused all_cons) = []
| otherwise = [mkSimpleMatch [nlWildPat]
(nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
(nlHsLit msg_lit))]
- unit_rhs = L loc $ ExplicitTuple [] Boxed
+ -- 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)
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.
+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
-We make a dummy binding
+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
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") <+>
projects / ghc-hetmet.git / blobdiff