X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=b844a2a0d371526bdb87217da6b64194540c5b7f;hp=d68e8b0fde8a9af9042bd68f89af140eb9c123e5;hb=bfd0c33d39619b580520e2d6e43d306380393ea6;hpb=27ca67931713c36f5ed248de88298416892e5649 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index d68e8b0..b844a2a 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1,91 +1,64 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcExpr]{Typecheck an expression} \begin{code} -module TcExpr ( tcPolyExpr, tcPolyExprNC, - tcMonoExpr, tcInferRho, tcSyntaxOp ) where +{-# 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 TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) -import HsSyn ( nlHsVar ) -import Id ( Id, idName ) -import Name ( isExternalName ) -import TcType ( isTauTy ) -import TcEnv ( checkWellStaged ) -import HsSyn ( nlHsApp ) import qualified DsMeta #endif -import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields, - HsMatchContext(..), HsRecordBinds, mkHsCoerce, - mkHsApp ) -import TcHsSyn ( hsLitType ) +import HsSyn +import TcHsSyn import TcRnMonad -import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType, - boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType, - unBox ) -import BasicTypes ( Arity, isMarkedStrict ) -import Inst ( newMethodFromName, newIPDict, instCall, - newMethodWithGivenTy, instStupidTheta ) -import TcBinds ( tcLocalBinds ) -import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField ) -import TcArrows ( tcProc ) -import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody, - TcMatchCtxt(..) ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) -import TcPat ( tcOverloadedLit, addDataConStupidTheta, badFieldCon ) -import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, - readFilledBox, zonkTcTypes ) -import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst, - BoxySigmaType, BoxyRhoType, ThetaType, - mkTyVarTys, mkFunTys, - tcMultiSplitSigmaTy, tcSplitFunTysN, - tcSplitTyConApp_maybe, - isSigmaTy, mkFunTy, mkTyConApp, isLinearPred, - exactTyVarsOfType, exactTyVarsOfTypes, - zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar - ) -import {- Kind parts of -} - Type ( argTypeKind ) - -import Id ( Id, idType, recordSelectorFieldLabel, - isRecordSelector, isNaughtyRecordSelector, - isDataConId_maybe ) -import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, - dataConSourceArity, - dataConWrapId, isVanillaDataCon, dataConUnivTyVars, - dataConOrigArgTys ) -import Name ( Name ) -import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons, - isEnumerationTyCon ) -import Type ( substTheta, substTy ) -import Var ( TyVar, tyVarKind ) -import VarSet ( emptyVarSet, elemVarSet, unionVarSet ) -import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) -import PrelNames ( enumFromName, enumFromThenName, - enumFromToName, enumFromThenToName, - enumFromToPName, enumFromThenToPName, negateName, - hasKey - ) -import PrimOp ( tagToEnumKey ) - +import TcUnify +import BasicTypes +import Inst +import TcBinds +import TcEnv +import TcArrows +import TcMatches +import TcHsType +import TcPat +import TcMType +import TcType +import TcIface ( checkWiredInTyCon ) +import Id +import DataCon +import Name +import TyCon +import Type +import TypeRep +import Coercion +import Var +import VarSet +import TysWiredIn +import PrelNames +import PrimOp import DynFlags -import StaticFlags ( opt_NoMethodSharing ) -import HscTypes ( TyThing(..) ) -import SrcLoc ( Located(..), unLoc, getLoc ) +import StaticFlags +import HscTypes +import SrcLoc import Util -import ListSetOps ( assocMaybe ) -import Maybes ( catMaybes ) +import ListSetOps +import Maybes import Outputable import FastString -#ifdef DEBUG -import TyCon ( tyConArity ) -#endif +import Control.Monad \end{code} %************************************************************************ @@ -107,25 +80,27 @@ tcPolyExpr, tcPolyExprNC tcPolyExpr expr res_ty = addErrCtxt (exprCtxt (unLoc expr)) $ - tcPolyExprNC expr res_ty + (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty }) tcPolyExprNC expr res_ty | isSigmaTy res_ty - = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr) + = do { traceTc (text "tcPolyExprNC" <+> ppr res_ty) + ; (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr) -- Note the recursive call to tcPolyExpr, because the -- type may have multiple layers of for-alls - ; return (L (getLoc expr') (mkHsCoerce gen_fn (unLoc expr'))) } + -- E.g. forall a. Eq a => forall b. Ord b => .... + ; return (mkLHsWrap gen_fn expr') } | otherwise = tcMonoExpr expr res_ty --------------- tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId] -tcPolyExprs [] [] = returnM [] +tcPolyExprs [] [] = return [] tcPolyExprs (expr:exprs) (ty:tys) = do { expr' <- tcPolyExpr expr ty ; exprs' <- tcPolyExprs exprs tys - ; returnM (expr':exprs') } + ; return (expr':exprs') } tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys) --------------- @@ -147,7 +122,6 @@ tcInferRho expr = tcInfer (tcMonoExpr expr) \end{code} - %************************************************************************ %* * tcExpr: the main expression typechecker @@ -158,14 +132,19 @@ tcInferRho expr = tcInfer (tcMonoExpr expr) tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId) tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty -tcExpr (HsLit lit) res_ty = do { boxyUnify (hsLitType lit) res_ty - ; return (HsLit lit) } +tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit + ; coi <- boxyUnify lit_ty res_ty + ; return $ mkHsWrapCoI coi (HsLit lit) + } tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; return (HsPar expr') } tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; returnM (HsSCC lbl expr') } + ; return (HsSCC lbl expr') } +tcExpr (HsTickPragma info expr) res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsTickPragma info expr') } tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation = do { expr' <- tcMonoExpr expr res_ty @@ -176,21 +155,22 @@ tcExpr (HsOverLit lit) res_ty ; return (HsOverLit lit') } tcExpr (NegApp expr neg_expr) res_ty - = do { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr + = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr (mkFunTy res_ty res_ty) ; expr' <- tcMonoExpr expr res_ty ; return (NegApp expr' neg_expr') } tcExpr (HsIPVar ip) res_ty - = do { -- Implicit parameters must have a *tau-type* not a + = do { let origin = IPOccOrigin ip + -- Implicit parameters must have a *tau-type* not a -- type scheme. We enforce this by creating a fresh -- type variable as its type. (Because res_ty may not -- be a tau-type.) - ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple - ; co_fn <- tcSubExp ip_ty res_ty - ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty + ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple + ; co_fn <- tcSubExp origin ip_ty res_ty + ; (ip', inst) <- newIPDict origin ip ip_ty ; extendLIE inst - ; return (mkHsCoerce co_fn (HsIPVar ip')) } + ; return (mkHsWrap co_fn (HsIPVar ip')) } tcExpr (HsApp e1 e2) res_ty = go e1 [e2] @@ -200,17 +180,23 @@ tcExpr (HsApp e1 e2) res_ty go lfun@(L loc fun) args = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $ tcApp fun (length args) (tcArgs lfun args) res_ty + ; traceTc (text "tcExpr args': " <+> ppr args') ; return (unLoc (foldl mkHsApp (L loc fun') args')) } tcExpr (HsLam match) res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty - ; return (mkHsCoerce co_fn (HsLam match')) } + ; return (mkHsWrap co_fn (HsLam match')) } tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty - ; expr' <- tcPolyExpr expr sig_tc_ty - ; co_fn <- tcSubExp sig_tc_ty res_ty - ; return (mkHsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) } + + -- Remember to extend the lexical type-variable environment + ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty -> + tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ + tcPolyExprNC expr res_ty) + + ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty + ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) } tcExpr (HsType ty) res_ty = failWithTc (text "Can't handle type argument:" <+> ppr ty) @@ -256,14 +242,16 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' -> tcApp op 2 (tc_args arg1_ty') res_ty' - ; return (mkHsCoerce co_fn (SectionR (L loc op') arg2')) } + ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) } where - doc = ptext SLIT("The section") <+> quotes (ppr in_expr) - <+> ptext SLIT("takes one argument") - tc_args arg1_ty' [arg1_ty, arg2_ty] - = do { boxyUnify arg1_ty' arg1_ty - ; tcArg lop (arg2, arg2_ty, 2) } - tc_args arg1_ty' other = panic "tcExpr SectionR" + 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') } + tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR" \end{code} \begin{code} @@ -303,40 +291,50 @@ tcExpr (HsDo do_or_lc stmts body _) res_ty = tcDoStmts do_or_lc stmts body res_ty tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list - = do { elt_ty <- boxySplitListTy res_ty - ; exprs' <- mappM (tc_elt elt_ty) exprs - ; return (ExplicitList elt_ty exprs') } + = do { (elt_ty, coi) <- boxySplitListTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty - = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty - ; exprs' <- mappM (tc_elt elt_ty) exprs - ; ifM (null exprs) (zapToMonotype elt_ty) + = do { (elt_ty, coi) <- boxySplitPArrTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; when (null exprs) (zapToMonotype elt_ty >> return ()) -- If there are no expressions in the comprehension -- we must still fill in the box -- (Not needed for [] and () becuase they happen -- to parse as data constructors.) - ; return (ExplicitPArr elt_ty exprs') } + ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') } 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 { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty - ; exprs' <- tcPolyExprs exprs arg_tys - ; return (ExplicitTuple exprs' boxity) } + = do { tvs <- newBoxyTyVars [argTypeKind | 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') <- tcProc pat cmd res_ty - ; return (HsProc pat' cmd') } + = do { (pat', cmd', coi) <- tcProc pat cmd res_ty + ; return $ mkHsWrapCoI coi (HsProc pat' cmd') } tcExpr e@(HsArrApp _ _ _ _ _) _ - = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), - ptext SLIT("was found where an expression was expected")]) + = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), + ptext (sLit "was found where an expression was expected")]) tcExpr e@(HsArrForm _ _ _) _ - = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), - ptext SLIT("was found where an expression was expected")]) + = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), + ptext (sLit "was found where an expression was expected")]) \end{code} %************************************************************************ @@ -353,16 +351,19 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty ; checkMissingFields data_con rbinds ; let arity = dataConSourceArity data_con - check_fields arg_tys - = do { rbinds' <- tcRecordBinds data_con arg_tys rbinds - ; mapM unBox arg_tys - ; return rbinds' } - -- The unBox ensures that all the boxes in arg_tys are indeed + check_fields qtvs qtys arg_tys + = do { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys + ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds + ; qtys' <- mapM refineBoxToTau qtys + ; return (qtys', rbinds') } + -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed -- filled, which is the invariant expected by tcIdApp + -- How could this not be the case? Consider a record construction + -- that does not mention all the fields. ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty - ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') } + ; return (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') } -- The main complication with RecordUpd is that we need to explicitly -- handle the *non-updated* fields. Consider: @@ -397,46 +398,47 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty -- don't know how to do the update otherwise. -tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty - = -- STEP 0 +tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty = do + -- STEP 0 -- Check that the field names are really field names - ASSERT( notNull rbinds ) let - field_names = map fst rbinds - in - mappM (tcLookupField . unLoc) field_names `thenM` \ sel_ids -> + field_names = hsRecFields rbinds + + MASSERT( notNull field_names ) + sel_ids <- mapM tcLookupField field_names -- The renamer has already checked that they -- are all in scope let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name) - | (L loc field_name, sel_id) <- field_names `zip` sel_ids, - not (isRecordSelector sel_id) -- Excludes class ops + | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids, + not (isRecordSelector sel_id), -- Excludes class ops + let L loc field_name = hsRecFieldId fld ] - in - checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_` + + unless (null bad_guys) (sequence bad_guys >> failM) -- STEP 1 -- Figure out the tycon and data cons from the first field name let -- It's OK to use the non-tc splitters here (for a selector) - upd_field_lbls = recBindFields rbinds sel_id : _ = sel_ids (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if - data_cons = tyConDataCons tycon -- it's not a field label + data_cons = tyConDataCons tycon -- it's not a field label + -- NB: for a data type family, the tycon is the instance tycon + relevant_cons = filter is_relevant data_cons - is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls - in + is_relevant con = all (`elem` dataConFieldLabels con) field_names -- 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) `thenM_` + (badFieldsUpd rbinds) -- Check that all relevant data cons are vanilla. Doing record updates on -- GADTs and/or existentials is more than my tiny brain can cope with today checkTc (all isVanillaDataCon relevant_cons) - (nonVanillaUpd tycon) `thenM_` + (nonVanillaUpd tycon) -- STEP 4 -- Use the un-updated fields to find a vector of booleans saying @@ -447,56 +449,61 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty let -- A constructor is only relevant to this process if -- it contains *all* the fields that are being updated - con1 = head relevant_cons -- A representative constructor - con1_tyvars = dataConUnivTyVars con1 - con1_flds = dataConFieldLabels con1 - con1_arg_tys = dataConOrigArgTys con1 - common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys - , not (fld `elem` upd_field_lbls) ] + con1 = ASSERT( not (null relevant_cons) ) head relevant_cons -- A representative constructor + (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1 + con1_flds = dataConFieldLabels con1 + common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys + , not (fld `elem` field_names) ] is_common_tv tv = tv `elemVarSet` common_tyvars mk_inst_ty tv result_inst_ty - | is_common_tv tv = returnM result_inst_ty -- Same as result type + | is_common_tv tv = return result_inst_ty -- Same as result type | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind - in - tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) -> - zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys -> - - -- STEP 3 - -- Typecheck the update bindings. - -- (Do this after checking for bad fields in case there's a field that - -- doesn't match the constructor.) + + MASSERT( null theta ) -- Vanilla datacon + (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tyvars + scrut_inst_tys <- zipWithM mk_inst_ty con1_tyvars result_inst_tys + + -- STEP 3: Typecheck the update bindings. + -- Do this after checking for bad fields in case + -- there's a field that doesn't match the constructor. let - result_record_ty = mkTyConApp tycon result_inst_tys - con1_arg_tys' = map (substTy inst_env) con1_arg_tys - in - tcSubExp result_record_ty res_ty `thenM` \ co_fn -> - tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' -> - - -- STEP 5 - -- Typecheck the expression to be updated + result_ty = substTy result_inst_env con1_res_ty + con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys + origin = RecordUpdOrigin + + co_fn <- tcSubExp origin result_ty res_ty + rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds + + -- STEP 5: Typecheck the expression to be updated let - record_ty = ASSERT( length inst_tys == tyConArity tycon ) - mkTyConApp tycon inst_tys + scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys + scrut_ty = substTy scrut_inst_env con1_res_ty -- This is one place where the isVanilla check is important - -- So that inst_tys matches the tycon - in - tcMonoExpr record_expr record_ty `thenM` \ record_expr' -> - - -- STEP 6 - -- Figure out the LIE we need. We have to generate some - -- dictionaries for the data type context, since we are going to - -- do pattern matching over the data cons. + -- So that inst_tys matches the con1_tyvars + + record_expr' <- tcMonoExpr record_expr scrut_ty + + -- STEP 6: Figure out the LIE we need. + -- We have to generate some dictionaries for the data type context, + -- since we are going to do pattern matching over the data cons. -- - -- What dictionaries do we need? The tyConStupidTheta tells us. + -- What dictionaries do we need? The dataConStupidTheta tells us. let - theta' = substTheta inst_env (tyConStupidTheta tycon) - in - instStupidTheta RecordUpdOrigin theta' `thenM_` + theta' = substTheta scrut_inst_env (dataConStupidTheta con1) + + instStupidTheta origin theta' + + -- Step 7: make a cast for the scrutinee, in the case that it's from a type family + let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon + = WpCast $ mkTyConApp co_con scrut_inst_tys + | otherwise + = idHsWrapper -- Phew! - returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty)) + return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' + relevant_cons scrut_inst_tys result_inst_tys)) \end{code} @@ -510,54 +517,58 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty \begin{code} tcExpr (ArithSeq _ seq@(From expr)) res_ty - = do { elt_ty <- boxySplitListTy res_ty + = do { (elt_ty, coi) <- boxySplitListTy res_ty ; expr' <- tcPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromName - ; return (ArithSeq (HsVar enum_from) (From expr')) } + ; return $ mkHsWrapCoI coi (ArithSeq (HsVar enum_from) (From expr')) } tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty - = do { elt_ty <- boxySplitListTy res_ty + = do { (elt_ty, coi) <- boxySplitListTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromThenName - ; return (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) } - + ; return $ mkHsWrapCoI coi + (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) } tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { elt_ty <- boxySplitListTy res_ty + = do { (elt_ty, coi) <- boxySplitListTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromToName - ; return (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) } + ; return $ mkHsWrapCoI coi + (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) } tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { elt_ty <- boxySplitListTy res_ty + = do { (elt_ty, coi) <- boxySplitListTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromThenToName - ; return (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) } + ; return $ mkHsWrapCoI coi + (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) } tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty + = do { (elt_ty, coi) <- boxySplitPArrTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) elt_ty enumFromToPName - ; return (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) } + ; return $ mkHsWrapCoI coi + (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) } tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty + = do { (elt_ty, coi) <- boxySplitPArrTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (PArrSeqOrigin seq) elt_ty enumFromThenToPName - ; return (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) } + ; return $ mkHsWrapCoI coi + (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) } tcExpr (PArrSeq _ _) _ = panic "TcExpr.tcMonoExpr: Infinite parallel array!" @@ -578,6 +589,8 @@ tcExpr (PArrSeq _ _) _ tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty ; return (unLoc e) } +tcExpr e@(HsQuasiQuoteE _) res_ty = + pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e) #endif /* GHCI */ \end{code} @@ -603,9 +616,9 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) --------------------------- tcApp :: HsExpr Name -- Function -> Arity -- Number of args reqd - -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker + -> ArgChecker results -> BoxyRhoType -- Result type - -> TcM (HsExpr TcId, arg_results) + -> TcM (HsExpr TcId, results) -- (tcFun fun n_args arg_checker res_ty) -- The argument type checker, arg_checker, will be passed exactly n_args types @@ -614,19 +627,18 @@ tcApp (HsVar fun_name) n_args arg_checker res_ty = tcIdApp fun_name n_args arg_checker res_ty tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP) - = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind) - ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty) - ; arg_tys' <- mapM readFilledBox arg_boxes - ; args' <- arg_checker arg_tys' + = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind) + ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty) + ; arg_tys' <- mapM readFilledBox arg_boxes + ; (_, args') <- arg_checker [] [] arg_tys' -- Yuk ; return (fun', args') } --------------------------- tcIdApp :: Name -- Function -> Arity -- Number of args reqd - -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker - -- The arg-checker guarantees to fill all boxes in the arg types + -> ArgChecker results -- The arg-checker guarantees to fill all boxes in the arg types -> BoxyRhoType -- Result type - -> TcM (HsExpr TcId, arg_results) + -> TcM (HsExpr TcId, results) -- Call (f e1 ... en) :: res_ty -- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres @@ -659,34 +671,28 @@ tcIdApp fun_name n_args arg_checker res_ty ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes res_ty' = mkFunTys extra_arg_tys' res_ty ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty' - ; let arg_subst = zipOpenTvSubst qtvs qtys' - fun_arg_tys' = substTys arg_subst fun_arg_tys -- Typecheck the arguments! -- Doing so will fill arg_qtvs and extra_arg_tys' - ; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys') + ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys') -- Strip boxes from the qtvs that have been filled in by the arg checking - -- AND any variables that are mentioned in neither arg nor result - -- the latter are mentioned only in constraints; stripBoxyType will - -- fill them with a monotype - ; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty' - | otherwise = return qty' - ; qtys'' <- zipWithM strip qtvs qtys' ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes -- Result subsumption + -- This fills in res_qtvs ; let res_subst = zipOpenTvSubst qtvs qtys'' fun_res_ty'' = substTy res_subst fun_res_ty res_ty'' = mkFunTys extra_arg_tys'' res_ty - ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty'' + ; co_fn <- tcSubExp orig fun_res_ty'' res_ty'' -- And pack up the results -- By applying the coercion just to the *function* we can make -- tcFun work nicely for OpApp and Sections too ; fun' <- instFun orig fun res_subst tv_theta_prs - ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn - ; return (mkHsCoerce co_fn' fun', args') } + ; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn + ; traceTc (text "tcIdApp: " <+> ppr (mkHsWrap co_fn' fun') <+> ppr tv_theta_prs <+> ppr co_fn' <+> ppr fun') + ; return (mkHsWrap co_fn' fun', args') } \end{code} Note [Silly type synonyms in smart-app] @@ -725,11 +731,12 @@ tcId orig fun_name res_ty ; let res_subst = zipTopTvSubst qtvs qtv_tys fun_tau' = substTy res_subst fun_tau - ; co_fn <- tcFunResTy fun_name fun_tau' res_ty + ; co_fn <- tcSubExp orig fun_tau' res_ty -- And pack up the results ; fun' <- instFun orig fun res_subst tv_theta_prs - ; return (mkHsCoerce co_fn fun') } + ; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun')) + ; return (mkHsWrap co_fn fun') } -- Note [Push result type in] -- @@ -772,52 +779,39 @@ instFun orig fun subst [] = return fun -- Common short cut instFun orig fun subst tv_theta_prs - = do { -- !!!SPJ: -- Horrid check for tagToEnum; see Note [tagToEnum#] - -- !!!SPJ: checkBadTagToEnumCall fun_id qtv_tys - - ; let ty_theta_prs' = map subst_pr tv_theta_prs - - -- First, chuck in the constraints from - -- the "stupid theta" of a data constructor (sigh) - ; inst_stupid fun ty_theta_prs' + = do { let ty_theta_prs' = map subst_pr tv_theta_prs + ; traceTc (text "instFun" <+> ppr ty_theta_prs') + -- Make two ad-hoc checks + ; doStupidChecks fun ty_theta_prs' -- Now do normal instantiation - ; go True fun ty_theta_prs' } + ; method_sharing <- doptM Opt_MethodSharing + ; result <- go method_sharing True fun ty_theta_prs' + ; traceTc (text "instFun result" <+> ppr result) + ; return result + } where subst_pr (tvs, theta) - = (map (substTyVar subst) tvs, substTheta subst theta) + = (substTyVars subst tvs, substTheta subst theta) - inst_stupid (HsVar fun_id) ((tys,_):_) - | Just con <- isDataConId_maybe fun_id - = addDataConStupidTheta orig con tys - inst_stupid _ _ = return () + go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun } - go _ fun [] = return fun - - go True (HsVar fun_id) ((tys,theta) : prs) - | want_method_inst theta - = do { meth_id <- newMethodWithGivenTy orig fun_id tys - ; go False (HsVar meth_id) prs } + go method_sharing True (HsVar fun_id) ((tys,theta) : prs) + | want_method_inst method_sharing theta + = do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta") + ; meth_id <- newMethodWithGivenTy orig fun_id tys + ; go method_sharing False (HsVar meth_id) prs } -- Go round with 'False' to prevent further use -- of newMethod: see Note [Multiple instantiation] - go _ fun ((tys, theta) : prs) + go method_sharing _ fun ((tys, theta) : prs) = do { co_fn <- instCall orig tys theta - ; go False (HsCoerce co_fn fun) prs } + ; traceTc (text "go yields co_fn" <+> ppr co_fn) + ; go method_sharing False (HsWrap co_fn fun) prs } - -- Hack Alert (want_method_inst)! -- See Note [No method sharing] - -- If f :: (%x :: T) => Int -> Int - -- Then if we have two separate calls, (f 3, f 4), we cannot - -- make a method constraint that then gets shared, thus: - -- let m = f %x in (m 3, m 4) - -- because that loses the linearity of the constraint. - -- The simplest thing to do is never to construct a method constraint - -- in the first place that has a linear implicit parameter in it. - want_method_inst theta = not (null theta) -- Overloaded - && not (any isLinearPred theta) -- Not linear - && not opt_NoMethodSharing - -- See Note [No method sharing] below + want_method_inst method_sharing theta = not (null theta) -- Overloaded + && method_sharing \end{code} Note [Multiple instantiation] @@ -869,19 +863,46 @@ This gets a bit less sharing, but a) it's better for RULEs involving overloaded functions b) perhaps fewer separated lambdas +Note [Left to right] +~~~~~~~~~~~~~~~~~~~~ +tcArgs implements a left-to-right order, which goes beyond what is described in the +impredicative type inference paper. In particular, it allows + runST $ foo +where runST :: (forall s. ST s a) -> a +When typechecking the application of ($)::(a->b) -> a -> b, we first check that +runST has type (a->b), thereby filling in a=forall s. ST s a. Then we un-box this type +before checking foo. The left-to-right order really helps here. + \begin{code} tcArgs :: LHsExpr Name -- The function (for error messages) - -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types - -> TcM [LHsExpr TcId] -- Resulting args + -> [LHsExpr Name] -- Actual args + -> ArgChecker [LHsExpr TcId] -tcArgs fun args expected_arg_tys - = mapM (tcArg fun) (zip3 args expected_arg_tys [1..]) +type ArgChecker results + = [TyVar] -> [TcSigmaType] -- Current instantiation + -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation) + -> TcM ([TcSigmaType], results) -- Resulting instaniation and args -tcArg :: LHsExpr Name -- The function (for error messages) - -> (LHsExpr Name, BoxySigmaType, Int) -- Actual argument and expected arg type - -> TcM (LHsExpr TcId) -- Resulting argument -tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $ - tcPolyExprNC arg ty +tcArgs fun args qtvs qtys arg_tys + = go 1 qtys args arg_tys + where + go n qtys [] [] = return (qtys, []) + go n qtys (arg:args) (arg_ty:arg_tys) + = do { arg' <- tcArg fun n arg qtvs qtys arg_ty + ; qtys' <- mapM refineBox qtys -- Exploit new info + ; (qtys'', args') <- go (n+1) qtys' args arg_tys + ; return (qtys'', arg':args') } + go n qtys args arg_tys = panic "tcArgs" + +tcArg :: LHsExpr Name -- The function + -> Int -- and arg number (for error messages) + -> LHsExpr Name + -> [TyVar] -> [TcSigmaType] -- Instantiate the arg type like this + -> BoxySigmaType + -> TcM (LHsExpr TcId) -- Resulting argument +tcArg fun arg_no arg qtvs qtys ty + = addErrCtxt (funAppCtxt fun arg arg_no) $ + tcPolyExprNC arg (substTyWith qtvs qtys ty) \end{code} @@ -900,32 +921,44 @@ Here's are two cases that should fail \begin{code} -checkBadTagToEnumCall :: Id -> [TcType] -> TcM () -checkBadTagToEnumCall fun_id tys - | fun_id `hasKey` tagToEnumKey +doStupidChecks :: HsExpr TcId + -> [([TcType], ThetaType)] + -> TcM () +-- Check two tiresome and ad-hoc cases +-- (a) the "stupid theta" for a data con; add the constraints +-- from the "stupid theta" of a data constructor (sigh) +-- (b) deal with the tagToEnum# problem: see Note [tagToEnum#] + +doStupidChecks (HsVar fun_id) ((tys,_):_) + | Just con <- isDataConId_maybe fun_id -- (a) + = addDataConStupidTheta con tys + + | fun_id `hasKey` tagToEnumKey -- (b) = do { tys' <- zonkTcTypes tys ; checkTc (ok tys') (tagToEnumError tys') } - | otherwise -- Vastly common case - = return () where ok [] = False ok (ty:tys) = case tcSplitTyConApp_maybe ty of Just (tc,_) -> isEnumerationTyCon tc Nothing -> False +doStupidChecks fun tv_theta_prs + = return () -- The common case + + tagToEnumError tys - = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type) - 2 (vcat [ptext SLIT("Specify the type by giving a type signature"), - ptext SLIT("e.g. (tagToEnum# x) :: Bool")]) + = hang (ptext (sLit "Bad call to tagToEnum#") <+> at_type) + 2 (vcat [ptext (sLit "Specify the type by giving a type signature"), + ptext (sLit "e.g. (tagToEnum# x) :: Bool")]) where at_type | null tys = empty -- Probably never happens - | otherwise = ptext SLIT("at type") <+> ppr (head tys) + | otherwise = ptext (sLit "at type") <+> ppr (head tys) \end{code} %************************************************************************ %* * -\subsection{@tcId@ typchecks an identifier occurrence} +\subsection{@tcId@ typechecks an identifier occurrence} %* * %************************************************************************ @@ -947,10 +980,13 @@ lookupFun orig id_name ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl } -> do { thLocalId orig id ty lvl ; case mb_co of - Nothing -> return (HsVar id, ty) -- Wobbly, or no free vars - Just co -> return (mkHsCoerce co (HsVar id), ty) } + Unrefineable -> return (HsVar id, ty) + Rigid co -> return (mkHsWrap co (HsVar id), ty) + Wobbly -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty) -- Wobbly, or no free vars + WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)")) + } - other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) + other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected")) } #ifndef GHCI /* GHCI and TH is off */ @@ -971,7 +1007,7 @@ thLocalId orig id id_ty th_bind_lvl -------------------------------------- thBrackId orig id ps_var lie_var - | isExternalName id_name + | thTopLevelId id = -- Top-level identifiers in this module, -- (which have External Names) -- are just like the imported case: @@ -982,7 +1018,7 @@ 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_name; return id } + do { keepAliveTc id; return id } | otherwise = -- Nested identifiers, such as 'x' in @@ -1014,11 +1050,9 @@ thBrackId orig id ps_var lie_var -- Update the pending splices ; ps <- readMutVar ps_var - ; writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) + ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) ; return id } } - where - id_name = idName id #endif /* GHCI */ \end{code} @@ -1053,18 +1087,18 @@ tcRecordBinds -> HsRecordBinds Name -> TcM (HsRecordBinds TcId) -tcRecordBinds data_con arg_tys rbinds - = do { mb_binds <- mappM do_bind rbinds - ; return (catMaybes mb_binds) } +tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) + = do { mb_binds <- mapM do_bind rbinds + ; return (HsRecFields (catMaybes mb_binds) dd) } where flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys - do_bind (L loc field_lbl, rhs) + do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs }) | Just field_ty <- assocMaybe flds_w_tys field_lbl = addErrCtxt (fieldCtxt field_lbl) $ do { rhs' <- tcPolyExprNC rhs field_ty ; sel_id <- tcLookupField field_lbl ; ASSERT( isRecordSelector sel_id ) - return (Just (L loc sel_id, rhs')) } + return (Just (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = rhs' })) } | otherwise = do { addErrTc (badFieldCon data_con field_lbl) ; return Nothing } @@ -1077,14 +1111,14 @@ checkMissingFields data_con rbinds -- Illegal if any arg is strict addErrTc (missingStrictFields data_con []) else - returnM () + return () - | otherwise -- A record - = checkM (null missing_s_fields) - (addErrTc (missingStrictFields data_con missing_s_fields)) `thenM_` + | otherwise = do -- A record + unless (null missing_s_fields) + (addErrTc (missingStrictFields data_con missing_s_fields)) - doptM Opt_WarnMissingFields `thenM` \ warn -> - checkM (not (warn && notNull missing_ns_fields)) + warn <- doptM Opt_WarnMissingFields + unless (not (warn && notNull missing_ns_fields)) (warnTc True (missingFields data_con missing_ns_fields)) where @@ -1099,7 +1133,7 @@ checkMissingFields data_con rbinds not (fl `elem` field_names_used) ] - field_names_used = recBindFields rbinds + field_names_used = hsRecFields rbinds field_labels = dataConFieldLabels data_con field_info = zipEqual "missingFields" @@ -1118,37 +1152,38 @@ checkMissingFields data_con rbinds Boring and alphabetical: \begin{code} caseScrutCtxt expr - = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) + = hang (ptext (sLit "In the scrutinee of a case expression:")) 4 (ppr expr) exprCtxt expr - = hang (ptext SLIT("In the expression:")) 4 (ppr expr) + = hang (ptext (sLit "In the expression:")) 4 (ppr expr) fieldCtxt field_name - = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record") + = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") funAppCtxt fun arg arg_no - = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), + = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), quotes (ppr fun) <> text ", namely"]) 4 (quotes (ppr arg)) predCtxt expr - = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) + = hang (ptext (sLit "In the predicate expression:")) 4 (ppr expr) nonVanillaUpd tycon - = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon) - <+> ptext SLIT("is not (yet) supported"), - ptext SLIT("Use pattern-matching instead")] + = vcat [ptext (sLit "Record update for the non-Haskell-98 data type") + <+> quotes (pprSourceTyCon tycon) + <+> ptext (sLit "is not (yet) supported"), + ptext (sLit "Use pattern-matching instead")] badFieldsUpd rbinds - = hang (ptext SLIT("No constructor has all these fields:")) - 4 (pprQuotedList (recBindFields rbinds)) + = hang (ptext (sLit "No constructor has all these fields:")) + 4 (pprQuotedList (hsRecFields rbinds)) naughtyRecordSel sel_id - = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+> - ptext SLIT("as a function due to escaped type variables") $$ - ptext SLIT("Probably fix: use pattern-matching syntax instead") + = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+> + ptext (sLit "as a function due to escaped type variables") $$ + ptext (sLit "Probably fix: use pattern-matching syntax instead") notSelector field - = hsep [quotes (ppr field), ptext SLIT("is not a record selector")] + = hsep [quotes (ppr field), ptext (sLit "is not a record selector")] missingStrictFields :: DataCon -> [FieldLabel] -> SDoc missingStrictFields con fields @@ -1158,20 +1193,19 @@ missingStrictFields con fields -- with strict fields | otherwise = colon <+> pprWithCommas ppr fields - header = ptext SLIT("Constructor") <+> quotes (ppr con) <+> - ptext SLIT("does not have the required strict field(s)") + header = ptext (sLit "Constructor") <+> quotes (ppr con) <+> + ptext (sLit "does not have the required strict field(s)") missingFields :: DataCon -> [FieldLabel] -> SDoc missingFields con fields - = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") + = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:") <+> pprWithCommas ppr fields -callCtxt fun args - = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args)) +-- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args)) #ifdef GHCI polySpliceErr :: Id -> SDoc polySpliceErr id - = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) + = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) #endif \end{code}