-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, addExprErrCtxt ) where
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
+ tcInferRho, tcInferRhoNC, tcSyntaxOp,
+ addExprErrCtxt ) where
#include "HsVersions.h"
-- but it's less work and kind of useful.
tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
- = do dflags <- getDOpts
- if dopt Opt_PostfixOperators dflags
- then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
- return (SectionL arg1' (L loc op'))
- else do (co_fn, (op', arg1'))
- <- subFunTys doc 1 res_ty Nothing
- $ \ [arg2_ty'] res_ty' ->
- tcApp op 2 (tc_args arg2_ty') res_ty'
- return (mkHsWrap co_fn (SectionL arg1' (L loc op')))
+ = do { dflags <- getDOpts
+ ; if dopt Opt_PostfixOperators dflags
+ then do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
+ ; return (SectionL arg1' (L loc op')) }
+ else do
+ { (co_fn, expr')
+ <- subFunTys doc 1 res_ty Nothing $ \ [arg2_ty'] res_ty' ->
+ do { (op', (arg1', co_arg2)) <- tcApp op 2 (tc_args arg2_ty') res_ty'
+ ; let coi = mkFunTyCoI arg2_ty' co_arg2 res_ty' IdCo
+ ; return (mkHsWrapCoI coi (SectionL arg1' (L loc op'))) }
+ ; return (mkHsWrap co_fn expr') } }
where
doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
<+> ptext (sLit "takes one argument")
tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty]
- = do { boxyUnify arg2_ty' (substTyWith qtvs qtys arg2_ty)
- ; arg1' <- tcArg lop 2 arg1 qtvs qtys arg1_ty
- ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
- ; return (qtys', arg1') }
+ = do { co_arg2 <- boxyUnify (substTyWith qtvs qtys arg2_ty) arg2_ty'
+ ; arg1' <- tcArg lop 1 arg1 qtvs qtys arg1_ty
+ ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
+ ; return (qtys', (arg1', co_arg2)) }
tc_args _ _ _ _ = panic "tcExpr SectionL"
-- Right sections, equivalent to \ x -> x `op` expr, or
-- \ x -> op x expr
tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
- = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
- tcApp op 2 (tc_args arg1_ty') res_ty'
- ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
+ = do { (co_fn, expr')
+ <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
+ do { (op', (co_arg1, arg2')) <- tcApp op 2 (tc_args arg1_ty') res_ty'
+ ; let coi = mkFunTyCoI arg1_ty' co_arg1 res_ty' IdCo
+ ; return (mkHsWrapCoI coi $ SectionR (L loc op') arg2') }
+ ; return (mkHsWrap co_fn expr') }
where
doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
<+> ptext (sLit "takes one argument")
tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty]
- = do { boxyUnify arg1_ty' (substTyWith qtvs qtys arg1_ty)
- ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty
- ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
- ; return (qtys', arg2') }
+ = do { co_arg1 <- boxyUnify (substTyWith qtvs qtys arg1_ty) arg1_ty'
+ ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty
+ ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
+ ; return (qtys', (co_arg1, arg2')) }
tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
+
+-- For tuples, take care to preserve rigidity
+-- E.g. case (x,y) of ....
+-- The scrutinee should have a rigid type if x,y do
+-- The general scheme is the same as in tcIdApp
+tcExpr in_expr@(ExplicitTuple tup_args boxity) res_ty
+ = do { let kind = case boxity of { Boxed -> liftedTypeKind
+ ; Unboxed -> argTypeKind }
+ arity = length tup_args
+ tup_tc = tupleTyCon boxity arity
+ mk_tup_res_ty arg_tys
+ = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
+ (mkTyConApp tup_tc arg_tys)
+
+ ; checkWiredInTyCon tup_tc -- Ensure instances are available
+ ; tvs <- newBoxyTyVars (replicate arity kind)
+ ; let arg_tys1 = map mkTyVarTy tvs
+ ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty
+
+ ; let go (Missing _, arg_ty) = return (Missing arg_ty)
+ go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+ ; return (Present expr') }
+ ; tup_args' <- mapM go (tup_args `zip` arg_tys2)
+
+ ; arg_tys3 <- mapM refineBox arg_tys2
+ ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty
+ ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) }
\end{code}
\begin{code}
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
--- For tuples, take care to preserve rigidity
--- E.g. case (x,y) of ....
--- The scrutinee should have a rigid type if x,y do
--- The general scheme is the same as in tcIdApp
-tcExpr (ExplicitTuple exprs boxity) res_ty
- = do { let kind = case boxity of { Boxed -> liftedTypeKind
- ; Unboxed -> argTypeKind }
- ; tvs <- newBoxyTyVars [kind | e <- exprs]
- ; let tup_tc = tupleTyCon boxity (length exprs)
- tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
- ; checkWiredInTyCon tup_tc -- Ensure instances are available
- ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
- ; exprs' <- tcPolyExprs exprs arg_tys
- ; arg_tys' <- mapM refineBox arg_tys
- ; co_fn <- tcSubExp TupleOrigin (mkTyConApp tup_tc arg_tys') res_ty
- ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
-
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
data T a where { MkT { f1::a, f2::b->b } :: T a }
f :: T a -> b -> T b
f t b = t { f1=b }
+
The criterion we use is this:
The types of the updated fields
mention only the universally-quantified type variables
of the data constructor
+NB: this is not (quite) the same as being a "naughty" record selector
+(See Note [Naughty record selectors]) in TcTyClsDecls), at least
+in the case of GADTs. Consider
+ data T a where { MkT :: { f :: a } :: T [a] }
+Then f is not "naughty" because it has a well-typed record selector.
+But we don't allow updates for 'f'. (One could consider trying to
+allow this, but it makes my head hurt. Badly. And no one has asked
+for it.)
+
In principle one could go further, and allow
g :: T a -> T a
g t = t { f2 = \x -> x }
con1_flds = dataConFieldLabels con1
con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
- -- STEP 2
+ -- Step 2
-- Check that at least one constructor has all the named fields
-- i.e. has an empty set of bad fields returned by badFields
; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)
-> BoxyRhoType -- Result type
-> TcM (HsExpr TcId)
tcId orig fun_name res_ty
- = do { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
- ; (fun, fun_ty) <- lookupFun orig fun_name
-
+ = do { (fun, fun_ty) <- lookupFun orig fun_name
+ ; traceTc (text "tcId" <+> ppr fun_name <+> (ppr fun_ty $$ ppr res_ty))
+
-- Split up the function type
; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
- qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
+ qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part
; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
; let res_subst = zipTopTvSubst qtvs qtv_tys
fun_tau' = substTy res_subst fun_tau
+ ; traceTc (text "tcId2" <+> ppr fun_name <+> (ppr qtvs $$ ppr qtv_tys))
+
; co_fn <- tcSubExp orig fun_tau' res_ty
-- And pack up the results
tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
-- Typecheck a syntax operator, checking that it has the specified type
-- The operator is always a variable at this stage (i.e. renamer output)
+-- This version assumes ty is a monotype
tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
-tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
-
+tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
+
---------------------------
instFun :: InstOrigin
-> HsExpr TcId
type ArgChecker results
= [TyVar] -> [TcSigmaType] -- Current instantiation
-> [TcSigmaType] -- Expected arg types (**before** applying the instantiation)
- -> TcM ([TcSigmaType], results) -- Resulting instaniation and args
+ -> TcM ([TcSigmaType], results) -- Resulting instantiation and args
tcArgs fun args qtvs qtys arg_tys
= go 1 qtys args arg_tys
#ifndef GHCI /* GHCI and TH is off */
--------------------------------------
--- thLocalId : Check for cross-stage lifting
-thLocalId orig id id_ty th_bind_lvl
+thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM ()
+-- Check for cross-stage lifting
+thLocalId orig id id_ty bind_lvl
= return ()
#else /* GHCI and TH is on */
-thLocalId orig id id_ty th_bind_lvl
+thLocalId orig id id_ty bind_lvl
= do { use_stage <- getStage -- TH case
- ; case use_stage of
- Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
- -> thBrackId orig id ps_var lie_var
- other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
- ; return id }
- }
+ ; let use_lvl = thLevel use_stage
+ ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
+ ; traceTc (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
+ ; when (use_lvl > bind_lvl) $
+ checkCrossStageLifting orig id id_ty bind_lvl use_stage }
--------------------------------------
-thBrackId orig id ps_var lie_var
+checkCrossStageLifting :: InstOrigin -> Id -> TcType -> ThLevel -> ThStage -> TcM ()
+-- We are inside brackets, and (use_lvl > bind_lvl)
+-- Now we must check whether there's a cross-stage lift to do
+-- Examples \x -> [| x |]
+-- [| map |]
+
+checkCrossStageLifting _ _ _ _ Comp = return ()
+checkCrossStageLifting _ _ _ _ Splice = return ()
+
+checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var)
| thTopLevelId id
= -- Top-level identifiers in this module,
-- (which have External Names)
-- But we do need to put f into the keep-alive
-- set, because after desugaring the code will
-- only mention f's *name*, not f itself.
- do { keepAliveTc id; return id }
+ keepAliveTc id
- | otherwise
+ | otherwise -- bind_lvl = outerLevel presumably,
+ -- but the Id is not bound at top level
= -- Nested identifiers, such as 'x' in
-- E.g. \x -> [| h x |]
-- We must behave as if the reference to x was
-- If 'x' occurs many times we may get many identical
-- bindings of the same splice proxy, but that doesn't
-- matter, although it's a mite untidy.
- do { let id_ty = idType id
- ; checkTc (isTauTy id_ty) (polySpliceErr id)
+ do { checkTc (isTauTy id_ty) (polySpliceErr id)
-- If x is polymorphic, its occurrence sites might
-- have different instantiations, so we can't use plain
-- 'x' as the splice proxy name. I don't know how to
-- so we zap it to a LiftedTypeKind monotype
-- C.f. the call in TcPat.newLitInst
- ; setLIEVar lie_var $ do
- { lift <- newMethodFromName orig id_ty' DsMeta.liftName
- -- Put the 'lift' constraint into the right LIE
+ ; lift <- if isStringTy id_ty' then
+ tcLookupId DsMeta.liftStringName
+ -- See Note [Lifting strings]
+ else
+ setLIEVar lie_var $ do -- Put the 'lift' constraint into the right LIE
+ newMethodFromName orig id_ty' DsMeta.liftName
-- Update the pending splices
; ps <- readMutVar ps_var
; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
- ; return id } }
+ ; return () }
#endif /* GHCI */
\end{code}
+Note [Lifting strings]
+~~~~~~~~~~~~~~~~~~~~~~
+If we see $(... [| s |] ...) where s::String, we don't want to
+generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
+So this conditional short-circuits the lifting mechanism to generate
+(liftString "xy") in that case. I didn't want to use overlapping instances
+for the Lift class in TH.Syntax, because that can lead to overlapping-instance
+errors in a polymorphic situation.
+
+If this check fails (which isn't impossible) we get another chance; see
+Note [Converting strings] in Convert.lhs
+
Local record selectors
~~~~~~~~~~~~~~~~~~~~~~
Record selectors for TyCons in this module are ordinary local bindings,
checkMissingFields data_con rbinds
| null field_labels -- Not declared as a record;
-- But C{} is still valid if no strict fields
- = if any isMarkedStrict field_strs then
+ = if any isBanged field_strs then
-- Illegal if any arg is strict
addErrTc (missingStrictFields data_con [])
else
where
missing_s_fields
= [ fl | (fl, str) <- field_info,
- isMarkedStrict str,
+ isBanged str,
not (fl `elem` field_names_used)
]
missing_ns_fields
= [ fl | (fl, str) <- field_info,
- not (isMarkedStrict str),
+ not (isBanged str),
not (fl `elem` field_names_used)
]
projects / ghc-hetmet.git / blobdiff