-- 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"
; qtys' <- mapM refineBox qtys -- c.f. tcArgs
; return (qtys', 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)
-- Figure out types for the scrutinee and result
-- Both are of form (T a b c), with fresh type variables, but with
-- common variables where the scrutinee and result must have the same type
- -- These are variables that appear in *any* arg of *any* of the relevant constructors
- -- *except* in the updated fields
+ -- These are variables that appear in *any* arg of *any* of the
+ -- relevant constructors *except* in the updated fields
--
; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
is_fixed_tv tv = tv `elemVarSet` fixed_tvs
fixed_tvs = exactTyVarsOfTypes fixed_tys
-- fixed_tys: See Note [Type of a record update]
`unionVarSet` tyVarsOfTheta theta
- -- Universally-quantified tyvars that appear in any of the
- -- *implicit* arguments to the constructor are fixed
+ -- Universally-quantified tyvars that
+ -- appear in any of the *implicit*
+ -- arguments to the constructor are fixed
-- See Note [Implict type sharing]
fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
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
#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,
projects / ghc-hetmet.git / blobdiff