Commit 1c17d00f authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Further refactoring to the tuple-typechecking patch

parent 96e6eddc
...@@ -417,33 +417,42 @@ tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind ...@@ -417,33 +417,42 @@ tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind
-- See Note [Distinguishing tuple kinds] in HsTypes -- See Note [Distinguishing tuple kinds] in HsTypes
-- See Note [Inferring tuple kinds] -- See Note [Inferring tuple kinds]
tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt) tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind@(EK exp_k _ctxt)
-- (NB: not zonking before looking at exp_k, to avoid left-right bias) -- (NB: not zonking before looking at exp_k, to avoid left-right bias)
| Just tup_sort <- tupKindSort_maybe exp_k | Just tup_sort <- tupKindSort_maybe exp_k
= tc_tuple hs_ty tup_sort tys exp_kind = tc_tuple hs_ty tup_sort hs_tys exp_kind
| otherwise | otherwise
= do { (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type tys = do { (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys
; kinds <- mapM zonkTcKind kinds ; kinds <- mapM zonkTcKind kinds
-- Infer each arg type separately, because errors can be
-- confusing if we give them a shared kind. Eg Trac #7410
-- (Either Int, Int), we do not want to get an error saying
-- "the second argument of a tuple should have kind *->*"
; let (arg_kind, tup_sort) ; let (arg_kind, tup_sort)
= case [ (k,s) | k <- kinds = case [ (k,s) | k <- kinds
, Just s <- [tupKindSort_maybe k] ] of , Just s <- [tupKindSort_maybe k] ] of
((k,s) : _) -> (k,s) ((k,s) : _) -> (k,s)
[] -> (liftedTypeKind, HsBoxedTuple) [] -> (liftedTypeKind, BoxedTuple)
-- In the [] case, it's not clear what the kind is, so guess * -- In the [] case, it's not clear what the kind is, so guess *
; sequence_ [ checkExpectedKind ty kind ; sequence_ [ setSrcSpan loc $
checkExpectedKind ty kind
(expArgKind (ptext (sLit "a tuple")) arg_kind n) (expArgKind (ptext (sLit "a tuple")) arg_kind n)
| (ty,kind,n) <- zip3 tys kinds [1..] ] | (ty@(L loc _),kind,n) <- zip3 hs_tys kinds [1..] ]
-- Do the experiment inside a 'tryTc' because errors can be
-- confusing. Eg Trac #7410 (Either Int, Int), we do not want to get
-- an error saying "the second argument of a tuple should have kind *->*"
; finish_tuple hs_ty tup_sort tys exp_kind } ; finish_tuple hs_ty tup_sort tys exp_kind }
tc_hs_type hs_ty@(HsTupleTy tup_sort tys) exp_kind tc_hs_type hs_ty@(HsTupleTy hs_tup_sort tys) exp_kind
= tc_tuple hs_ty tup_sort tys exp_kind = tc_tuple hs_ty tup_sort tys exp_kind
where
tup_sort = case hs_tup_sort of -- Fourth case dealt with above
HsUnboxedTuple -> UnboxedTuple
HsBoxedTuple -> BoxedTuple
HsConstraintTuple -> ConstraintTuple
_ -> panic "tc_hs_type HsTupleTy"
--------- Promoted lists and tuples --------- Promoted lists and tuples
tc_hs_type hs_ty@(HsExplicitListTy _k tys) exp_kind tc_hs_type hs_ty@(HsExplicitListTy _k tys) exp_kind
...@@ -518,47 +527,37 @@ tc_hs_type hs_ty@(HsTyLit (HsStrTy s)) exp_kind ...@@ -518,47 +527,37 @@ tc_hs_type hs_ty@(HsTyLit (HsStrTy s)) exp_kind
; return (mkStrLitTy s) } ; return (mkStrLitTy s) }
--------------------------- ---------------------------
tupKindSort_maybe :: TcKind -> Maybe HsTupleSort tupKindSort_maybe :: TcKind -> Maybe TupleSort
tupKindSort_maybe k tupKindSort_maybe k
| isConstraintKind k = Just HsConstraintTuple | isConstraintKind k = Just ConstraintTuple
| isLiftedTypeKind k = Just HsBoxedTuple | isLiftedTypeKind k = Just BoxedTuple
| otherwise = Nothing | otherwise = Nothing
tc_tuple :: HsType Name -> HsTupleSort -> [LHsType Name] -> ExpKind -> TcM TcType tc_tuple :: HsType Name -> TupleSort -> [LHsType Name] -> ExpKind -> TcM TcType
-- Invariant: tup_sort is not HsBoxedOrConstraintTuple
tc_tuple hs_ty tup_sort tys exp_kind tc_tuple hs_ty tup_sort tys exp_kind
= do { tau_tys <- tc_hs_arg_tys cxt_doc tys (repeat arg_kind) = do { tau_tys <- tc_hs_arg_tys cxt_doc tys (repeat arg_kind)
; finish_tuple hs_ty tup_sort tau_tys exp_kind } ; finish_tuple hs_ty tup_sort tau_tys exp_kind }
where where
arg_kind = case tup_sort of arg_kind = case tup_sort of
HsBoxedTuple -> liftedTypeKind BoxedTuple -> liftedTypeKind
HsUnboxedTuple -> openTypeKind UnboxedTuple -> openTypeKind
HsConstraintTuple -> constraintKind ConstraintTuple -> constraintKind
_ -> panic "tc_hs_type arg_kind"
cxt_doc = case tup_sort of cxt_doc = case tup_sort of
HsBoxedTuple -> ptext (sLit "a tuple") BoxedTuple -> ptext (sLit "a tuple")
HsUnboxedTuple -> ptext (sLit "an unboxed tuple") UnboxedTuple -> ptext (sLit "an unboxed tuple")
HsConstraintTuple -> ptext (sLit "a constraint tuple") ConstraintTuple -> ptext (sLit "a constraint tuple")
_ -> panic "tc_hs_type tup_sort"
finish_tuple :: HsType Name -> HsTupleSort -> [TcType] -> ExpKind -> TcM TcType finish_tuple :: HsType Name -> TupleSort -> [TcType] -> ExpKind -> TcM TcType
finish_tuple hs_ty tup_sort tau_tys exp_kind finish_tuple hs_ty tup_sort tau_tys exp_kind
= do { checkExpectedKind hs_ty res_kind exp_kind = do { checkExpectedKind hs_ty res_kind exp_kind
; checkWiredInTyCon tycon ; checkWiredInTyCon tycon
; return (mkTyConApp tycon tau_tys) } ; return (mkTyConApp tycon tau_tys) }
where where
tycon = tupleTyCon con (length tau_tys) tycon = tupleTyCon tup_sort (length tau_tys)
con = case tup_sort of
HsUnboxedTuple -> UnboxedTuple
HsBoxedTuple -> BoxedTuple
HsConstraintTuple -> ConstraintTuple
_ -> panic "tc_hs_type HsTupleTy"
res_kind = case tup_sort of res_kind = case tup_sort of
HsUnboxedTuple -> unliftedTypeKind UnboxedTuple -> unliftedTypeKind
HsBoxedTuple -> liftedTypeKind BoxedTuple -> liftedTypeKind
HsConstraintTuple -> constraintKind ConstraintTuple -> constraintKind
_ -> panic "tc_hs_type arg_kind"
--------------------------- ---------------------------
tcInferApps :: Outputable a tcInferApps :: Outputable a
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment