TcPat: Typechecking patterns
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
addDataConStupidTheta, badFieldCon, polyPatSig ) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcSyntaxOp )
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho)
import HsSyn
import TcHsSyn
import TysWiredIn
import TcGadt
import Type
+import Coercion
import StaticFlags
import TyCon
import DataCon
+import DynFlags
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import SrcLoc
\begin{code}
tcLetPat :: (Name -> Maybe TcRhoType)
-> LPat Name -> BoxySigmaType
- -> TcM a
+ -> TcM a
-> TcM (LPat TcId, a)
tcLetPat sig_fn pat pat_ty thing_inside
= do { let init_state = PS { pat_ctxt = LetPat sig_fn,
- pat_reft = emptyRefinement }
+ pat_reft = emptyRefinement,
+ pat_eqs = False }
; (pat', ex_tvs, res) <- tc_lpat pat pat_ty init_state (\ _ -> thing_inside)
-- Don't know how to deal with pattern-bound existentials yet
-> ((Refinement,BoxyRhoType) -> TcM a) -- Checker for body, given its result type
-> TcM ([LPat TcId], a)
tc_lam_pats pat_ty_prs (reft, res_ty) thing_inside
- = do { let init_state = PS { pat_ctxt = LamPat, pat_reft = reft }
+ = do { let init_state = PS { pat_ctxt = LamPat, pat_reft = reft, pat_eqs = False }
; (pats', ex_tvs, res) <- tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
- refineEnvironment (pat_reft pstate') $
- thing_inside (pat_reft pstate', res_ty)
+ refineEnvironment (pat_reft pstate') (pat_eqs pstate') $
+ if (pat_eqs pstate' && (not $ isRigidTy res_ty))
+ then failWithTc (nonRigidResult res_ty)
+ else thing_inside (pat_reft pstate', res_ty)
; let tys = map snd pat_ty_prs
; tcCheckExistentialPat pats' ex_tvs tys res_ty
= return () -- Short cut for case when there are no existentials
tcCheckExistentialPat pats ex_tvs pat_tys body_ty
- = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys body_ty) $
+ = addErrCtxtM (sigPatCtxt pats ex_tvs pat_tys body_ty) $
checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
data PatState = PS {
pat_ctxt :: PatCtxt,
- pat_reft :: Refinement -- Binds rigid TcTyVars to their refinements
+ pat_reft :: Refinement, -- Binds rigid TcTyVars to their refinements
+ pat_eqs :: Bool -- <=> there are GADT equational constraints
+ -- for refinement
}
data PatCtxt
-------------------
unBoxPatBndrType ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name))
unBoxWildCardType ty = unBoxArgType ty (ptext SLIT("A wild-card pattern"))
+unBoxViewPatType ty pat = unBoxArgType ty (ptext SLIT("The view pattern") <+> ppr pat)
unBoxArgType :: BoxyType -> SDoc -> TcM TcType
-- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind;
Note [Nesting]
~~~~~~~~~~~~~~
-tcPat takes a "thing inside" over which the patter scopes. This is partly
+tcPat takes a "thing inside" over which the pattern scopes. This is partly
so that tcPat can extend the environment for the thing_inside, but also
so that constraints arising in the thing_inside can be discharged by the
pattern.
tc_lpat (L span pat) pat_ty pstate thing_inside
= setSrcSpan span $
maybeAddErrCtxt (patCtxt pat) $
- do { let (coercion, pat_ty') = refineType (pat_reft pstate) pat_ty
+ do { let mb_reft = refineType (pat_reft pstate) pat_ty
+ pat_ty' = case mb_reft of { Just (_, ty') -> ty'; Nothing -> pat_ty }
+
-- Make sure the result type reflects the current refinement
-- We must do this here, so that it correctly ``sees'' all
-- the refinements to the left. Example:
-- pattern had better see it.
; (pat', tvs, res) <- tc_pat pstate pat pat_ty' thing_inside
- ; return (mkCoPat coercion (L span pat') pat_ty, tvs, res) }
+ ; let final_pat = case mb_reft of
+ Nothing -> pat'
+ Just (co,_) -> CoPat (WpCo co) pat' pat_ty
+ ; return (L span final_pat, tvs, res) }
--------------------
tc_pat :: PatState
- -> Pat Name -> BoxySigmaType -- Fully refined result type
- -> (PatState -> TcM a) -- Thing inside
- -> TcM (Pat TcId, -- Translated pattern
- [TcTyVar], -- Existential binders
- a) -- Result of thing inside
+ -> Pat Name
+ -> BoxySigmaType -- Fully refined result type
+ -> (PatState -> TcM a) -- Thing inside
+ -> TcM (Pat TcId, -- Translated pattern
+ [TcTyVar], -- Existential binders
+ a) -- Result of thing inside
tc_pat pstate (VarPat name) pat_ty thing_inside
= do { id <- tcPatBndr pstate name pat_ty
--
-- Nor should a lazy pattern bind any existential type variables
-- because they won't be in scope when we do the desugaring
+--
+-- Note [Hopping the LIE in lazy patterns]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In a lazy pattern, we must *not* discharge constraints from the RHS
+-- from dictionaries bound in the pattern. E.g.
+-- f ~(C x) = 3
+-- We can't discharge the Num constraint from dictionaries bound by
+-- the pattern C!
+--
+-- So we have to make the constraints from thing_inside "hop around"
+-- the pattern. Hence the getLLE and extendLIEs later.
+
tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
- = do { (pat', pat_tvs, res) <- tc_lpat pat pat_ty pstate $ \ _ ->
- thing_inside pstate
- -- Ignore refined pstate',
- -- revert to pstate
+ = do { (pat', pat_tvs, (res,lie))
+ <- tc_lpat pat pat_ty pstate $ \ _ ->
+ getLIE (thing_inside pstate)
+ -- Ignore refined pstate', revert to pstate
+ ; extendLIEs lie
+ -- getLIE/extendLIEs: see Note [Hopping the LIE in lazy patterns]
+
-- Check no existentials
; if (null pat_tvs) then return ()
else lazyPatErr lpat pat_tvs
-- If you fix it, don't forget the bindInstsOfPatIds!
; return (AsPat (L nm_loc bndr_id) pat', tvs, res) }
+tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside
+ = do { -- morally, expr must have type
+ -- `forall a1...aN. OPT' -> B`
+ -- where overall_pat_ty is an instance of OPT'.
+ -- Here, we infer a rho type for it,
+ -- which replaces the leading foralls and constraints
+ -- with fresh unification variables.
+ (expr',expr'_inferred) <- tcInferRho expr
+ -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty`
+ ; let expr'_expected = \ pat_ty -> (mkFunTy overall_pat_ty pat_ty)
+ -- tcSubExp: expected first, offered second
+ -- returns coercion
+ --
+ -- NOTE: this forces pat_ty to be a monotype (because we use a unification
+ -- variable to find it). this means that in an example like
+ -- (view -> f) where view :: _ -> forall b. b
+ -- we will only be able to use view at one instantation in the
+ -- rest of the view
+ ; (expr_coerc, pat_ty) <- tcInfer (\ pat_ty -> tcSubExp (expr'_expected pat_ty) expr'_inferred)
+ -- pattern must have pat_ty
+ ; (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
+ -- this should get zonked later on, but we unBox it here
+ -- so that we do the same checks as above
+ ; annotation_ty <- unBoxViewPatType overall_pat_ty orig
+ ; return (ViewPat (mkLHsWrap expr_coerc expr') pat' annotation_ty, tvs, res) }
+
-- Type signatures in patterns
-- See Note [Pattern coercions] below
tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
------------------------
-- Lists, tuples, arrays
tc_pat pstate (ListPat pats _) pat_ty thing_inside
- = do { elt_ty <- boxySplitListTy pat_ty
+ = do { (elt_ty, coi) <- boxySplitListTy pat_ty
; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
pats pstate thing_inside
- ; return (ListPat pats' elt_ty, pats_tvs, res) }
+ ; return (mkCoPatCoI coi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) }
tc_pat pstate (PArrPat pats _) pat_ty thing_inside
- = do { [elt_ty] <- boxySplitTyConApp parrTyCon pat_ty
+ = do { (elt_ty, coi) <- boxySplitPArrTy pat_ty
; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
pats pstate thing_inside
- ; ifM (null pats) (zapToMonotype pat_ty) -- c.f. ExplicitPArr in TcExpr
- ; return (PArrPat pats' elt_ty, pats_tvs, res) }
+ ; ifM (null pats) (zapToMonotype pat_ty) -- c.f. ExplicitPArr in TcExpr
+ ; return (mkCoPatCoI coi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res) }
tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
- = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length pats)) pat_ty
+ = do { let tc = tupleTyCon boxity (length pats)
+ ; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty
; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys)
pstate thing_inside
-- so that we can experiment with lazy tuple-matching.
-- This is a pretty odd place to make the switch, but
-- it was easy to do.
- ; let unmangled_result = TuplePat pats' boxity pat_ty
+ ; let pat_ty' = mkTyConApp tc arg_tys
+ -- pat_ty /= pat_ty iff coi /= IdCo
+ unmangled_result = TuplePat pats' boxity pat_ty'
possibly_mangled_result
- | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
- | otherwise = unmangled_result
+ | opt_IrrefutableTuples &&
+ isBoxed boxity = LazyPat (noLoc unmangled_result)
+ | otherwise = unmangled_result
- ; ASSERT( length arg_tys == length pats ) -- Syntactically enforced
- return (possibly_mangled_result, pats_tvs, res) }
+ ; ASSERT( length arg_tys == length pats ) -- Syntactically enforced
+ return (mkCoPatCoI coi possibly_mangled_result pat_ty, pats_tvs, res)
+ }
------------------------
-- Data constructors
------------------------
-- Literal patterns
tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
- = do { boxyUnify (hsLitType simple_lit) pat_ty
+ = do { let lit_ty = hsLitType simple_lit
+ ; coi <- boxyUnify lit_ty pat_ty
+ -- coi is of kind: lit_ty ~ pat_ty
; res <- thing_inside pstate
- ; returnM (LitPat simple_lit, [], res) }
+ ; span <- getSrcSpanM
+ -- pattern coercions have to
+ -- be of kind: pat_ty ~ lit_ty
+ -- hence, sym coi
+ ; returnM (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty,
+ [], res) }
------------------------
-- Overloaded patterns: n, and n+k
-tc_pat pstate pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside
+tc_pat pstate pat@(NPat over_lit mb_neg eq) pat_ty thing_inside
= do { let orig = LiteralOrigin over_lit
; lit' <- tcOverloadedLit orig over_lit pat_ty
; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
; return (Just neg') }
; res <- thing_inside pstate
- ; returnM (NPat lit' mb_neg' eq' pat_ty, [], res) }
+ ; returnM (NPat lit' mb_neg' eq', [], res) }
tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
= do { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
-tc_pat _ _other_pat _ _ = panic "tc_pat" -- DictPat, ConPatOut, SigPatOut, VarPatOut
+tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut, VarPatOut
\end{code}
tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon
-> BoxySigmaType -- Type of the pattern
- -> HsConDetails Name (LPat Name) -> (PatState -> TcM a)
+ -> HsConPatDetails Name -> (PatState -> TcM a)
-> TcM (Pat TcId, [TcTyVar], a)
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
- = do { span <- getSrcSpanM -- Span for the whole pattern
- ; let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
- skol_info = PatSkol data_con span
- origin = SigOrigin skol_info
+ = do { let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) = dataConFullSig data_con
+ skol_info = PatSkol data_con
+ origin = SigOrigin skol_info
+ full_theta = eq_theta ++ dict_theta
-- Instantiate the constructor type variables [a->ty]
- ; ctxt_res_tys <- boxySplitTyConAppWithFamily tycon pat_ty
- ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
- ; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
- (ctxt_res_tys ++ mkTyVarTys ex_tvs')
- eq_spec' = substEqSpec tenv eq_spec
- theta' = substTheta tenv theta
- arg_tys' = substTys tenv arg_tys
+ -- This may involve doing a family-instance coercion, and building a wrapper
+ ; (ctxt_res_tys, coi) <- boxySplitTyConAppWithFamily tycon pat_ty
+ ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
+ -- pat_ty /= pat_ty iff coi /= IdCo
+ wrap_res_pat res_pat
+ = mkCoPatCoI coi (unwrapFamInstScrutinee tycon ctxt_res_tys res_pat) pat_ty
+
+ -- Add the stupid theta
+ ; addDataConStupidTheta data_con ctxt_res_tys
+ ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad,
+ -- not from ex_tvs
+ ; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
+ (ctxt_res_tys ++ mkTyVarTys ex_tvs')
+ arg_tys' = substTys tenv arg_tys
+
+ ; if null ex_tvs && null eq_spec && null full_theta
+ then do { -- The common case; no class bindings etc (see Note [Arrows and patterns])
+ (arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys'
+ arg_pats pstate thing_inside
+ ; let res_pat = ConPatOut { pat_con = L con_span data_con,
+ pat_tvs = [], pat_dicts = [], pat_binds = emptyLHsBinds,
+ pat_args = arg_pats', pat_ty = pat_ty' }
+
+ ; return (wrap_res_pat res_pat, inner_tvs, res) }
+
+ else do -- The general case, with existential, and local equality constraints
+ { let eq_spec' = substEqSpec tenv eq_spec
+ theta' = substTheta tenv full_theta
; co_vars <- newCoVars eq_spec' -- Make coercion variables
+ ; traceTc (text "tcConPat: refineAlt")
; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty
-
+ ; traceTc (text "tcConPat: refineAlt done!")
+
; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
; loc <- getInstLoc origin
; dicts <- newDictBndrs loc theta'
- ; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req
-
- ; addDataConStupidTheta data_con ctxt_res_tys
-
- ; return
- (unwrapFamInstScrutinee tycon ctxt_res_tys $
- ConPatOut { pat_con = L con_span data_con,
- pat_tvs = ex_tvs' ++ co_vars,
- pat_dicts = map instToId dicts,
- pat_binds = dict_binds,
- pat_args = arg_pats', pat_ty = pat_ty },
- ex_tvs' ++ inner_tvs, res)
- }
+ ; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate')
+ ex_tvs' dicts lie_req
+
+ ; let res_pat = ConPatOut { pat_con = L con_span data_con,
+ pat_tvs = ex_tvs' ++ co_vars,
+ pat_dicts = map instToVar dicts,
+ pat_binds = dict_binds,
+ pat_args = arg_pats', pat_ty = pat_ty' }
+ ; return (wrap_res_pat res_pat, ex_tvs' ++ inner_tvs, res)
+ } }
where
- doc = ptext SLIT("existential context for") <+> quotes (ppr data_con)
-
- -- Split against the family tycon if the pattern constructor belongs to a
- -- representation tycon.
- --
+ -- Split against the family tycon if the pattern constructor
+ -- belongs to a family instance tycon.
boxySplitTyConAppWithFamily tycon pat_ty =
traceTc traceMsg >>
case tyConFamInst_maybe tycon of
Nothing -> boxySplitTyConApp tycon pat_ty
Just (fam_tycon, instTys) ->
- do { scrutinee_arg_tys <- boxySplitTyConApp fam_tycon pat_ty
+ do { (scrutinee_arg_tys, coi) <- boxySplitTyConApp fam_tycon pat_ty
; (_, freshTvs, subst) <- tcInstTyVars (tyConTyVars tycon)
; boxyUnifyList (substTys subst instTys) scrutinee_arg_tys
- ; return freshTvs
+ ; return (freshTvs, coi)
}
where
traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+>
tcConArgs :: DataCon -> [TcSigmaType]
- -> Checker (HsConDetails Name (LPat Name))
- (HsConDetails Id (LPat Id))
+ -> Checker (HsConPatDetails Name) (HsConPatDetails Id)
tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside
= do { checkTc (con_arity == no_of_args) -- Check correct arity
tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside
= pprPanic "tcConArgs" (ppr data_con) -- InfixCon always has two arguments
-tcConArgs data_con arg_tys (RecCon rpats) pstate thing_inside
+tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
= do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
- ; return (RecCon rpats', tvs, res) }
+ ; return (RecCon (HsRecFields rpats' dd), tvs, res) }
where
- -- doc comments are typechecked to Nothing here
tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
- tc_field (HsRecField field_lbl pat _) pstate thing_inside
+ tc_field (HsRecField field_lbl pat pun) pstate thing_inside
= do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
- ; return (mkRecField sel_id pat', tvs, res) }
+ ; return (HsRecField sel_id pat' pun, tvs, res) }
find_field_ty :: FieldLabel -> TcM (Id, TcType)
find_field_ty field_lbl
inst_theta = substTheta tenv stupid_theta
\end{code}
+Note [Arrows and patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+(Oct 07) Arrow noation has the odd property that it involves "holes in the scope".
+For example:
+ expr :: Arrow a => a () Int
+ expr = proc (y,z) -> do
+ x <- term -< y
+ expr' -< x
+
+Here the 'proc (y,z)' binding scopes over the arrow tails but not the
+arrow body (e.g 'term'). As things stand (bogusly) all the
+constraints from the proc body are gathered together, so constraints
+from 'term' will be seen by the tcPat for (y,z). But we must *not*
+bind constraints from 'term' here, becuase the desugarer will not make
+these bindings scope over 'term'.
+
+The Right Thing is not to confuse these constraints together. But for
+now the Easy Thing is to ensure that we do not have existential or
+GADT constraints in a 'proc', and to short-cut the constraint
+simplification for such vanilla patterns so that it binds no
+constraints. Hence the 'fast path' in tcConPat; but it's also a good
+plan for ordinary vanilla patterns to bypass the constraint
+simplification step.
+
%************************************************************************
%* *
-> TcM PatState
refineAlt con pstate ex_tvs [] pat_ty
+ | null $ dataConEqTheta con
= return pstate -- Common case: no equational constraints
refineAlt con pstate ex_tvs co_vars pat_ty
- | not (isRigidTy pat_ty)
- = failWithTc (nonRigidMatch con)
+ = do { opt_gadt <- doptM Opt_GADTs -- No type-refinement unless GADTs are on
+ ; if (not opt_gadt) then return pstate
+ else do
+
+ { checkTc (isRigidTy pat_ty) (nonRigidMatch con)
-- We are matching against a GADT constructor with non-trivial
-- constraints, but pattern type is wobbly. For now we fail.
-- We can make sense of this, however:
-- then unify these constraints to make pat_ty the right shape;
-- then proceed exactly as in the rigid case
- | otherwise -- In the rigid case, we perform type refinement
- = case gadtRefine (pat_reft pstate) ex_tvs co_vars of {
+ -- In the rigid case, we perform type refinement
+ ; case gadtRefine (pat_reft pstate) ex_tvs co_vars of {
Failed msg -> failWithTc (inaccessibleAlt msg) ;
Succeeded reft -> do { traceTc trace_msg
- ; return (pstate { pat_reft = reft }) }
+ ; return (pstate { pat_reft = reft, pat_eqs = (pat_eqs pstate || not (null $ dataConEqTheta con)) }) }
-- DO NOT refine the envt right away, because we
-- might be inside a lazy pattern. Instead, refine pstate
where
vcat [ ppr con <+> ppr ex_tvs,
ppr [(v, tyVarKind v) | v <- co_vars],
ppr reft]
- }
+ } } }
\end{code}
-> HsOverLit Name
-> BoxyRhoType
-> TcM (HsOverLit TcId)
-tcOverloadedLit orig lit@(HsIntegral i fi) res_ty
+tcOverloadedLit orig lit@(HsIntegral i fi _) res_ty
| not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
-- Reason: If we do, tcSimplify will call lookupInst, which
-- will call tcSyntaxName, which does unification,
-- ToDo: noLoc sadness
= do { integer_ty <- tcMetaTy integerTyConName
; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty)
- ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
+ ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty))) res_ty) }
| Just expr <- shortCutIntLit i res_ty
- = return (HsIntegral i expr)
+ = return (HsIntegral i expr res_ty)
| otherwise
= do { expr <- newLitInst orig lit res_ty
- ; return (HsIntegral i expr) }
+ ; return (HsIntegral i expr res_ty) }
-tcOverloadedLit orig lit@(HsFractional r fr) res_ty
+tcOverloadedLit orig lit@(HsFractional r fr _) res_ty
| not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
= do { rat_ty <- tcMetaTy rationalTyConName
; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty)
-- we're instantiating an overloaded function here,
-- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
-- However this'll be picked up by tcSyntaxOp if necessary
- ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
+ ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty))) res_ty) }
| Just expr <- shortCutFracLit r res_ty
- = return (HsFractional r expr)
+ = return (HsFractional r expr res_ty)
| otherwise
= do { expr <- newLitInst orig lit res_ty
- ; return (HsFractional r expr) }
+ ; return (HsFractional r expr res_ty) }
+
+tcOverloadedLit orig lit@(HsIsString s fr _) res_ty
+ | not (fr `isHsVar` fromStringName) -- c.f. HsIntegral case
+ = do { str_ty <- tcMetaTy stringTyConName
+ ; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty)
+ ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s))) res_ty) }
+
+ | Just expr <- shortCutStringLit s res_ty
+ = return (HsIsString s expr res_ty)
+
+ | otherwise
+ = do { expr <- newLitInst orig lit res_ty
+ ; return (HsIsString s expr res_ty) }
newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
newLitInst orig lit res_ty -- Make a LitInst
existentialExplode pat
= hang (vcat [text "My brain just exploded.",
text "I can't handle pattern bindings for existentially-quantified constructors.",
+ text "Instead, use a case-expression, or do-notation, to unpack the constructor.",
text "In the binding group for"])
4 (ppr pat)
-sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env
+sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
= do { pat_tys' <- mapM zonkTcType pat_tys
; body_ty' <- zonkTcType body_ty
; let (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
ptext SLIT("The body has type:") <+> ppr tidy_body_ty
]) }
where
+ bound_ids = collectPatsBinders pats
show_ids = filter is_interesting bound_ids
- is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
+ is_interesting id = any (`elemVarSet` varTypeTyVars id) bound_tvs
ppr_id id ty = ppr id <+> dcolon <+> ppr ty
-- Don't zonk the types so we get the separate, un-unified versions
lazyPatErr pat tvs
= failWithTc $
- hang (ptext SLIT("A lazy (~) pattern connot bind existential type variables"))
+ hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables"))
2 (vcat (map pprSkolTvBinding tvs))
nonRigidMatch con
= hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con))
2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
+nonRigidResult res_ty
+ = hang (ptext SLIT("GADT pattern match with non-rigid result type") <+> quotes (ppr res_ty))
+ 2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
+
inaccessibleAlt msg
= hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
\end{code}