X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=4ccd89c3a4f7eef91ad476c00d48c2be4eb3501b;hb=ee2571bd2a80683d33cf65a01942bc8be50a5e33;hp=15089959346cb0189b5f666a6ce3dc7d6cad1629;hpb=110b54f7e7340aecac237012ac9aa31c4ea16cfd;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 1508995..4ccd89c 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -12,7 +12,9 @@ -- 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" @@ -280,6 +282,33 @@ tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty ; 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} @@ -344,23 +373,6 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty 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') } @@ -457,12 +469,22 @@ field isn't part of the existential. For example, this should be ok. 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 } @@ -529,7 +551,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty 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) @@ -870,9 +892,10 @@ tcId orig fun_name res_ty 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 @@ -1099,22 +1122,31 @@ lookupFun orig id_name #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) @@ -1126,9 +1158,10 @@ thBrackId orig id ps_var lie_var -- 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 @@ -1138,8 +1171,7 @@ thBrackId orig id ps_var lie_var -- 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 @@ -1152,18 +1184,33 @@ thBrackId orig id ps_var lie_var -- 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,