diff options
| author | Jan Stolarek <jan.stolarek@p.lodz.pl> | 2016-01-15 18:24:14 +0100 |
|---|---|---|
| committer | Jan Stolarek <jan.stolarek@p.lodz.pl> | 2016-01-18 18:54:10 +0100 |
| commit | b8abd852d3674cb485490d2b2e94906c06ee6e8f (patch) | |
| tree | eddf226b9c10be8b9b982ed29c1ef61841755c6f /compiler/typecheck | |
| parent | 817dd925569d981523bbf4fb471014d46c51c7db (diff) | |
| download | haskell-b8abd852d3674cb485490d2b2e94906c06ee6e8f.tar.gz | |
Replace calls to `ptext . sLit` with `text`
Summary:
In the past the canonical way for constructing an SDoc string literal was the
composition `ptext . sLit`. But for some time now we have function `text` that
does the same. Plus it has some rules that optimize its runtime behaviour.
This patch takes all uses of `ptext . sLit` in the compiler and replaces them
with calls to `text`. The main benefits of this patch are clener (shorter) code
and less dependencies between module, because many modules now do not need to
import `FastString`. I don't expect any performance benefits - we mostly use
SDocs to report errors and it seems there is little to be gained here.
Test Plan: ./validate
Reviewers: bgamari, austin, goldfire, hvr, alanz
Subscribers: goldfire, thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D1784
Diffstat (limited to 'compiler/typecheck')
36 files changed, 807 insertions, 819 deletions
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index c5eec49140..e4b2cc3517 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -28,7 +28,6 @@ import DynFlags import Module import Outputable import UniqFM -import FastString import Util import RdrName import DataCon ( dataConName ) @@ -187,7 +186,7 @@ getFamInsts hpt_fam_insts mod ; return (expectJust "checkFamInstConsistency" $ lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } where - doc = ppr mod <+> ptext (sLit "is a family-instance module") + doc = ppr mod <+> text "is a family-instance module" {- ************************************************************************ diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs index b4edd37c3e..edf178182b 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -32,7 +32,6 @@ import Outputable import ErrUtils( Validity(..), allValid ) import SrcLoc import Util -import FastString import Pair ( Pair(..) ) import Data.List ( nubBy ) @@ -185,8 +184,8 @@ improveFromAnother _ _ _ = [] pprEquation :: FunDepEqn a -> SDoc pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) - = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs), - nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 + = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), + nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 | Pair t1 t2 <- pairs])] improveFromInstEnv :: InstEnvs @@ -389,26 +388,26 @@ checkInstCoverage be_liberal clas theta inst_taus -- , text "theta" <+> ppr theta -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs)) -- , text "rs_tvs" <+> ppr rs_tvs - sep [ ptext (sLit "The") - <+> ppWhen be_liberal (ptext (sLit "liberal")) - <+> ptext (sLit "coverage condition fails in class") + sep [ text "The" + <+> ppWhen be_liberal (text "liberal") + <+> text "coverage condition fails in class" <+> quotes (ppr clas) - , nest 2 $ ptext (sLit "for functional dependency:") + , nest 2 $ text "for functional dependency:" <+> quotes (pprFunDep fd) ] - , sep [ ptext (sLit "Reason: lhs type")<>plural ls <+> pprQuotedList ls + , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls , nest 2 $ (if isSingleton ls - then ptext (sLit "does not") - else ptext (sLit "do not jointly")) - <+> ptext (sLit "determine rhs type")<>plural rs + then text "does not" + else text "do not jointly") + <+> text "determine rhs type"<>plural rs <+> pprQuotedList rs ] - , ptext (sLit "Un-determined variable") <> plural undet_list <> colon + , text "Un-determined variable" <> plural undet_list <> colon <+> pprWithCommas ppr undet_list , ppWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ - ptext (sLit "(Use -fprint-explicit-kinds to see the kind variables in the types)") + text "(Use -fprint-explicit-kinds to see the kind variables in the types)" , ppWhen (not be_liberal && and (isEmptyVarSet <$> liberal_undet_tvs)) $ - ptext (sLit "Using UndecidableInstances might help") ] + text "Using UndecidableInstances might help" ] {- Note [Closing over kinds in coverage] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 8878ba6b46..43f7f1eba7 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -467,9 +467,9 @@ syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv -> TcRn (TidyEnv, SDoc) syntaxNameCtxt name orig ty tidy_env = do { inst_loc <- getCtLocM orig (Just TypeLevel) - ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name) - <+> ptext (sLit "(needed by a syntactic construct)") - , nest 2 (ptext (sLit "has the required type:") + ; let msg = vcat [ text "When checking that" <+> quotes (ppr name) + <+> text "(needed by a syntactic construct)" + , nest 2 (text "has the required type:" <+> ppr (tidyType tidy_env ty)) , nest 2 (pprCtLoc inst_loc) ] ; return (tidy_env, msg) } @@ -524,7 +524,7 @@ newClsInst overlap_mode dfun_name tvs theta clas tys instOrphWarn :: ClsInst -> SDoc instOrphWarn inst - = hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst) + = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) $$ text "To avoid this" $$ nest 4 (vcat possibilities) where @@ -656,12 +656,12 @@ traceDFuns ispecs funDepErr :: ClsInst -> [ClsInst] -> TcRn () funDepErr ispec ispecs - = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:")) + = addClsInstsErr (text "Functional dependencies conflict between instance declarations:") (ispec : ispecs) dupInstErr :: ClsInst -> ClsInst -> TcRn () dupInstErr ispec dup_ispec - = addClsInstsErr (ptext (sLit "Duplicate instance declarations:")) + = addClsInstsErr (text "Duplicate instance declarations:") [ispec, dup_ispec] addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 688a1e9370..b80d5bd236 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -23,8 +23,6 @@ import TcRnMonad import SrcLoc import Outputable -import FastString - #ifndef GHCI tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] @@ -32,8 +30,8 @@ tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] tcAnnotations [] = return [] tcAnnotations anns@(L loc _ : _) = do { setSrcSpan loc $ addWarnTc $ - (ptext (sLit "Ignoring ANN annotation") <> plural anns <> comma - <+> ptext (sLit "because this is a stage-1 compiler or doesn't support GHCi")) + (text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler or doesn't support GHCi") ; return [] } #else @@ -55,8 +53,8 @@ tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do when (safeLanguageOn dflags) $ failWithTc safeHsErr runAnnotation target expr where - safeHsErr = vcat [ ptext (sLit "Annotations are not compatible with Safe Haskell.") - , ptext (sLit "See https://ghc.haskell.org/trac/ghc/ticket/10826") ] + safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ] annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name @@ -66,4 +64,4 @@ annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod annCtxt :: OutputableBndr id => AnnDecl id -> SDoc annCtxt ann - = hang (ptext (sLit "In the annotation:")) 2 (ppr ann) + = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 7f00d437fd..a781c0397e 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -31,7 +31,6 @@ import TysPrim import BasicTypes( Arity ) import SrcLoc import Outputable -import FastString import Util import Control.Monad @@ -168,7 +167,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if ; let r_ty = mkTyVarTy r_tv ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) - (ptext (sLit "Predicate type of `ifThenElse' depends on result type")) + (text "Predicate type of `ifThenElse' depends on result type") ; fun' <- tcSyntaxOp IfOrigin fun if_ty ; pred' <- tcMonoExpr pred pred_ty ; b1' <- tcCmd env b1 res_ty @@ -314,8 +313,8 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- This is where expressions that aren't commands get rejected tc_cmd _ cmd _ - = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), - ptext (sLit "was found where an arrow command was expected")]) + = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), + text "was found where an arrow command was expected"]) matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType) @@ -420,4 +419,4 @@ arrowTyConKind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind -} cmdCtxt :: HsCmd Name -> SDoc -cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd +cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index b306f93727..dacdafdff1 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -55,7 +55,6 @@ import Maybes import Util import BasicTypes import Outputable -import FastString import Type(mkStrLitTy, tidyOpenType) import PrelNames( mkUnboundName, gHC_PRIM, ipClassName ) import TcValidity (checkValidType) @@ -216,7 +215,7 @@ tcHsBootSigs binds sigs tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) badBootDeclErr :: MsgDoc -badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file") +badBootDeclErr = text "Illegal declarations in an hs-boot file" ------------------------ tcLocalBinds :: HsLocalBinds Name -> TcM thing @@ -439,10 +438,10 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a recursivePatSynErr binds = failWithTc $ - hang (ptext (sLit "Recursive pattern synonym definition with following bindings:")) + hang (text "Recursive pattern synonym definition with following bindings:") 2 (vcat $ map pprLBind . bagToList $ binds) where - pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc) + pprLoc loc = parens (text "defined at" <+> ppr loc) pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> pprLoc loc @@ -908,22 +907,22 @@ mk_impedence_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig }) inf_ty sig_ty tidy_env = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty - ; let msg = vcat [ ptext (sLit "When checking that the inferred type") + ; let msg = vcat [ text "When checking that the inferred type" , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty - , ptext (sLit "is as general as its") <+> what <+> ptext (sLit "signature") + , text "is as general as its" <+> what <+> text "signature" , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] ; return (tidy_env2, msg) } where what = case mb_sig of - Nothing -> ptext (sLit "inferred") - Just sig | isPartialSig sig -> ptext (sLit "(partial)") + Nothing -> text "inferred" + Just sig | isPartialSig sig -> text "(partial)" | otherwise -> empty mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_inf_msg poly_name poly_ty tidy_env = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty - ; let msg = vcat [ ptext (sLit "When checking the inferred type") + ; let msg = vcat [ text "When checking the inferred type" , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] ; return (tidy_env1, msg) } @@ -935,7 +934,7 @@ localSigWarn id mb_sig | not (isSigmaTy (idType id)) = return () | otherwise = warnMissingSig msg id where - msg = ptext (sLit "Polymorphic local binding with no type signature:") + msg = text "Polymorphic local binding with no type signature:" warnMissingSig :: SDoc -> Id -> TcM () warnMissingSig msg id @@ -1167,7 +1166,7 @@ mkPragEnv sigs binds -- add arity only for real INLINE pragmas, not INLINABLE = case lookupNameEnv ar_env n of Just ar -> inl_prag { inl_sat = Just ar } - Nothing -> WARN( True, ptext (sLit "mkPragEnv no arity") <+> ppr n ) + Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n ) -- There really should be a binding for every INLINE pragma inl_prag | otherwise @@ -1204,7 +1203,7 @@ tcSpecPrags poly_id prag_sigs is_bad_sig s = not (isSpecLSig s || isInlineLSig s) warn_discarded_sigs - = addWarnTc (hang (ptext (sLit "Discarding unexpected pragmas for") <+> ppr poly_id) + = addWarnTc (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) 2 (vcat (map (ppr . getLoc) bad_sigs))) -------------- @@ -1219,7 +1218,7 @@ tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl) -- what the user wrote (Trac #8537) = addErrCtxt (spec_ctxt prag) $ do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (ptext (sLit "SPECIALISE pragma for non-overloaded function") + (text "SPECIALISE pragma for non-overloaded function" <+> quotes (ppr fun_name)) -- Note [SPECIALISE pragmas] ; spec_prags <- mapM tc_one hs_tys @@ -1228,7 +1227,7 @@ tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl) where name = idName poly_id poly_ty = idType poly_id - spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag) tc_one hs_ty = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty @@ -1289,11 +1288,11 @@ tcImpSpec (name, prag) impSpecErr :: Name -> SDoc impSpecErr name - = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name)) - 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma") + = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) + 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" , parens $ sep - [ ptext (sLit "or its defining module") <+> quotes (ppr mod) - , ptext (sLit "was compiled without -O")]]) + [ text "or its defining module" <+> quotes (ppr mod) + , text "was compiled without -O"]]) where mod = nameModule name @@ -1316,7 +1315,7 @@ tcVectDecls decls where reportVectDups (first:_second:_more) = addErrAt (getSrcSpan first) $ - ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first + text "Duplicate vectorisation declarations for" <+> ppr first reportVectDups _ = return () -------------- @@ -1396,10 +1395,10 @@ tcVect (HsVectInstOut _) = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'" vectCtxt :: Outputable thing => thing -> SDoc -vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing +vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing scalarTyConMustBeNullary :: MsgDoc -scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary") +scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary" {- Note [SPECIALISE pragmas] @@ -1927,9 +1926,9 @@ data GeneralisationPlan -- no "polymorphic Id" and "monmomorphic Id"; there is just the one instance Outputable GeneralisationPlan where - ppr NoGen = ptext (sLit "NoGen") - ppr (InferGen b) = ptext (sLit "InferGen") <+> ppr b - ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s + ppr NoGen = text "NoGen" + ppr (InferGen b) = text "InferGen" <+> ppr b + ppr (CheckGen _ s) = text "CheckGen" <+> ppr s decideGeneralisationPlan :: DynFlags -> TcTypeEnv -> [Name] @@ -2089,17 +2088,17 @@ unliftedMustBeBang binds polyBindErr :: [LHsBind Name] -> SDoc polyBindErr binds - = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings")) + = hang (text "You can't mix polymorphic and unlifted bindings") 2 (vcat [vcat (map ppr binds), - ptext (sLit "Probable fix: add a type signature")]) + text "Probable fix: add a type signature"]) strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc strictBindErr flavour any_unlifted_bndr binds - = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) + = hang (text flavour <+> msg <+> text "aren't allowed:") 2 (vcat (map ppr binds)) where - msg | any_unlifted_bndr = ptext (sLit "bindings for unlifted types") - | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings") + msg | any_unlifted_bndr = text "bindings for unlifted types" + | otherwise = text "bang-pattern or unboxed-tuple bindings" {- Note [Compiling GHC.Prim] @@ -2129,7 +2128,7 @@ the common case.) -} -- and on RHS, when pat is TcId and grhss is still Name patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc patMonoBindsCtxt pat grhss - = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss) + = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) typeSigCtxt :: UserTypeCtxt -> TcIdSigBndr -> SDoc typeSigCtxt ctxt (PartialSig { sig_hs_ty = hs_ty }) diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 031c5dbb3f..d0c36261e3 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -37,7 +37,6 @@ import MonadUtils import Control.Monad import Data.List ( zip4, foldl' ) import BasicTypes -import FastString import Data.Bifunctor ( bimap ) @@ -1693,8 +1692,8 @@ instance Functor StopOrContinue where fmap _ (Stop ev s) = Stop ev s instance Outputable a => Outputable (StopOrContinue a) where - ppr (Stop ev s) = ptext (sLit "Stop") <> parens s <+> ppr ev - ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w + ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev + ppr (ContinueWith w) = text "ContinueWith" <+> ppr w continueWith :: a -> TcS (StopOrContinue a) continueWith = return . ContinueWith diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 6411fa980d..4fe42b08a3 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -211,7 +211,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ; spec_prags <- discardConstraints $ tcSpecPrags global_dm_id prags ; warnTc (not (null spec_prags)) - (ptext (sLit "Ignoring SPECIALISE pragmas on default method") + (text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name)) ; let hs_ty = lookupHsSig hs_sig_fn sel_name @@ -386,8 +386,8 @@ This makes the error messages right. -} tcMkDeclCtxt :: TyClDecl Name -> SDoc -tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl, - ptext (sLit "declaration for"), quotes (ppr (tcdName decl))] +tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, + text "declaration for", quotes (ppr (tcdName decl))] tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a tcAddDeclCtxt decl thing_inside @@ -395,44 +395,44 @@ tcAddDeclCtxt decl thing_inside badMethodErr :: Outputable a => a -> Name -> SDoc badMethodErr clas op - = hsep [ptext (sLit "Class"), quotes (ppr clas), - ptext (sLit "does not have a method"), quotes (ppr op)] + = hsep [text "Class", quotes (ppr clas), + text "does not have a method", quotes (ppr op)] badGenericMethod :: Outputable a => a -> Name -> SDoc badGenericMethod clas op - = hsep [ptext (sLit "Class"), quotes (ppr clas), - ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)] + = hsep [text "Class", quotes (ppr clas), + text "has a generic-default signature without a binding", quotes (ppr op)] {- badGenericInstanceType :: LHsBinds Name -> SDoc badGenericInstanceType binds - = vcat [ptext (sLit "Illegal type pattern in the generic bindings"), + = vcat [text "Illegal type pattern in the generic bindings", nest 2 (ppr binds)] missingGenericInstances :: [Name] -> SDoc missingGenericInstances missing - = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing + = text "Missing type patterns for" <+> pprQuotedList missing dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc dupGenericInsts tc_inst_infos - = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"), + = vcat [text "More than one type pattern for a single generic type constructor:", nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), - ptext (sLit "All the type patterns for a generic type constructor must be identical") + text "All the type patterns for a generic type constructor must be identical" ] where ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) -} badDmPrag :: Id -> Sig Name -> TcM () badDmPrag sel_id prag - = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method") + = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") <+> quotes (ppr sel_id) - <+> ptext (sLit "lacks an accompanying binding")) + <+> text "lacks an accompanying binding") warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc warningMinimalDefIncomplete mindef - = vcat [ ptext (sLit "The MINIMAL pragma does not require:") + = vcat [ text "The MINIMAL pragma does not require:" , nest 2 (pprBooleanFormulaNice mindef) - , ptext (sLit "but there is no default implementation.") ] + , text "but there is no default implementation." ] tcATDefault :: Bool -- If a warning should be emitted when a default instance -- definition is not provided by the user @@ -493,6 +493,6 @@ warnMissingAT name = do { warn <- woptM Opt_WarnMissingMethods ; traceTc "warn" (ppr name <+> ppr warn) ; warnTc warn -- Warn only if -Wmissing-methods - (ptext (sLit "No explicit") <+> text "associated type" - <+> ptext (sLit "or default declaration for ") + (text "No explicit" <+> text "associated type" + <+> text "or default declaration for " <+> quotes (ppr name)) } diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs index fb43bebf45..f45dd633bf 100644 --- a/compiler/typecheck/TcDefaults.hs +++ b/compiler/typecheck/TcDefaults.hs @@ -81,21 +81,21 @@ check_instance ty cls ; return (isJust mb_res) } defaultDeclCtxt :: SDoc -defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration") +defaultDeclCtxt = text "When checking the types in a default declaration" dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things) - = hang (ptext (sLit "Multiple default declarations")) + = hang (text "Multiple default declarations") 2 (vcat (map pp dup_things)) where - pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn + pp (L locn (DefaultDecl _)) = text "here was another default declaration" <+> ppr locn dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" polyDefErr :: LHsType Name -> SDoc polyDefErr ty - = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 2 (ppr ty) + = hang (text "Illegal polymorphic type in default declaration" <> colon) 2 (ppr ty) badDefaultTy :: Type -> [Class] -> SDoc badDefaultTy ty deflt_clss - = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) - 2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss)) + = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) + 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index c790956fa8..385aa5dc41 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -174,8 +174,8 @@ instance Outputable theta => Outputable (DerivSpec theta) where ppr = pprDerivSpec instance Outputable EarlyDerivSpec where - ppr (InferTheta spec) = ppr spec <+> ptext (sLit "(Infer)") - ppr (GivenTheta spec) = ppr spec <+> ptext (sLit "(Given)") + ppr (InferTheta spec) = ppr spec <+> text "(Infer)" + ppr (GivenTheta spec) = ppr spec <+> text "(Given)" instance Outputable PredOrigin where ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging @@ -368,7 +368,7 @@ tcDeriving deriv_infos deriv_decls -> Bag FamInst -- ^ Rep type family instances -> SDoc ddump_deriving inst_infos extra_binds repFamInsts - = hang (ptext (sLit "Derived instances:")) + = hang (text "Derived instances:") 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) $$ ppr extra_binds) $$ hangP "GHC.Generics representation types:" @@ -379,7 +379,7 @@ tcDeriving deriv_infos deriv_decls -- Prints the representable type family instance pprRepTy :: FamInst -> SDoc pprRepTy fi@(FamInst { fi_tys = lhs }) - = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> + = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> equals <+> ppr rhs where rhs = famInstRHS fi @@ -495,8 +495,8 @@ makeDerivSpecs is_boot deriv_infos deriv_decls where add_deriv_err eqn = setSrcSpan (earlyDSLoc eqn) $ - addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) - 2 (ptext (sLit "Use an instance declaration instead"))) + addErr (hang (text "Deriving not permitted in hs-boot file") + 2 (text "Use an instance declaration instead")) ------------------------------------------------------------------ -- | Process a `deriving` clause @@ -554,15 +554,15 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode)) _ -> -- Complain about functions, primitive types, etc, failWithTc $ derivingThingErr False cls cls_tys inst_ty $ - ptext (sLit "The last argument of the instance must be a data or newtype application") + text "The last argument of the instance must be a data or newtype application" } warnUselessTypeable :: TcM () warnUselessTypeable = do { warn <- woptM Opt_WarnDerivingTypeable ; when warn $ addWarnTc - $ ptext (sLit "Deriving") <+> quotes (ppr typeableClassName) <+> - ptext (sLit "has no effect: all types now auto-derive Typeable") } + $ text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" } ------------------------------------------------------------------ deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance @@ -752,7 +752,7 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args -- If it's still a data family, the lookup failed; i.e no instance exists ; when (isDataFamilyTyCon rep_tc) - (bale_out (ptext (sLit "No family instance for") <+> quotes (pprTypeApp tycon tc_args))) + (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args))) -- For standalone deriving (mtheta /= Nothing), -- check that all the data constructors are in scope. @@ -1118,12 +1118,12 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args classArgsErr :: Class -> [Type] -> SDoc -classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") +classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" nonStdErr :: Class -> SDoc nonStdErr cls = quotes (ppr cls) - <+> ptext (sLit "is not a standard derivable class (Eq, Show, etc.)") + <+> text "is not a standard derivable class (Eq, Show, etc.)" sideConditions :: DerivContext -> Class -> Maybe Condition -- Side conditions for classes that GHC knows about, @@ -1174,10 +1174,10 @@ canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc -- Precondition: the class is not one of the standard ones canDeriveAnyClass dflags _tycon clas | not (xopt LangExt.DeriveAnyClass dflags) - = Just (ptext (sLit "Try enabling DeriveAnyClass")) + = Just (text "Try enabling DeriveAnyClass") | not (any (target_kind `tcEqKind`) [ liftedTypeKind, typeToTypeKind ]) - = Just (ptext (sLit "The last argument of class") <+> quotes (ppr clas) - <+> ptext (sLit "does not have kind * or (* -> *)")) + = Just (text "The last argument of class" <+> quotes (ppr clas) + <+> text "does not have kind * or (* -> *)") | otherwise = Nothing -- OK! where @@ -1202,7 +1202,7 @@ orCond c1 c2 tc = case (c1 tc, c2 tc) of (IsValid, _) -> IsValid -- c1 succeeds (_, IsValid) -> IsValid -- c21 succeeds - (NotValid x, NotValid y) -> NotValid (x $$ ptext (sLit " or") $$ y) + (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) -- Both fail andCond :: Condition -> Condition -> Condition @@ -1223,22 +1223,22 @@ cond_stdOK Nothing permissive (_, rep_tc, _) | not (null con_whys) = NotValid (vcat con_whys $$ suggestion) | otherwise = IsValid where - suggestion = ptext (sLit "Possible fix: use a standalone deriving declaration instead") + suggestion = text "Possible fix: use a standalone deriving declaration instead" data_cons = tyConDataCons rep_tc con_whys = getInvalids (map check_con data_cons) check_con :: DataCon -> Validity check_con con | not (isVanillaDataCon con) - = NotValid (badCon con (ptext (sLit "has existentials or constraints in its type"))) + = NotValid (badCon con (text "has existentials or constraints in its type")) | not (permissive || all isTauTy (dataConOrigArgTys con)) - = NotValid (badCon con (ptext (sLit "has a higher-rank type"))) + = NotValid (badCon con (text "has a higher-rank type")) | otherwise = IsValid no_cons_why :: TyCon -> SDoc no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "must have at least one data constructor") + text "must have at least one data constructor" cond_RepresentableOk :: Condition cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args @@ -1256,8 +1256,8 @@ cond_args :: Class -> Condition cond_args cls (_, tc, _) = case bad_args of [] -> IsValid - (ty:_) -> NotValid (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) - 2 (ptext (sLit "for type") <+> quotes (ppr ty))) + (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) + 2 (text "for type" <+> quotes (ppr ty))) where bad_args = [ arg_ty | con <- tyConDataCons tc , arg_ty <- dataConOrigArgTys con @@ -1282,8 +1282,8 @@ cond_isEnumeration (_, rep_tc, _) | otherwise = NotValid why where why = sep [ quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "must be an enumeration type") - , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ] + text "must be an enumeration type" + , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] -- See Note [Enumeration types] in TyCon cond_isProduct :: Condition @@ -1292,7 +1292,7 @@ cond_isProduct (_, rep_tc, _) | otherwise = NotValid why where why = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "must have precisely one constructor") + text "must have precisely one constructor" cond_functorOK :: Bool -> Bool -> Condition -- OK for Functor/Foldable/Traversable class @@ -1303,12 +1303,12 @@ cond_functorOK :: Bool -> Bool -> Condition -- (e) no "stupid context" on data type cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc, _) | null tc_tvs - = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must have some type parameters")) + = NotValid (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters") | not (null bad_stupid_theta) - = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must not have a class context:") <+> pprTheta bad_stupid_theta) + = NotValid (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) | otherwise = allValid (map check_con data_cons) @@ -1343,18 +1343,18 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc, _) , ft_bad_app = NotValid (badCon con wrong_arg) , ft_forall = \_ x -> x } - existential = ptext (sLit "must be truly polymorphic in the last argument of the data type") - covariant = ptext (sLit "must not use the type variable in a function argument") - functions = ptext (sLit "must not contain function types") - wrong_arg = ptext (sLit "must use the type variable only as the last argument of a data type") + existential = text "must be truly polymorphic in the last argument of the data type" + covariant = text "must not use the type variable in a function argument" + functions = text "must not contain function types" + wrong_arg = text "must use the type variable only as the last argument of a data type" checkFlag :: LangExt.Extension -> Condition checkFlag flag (dflags, _, _) | xopt flag dflags = IsValid | otherwise = NotValid why where - why = ptext (sLit "You need ") <> text flag_str - <+> ptext (sLit "to derive an instance for this class") + why = text "You need " <> text flag_str + <+> text "to derive an instance for this class" flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of [s] -> s other -> pprPanic "checkFlag" (ppr other) @@ -1381,7 +1381,7 @@ non_coercible_class cls , traversableClassKey, liftClassKey ]) badCon :: DataCon -> SDoc -> SDoc -badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg +badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg {- Note [Check that the type variable is truly universal] @@ -1500,8 +1500,8 @@ mkNewTypeEqn dflags overlap_mode tvs -- CanDerive/DerivableViaInstance _ -> do when (newtype_deriving && deriveAnyClass) $ - addWarnTc (sep [ ptext (sLit "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled") - , ptext (sLit "Defaulting to the DeriveAnyClass strategy for instantiating") <+> ppr cls ]) + addWarnTc (sep [ text "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled" + , text "Defaulting to the DeriveAnyClass strategy for instantiating" <+> ppr cls ]) go_for_it where newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags @@ -1512,7 +1512,7 @@ mkNewTypeEqn dflags overlap_mode tvs bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty non_std = nonStdErr cls - suggest_gnd = ptext (sLit "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension") + suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension" -- Here is the plan for newtype derivings. We see -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...) @@ -1623,8 +1623,8 @@ mkNewTypeEqn dflags overlap_mode tvs cant_derive_err = vcat [ ppUnless eta_ok eta_msg , ppUnless ats_ok ats_msg ] - eta_msg = ptext (sLit "cannot eta-reduce the representation type enough") - ats_msg = ptext (sLit "the class has associated types") + eta_msg = text "cannot eta-reduce the representation type enough" + ats_msg = text "the class has associated types" {- Note [Recursive newtypes] @@ -1846,7 +1846,7 @@ simplifyDeriv pred tvs theta ; let skol_set = mkVarSet tvs_skols skol_info = DerivSkol pred - doc = ptext (sLit "deriving") <+> parens (ppr pred) + doc = text "deriving" <+> parens (ppr pred) mk_ct (PredOrigin t o t_or_k) = newWanted o (Just t_or_k) (substTy skol_subst t) @@ -2137,7 +2137,7 @@ getDataConFixityFun tc ; return (mi_fix iface . nameOccName) } } where name = tyConName tc - doc = ptext (sLit "Data con fixities for") <+> ppr name + doc = text "Data con fixities for" <+> ppr name {- Note [Bindings for Generalised Newtype Deriving] @@ -2194,41 +2194,41 @@ the empty instance declaration case). -} derivingNullaryErr :: MsgDoc -derivingNullaryErr = ptext (sLit "Cannot derive instances for nullary classes") +derivingNullaryErr = text "Cannot derive instances for nullary classes" derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc derivingKindErr tc cls cls_tys cls_kind - = hang (ptext (sLit "Cannot derive well-kinded instance of form") - <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "...")))) - 2 (ptext (sLit "Class") <+> quotes (ppr cls) - <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind)) + = hang (text "Cannot derive well-kinded instance of form" + <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> text "..."))) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" <+> quotes (pprKind cls_kind)) derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc derivingEtaErr cls cls_tys inst_ty - = sep [ptext (sLit "Cannot eta-reduce to an instance of form"), - nest 2 (ptext (sLit "instance (...) =>") + = sep [text "Cannot eta-reduce to an instance of form", + nest 2 (text "instance (...) =>" <+> pprClassPred cls (cls_tys ++ [inst_ty]))] derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc derivingThingErr newtype_deriving clas tys ty why - = sep [(hang (ptext (sLit "Can't make a derived instance of")) + = sep [(hang (text "Can't make a derived instance of") 2 (quotes (ppr pred)) $$ nest 2 extra) <> colon, nest 2 why] where - extra | newtype_deriving = ptext (sLit "(even with cunning GeneralizedNewtypeDeriving)") + extra | newtype_deriving = text "(even with cunning GeneralizedNewtypeDeriving)" | otherwise = Outputable.empty pred = mkClassPred clas (tys ++ [ty]) derivingHiddenErr :: TyCon -> SDoc derivingHiddenErr tc - = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) - 2 (ptext (sLit "so you cannot derive an instance for it")) + = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) + 2 (text "so you cannot derive an instance for it") standaloneCtxt :: LHsSigType Name -> SDoc -standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) +standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") 2 (quotes (ppr ty)) derivInstCtxt :: PredType -> MsgDoc derivInstCtxt pred - = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) + = text "When deriving the instance for" <+> parens (ppr pred) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 17a9b9bf97..f86156b1b1 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -221,13 +221,13 @@ tcLookupInstance :: Class -> [Type] -> TcM ClsInst tcLookupInstance cls tys = do { instEnv <- tcGetInstEnvs ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> failWithTc $ ptext (sLit "Couldn't match instance:") <+> err + Left err -> failWithTc $ text "Couldn't match instance:" <+> err Right (inst, tys) | uniqueTyVars tys -> return inst | otherwise -> failWithTc errNotExact } where - errNotExact = ptext (sLit "Not an exact match (i.e., some variables get instantiated)") + errNotExact = text "Not an exact match (i.e., some variables get instantiated)" uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map (getTyVar "tcLookupInstance") tys) @@ -675,16 +675,16 @@ checkWellStaged pp_thing bind_lvl use_lvl | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) - ptext (sLit "Stage error:") <+> pp_thing <+> - hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl, - ptext (sLit "but used at stage") <+> ppr use_lvl] + text "Stage error:" <+> pp_thing <+> + hsep [text "is bound at stage" <+> ppr bind_lvl, + text "but used at stage" <+> ppr use_lvl] stageRestrictionError :: SDoc -> TcM a stageRestrictionError pp_thing = failWithTc $ - sep [ ptext (sLit "GHC stage restriction:") - , nest 2 (vcat [ pp_thing <+> ptext (sLit "is used in a top-level splice, quasi-quote, or annotation,") - , ptext (sLit "and must be imported, not defined locally")])] + sep [ text "GHC stage restriction:" + , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," + , text "and must be imported, not defined locally"])] topIdLvl :: Id -> ThLevel -- Globals may either be imported, or may be from an earlier "chunk" @@ -822,7 +822,7 @@ instance OutputableBndr a => Outputable (InstInfo a) where pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc pprInstInfoDetails info - = hang (pprInstanceHdr (iSpec info) <+> ptext (sLit "where")) + = hang (pprInstanceHdr (iSpec info) <+> text "where") 2 (details (iBinds info)) where details (InstBindings { ib_binds = b }) = pprLHsBinds b @@ -957,9 +957,9 @@ notFound name ; case stage of -- See Note [Out of scope might be a staging error] Splice {} -> stageRestrictionError (quotes (ppr name)) _ -> failWithTc $ - vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> - ptext (sLit "is not in scope during type checking, but it passed the renamer"), - ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl_env)] + vcat[text "GHC internal error:" <+> quotes (ppr name) <+> + text "is not in scope during type checking, but it passed the renamer", + text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] -- Take care: printing the whole gbl env can -- cause an infinite loop, in the case where we -- are in the middle of a recursive TyCon/Class group; @@ -973,7 +973,7 @@ wrongThingErr :: String -> TcTyThing -> Name -> TcM a -- See Note [Placeholder PatSyn kinds] in TcBinds wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - ptext (sLit "used as a") <+> text expected) + text "used as a" <+> text expected) {- Note [Out of scope might be a staging error] diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index a878aa7f95..8a2b0ad6df 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -324,7 +324,7 @@ warnRedundantConstraints ctxt env info ev_vars | SigSkol {} <- info = setLclEnv env $ -- We want to add "In the type signature for f" -- to the error context, which is a bit tiresome - addErrCtxt (ptext (sLit "In") <+> ppr info) $ + addErrCtxt (text "In" <+> ppr info) $ do { env <- getLclEnv ; msg <- mkErrorReport ctxt env (important doc) ; reportWarning msg } @@ -335,7 +335,7 @@ warnRedundantConstraints ctxt env info ev_vars = do { msg <- mkErrorReport ctxt env (important doc) ; reportWarning msg } where - doc = ptext (sLit "Redundant constraint") <> plural redundant_evs <> colon + doc = text "Redundant constraint" <> plural redundant_evs <> colon <+> pprEvVarTheta redundant_evs redundant_evs = case info of -- See Note [Redundant constraints in instance decls] @@ -364,8 +364,8 @@ This only matters in instance declarations.. reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) - = do { traceTc "reportWanteds" (vcat [ ptext (sLit "Simples =") <+> ppr simples - , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)]) + = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples + , text "Suppress =" <+> ppr (cec_suppress ctxt)]) ; let tidy_cts = bagToList (mapBag (tidyCt env) (insols `unionBags` simples)) -- First deal with things that are utterly wrong @@ -860,30 +860,30 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) | otherwise = hang herald 2 pp_with_type pp_with_type = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - herald | isDataOcc occ = ptext (sLit "Data constructor not in scope:") - | otherwise = ptext (sLit "Variable not in scope:") + herald | isDataOcc occ = text "Data constructor not in scope:" + | otherwise = text "Variable not in scope:" hole_msg = case hole_sort of - ExprHole -> vcat [ hang (ptext (sLit "Found hole:")) + ExprHole -> vcat [ hang (text "Found hole:") 2 pp_with_type , tyvars_msg, expr_hole_hint ] - TypeHole -> vcat [ hang (ptext (sLit "Found type wildcard") <+> quotes (ppr occ)) - 2 (ptext (sLit "standing for") <+> quotes (pprType hole_ty)) + TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) + 2 (text "standing for" <+> quotes (pprType hole_ty)) , tyvars_msg, type_hole_hint ] tyvars_msg = ppUnless (null tyvars) $ - ptext (sLit "Where:") <+> vcat (map loc_msg tyvars) + text "Where:" <+> vcat (map loc_msg tyvars) type_hole_hint | HoleError <- cec_type_holes ctxt - = ptext (sLit "To use the inferred type, enable PartialTypeSignatures") + = text "To use the inferred type, enable PartialTypeSignatures" | otherwise = empty expr_hole_hint -- Give hint for, say, f x = _x | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" - = ptext (sLit "Or perhaps") <+> quotes (ppr occ) - <+> ptext (sLit "is mis-spelled, or not in scope") + = text "Or perhaps" <+> quotes (ppr occ) + <+> text "is mis-spelled, or not in scope" | otherwise = empty @@ -891,7 +891,7 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) | isTyVar tv = case tcTyVarDetails tv of SkolemTv {} -> pprSkol (cec_encl ctxt) tv - MetaTv {} -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable") + MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" det -> pprTcTyVarDetails det | otherwise = sdocWithDynFlags $ \dflags -> @@ -910,7 +910,7 @@ mkIPErr ctxt cts givens = getUserGivens ctxt msg | null givens = addArising orig $ - sep [ ptext (sLit "Unbound implicit parameter") <> plural cts + sep [ text "Unbound implicit parameter" <> plural cts , nest 2 (pprTheta preds) ] | otherwise = couldNotDeduce givens (preds, orig) @@ -988,7 +988,7 @@ mkEqErr1 ctxt ct -- with one from the implication. See Note [Inaccessible code] mk_given loc [] = (loc, empty) mk_given loc (implic : _) = (setCtLocEnv loc (ic_env implic) - , hang (ptext (sLit "Inaccessible code in")) + , hang (text "Inaccessible code in") 2 (ppr (ic_info implic))) -- If the types in the error message are the same as the types @@ -1146,10 +1146,10 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 ; mkErrorMsgFromCt ctxt ct $ mconcat [occCheckMsg, extra2, report] } | OC_Forall <- occ_check_expand - = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable") + = do { let msg = vcat [ text "Cannot instantiate unification variable" <+> quotes (ppr tv1) , hang (text "with a" <+> what <+> text "involving foralls:") 2 (ppr ty2) - , nest 2 (ptext (sLit "GHC doesn't yet support impredicative polymorphism")) ] + , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ] -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely -- to be helpful since this is just an unimplemented feature. @@ -1176,9 +1176,9 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols <+> pprQuotedList esc_skols - , ptext (sLit "would escape") <+> - if isSingleton esc_skols then ptext (sLit "its scope") - else ptext (sLit "their scope") ] + , text "would escape" <+> + if isSingleton esc_skols then text "its scope" + else text "their scope" ] tv_extra = important $ vcat [ nest 2 $ esc_doc , sep [ (if isSingleton esc_skols @@ -1186,9 +1186,9 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 what <+> text "variable is" else text "These (rigid, skolem)" <+> what <+> text "variables are") - <+> ptext (sLit "bound by") + <+> text "bound by" , nest 2 $ ppr skol_info - , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ] + , nest 2 $ text "at" <+> ppr (tcl_loc env) ] ] ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) } -- Nastiest case: attempt to unify an untouchable variable @@ -1197,10 +1197,10 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 tclvl_extra = important $ nest 2 $ - sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable") - , nest 2 $ ptext (sLit "inside the constraints:") <+> pprEvVarTheta given - , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info - , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] + sep [ quotes (ppr tv1) <+> text "is untouchable" + , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given + , nest 2 $ text "bound by" <+> ppr skol_info + , nest 2 $ text "at" <+> ppr (tcl_loc env) ] tv_extra = important $ extraTyVarInfo ctxt tv1 ty2 add_sig = important $ suggestAddSig ctxt ty1 ty2 ; mkErrorMsgFromCt ctxt ct $ mconcat @@ -1249,8 +1249,8 @@ mkEqInfoMsg ct ty1 ty2 tyfun_msg | Just tc1 <- mb_fun1 , Just tc2 <- mb_fun2 , tc1 == tc2 - = ptext (sLit "NB:") <+> quotes (ppr tc1) - <+> ptext (sLit "is a type function, and may not be injective") + = text "NB:" <+> quotes (ppr tc1) + <+> text "is a type function, and may not be injective" | otherwise = empty isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool @@ -1285,20 +1285,20 @@ misMatchOrCND ctxt ct oriented ty1 ty2 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce givens (wanteds, orig) - = vcat [ addArising orig (ptext (sLit "Could not deduce:") <+> pprTheta wanteds) + = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) , vcat (pp_givens givens)] pp_givens :: [UserGiven] -> [SDoc] pp_givens givens = case givens of [] -> [] - (g:gs) -> ppr_given (ptext (sLit "from the context:")) g - : map (ppr_given (ptext (sLit "or from:"))) gs + (g:gs) -> ppr_given (text "from the context:") g + : map (ppr_given (text "or from:")) gs where ppr_given herald (gs, skol_info, _, loc) = hang (herald <+> pprEvVarTheta gs) - 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info - , ptext (sLit "at") <+> ppr loc]) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> ppr loc]) extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc -- Add on extra info about skolem constants @@ -1315,8 +1315,8 @@ extraTyVarInfo ctxt tv1 ty2 , let pp_tv = quotes (ppr tv) = case tcTyVarDetails tv of SkolemTv {} -> pprSkol implics tv - FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") - RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") + FlatSkol {} -> pp_tv <+> text "is a flattening type variable" + RuntimeUnk {} -> pp_tv <+> text "is an interactive-debugger skolem" MetaTv {} -> empty | otherwise -- Normal case @@ -1328,9 +1328,9 @@ suggestAddSig ctxt ty1 ty2 | null inferred_bndrs = empty | [bndr] <- inferred_bndrs - = ptext (sLit "Possible fix: add a type signature for") <+> quotes (ppr bndr) + = text "Possible fix: add a type signature for" <+> quotes (ppr bndr) | otherwise - = ptext (sLit "Possible fix: add type signatures for some or all of") <+> (ppr inferred_bndrs) + = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) where inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) get_inf ty | Just tv <- tcGetTyVar_maybe ty @@ -1623,19 +1623,19 @@ sameOccExtra ty1 ty2 same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2) , n1 /= n2 -- Different Names , same_occ -- but same OccName - = ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) | otherwise = empty where ppr_from same_pkg nm | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> ptext (sLit "is defined at")) + = hang (quotes (ppr nm) <+> text "is defined at") 2 (ppr loc) | otherwise -- Imported things have an UnhelpfulSrcSpan = hang (quotes (ppr nm)) - 2 (sep [ ptext (sLit "is defined in") <+> quotes (ppr (moduleName mod)) + 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) , ppUnless (same_pkg || pkg == mainUnitId) $ - nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ]) + nest 4 $ text "in package" <+> quotes (ppr pkg) ]) where pkg = moduleUnitId mod mod = nameModule nm @@ -1803,7 +1803,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) = vcat [ ppWhen lead_with_ambig $ text "Probable fix: use a type annotation to specify what" <+> pprQuotedList ambig_tvs <+> text "should be." - , ptext (sLit "These potential instance") <> plural unifiers + , text "These potential instance" <> plural unifiers <+> text "exist:"] -- Report "potential instances" only when the constraint arises @@ -1814,24 +1814,24 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) add_to_ctxt_fixes has_ambig_tvs | not has_ambig_tvs && all_tyvars , (orig:origs) <- usefulContext ctxt pred - = [sep [ ptext (sLit "add") <+> pprParendType pred - <+> ptext (sLit "to the context of") + = [sep [ text "add" <+> pprParendType pred + <+> text "to the context of" , nest 2 $ ppr_skol orig $$ - vcat [ ptext (sLit "or") <+> ppr_skol orig + vcat [ text "or" <+> ppr_skol orig | orig <- origs ] ] ] | otherwise = [] - ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) + ppr_skol (PatSkol dc _) = text "the data constructor" <+> quotes (ppr dc) ppr_skol skol_info = ppr skol_info extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = ptext (sLit "(maybe you haven't applied a function to enough arguments?)") + = text "(maybe you haven't applied a function to enough arguments?)" | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) , Just (tc,_) <- tcSplitTyConApp_maybe ty , not (isTypeFamilyTyCon tc) - = hang (ptext (sLit "GHC can't yet do polykinded")) - 2 (ptext (sLit "Typeable") <+> + = hang (text "GHC can't yet do polykinded") + 2 (text "Typeable" <+> parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) | otherwise = empty @@ -1842,22 +1842,22 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) DerivOriginCoerce {} -> [drv_fix] _ -> [] - drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,")) - 2 (ptext (sLit "so you can specify the instance context yourself")) + drv_fix = hang (text "use a standalone 'deriving instance' declaration,") + 2 (text "so you can specify the instance context yourself") -- Normal overlap error overlap_msg = ASSERT( not (null matches) ) - vcat [ addArising orig (ptext (sLit "Overlapping instances for") + vcat [ addArising orig (text "Overlapping instances for" <+> pprType (mkClassPred clas tys)) , ppUnless (null matching_givens) $ - sep [ptext (sLit "Matching givens (or their superclasses):") + sep [text "Matching givens (or their superclasses):" , nest 2 (vcat matching_givens)] , sdocWithDynFlags $ \dflags -> getPprStyle $ \sty -> - pprPotentials dflags sty (ptext (sLit "Matching instances:")) $ + pprPotentials dflags sty (text "Matching instances:") $ ispecs ++ unifiers , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ @@ -1867,15 +1867,15 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) -- constraints are non-flat and non-rewritten so we -- simply report back the whole given -- context. Accelerate Smart.hs showed this problem. - sep [ ptext (sLit "There exists a (perhaps superclass) match:") + sep [ text "There exists a (perhaps superclass) match:" , nest 2 (vcat (pp_givens givens))] , ppWhen (isSingleton matches) $ - parens (vcat [ ptext (sLit "The choice depends on the instantiation of") <+> + parens (vcat [ text "The choice depends on the instantiation of" <+> quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys)) , ppWhen (null (matching_givens)) $ - vcat [ ptext (sLit "To pick the first instance above, use IncoherentInstances") - , ptext (sLit "when compiling the other instance declarations")] + vcat [ text "To pick the first instance above, use IncoherentInstances" + , text "when compiling the other instance declarations"] ])] where givens = getUserGivens ctxt @@ -1885,8 +1885,8 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) = case ev_vars_matching of [] -> Nothing _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info - , ptext (sLit "at") <+> ppr loc]) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> ppr loc]) where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) ev_var_matches ty = case getClassPredTys_maybe ty of Just (clas', tys') @@ -1900,17 +1900,18 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) -- Overlap error because of Safe Haskell (first -- match should be the most specific match) safe_haskell_msg - = ASSERT( length matches == 1 && not (null unsafe_ispecs) ) - vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") - <+> pprType (mkClassPred clas tys)) - , sep [ptext (sLit "The matching instance is:"), - nest 2 (pprInstance $ head ispecs)] - , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only" - , ptext $ sLit "overlap instances from the same module, however it" - , ptext $ sLit "overlaps the following instances from different modules:" - , nest 2 (vcat [pprInstances $ unsafe_ispecs]) - ] - ] + = ASSERT( length matches == 1 && not (null unsafe_ispecs) ) + vcat [ addArising orig (text "Unsafe overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , sep [text "The matching instance is:", + nest 2 (pprInstance $ head ispecs)] + , vcat [ text "It is compiled in a Safe module and as such can only" + , text "overlap instances from the same module, however it" + , text "overlaps the following instances from different" <+> + text "modules:" + , nest 2 (vcat [pprInstances $ unsafe_ispecs]) + ] + ] {- Note [Highlighting ambiguous type variables] ----------------------------------------------- @@ -1955,8 +1956,8 @@ usefulContext ctxt pred show_fixes :: [SDoc] -> SDoc show_fixes [] = empty -show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") - , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] +show_fixes (f:fs) = sep [ text "Possible fix:" + , nest 2 (vcat (f : map (text "or" <+>) fs))] pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc -- See Note [Displaying potential instances] @@ -1973,9 +1974,9 @@ pprPotentials dflags sty herald insts = hang herald 2 (vcat [ pprInstances show_these , ppWhen (n_in_scope_hidden > 0) $ - ptext (sLit "...plus") - <+> speakNOf n_in_scope_hidden (ptext (sLit "other")) - , not_in_scope_msg (ptext (sLit "...plus")) + text "...plus" + <+> speakNOf n_in_scope_hidden (text "other") + , not_in_scope_msg (text "...plus") , flag_hint ]) where n_show = 3 :: Int @@ -2012,11 +2013,11 @@ pprPotentials dflags sty herald insts = empty | otherwise = hang (herald <+> speakNOf (length not_in_scope) - (ptext (sLit "instance involving out-of-scope types"))) + (text "instance involving out-of-scope types")) 2 (ppWhen show_potentials (pprInstances not_in_scope)) flag_hint = ppUnless (show_potentials || length show_these == length insts) $ - ptext (sLit "(use -fprint-potential-instances to see them all)") + text "(use -fprint-potential-instances to see them all)" {- Note [Displaying potential instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2076,46 +2077,46 @@ mkAmbigMsg prepend_msg ct msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] || any isRuntimeUnkSkol ambig_tvs - = vcat [ ptext (sLit "Cannot resolve unknown runtime type") + = vcat [ text "Cannot resolve unknown runtime type" <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , ptext (sLit "Use :print or :force to determine these types")] + , text "Use :print or :force to determine these types"] | not (null ambig_tvs) - = pp_ambig (ptext (sLit "type")) ambig_tvs + = pp_ambig (text "type") ambig_tvs | otherwise -- All ambiguous kind variabes; suggest -fprint-explicit-kinds - = vcat [ pp_ambig (ptext (sLit "kind")) ambig_kvs + = vcat [ pp_ambig (text "kind") ambig_kvs , sdocWithDynFlags suggest_explicit_kinds ] pp_ambig what tkvs | prepend_msg -- "Ambiguous type variable 't0'" - = ptext (sLit "Ambiguous") <+> what <+> ptext (sLit "variable") + = text "Ambiguous" <+> what <+> text "variable" <> plural tkvs <+> pprQuotedList tkvs | otherwise -- "The type variable 't0' is ambiguous" - = ptext (sLit "The") <+> what <+> ptext (sLit "variable") <> plural tkvs - <+> pprQuotedList tkvs <+> is_or_are tkvs <+> ptext (sLit "ambiguous") + = text "The" <+> what <+> text "variable" <> plural tkvs + <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous" is_or_are [_] = text "is" is_or_are _ = text "are" suggest_explicit_kinds dflags -- See Note [Suggest -fprint-explicit-kinds] | gopt Opt_PrintExplicitKinds dflags = empty - | otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments") + | otherwise = text "Use -fprint-explicit-kinds to see the kind arguments" pprSkol :: [Implication] -> TcTyVar -> SDoc pprSkol implics tv | (skol_tvs, skol_info) <- getSkolemInfo implics tv = case skol_info of - UnkSkol -> pp_tv <+> ptext (sLit "is an unknown type variable") + UnkSkol -> pp_tv <+> text "is an unknown type variable" SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt (mkSpecForAllTys skol_tvs ty)) _ -> ppr_rigid (pprSkolInfo skol_info) where pp_tv = quotes (ppr tv) - ppr_rigid pp_info = hang (pp_tv <+> ptext (sLit "is a rigid type variable bound by")) + ppr_rigid pp_info = hang (pp_tv <+> text "is a rigid type variable bound by") 2 (sep [ pp_info - , ptext (sLit "at") <+> ppr (getSrcLoc tv) ]) + , text "at" <+> ppr (getSrcLoc tv) ]) getAmbigTkvs :: Ct -> ([Var],[Var]) getAmbigTkvs ct @@ -2176,7 +2177,7 @@ relevantBindings want_filtering ctxt ct -- which are probably the most relevant ones ; let doc = ppUnless (null docs) $ - hang (ptext (sLit "Relevant bindings include")) + hang (text "Relevant bindings include") 2 (vcat docs $$ ppWhen discards discardMsg) -- Put a zonked, tidied CtOrigin into the Ct @@ -2209,7 +2210,7 @@ relevantBindings want_filtering ctxt ct ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty) ; let id_tvs = tyCoVarsOfType tidy_ty doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (ptext (sLit "bound at") + , nest 2 (parens (text "bound at" <+> ppr (getSrcLoc id)))] new_seen = tvs_seen `unionVarSet` id_tvs @@ -2233,7 +2234,8 @@ relevantBindings want_filtering ctxt ct else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } discardMsg :: SDoc -discardMsg = ptext (sLit "(Some bindings suppressed; use -fmax-relevant-binds=N or -fno-max-relevant-binds)") +discardMsg = text "(Some bindings suppressed;" <+> + text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" ----------------------- warnDefaulting :: [Ct] -> Type -> TcM () diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index cca1684a24..517e724e69 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -652,7 +652,7 @@ Important Details: mkEvCast :: EvTerm -> TcCoercion -> EvTerm mkEvCast ev lco - | ASSERT2(tcCoercionRole lco == Representational, (vcat [ptext (sLit "Coercion of wrong role passed to mkEvCast:"), ppr ev, ppr lco])) + | ASSERT2(tcCoercionRole lco == Representational, (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco])) isTcReflCo lco = ev | otherwise = EvCast ev lco @@ -725,7 +725,7 @@ evVarsOfTypeable ev = -} instance Outputable HsWrapper where - ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn + ppr co_fn = pprHsWrapper (text "<>") co_fn pprHsWrapper :: SDoc -> HsWrapper -> SDoc -- In debug mode, print the wrapper @@ -741,15 +741,15 @@ pprHsWrapper doc wrap -- False <=> appears as body of let or lambda help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpFun f1 f2 t1) = add_parens $ ptext (sLit "\\(x") <> dcolon <> ppr t1 <> ptext (sLit ").") <+> - help (\_ -> it True <+> help (\_ -> ptext (sLit "x")) f1 True) f2 False - help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") + help it (WpFun f1 f2 t1) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> + help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False + help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" <+> pprParendCo co)] help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] - help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] - help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] - help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False] - help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False] + help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pp_bndr id, it False] + help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pp_bndr tv, it False] + help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] pp_bndr v = pprBndr LambdaBind v <> dot @@ -760,10 +760,10 @@ pprHsWrapper doc wrap instance Outputable TcEvBinds where ppr (TcEvBinds v) = ppr v - ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (vcat (map ppr (bagToList bs))) + ppr (EvBinds bs) = text "EvBinds" <> braces (vcat (map ppr (bagToList bs))) instance Outputable EvBindsVar where - ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u) + ppr (EvBindsVar _ u) = text "EvBindsVar" <> angleBrackets (ppr u) instance Uniquable EvBindsVar where getUnique (EvBindsVar _ u) = u @@ -778,15 +778,15 @@ instance Outputable EvBind where instance Outputable EvTerm where ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co - ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co - ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) + ppr (EvCast v co) = ppr v <+> (text "`cast`") <+> pprParendCo co + ppr (EvCoercion co) = text "CO" <+> ppr co + ppr (EvSuperClass d n) = text "sc" <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] ppr (EvLit l) = ppr l ppr (EvCallStack cs) = ppr cs - ppr (EvDelayedError ty msg) = ptext (sLit "error") + ppr (EvDelayedError ty msg) = text "error" <+> sep [ char '@' <> ppr ty, ppr msg ] - ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> ptext (sLit "Typeable") <+> ppr ty + ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty instance Outputable EvLit where ppr (EvNum n) = integer n @@ -794,14 +794,14 @@ instance Outputable EvLit where instance Outputable EvCallStack where ppr EvCsEmpty - = ptext (sLit "[]") + = text "[]" ppr (EvCsPushCall name loc tm) - = ppr (name,loc) <+> ptext (sLit ":") <+> ppr tm + = ppr (name,loc) <+> text ":" <+> ppr tm instance Outputable EvTypeable where - ppr (EvTypeableTyCon ts) = ptext (sLit "TC") <+> ppr ts + ppr (EvTypeableTyCon ts) = text "TC" <+> ppr ts ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) - ppr (EvTypeableTyLit t1) = ptext (sLit "TyLit") <> ppr t1 + ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 ---------------------------------------------------------------------- diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 575e1920fc..125d455701 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -230,11 +230,11 @@ tcExpr (HsLam match) res_ty ; return (mkHsWrap co_fn (HsLam match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } - herald = sep [ ptext (sLit "The lambda expression") <+> + herald = sep [ text "The lambda expression" <+> quotes (pprSetDepth (PartWay 1) $ pprMatches (LambdaExpr :: HsMatchContext Name) match), -- The pprSetDepth makes the abstraction print briefly - ptext (sLit "has")] + text "has"] tcExpr e@(HsLamCase _ matches) res_ty = do { (co_fn, ~[arg_ty], matches') @@ -242,8 +242,8 @@ tcExpr e@(HsLamCase _ matches) res_ty -- The laziness annotation is because we don't want to fail here -- if there are multiple arguments ; return (mkHsWrap co_fn $ HsLamCase arg_ty matches') } - where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e) - , ptext (sLit "requires")] + where msg = sep [ text "The function" <+> quotes (ppr e) + , text "requires"] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } tcExpr e@(ExprWithTySig expr sig_ty) res_ty @@ -343,7 +343,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty = do { traceTc "Application rule" (ppr op) ; (arg1', arg1_ty) <- tcInferSigma arg1 - ; let doc = ptext (sLit "The first argument of ($) takes") + ; let doc = text "The first argument of ($) takes" orig1 = exprCtOrigin (unLoc arg1) ; (wrap_arg1, [arg2_sigma], op_res_ty) <- matchActualFunTys doc orig1 1 arg1_ty @@ -557,7 +557,7 @@ tcExpr (HsStatic expr) res_ty = do { staticPtrTyCon <- tcLookupTyCon staticPtrTyConName ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty ; (expr', lie) <- captureConstraints $ - addErrCtxt (hang (ptext (sLit "In the body of a static form:")) + addErrCtxt (hang (text "In the body of a static form:") 2 (ppr expr) ) $ tcPolyExprNC expr expr_ty @@ -1097,8 +1097,8 @@ tcApp m_herald orig_fun orig_args res_ty ; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) } mk_app_msg :: LHsExpr Name -> SDoc -mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun) - , ptext (sLit "is applied to")] +mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun) + , text "is applied to"] mk_op_msg :: LHsExpr Name -> SDoc mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" @@ -1330,7 +1330,7 @@ tcInferId :: Name -> TcM (HsExpr TcId, TcSigmaType) -- Look up an occurrence of an Id tcInferId id_name | id_name `hasKey` tagToEnumKey - = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument")) + = failWithTc (text "tagToEnum# must appear applied to one argument") -- tcApp catches the case (tagToEnum# arg) | id_name `hasKey` assertIdKey @@ -1375,7 +1375,7 @@ tc_infer_id lbl id_name PatSynCon ps -> tcPatSynBuilderOcc ps _ -> failWithTc $ - ppr thing <+> ptext (sLit "used where a value identifier was expected") } + ppr thing <+> text "used where a value identifier was expected" } where return_id id = return (HsVar (noLoc id), idType id) @@ -1562,14 +1562,14 @@ tcTagToEnum loc fun_name args res_ty ; return (mkWpCastR (mkTcSymCo coi), fun', [arg']) } -- coi is a Representational coercion where - doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature") - , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ] - doc2 = ptext (sLit "Result type must be an enumeration type") + doc1 = vcat [ text "Specify the type by giving a type signature" + , text "e.g. (tagToEnum# x) :: Bool" ] + doc2 = text "Result type must be an enumeration type" mk_error :: TcType -> SDoc -> SDoc mk_error ty what - = hang (ptext (sLit "Bad call to tagToEnum#") - <+> ptext (sLit "at type") <+> ppr ty) + = hang (text "Bad call to tagToEnum#" + <+> text "at type" <+> ppr ty) 2 what too_many_args :: TcM a @@ -1648,7 +1648,7 @@ checkCrossStageLifting _ _ = return () polySpliceErr :: Id -> SDoc polySpliceErr id - = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) + = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) {- Note [Lifting strings] @@ -2091,11 +2091,11 @@ addExprErrCtxt expr = addErrCtxt (exprCtxt expr) exprCtxt :: LHsExpr Name -> SDoc exprCtxt expr - = hang (ptext (sLit "In the expression:")) 2 (ppr expr) + = hang (text "In the expression:") 2 (ppr expr) fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name - = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") + = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") addFunResCtxt :: Bool -- There is at least one argument -> HsExpr Name -> TcType -> TcType @@ -2121,13 +2121,13 @@ addFunResCtxt has_args fun fun_res_ty env_ty info | n_fun == n_env = Outputable.empty | n_fun > n_env , not_fun res_env - = ptext (sLit "Probable cause:") <+> quotes (ppr fun) - <+> ptext (sLit "is applied to too few arguments") + = text "Probable cause:" <+> quotes (ppr fun) + <+> text "is applied to too few arguments" | has_args , not_fun res_fun - = ptext (sLit "Possible cause:") <+> quotes (ppr fun) - <+> ptext (sLit "is applied to too many arguments") + = text "Possible cause:" <+> quotes (ppr fun) + <+> text "is applied to too many arguments" | otherwise = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! @@ -2141,7 +2141,7 @@ addFunResCtxt has_args fun fun_res_ty env_ty badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc badFieldTypes prs - = hang (ptext (sLit "Record update for insufficiently polymorphic field") + = hang (text "Record update for insufficiently polymorphic field" <> plural prs <> colon) 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) @@ -2150,7 +2150,7 @@ badFieldsUpd -> [ConLike] -- Data cons of the type which the first field name belongs to -> SDoc badFieldsUpd rbinds data_cons - = hang (ptext (sLit "No constructor has all these fields:")) + = hang (text "No constructor has all these fields:") 2 (pprQuotedList conflictingFields) -- See Note [Finding the conflicting fields] where @@ -2222,23 +2222,23 @@ a decent stab, no more. See Trac #7989. naughtyRecordSel :: RdrName -> SDoc 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 "Probable fix: use pattern-matching syntax instead") + = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> + text "as a function due to escaped type variables" $$ + text "Probable fix: use pattern-matching syntax instead" notSelector :: Name -> SDoc notSelector field - = hsep [quotes (ppr field), ptext (sLit "is not a record selector")] + = hsep [quotes (ppr field), text "is not a record selector"] mixedSelectors :: [Id] -> [Id] -> SDoc mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) = ptext (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ - ptext (sLit "Record selectors defined by") + text "Record selectors defined by" <+> quotes (ppr (tyConName rep_dc)) <> text ":" <+> pprWithCommas ppr data_sels $$ - ptext (sLit "Pattern synonym selectors defined by") + text "Pattern synonym selectors defined by" <+> quotes (ppr (patSynName rep_ps)) <> text ":" <+> pprWithCommas ppr pat_syn_sels @@ -2256,26 +2256,26 @@ 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 = text "Constructor" <+> quotes (ppr con) <+> + text "does not have the required strict field(s)" missingFields :: ConLike -> [FieldLabelString] -> SDoc missingFields con fields - = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:") + = text "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 = text "In the call" <+> parens (ppr (foldl mkHsApp fun args)) noPossibleParents :: [LHsRecUpdField Name] -> SDoc noPossibleParents rbinds - = hang (ptext (sLit "No type has all these fields:")) + = hang (text "No type has all these fields:") 2 (pprQuotedList fields) where fields = map (hsRecFieldLbl . unLoc) rbinds badOverloadedUpdate :: SDoc -badOverloadedUpdate = ptext (sLit "Record update is ambiguous, and requires a type signature") +badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" fieldNotInType :: RecSelParent -> RdrName -> SDoc fieldNotInType p rdr - = unknownSubordinateErr (ptext (sLit "field of type") <+> quotes (ppr p)) rdr + = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index 06ef6930cf..f87a302d5c 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -26,7 +26,6 @@ import DynFlags( DynFlags ) import Util import Bag import Pair -import FastString import Control.Monad import MonadUtils ( zipWithAndUnzipM ) import GHC.Exts ( inline ) @@ -1439,8 +1438,8 @@ unflatten tv_eqs funeqs ; tclvl <- getTcLevel ; traceTcS "Unflattening" $ braces $ - vcat [ ptext (sLit "Funeqs =") <+> pprCts funeqs - , ptext (sLit "Tv eqs =") <+> pprCts tv_eqs ] + vcat [ text "Funeqs =" <+> pprCts funeqs + , text "Tv eqs =" <+> pprCts tv_eqs ] -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check -- Occurs check: consider [W] alpha ~ [F alpha] diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index 3f10fe1c54..bc3a9283c6 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -57,7 +57,6 @@ import Outputable import Platform import SrcLoc import Bag -import FastString import Hooks import qualified GHC.LanguageExtensions as LangExt @@ -289,7 +288,7 @@ tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - _ -> addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "One argument expected"))) + _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected")) return (CImport (L lc cconv') safety mh CWrapper src) tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh @@ -299,7 +298,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh cconv' <- checkCConv cconv case arg_tys of -- The first arg must be Ptr or FunPtr [] -> - addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "At least one argument expected"))) + addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) (arg1_ty:arg_tys) -> do dflags <- getDynFlags let curried_res_ty = mkFunTys arg_tys res_ty @@ -350,7 +349,7 @@ checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand dflags arg_tys res_ty | null arg_tys && isFunPtrTy res_ty && wopt Opt_WarnDodgyForeignImports dflags - = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr")) + = addWarn (text "possible missing & in foreign import of FunPtr") | otherwise = return () @@ -453,7 +452,7 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty -- Case for non-IO result type with FFI Import | not non_io_result_ok - = addErrTc $ illegalForeignTyErr result (ptext (sLit "IO result type expected")) + = addErrTc $ illegalForeignTyErr result (text "IO result type expected") | otherwise = do { dflags <- getDynFlags @@ -473,7 +472,8 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty -- success! non-IO return is fine _ -> return () } where - safeHsErr = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad" + safeHsErr = + text "Safe Haskell is on, all FFI imports must be in the IO monad" nonIOok, mustBeIO :: Bool nonIOok = True @@ -542,8 +542,8 @@ illegalForeignTyErr :: SDoc -> SDoc -> SDoc illegalForeignTyErr arg_or_res extra = hang msg 2 extra where - msg = hsep [ ptext (sLit "Unacceptable"), arg_or_res - , ptext (sLit "type in foreign declaration:")] + msg = hsep [ text "Unacceptable", arg_or_res + , text "type in foreign declaration:"] -- Used for 'arg_or_res' argument to illegalForeignTyErr argument, result :: SDoc @@ -552,9 +552,9 @@ result = text "result" badCName :: CLabelString -> MsgDoc badCName target - = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] + = sep [quotes (ppr target) <+> text "is not a valid C identifier"] foreignDeclCtxt :: ForeignDecl Name -> SDoc foreignDeclCtxt fo - = hang (ptext (sLit "When checking declaration:")) + = hang (text "When checking declaration:") 2 (ppr fo) diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 2ebf3fda15..33c04b3693 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -235,8 +235,8 @@ canDoGenerics1 rep_tc tc_args = additionalChecks -- check (f) from Note [Requirements for deriving Generic and Rep] | null (tyConTyVars rep_tc) = NotValid $ - ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must have some type parameters") + text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters" | otherwise = mergeErrors $ concatMap check_con data_cons @@ -246,7 +246,7 @@ canDoGenerics1 rep_tc tc_args = IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con bad :: DataCon -> SDoc -> SDoc - bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg + bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg check_vanilla :: DataCon -> Validity check_vanilla con | isVanillaDataCon con = IsValid diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 06f1d4a5de..b301149c6a 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -226,7 +226,7 @@ tcHsDeriv hs_ty ; let (tvs, pred) = splitForAllTys ty ; case getClassPredTys_maybe pred of Just (cls, tys) -> return (tvs, cls, tys, arg_kind) - Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> quotes (ppr hs_ty)) } + Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt -> LHsSigType Name @@ -266,7 +266,7 @@ tcHsVectInst ty return (cls, args) _ -> failWithTc (text "Too many arguments passed to" <+> ppr cls_name) } | otherwise - = failWithTc $ ptext (sLit "Malformed instance type") + = failWithTc $ text "Malformed instance type" ---------------------------------------------- -- | Type-check a visible type application @@ -489,15 +489,15 @@ tc_hs_type _ ty@(HsBangTy {}) _ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of -- bangs are invalid, so fail. (#7210) - = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) + = failWithTc (text "Unexpected strictness annotation:" <+> ppr ty) tc_hs_type _ ty@(HsRecTy _) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now - = failWithTc (ptext (sLit "Record syntax is illegal here:") <+> ppr ty) + = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) -- This should never happen; type splices are expanded by the renamer tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) + = failWithTc (text "Unexpected type splice:" <+> ppr ty) ---------- Functions and applications tc_hs_type mode (HsFunTy ty1 ty2) exp_kind @@ -511,7 +511,7 @@ tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind tc_hs_type mode hs_ty@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind -- Do not kind-generalise here. See Note [Kind generalisation] | isConstraintKind exp_kind - = failWithTc (hang (ptext (sLit "Illegal constraint:")) 2 (ppr hs_ty)) + = failWithTc (hang (text "Illegal constraint:") 2 (ppr hs_ty)) | otherwise = fmap fst $ @@ -714,9 +714,9 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind bigConstraintTuple :: Arity -> MsgDoc bigConstraintTuple arity - = hang (ptext (sLit "Constraint tuple arity too large:") <+> int arity - <+> parens (ptext (sLit "max arity =") <+> int mAX_CTUPLE_SIZE)) - 2 (ptext (sLit "Instead, use a nested tuple")) + = hang (text "Constraint tuple arity too large:" <+> int arity + <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) + 2 (text "Instead, use a nested tuple") --------------------------- -- | Apply a type of a given kind to a list of arguments. This instantiates @@ -1231,7 +1231,7 @@ addTypeCtxt :: LHsType Name -> TcM a -> TcM a addTypeCtxt (L _ ty) thing = addErrCtxt doc thing where - doc = ptext (sLit "In the type") <+> quotes (ppr ty) + doc = text "In the type" <+> quotes (ppr ty) {- ************************************************************************ @@ -1912,7 +1912,7 @@ tcDataKindSig kind badKindSig :: Kind -> SDoc badKindSig kind - = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind")) + = hang (text "Kind signature on data type declaration has non-* return kind") 2 (ppr kind) {- @@ -2059,17 +2059,17 @@ tcPatSig in_pat_bind sig res_ty mk_msg sig_ty tidy_env = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty - ; let msg = vcat [ hang (ptext (sLit "When checking that the pattern signature:")) + ; let msg = vcat [ hang (text "When checking that the pattern signature:") 4 (ppr sig_ty) - , nest 2 (hang (ptext (sLit "fits the type of its context:")) + , nest 2 (hang (text "fits the type of its context:") 2 (ppr res_ty)) ] ; return (tidy_env, msg) } patBindSigErr :: [TcTyVar] -> SDoc patBindSigErr sig_tvs - = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs + = hang (text "You cannot bind scoped type variable" <> plural sig_tvs <+> pprQuotedList sig_tvs) - 2 (ptext (sLit "in a pattern binding signature")) + 2 (text "in a pattern binding signature") {- Note [Pattern signature binders] @@ -2151,12 +2151,12 @@ tcLHsKind = tc_lhs_kind kindLevelMode tc_lhs_kind :: TcTyMode -> LHsKind Name -> TcM Kind tc_lhs_kind mode k - = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ + = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $ tc_lhs_type (kindLevel mode) k liftedTypeKind promotionErr :: Name -> PromotionErr -> TcM a promotionErr name err - = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> ptext (sLit "cannot be used here")) + = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") 2 (parens reason)) where reason = case err of @@ -2177,12 +2177,12 @@ promotionErr name err badPatSigTvs :: TcType -> [TyVar] -> SDoc badPatSigTvs sig_ty bad_tvs - = vcat [ fsep [ptext (sLit "The type variable") <> plural bad_tvs, + = vcat [ fsep [text "The type variable" <> plural bad_tvs, quotes (pprWithCommas ppr bad_tvs), - ptext (sLit "should be bound by the pattern signature") <+> quotes (ppr sig_ty), - ptext (sLit "but are actually discarded by a type synonym") ] - , ptext (sLit "To fix this, expand the type synonym") - , ptext (sLit "[Note: I hope to lift this restriction in due course]") ] + text "should be bound by the pattern signature" <+> quotes (ppr sig_ty), + text "but are actually discarded by a type synonym" ] + , text "To fix this, expand the type synonym" + , text "[Note: I hope to lift this restriction in due course]" ] {- ************************************************************************ @@ -2196,6 +2196,6 @@ badPatSigTvs sig_ty bad_tvs -- Used for both expressions and types. funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc funAppCtxt fun arg arg_no - = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), + = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg)) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 5fc09eaa74..a1cff1d8e3 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -433,9 +433,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- Check for hand-written Generic instances (disallowed in Safe Haskell) genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames - genInstErr i = hang (ptext (sLit $ "Generic instances can only be " + genInstErr i = hang (text ("Generic instances can only be " ++ "derived in Safe Haskell.") $+$ - ptext (sLit "Replace the following instance:")) + text "Replace the following instance:") 2 (pprInstanceHdr (iSpec i)) -- Report an error or a warning for a Typeable instances. @@ -449,11 +449,11 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls then do warn <- woptM Opt_WarnDerivingTypeable when warn $ addWarnTc $ vcat - [ ppTypeable <+> ptext (sLit "instances in .hs-boot files are ignored") - , ptext (sLit "This warning will become an error in future versions of the compiler") + [ ppTypeable <+> text "instances in .hs-boot files are ignored" + , text "This warning will become an error in future versions of the compiler" ] - else addErrTc $ ptext (sLit "Class") <+> ppTypeable - <+> ptext (sLit "does not support user-specified instances") + else addErrTc $ text "Class" <+> ppTypeable + <+> text "does not support user-specified instances" ppTypeable :: SDoc ppTypeable = quotes (ppr typeableClassName) @@ -1455,18 +1455,18 @@ methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) methSigCtxt sel_name sig_ty meth_ty env0 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty - ; let msg = hang (ptext (sLit "When checking that instance signature for") <+> quotes (ppr sel_name)) - 2 (vcat [ ptext (sLit "is more general than its signature in the class") - , ptext (sLit "Instance sig:") <+> ppr sig_ty - , ptext (sLit " Class sig:") <+> ppr meth_ty ]) + ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) + 2 (vcat [ text "is more general than its signature in the class" + , text "Instance sig:" <+> ppr sig_ty + , text " Class sig:" <+> ppr meth_ty ]) ; return (env2, msg) } misplacedInstSig :: Name -> LHsSigType Name -> SDoc misplacedInstSig name hs_ty - = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:")) + = vcat [ hang (text "Illegal type signature in instance declaration:") 2 (hang (pprPrefixName name) 2 (dcolon <+> ppr hs_ty)) - , ptext (sLit "(Use InstanceSigs to allow this)") ] + , text "(Use InstanceSigs to allow this)" ] {- Note [Instance method signatures] @@ -1544,10 +1544,10 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name ---------------------- derivBindCtxt :: Id -> Class -> [Type ] -> SDoc derivBindCtxt sel_id clas tys - = vcat [ ptext (sLit "When typechecking the code for") <+> quotes (ppr sel_id) - , nest 2 (ptext (sLit "in a derived instance for") + = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) + , nest 2 (text "in a derived instance for" <+> quotes (pprClassPred clas tys) <> colon) - , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] + , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef @@ -1555,7 +1555,7 @@ warnUnsatisfiedMinimalDefinition mindef ; warnTc warn message } where - message = vcat [ptext (sLit "No explicit implementation for") + message = vcat [text "No explicit implementation for" ,nest 2 $ pprBooleanFormulaNice mindef ] @@ -1743,7 +1743,7 @@ tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where - spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag) tcSpecInst _ _ = panic "tcSpecInst" @@ -1767,34 +1767,34 @@ instDeclCtxt2 dfun_ty (_,_,cls,tys) = tcSplitDFunTy dfun_ty inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (ptext (sLit "In the instance declaration for")) +inst_decl_ctxt doc = hang (text "In the instance declaration for") 2 (quotes doc) badBootFamInstDeclErr :: SDoc badBootFamInstDeclErr - = ptext (sLit "Illegal family instance in hs-boot file") + = text "Illegal family instance in hs-boot file" notFamily :: TyCon -> SDoc notFamily tycon - = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] + = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] tooFewParmsErr :: Arity -> SDoc tooFewParmsErr arity - = ptext (sLit "Family instance has too few parameters; expected") <+> + = text "Family instance has too few parameters; expected" <+> ppr arity assocInClassErr :: Located Name -> SDoc assocInClassErr name - = ptext (sLit "Associated type") <+> quotes (ppr name) <+> - ptext (sLit "must be inside a class instance") + = text "Associated type" <+> quotes (ppr name) <+> + text "must be inside a class instance" badFamInstDecl :: Located Name -> SDoc badFamInstDecl tc_name - = vcat [ ptext (sLit "Illegal family instance for") <+> + = vcat [ text "Illegal family instance for" <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext (sLit "Use TypeFamilies to allow indexed type families")) ] + , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] notOpenFamily :: TyCon -> SDoc notOpenFamily tc - = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc) + = text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 9722166565..8582c7298f 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -11,7 +11,6 @@ module TcInteract ( import BasicTypes ( infinity, IntWithInf, intGtLimit ) import HsTypes ( HsIPName(..) ) -import FastString import TcCanonical import TcFlatten import VarSet @@ -154,18 +153,18 @@ solveSimpleWanteds simples ; dflags <- getDynFlags ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples }) ; traceTcS "solveSimples end }" $ - vcat [ ptext (sLit "iterations =") <+> ppr n - , ptext (sLit "residual =") <+> ppr wc ] + vcat [ text "iterations =" <+> ppr n + , text "residual =" <+> ppr wc ] ; return wc } where go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) go n limit wc | n `intGtLimit` limit - = failTcS (hang (ptext (sLit "solveSimpleWanteds: too many iterations") - <+> parens (ptext (sLit "limit =") <+> ppr limit)) - 2 (vcat [ ptext (sLit "Set limit with -fsolver-iterations=n; n=0 for no limit") - , ptext (sLit "Simples =") <+> ppr simples - , ptext (sLit "WC =") <+> ppr wc ])) + = failTcS (hang (text "solveSimpleWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Set limit with -fsolver-iterations=n; n=0 for no limit" + , text "Simples =" <+> ppr simples + , text "WC =" <+> ppr wc ])) | isEmptyBag (wc_simple wc) = return (n,wc) @@ -378,8 +377,8 @@ runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline runSolverPipeline pipeline workItem = do { initial_is <- getTcSInerts ; traceTcS "Start solver pipeline {" $ - vcat [ ptext (sLit "work item = ") <+> ppr workItem - , ptext (sLit "inerts = ") <+> ppr initial_is] + vcat [ text "work item = " <+> ppr workItem + , text "inerts = " <+> ppr initial_is] ; bumpStepCountTcS -- One step for each constraint processed ; final_res <- run_pipeline pipeline (ContinueWith workItem) @@ -388,13 +387,13 @@ runSolverPipeline pipeline workItem ; case final_res of Stop ev s -> do { traceFireTcS ev s ; traceTcS "End solver pipeline (discharged) }" - (ptext (sLit "inerts =") <+> ppr final_is) + (text "inerts =" <+> ppr final_is) ; return () } - ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (ptext (sLit "Kept as inert")) + ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (text "Kept as inert") ; traceTcS "End solver pipeline (kept as inert) }" $ - vcat [ ptext (sLit "final_item =") <+> ppr ct + vcat [ text "final_item =" <+> ppr ct , pprTvBndrs (varSetElems $ tyCoVarsOfCt ct) - , ptext (sLit "inerts =") <+> ppr final_is] + , text "inerts =" <+> ppr final_is] ; addInertCan ct } } where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct @@ -497,9 +496,9 @@ data InteractResult | IRDelete -- Delete the existing inert constraint from the inert set instance Outputable InteractResult where - ppr IRKeep = ptext (sLit "keep") - ppr IRReplace = ptext (sLit "replace") - ppr IRDelete = ptext (sLit "delete") + ppr IRKeep = text "keep" + ppr IRReplace = text "replace" + ppr IRDelete = text "delete" solveOneFromTheOther :: CtEvidence -- Inert -> CtEvidence -- WorkItem @@ -661,7 +660,7 @@ interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w }) -- These const upd's assume that solveOneFromTheOther -- has no side effects on InertCans ; if stop_now then - return (Stop ev_w (ptext (sLit "Irred equal") <+> parens (ppr inert_effect))) + return (Stop ev_w (text "Irred equal" <+> parens (ppr inert_effect))) ; else continueWith workItem } @@ -712,7 +711,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs IRDelete -> updInertDicts $ \ ds -> delDict ds cls tys IRReplace -> updInertDicts $ \ ds -> addDict ds cls tys workItem ; if stop_now then - return (Stop ev_w (ptext (sLit "Dict equal") <+> parens (ppr inert_effect))) + return (Stop ev_w (text "Dict equal" <+> parens (ppr inert_effect))) else continueWith workItem } @@ -879,9 +878,9 @@ improveLocalFunEqs :: CtLoc -> InertCans -> TyCon -> [TcType] -> TcTyVar improveLocalFunEqs loc inerts fam_tc args fsk | not (null improvement_eqns) = do { traceTcS "interactFunEq improvements: " $ - vcat [ ptext (sLit "Eqns:") <+> ppr improvement_eqns - , ptext (sLit "Candidates:") <+> ppr funeqs_for_tc - , ptext (sLit "Model:") <+> ppr model ] + vcat [ text "Eqns:" <+> ppr improvement_eqns + , text "Candidates:" <+> ppr funeqs_for_tc + , text "Model:" <+> ppr model ] ; mapM_ (unifyDerived loc Nominal) improvement_eqns } | otherwise = return () @@ -1127,7 +1126,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv ; if canSolveByUnification tclvl ev eq_rel tv rhs then do { solveByUnification ev tv rhs ; n_kicked <- kickOutAfterUnification tv - ; return (Stop ev (ptext (sLit "Solved by unification") <+> ppr_kicked n_kicked)) } + ; return (Stop ev (text "Solved by unification" <+> ppr_kicked n_kicked)) } else do { traceTcS "Can't solve tyvar equality" (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv) @@ -1137,7 +1136,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) , text "TcLevel =" <+> ppr tclvl ]) ; addInertEq workItem - ; return (Stop ev (ptext (sLit "Kept as inert"))) } } + ; return (Stop ev (text "Kept as inert")) } } interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) @@ -1191,7 +1190,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () solveByUnification wd tv xi = do { let tv_ty = mkTyVarTy tv ; traceTcS "Sneaky unification:" $ - vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi, + vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, text "Coercion:" <+> pprEq tv_ty xi, text "Left Kind is:" <+> ppr (typeKind tv_ty), text "Right Kind is:" <+> ppr (typeKind xi) ] @@ -1201,7 +1200,7 @@ solveByUnification wd tv xi ppr_kicked :: Int -> SDoc ppr_kicked 0 = empty -ppr_kicked n = parens (int n <+> ptext (sLit "kicked out")) +ppr_kicked n = parens (int n <+> text "kicked out") {- Note [Avoid double unifications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1273,7 +1272,7 @@ topReactionsStage wi = do { tir <- doTopReact wi ; case tir of ContinueWith wi -> continueWith wi - Stop ev s -> return (Stop ev (ptext (sLit "Top react:") <+> s)) } + Stop ev s -> return (Stop ev (text "Top react:" <+> s)) } doTopReact :: WorkItem -> TcS (StopOrContinue Ct) -- The work item does not react with the inert set, so try interaction with top-level diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index ae8923d6e6..7ab59be38d 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -894,7 +894,7 @@ skolemiseUnboundMetaTyVar tv details final_name = mkInternalName uniq tv_name span final_tv = mkTcTyVar final_name kind details - ; traceTc "Skolemising" (ppr tv <+> ptext (sLit ":=") <+> ppr final_tv) + ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) ; writeMetaTyVar tv (mkTyVarTy final_tv) ; return final_tv } diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 3f4b6adb63..216f25ba8d 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -37,7 +37,6 @@ import TcEvidence import Outputable import Util import SrcLoc -import FastString import DynFlags import PrelNames (monadFailClassName) import qualified GHC.LanguageExtensions as LangExt @@ -94,8 +93,8 @@ tcMatchesFun fun_name matches exp_ty ; return (wrap_gen <.> wrap_fun, group) } where arity = matchGroupArity matches - herald = ptext (sLit "The equation(s) for") - <+> quotes (ppr fun_name) <+> ptext (sLit "have") + herald = text "The equation(s) for" + <+> quotes (ppr fun_name) <+> text "have" match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody } {- @@ -1059,10 +1058,10 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) }) | null bad_matches = return () | otherwise - = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+> - ptext (sLit "have different numbers of arguments"), - nest 2 (ppr (getLoc match1)), - nest 2 (ppr (getLoc (head bad_matches)))]) + = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> + text "have different numbers of arguments" + , nest 2 (ppr (getLoc match1)) + , nest 2 (ppr (getLoc (head bad_matches)))]) where n_args1 = args_in_match match1 bad_matches = [m | m <- matches, args_in_match m /= n_args1] diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index b919e4ed23..d6999f1af2 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -46,7 +46,6 @@ import SrcLoc import VarSet import Util import Outputable -import FastString import Maybes( orElse ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -217,8 +216,8 @@ addInlinePrags poly_id prags warn_multiple_inlines inl2 inls | otherwise = setSrcSpan loc $ - addWarnTc (hang (ptext (sLit "Multiple INLINE pragmas for") <+> ppr poly_id) - 2 (vcat (ptext (sLit "Ignoring all but the first") + addWarnTc (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" : map pp_inl (inl1:inl2:inls)))) pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) @@ -1027,7 +1026,7 @@ maybeWrapPatCtxt pat tcm thing_inside worth_wrapping (ParPat {}) = False worth_wrapping (AsPat {}) = False worth_wrapping _ = True - msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat) + msg = hang (text "In the pattern:") 2 (ppr pat) ----------------------------------------------- checkExistentials :: [TyVar] -- existentials @@ -1043,12 +1042,12 @@ checkExistentials _ _ _ = return () existentialLazyPat :: SDoc existentialLazyPat - = hang (ptext (sLit "An existential or GADT data constructor cannot be used")) - 2 (ptext (sLit "inside a lazy (~) pattern")) + = hang (text "An existential or GADT data constructor cannot be used") + 2 (text "inside a lazy (~) pattern") existentialProcPat :: SDoc existentialProcPat - = ptext (sLit "Proc patterns cannot use existential or GADT data constructors") + = text "Proc patterns cannot use existential or GADT data constructors" existentialLetPat :: SDoc existentialLetPat @@ -1058,16 +1057,16 @@ existentialLetPat badFieldCon :: ConLike -> FieldLabelString -> SDoc badFieldCon con field - = hsep [ptext (sLit "Constructor") <+> quotes (ppr con), - ptext (sLit "does not have field"), quotes (ppr field)] + = hsep [text "Constructor" <+> quotes (ppr con), + text "does not have field", quotes (ppr field)] polyPatSig :: TcType -> SDoc polyPatSig sig_ty - = hang (ptext (sLit "Illegal polymorphic type signature in pattern:")) + = hang (text "Illegal polymorphic type signature in pattern:") 2 (ppr sig_ty) lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM () lazyUnliftedPatErr pat = failWithTc $ - hang (ptext (sLit "A lazy (~) pattern cannot contain unlifted types:")) + hang (text "A lazy (~) pattern cannot contain unlifted types:") 2 (ppr pat) diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 3b758389c6..c12ca6cba1 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -141,8 +141,8 @@ tcPatSynSig name sig_ty -- should not appear in the result type ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType body_ty) ex_tvs ; unless (null bad_tvs) $ addErr $ - hang (ptext (sLit "The result type") <+> quotes (ppr body_ty)) - 2 (ptext (sLit "mentions existential type variable") <> plural bad_tvs + hang (text "The result type" <+> quotes (ppr body_ty)) + 2 (text "mentions existential type variable" <> plural bad_tvs <+> pprQuotedList bad_tvs) -- Split [Splitting the implicit tyvars in a pattern synonym] @@ -348,15 +348,15 @@ collectPatSynArgInfo details = addPatSynCtxt :: Located Name -> TcM a -> TcM a addPatSynCtxt (L loc name) thing_inside = setSrcSpan loc $ - addErrCtxt (ptext (sLit "In the declaration for pattern synonym") + addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ thing_inside wrongNumberOfParmsErr :: Name -> Arity -> Arity -> SDoc wrongNumberOfParmsErr name decl_arity ty_arity - = hang (ptext (sLit "Patten synonym") <+> quotes (ppr name) <+> ptext (sLit "has") - <+> speakNOf decl_arity (ptext (sLit "argument"))) - 2 (ptext (sLit "but its type signature has") <+> speakN ty_arity) + = hang (text "Patten synonym" <+> quotes (ppr name) <+> ptext (sLit "has") + <+> speakNOf decl_arity (text "argument")) + 2 (text "but its type signature has" <+> speakN ty_arity) ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn @@ -593,7 +593,7 @@ tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat | isNothing mb_match_group -- Can't invert the pattern = setSrcSpan (getLoc lpat) $ failWithTc $ - hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression")) + hang (text "Right-hand side of bidirectional pattern synonym cannot be used as an expression") 2 (ppr lpat) | otherwise -- Bidirectional @@ -779,25 +779,25 @@ tcCheckPatSynPat = go asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a asPatInPatSynErr pat = failWithTc $ - hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):")) + hang (text "Pattern synonym definition cannot contain as-patterns (@):") 2 (ppr pat) thInPatSynErr :: OutputableBndr name => Pat name -> TcM a thInPatSynErr pat = failWithTc $ - hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:")) + hang (text "Pattern synonym definition cannot contain Template Haskell:") 2 (ppr pat) nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a nPlusKPatInPatSynErr pat = failWithTc $ - hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:")) + hang (text "Pattern synonym definition cannot contain n+k-pattern:") 2 (ppr pat) nonBidirectionalErr :: Outputable name => name -> TcM a nonBidirectionalErr name = failWithTc $ - ptext (sLit "non-bidirectional pattern synonym") - <+> quotes (ppr name) <+> ptext (sLit "used in an expression") + text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name) tcPatToExpr args = go diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index da2aa7416d..3ded08a425 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -169,7 +169,7 @@ tcRnSignature dflags hsc_src case tcg_sig_of tcg_env of { Just sof | hsc_src /= HsigFile -> do - { addErr (ptext (sLit "Illegal -sig-of specified for non hsig")) + { addErr (text "Illegal -sig-of specified for non hsig") ; return tcg_env } | otherwise -> do @@ -189,7 +189,7 @@ tcRnSignature dflags hsc_src { return tcg_env } | HsigFile <- hsc_src -> do - { addErr (ptext (sLit "Missing -sig-of for hsig")) + { addErr (text "Missing -sig-of for hsig") ; failM } | otherwise -> return tcg_env } @@ -385,7 +385,7 @@ tcRnModuleTcRnM hsc_env hsc_src implicitPreludeWarn :: SDoc implicitPreludeWarn - = ptext (sLit "Module `Prelude' implicitly imported") + = text "Module `Prelude' implicitly imported" {- ************************************************************************ @@ -445,7 +445,7 @@ tcRnImports hsc_env import_decls -- interfaces, so that their rules and instance decls will be -- found. But filter out a self hs-boot: these instances -- will be checked when we define them locally. - ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) + ; loadModuleInterfaces (text "Loading orphan modules") (filter (/= this_mod) (imp_orphs imports)) -- Check type-family consistency @@ -573,7 +573,7 @@ tc_rn_src_decls ds { Nothing -> return () ; ; Just (SpliceDecl (L loc _) _, _) -> setSrcSpan loc $ - addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls")) + addErr (text "Declaration splices are not permitted inside top-level declarations added with addTopDecls") } ; -- Rename TH-generated top-level declarations @@ -691,12 +691,12 @@ tcRnHsBootDecls hsc_src decls badBootDecl :: HscSource -> String -> Located decl -> TcM () badBootDecl hsc_src what (L loc _) = addErrAt loc (char 'A' <+> text what - <+> ptext (sLit "declaration is not (currently) allowed in a") + <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of - HsBootFile -> ptext (sLit "hs-boot") - HsigFile -> ptext (sLit "hsig") + HsBootFile -> text "hs-boot" + HsigFile -> text "hsig" _ -> panic "badBootDecl: should be an hsig or hs-boot file") - <+> ptext (sLit "file")) + <+> text "file") {- Once we've typechecked the body of the module, we want to compare what @@ -1081,31 +1081,31 @@ emptyRnEnv2 = mkRnEnv2 emptyInScopeSet ---------------- missingBootThing :: Bool -> Name -> String -> SDoc missingBootThing is_boot name what - = quotes (ppr name) <+> ptext (sLit "is exported by the") - <+> (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig")) - <+> ptext (sLit "file, but not") - <+> text what <+> ptext (sLit "the module") + = quotes (ppr name) <+> text "is exported by the" + <+> (if is_boot then text "hs-boot" else text "hsig") + <+> text "file, but not" + <+> text what <+> text "the module" bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc bootMisMatch is_boot extra_info real_thing boot_thing = vcat [ppr real_thing <+> - ptext (sLit "has conflicting definitions in the module"), - ptext (sLit "and its") <+> - (if is_boot then ptext (sLit "hs-boot file") - else ptext (sLit "hsig file")), - ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing, + text "has conflicting definitions in the module", + text "and its" <+> + (if is_boot then text "hs-boot file" + else text "hsig file"), + text "Main module:" <+> PprTyThing.pprTyThing real_thing, (if is_boot - then ptext (sLit "Boot file: ") - else ptext (sLit "Hsig file: ")) + then text "Boot file: " + else text "Hsig file: ") <+> PprTyThing.pprTyThing boot_thing, extra_info] instMisMatch :: Bool -> ClsInst -> SDoc instMisMatch is_boot inst = hang (ppr inst) - 2 (ptext (sLit "is defined in the") <+> - (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig")) - <+> ptext (sLit "file, but not in the module itself")) + 2 (text "is defined in the" <+> + (if is_boot then text "hs-boot" else text "hsig") + <+> text "file, but not in the module itself") {- ************************************************************************ @@ -1511,9 +1511,9 @@ check_main dflags tcg_env explicit_mod_hdr -- In other modes, fail altogether, so that we don't go on -- and complain a second time when processing the export list. - mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn - noMainMsg = ptext (sLit "The") <+> pp_main_fn - <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) + mainCtxt = text "When checking the type of the" <+> pp_main_fn + noMainMsg = text "The" <+> pp_main_fn + <+> text "is not defined in module" <+> quotes (ppr main_mod) pp_main_fn = ppMainFn main_fn -- | Get the unqualified name of the function to use as the \"main\" for the main module. @@ -1532,15 +1532,15 @@ checkMainExported tcg_env do { dflags <- getDynFlags ; let main_mod = mainModIs dflags ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ - ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+> - ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) } + text "The" <+> ppMainFn (nameRdrName main_name) <+> + text "is not exported by module" <+> quotes (ppr main_mod) } ppMainFn :: RdrName -> SDoc ppMainFn main_fn | rdrNameOcc main_fn == mainOcc - = ptext (sLit "IO action") <+> quotes (ppr main_fn) + = text "IO action" <+> quotes (ppr main_fn) | otherwise - = ptext (sLit "main IO action") <+> quotes (ppr main_fn) + = text "main IO action" <+> quotes (ppr main_fn) mainOcc :: OccName mainOcc = mkVarOccFS (fsLit "main") @@ -1720,7 +1720,7 @@ tcRnStmt hsc_env rdr_stmt return (global_ids, zonked_expr, fix_env) } where - bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), + bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:", nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) {- @@ -2113,7 +2113,7 @@ externaliseAndTidyId this_mod id getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) getModuleInterface hsc_env mod = runTcInteractive hsc_env $ - loadModuleInterface (ptext (sLit "getModuleInterface")) mod + loadModuleInterface (text "getModuleInterface") mod tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name]) @@ -2127,7 +2127,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) let rdr_names = dataTcOccs rdr_name ; names_s <- mapM lookupInfoOccRn rdr_names ; let names = concat names_s - ; when (null names) (addErrTc (ptext (sLit "Not in scope:") <+> quotes (ppr rdr_name))) + ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } #endif @@ -2213,7 +2213,7 @@ loadUnqualIfaces hsc_env ictxt , nameIsFromExternalPackage this_pkg name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified - doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") + doc = text "Need interface for module whose export(s) are in scope unqualified" {- ****************************************************************************** @@ -2394,9 +2394,9 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_fam_insts fam_insts , vcat (map ppr rules) , vcat (map ppr vects) - , ptext (sLit "Dependent modules:") <+> + , text "Dependent modules:" <+> ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) - , ptext (sLit "Dependent packages:") <+> + , text "Dependent packages:" <+> ppr (sortBy stableUnitIdCmp $ imp_dep_pkgs imports)] where -- The two uses of sortBy are just to reduce unnecessary -- wobbling in testsuite output diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index f55f5dd548..b0b1e3dcfe 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -953,9 +953,9 @@ checkTH e what = failTH e what -- Raise an error in a stage-1 compiler failTH :: Outputable a => a -> String -> TcRn x failTH e what -- Raise an error in a stage-1 compiler = failWithTc (vcat [ hang (char 'A' <+> text what - <+> ptext (sLit "requires GHC with interpreter support:")) + <+> text "requires GHC with interpreter support:") 2 (ppr e) - , ptext (sLit "Perhaps you are using a stage-1 compiler?") ]) + , text "Perhaps you are using a stage-1 compiler?" ]) {- ************************************************************************ @@ -1353,7 +1353,7 @@ recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) T keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set keepAlive name = do { env <- getGblEnv - ; traceRn (ptext (sLit "keep alive") <+> ppr name) + ; traceRn (text "keep alive" <+> ppr name) ; updTcRef (tcg_keep env) (`extendNameSet` name) } getStage :: TcM ThStage @@ -1466,7 +1466,7 @@ initIfaceTc iface do_this } where mod = mi_module iface - doc = ptext (sLit "The interface for") <+> quotes (ppr mod) + doc = text "The interface for" <+> quotes (ppr mod) initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a initIfaceLcl mod loc_doc thing_inside diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 6330c71c88..60abfca12e 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -925,20 +925,20 @@ instance Outputable PromotionErr where pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing -pprTcTyThingCategory (ATyVar {}) = ptext (sLit "Type variable") -pprTcTyThingCategory (ATcId {}) = ptext (sLit "Local identifier") -pprTcTyThingCategory (ATcTyCon {}) = ptext (sLit "Local tycon") +pprTcTyThingCategory (ATyVar {}) = text "Type variable" +pprTcTyThingCategory (ATcId {}) = text "Local identifier" +pprTcTyThingCategory (ATcTyCon {}) = text "Local tycon" pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe pprPECategory :: PromotionErr -> SDoc -pprPECategory ClassPE = ptext (sLit "Class") -pprPECategory TyConPE = ptext (sLit "Type constructor") -pprPECategory PatSynPE = ptext (sLit "Pattern synonym") -pprPECategory FamDataConPE = ptext (sLit "Data constructor") -pprPECategory RecDataConPE = ptext (sLit "Data constructor") -pprPECategory NoDataKinds = ptext (sLit "Data constructor") -pprPECategory NoTypeInTypeTC = ptext (sLit "Type constructor") -pprPECategory NoTypeInTypeDC = ptext (sLit "Data constructor") +pprPECategory ClassPE = text "Class" +pprPECategory TyConPE = text "Type constructor" +pprPECategory PatSynPE = text "Pattern synonym" +pprPECategory FamDataConPE = text "Data constructor" +pprPECategory RecDataConPE = text "Data constructor" +pprPECategory NoDataKinds = text "Data constructor" +pprPECategory NoTypeInTypeTC = text "Type constructor" +pprPECategory NoTypeInTypeDC = text "Data constructor" {- Note [Bindings with closed types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1123,10 +1123,10 @@ data WhereFrom -- See Note [Care with plugin imports] in LoadIface instance Outputable WhereFrom where - ppr (ImportByUser is_boot) | is_boot = ptext (sLit "{- SOURCE -}") + ppr (ImportByUser is_boot) | is_boot = text "{- SOURCE -}" | otherwise = empty - ppr ImportBySystem = ptext (sLit "{- SYSTEM -}") - ppr ImportByPlugin = ptext (sLit "{- PLUGIN -}") + ppr ImportBySystem = text "{- SYSTEM -}" + ppr ImportByPlugin = text "{- PLUGIN -}" {- ********************************************************************* @@ -1226,8 +1226,8 @@ instance Outputable TcIdSigInfo where , ppr (map fst tyvars) ] instance Outputable TcIdSigBndr where - ppr (CompleteSig f) = ptext (sLit "CompleteSig") <+> ppr f - ppr (PartialSig { sig_name = n }) = ptext (sLit "PartialSig") <+> ppr n + ppr (CompleteSig f) = text "CompleteSig" <+> ppr f + ppr (PartialSig { sig_name = n }) = text "PartialSig" <+> ppr n instance Outputable TcPatSynInfo where ppr (TPSI{ patsig_name = name}) = ppr name @@ -1911,10 +1911,10 @@ trulyInsoluble _tc_lvl insol instance Outputable WantedConstraints where ppr (WC {wc_simple = s, wc_impl = i, wc_insol = n}) - = ptext (sLit "WC") <+> braces (vcat - [ ppr_bag (ptext (sLit "wc_simple")) s - , ppr_bag (ptext (sLit "wc_insol")) n - , ppr_bag (ptext (sLit "wc_impl")) i ]) + = text "WC" <+> braces (vcat + [ ppr_bag (text "wc_simple") s + , ppr_bag (text "wc_insol") n + , ppr_bag (text "wc_impl") i ]) ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc ppr_bag doc bag @@ -1977,23 +1977,23 @@ instance Outputable Implication where , ic_given = given, ic_no_eqs = no_eqs , ic_wanted = wanted, ic_status = status , ic_binds = binds, ic_info = info }) - = hang (ptext (sLit "Implic") <+> lbrace) - 2 (sep [ ptext (sLit "TcLevel =") <+> ppr tclvl - , ptext (sLit "Skolems =") <+> pprTvBndrs skols - , ptext (sLit "No-eqs =") <+> ppr no_eqs - , ptext (sLit "Status =") <+> ppr status - , hang (ptext (sLit "Given =")) 2 (pprEvVars given) - , hang (ptext (sLit "Wanted =")) 2 (ppr wanted) - , ptext (sLit "Binds =") <+> ppr binds + = hang (text "Implic" <+> lbrace) + 2 (sep [ text "TcLevel =" <+> ppr tclvl + , text "Skolems =" <+> pprTvBndrs skols + , text "No-eqs =" <+> ppr no_eqs + , text "Status =" <+> ppr status + , hang (text "Given =") 2 (pprEvVars given) + , hang (text "Wanted =") 2 (ppr wanted) + , text "Binds =" <+> ppr binds , pprSkolInfo info ] <+> rbrace) instance Outputable ImplicStatus where - ppr IC_Insoluble = ptext (sLit "Insoluble") - ppr IC_Unsolved = ptext (sLit "Unsolved") + ppr IC_Insoluble = text "Insoluble" + ppr IC_Unsolved = text "Unsolved" ppr (IC_Solved { ics_need = vs, ics_dead = dead }) - = ptext (sLit "Solved") - <+> (braces $ vcat [ ptext (sLit "Dead givens =") <+> ppr dead - , ptext (sLit "Needed =") <+> ppr vs ]) + = text "Solved" + <+> (braces $ vcat [ text "Dead givens =" <+> ppr dead + , text "Needed =" <+> ppr vs ]) {- Note [Needed evidence variables] @@ -2182,9 +2182,9 @@ instance Outputable TcEvDest where instance Outputable CtEvidence where ppr fl = case fl of - CtGiven {} -> ptext (sLit "[G]") <+> ppr (ctev_evar fl) <+> ppr_pty - CtWanted {} -> ptext (sLit "[W]") <+> ppr (ctev_dest fl) <+> ppr_pty - CtDerived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty + CtGiven {} -> text "[G]" <+> ppr (ctev_evar fl) <+> ppr_pty + CtWanted {} -> text "[W]" <+> ppr (ctev_dest fl) <+> ppr_pty + CtDerived {} -> text "[D]" <+> text "_" <+> ppr_pty where ppr_pty = dcolon <+> ppr (ctEvPred fl) isWanted :: CtEvidence -> Bool @@ -2561,28 +2561,28 @@ instance Outputable SkolemInfo where pprSkolInfo :: SkolemInfo -> SDoc -- Complete the sentence "is a rigid type variable bound by..." pprSkolInfo (SigSkol ctxt ty) = pprSigSkolInfo ctxt ty -pprSkolInfo (IPSkol ips) = ptext (sLit "the implicit-parameter binding") <> plural ips <+> ptext (sLit "for") +pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" <+> pprWithCommas ppr ips -pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls) -pprSkolInfo (DerivSkol pred) = ptext (sLit "the deriving clause for") <+> quotes (ppr pred) -pprSkolInfo InstSkol = ptext (sLit "the instance declaration") -pprSkolInfo (InstSC n) = ptext (sLit "the instance declaration") <> ifPprDebug (parens (ppr n)) -pprSkolInfo DataSkol = ptext (sLit "a data type declaration") -pprSkolInfo FamInstSkol = ptext (sLit "a family instance declaration") -pprSkolInfo BracketSkol = ptext (sLit "a Template Haskell bracket") -pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> pprRuleName name -pprSkolInfo ArrowSkol = ptext (sLit "an arrow form") +pprSkolInfo (ClsSkol cls) = text "the class declaration for" <+> quotes (ppr cls) +pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) +pprSkolInfo InstSkol = text "the instance declaration" +pprSkolInfo (InstSC n) = text "the instance declaration" <> ifPprDebug (parens (ppr n)) +pprSkolInfo DataSkol = text "a data type declaration" +pprSkolInfo FamInstSkol = text "a family instance declaration" +pprSkolInfo BracketSkol = text "a Template Haskell bracket" +pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name +pprSkolInfo ArrowSkol = text "an arrow form" pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl - , ptext (sLit "in") <+> pprMatchContext mc ] -pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") + , text "in" <+> pprMatchContext mc ] +pprSkolInfo (InferSkol ids) = sep [ text "the inferred type of" , vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]] -pprSkolInfo (UnifyForAllSkol ty) = ptext (sLit "the type") <+> ppr ty +pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen -pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") +pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" pprSigSkolInfo :: UserTypeCtxt -> Type -> SDoc pprSigSkolInfo ctxt ty @@ -2591,12 +2591,12 @@ pprSigSkolInfo ctxt ty _ -> vcat [ pprUserTypeCtxt ctxt <> colon , nest 2 (ppr ty) ] where - pp_sig f = vcat [ ptext (sLit "the type signature for:") + pp_sig f = vcat [ text "the type signature for:" , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] pprPatSkolInfo :: ConLike -> SDoc pprPatSkolInfo (RealDataCon dc) - = sep [ ptext (sLit "a pattern with constructor:") + = sep [ text "a pattern with constructor:" , nest 2 $ ppr dc <+> dcolon <+> pprType (dataConUserType dc) <> comma ] -- pprType prints forall's regardless of -fprint-explict-foralls @@ -2604,7 +2604,7 @@ pprPatSkolInfo (RealDataCon dc) -- type variable 't' is bound by ... pprPatSkolInfo (PatSynCon ps) - = sep [ ptext (sLit "a pattern with pattern synonym:") + = sep [ text "a pattern with pattern synonym:" , nest 2 $ ppr ps <+> dcolon <+> pprType (patSynType ps) <> comma ] @@ -2737,7 +2737,7 @@ instance Outputable ErrorThing where ppr (ErrorThing thing _ _) = ppr thing ctoHerald :: SDoc -ctoHerald = ptext (sLit "arising from") +ctoHerald = text "arising from" -- | Extract a suitable CtOrigin from a HsExpr exprCtOrigin :: HsExpr Name -> CtOrigin @@ -2825,38 +2825,38 @@ pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk pprCtOrigin (SpecPragOrigin ctxt) = case ctxt of - FunSigCtxt n _ -> ptext (sLit "a SPECIALISE pragma for") <+> quotes (ppr n) - SpecInstCtxt -> ptext (sLit "a SPECIALISE INSTANCE pragma") - _ -> ptext (sLit "a SPECIALISE pragma") -- Never happens I think + FunSigCtxt n _ -> text "a SPECIALISE pragma for" <+> quotes (ppr n) + SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" + _ -> text "a SPECIALISE pragma" -- Never happens I think pprCtOrigin (FunDepOrigin1 pred1 loc1 pred2 loc2) - = hang (ctoHerald <+> ptext (sLit "a functional dependency between constraints:")) + = hang (ctoHerald <+> text "a functional dependency between constraints:") 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtLoc loc1) , hang (quotes (ppr pred2)) 2 (pprCtLoc loc2) ]) pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) - = hang (ctoHerald <+> ptext (sLit "a functional dependency between:")) - 2 (vcat [ hang (ptext (sLit "constraint") <+> quotes (ppr pred1)) + = hang (ctoHerald <+> text "a functional dependency between:") + 2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1)) 2 (pprCtOrigin orig1 ) - , hang (ptext (sLit "instance") <+> quotes (ppr pred2)) - 2 (ptext (sLit "at") <+> ppr loc2) ]) + , hang (text "instance" <+> quotes (ppr pred2)) + 2 (text "at" <+> ppr loc2) ]) pprCtOrigin (KindEqOrigin t1 t2 _ _) - = hang (ctoHerald <+> ptext (sLit "a kind equality arising from")) + = hang (ctoHerald <+> text "a kind equality arising from") 2 (sep [ppr t1, char '~', ppr t2]) pprCtOrigin (UnboundOccurrenceOf name) - = ctoHerald <+> ptext (sLit "an undeclared identifier") <+> quotes (ppr name) + = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name) pprCtOrigin (DerivOriginDC dc n) - = hang (ctoHerald <+> ptext (sLit "the") <+> speakNth n - <+> ptext (sLit "field of") <+> quotes (ppr dc)) - 2 (parens (ptext (sLit "type") <+> quotes (ppr ty))) + = hang (ctoHerald <+> text "the" <+> speakNth n + <+> text "field of" <+> quotes (ppr dc)) + 2 (parens (text "type" <+> quotes (ppr ty))) where ty = dataConOrigArgTys dc !! (n-1) pprCtOrigin (DerivOriginCoerce meth ty1 ty2) - = hang (ctoHerald <+> ptext (sLit "the coercion of the method") <+> quotes (ppr meth)) + = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth)) 2 (sep [ text "from type" <+> quotes (ppr ty1) , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) @@ -2888,37 +2888,37 @@ pprCtOrigin simple_origin -- | Short one-liners pprCtO :: CtOrigin -> SDoc -pprCtO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] -pprCtO (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] -pprCtO AppOrigin = ptext (sLit "an application") -pprCtO (IPOccOrigin name) = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)] -pprCtO (OverLabelOrigin l) = hsep [ptext (sLit "the overloaded label") +pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] +pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] +pprCtO AppOrigin = text "an application" +pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] +pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)] -pprCtO RecordUpdOrigin = ptext (sLit "a record update") -pprCtO ExprSigOrigin = ptext (sLit "an expression type signature") -pprCtO PatSigOrigin = ptext (sLit "a pattern type signature") -pprCtO PatOrigin = ptext (sLit "a pattern") -pprCtO ViewPatOrigin = ptext (sLit "a view pattern") -pprCtO IfOrigin = ptext (sLit "an if expression") -pprCtO (LiteralOrigin lit) = hsep [ptext (sLit "the literal"), quotes (ppr lit)] -pprCtO (ArithSeqOrigin seq) = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)] -pprCtO (PArrSeqOrigin seq) = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)] -pprCtO SectionOrigin = ptext (sLit "an operator section") -pprCtO TupleOrigin = ptext (sLit "a tuple") -pprCtO NegateOrigin = ptext (sLit "a use of syntactic negation") -pprCtO (ScOrigin n) = ptext (sLit "the superclasses of an instance declaration") +pprCtO RecordUpdOrigin = text "a record update" +pprCtO ExprSigOrigin = text "an expression type signature" +pprCtO PatSigOrigin = text "a pattern type signature" +pprCtO PatOrigin = text "a pattern" +pprCtO ViewPatOrigin = text "a view pattern" +pprCtO IfOrigin = text "an if expression" +pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] +pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] +pprCtO (PArrSeqOrigin seq) = hsep [text "the parallel array sequence", quotes (ppr seq)] +pprCtO SectionOrigin = text "an operator section" +pprCtO TupleOrigin = text "a tuple" +pprCtO NegateOrigin = text "a use of syntactic negation" +pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" <> ifPprDebug (parens (ppr n)) -pprCtO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration") -pprCtO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") -pprCtO DefaultOrigin = ptext (sLit "a 'default' declaration") -pprCtO DoOrigin = ptext (sLit "a do statement") +pprCtO DerivOrigin = text "the 'deriving' clause of a data type declaration" +pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" +pprCtO DefaultOrigin = text "a 'default' declaration" +pprCtO DoOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" -pprCtO ProcOrigin = ptext (sLit "a proc expression") -pprCtO (TypeEqOrigin t1 t2 _)= ptext (sLit "a type equality") <+> sep [ppr t1, char '~', ppr t2] -pprCtO AnnOrigin = ptext (sLit "an annotation") -pprCtO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_") -pprCtO ListOrigin = ptext (sLit "an overloaded list") -pprCtO StaticOrigin = ptext (sLit "a static form") +pprCtO ProcOrigin = text "a proc expression" +pprCtO (TypeEqOrigin t1 t2 _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2] +pprCtO AnnOrigin = text "an annotation" +pprCtO HoleOrigin = text "a use of" <+> quotes (text "_") +pprCtO ListOrigin = text "an overloaded list" +pprCtO StaticOrigin = text "a static form" pprCtO _ = panic "pprCtOrigin" {- diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index d90b9a7305..fe6561c306 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -154,7 +154,7 @@ tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs) ; return (tvs ++ id : vars) } ruleCtxt :: FastString -> SDoc -ruleCtxt name = ptext (sLit "When checking the transformation rule") <+> +ruleCtxt name = text "When checking the transformation rule" <+> doubleQuotes (ftext name) @@ -325,7 +325,7 @@ simplifyRule name lhs_wanted rhs_wanted bagToList zonked_lhs_simples ; traceTc "simplifyRule" $ - vcat [ ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) + vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) , text "lhs_wantd" <+> ppr lhs_wanted , text "rhs_wantd" <+> ppr rhs_wanted , text "zonked_lhs_simples" <+> ppr zonked_lhs_simples diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 6d309583cd..0214f135da 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -143,7 +143,6 @@ import VarSet import Outputable import Bag import UniqSupply -import FastString import Util import TcRnTypes @@ -317,15 +316,15 @@ instance Outputable WorkList where , wl_rest = rest, wl_implics = implics, wl_deriv = ders }) = text "WL" <+> (braces $ vcat [ ppUnless (null eqs) $ - ptext (sLit "Eqs =") <+> vcat (map ppr eqs) + text "Eqs =" <+> vcat (map ppr eqs) , ppUnless (null feqs) $ - ptext (sLit "Funeqs =") <+> vcat (map ppr feqs) + text "Funeqs =" <+> vcat (map ppr feqs) , ppUnless (null rest) $ - ptext (sLit "Non-eqs =") <+> vcat (map ppr rest) + text "Non-eqs =" <+> vcat (map ppr rest) , ppUnless (null ders) $ - ptext (sLit "Derived =") <+> vcat (map ppr ders) + text "Derived =" <+> vcat (map ppr ders) , ppUnless (isEmptyBag implics) $ - ptext (sLit "Implics =") <+> vcat (map ppr (bagToList implics)) + text "Implics =" <+> vcat (map ppr (bagToList implics)) ]) @@ -1060,16 +1059,16 @@ instance Outputable InertCans where , inert_insols = insols, inert_count = count }) = braces $ vcat [ ppUnless (isEmptyVarEnv eqs) $ - ptext (sLit "Equalities:") + text "Equalities:" <+> pprCts (foldVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs) , ppUnless (isEmptyTcAppMap funeqs) $ - ptext (sLit "Type-function equalities =") <+> pprCts (funEqsToBag funeqs) + text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs) , ppUnless (isEmptyTcAppMap dicts) $ - ptext (sLit "Dictionaries =") <+> pprCts (dictsToBag dicts) + text "Dictionaries =" <+> pprCts (dictsToBag dicts) , ppUnless (isEmptyTcAppMap safehask) $ - ptext (sLit "Safe Haskell unsafe overlap =") <+> pprCts (dictsToBag safehask) + text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) , ppUnless (isEmptyCts irreds) $ - ptext (sLit "Irreds =") <+> pprCts irreds + text "Irreds =" <+> pprCts irreds , ppUnless (isEmptyCts insols) $ text "Insolubles =" <+> pprCts insols , ppUnless (isEmptyVarEnv model) $ @@ -1185,7 +1184,7 @@ addInertEq ct@(CTyEqCan { cc_tyvar = tv }) ; unless (isEmptyWorkList kicked_out) $ do { updWorkListTcS (appendWorkList kicked_out) ; csTraceTcS $ - hang (ptext (sLit "Kick out, tv =") <+> ppr tv) + hang (text "Kick out, tv =" <+> ppr tv) 2 (vcat [ text "n-kicked =" <+> int (workListSize kicked_out) , ppr kicked_out ]) } @@ -1237,8 +1236,8 @@ emitDerivedShadows IC { inert_eqs = tv_eqs = return () | otherwise = do { traceTcS "Emit derived shadows:" $ - vcat [ ptext (sLit "tyvar =") <+> ppr new_tv - , ptext (sLit "shadows =") <+> vcat (map ppr shadows) ] + vcat [ text "tyvar =" <+> ppr new_tv + , text "shadows =" <+> vcat (map ppr shadows) ] ; emitWork shadows } where shadows = foldDicts get_ct dicts $ @@ -1475,7 +1474,7 @@ kickOutAfterUnification new_tv ; unless (isEmptyWorkList kicked_out) $ csTraceTcS $ - hang (ptext (sLit "Kick out (unify), tv =") <+> ppr new_tv) + hang (text "Kick out (unify), tv =" <+> ppr new_tv) 2 (vcat [ text "n-kicked =" <+> int (workListSize kicked_out) , text "kicked_out =" <+> ppr kicked_out , text "Residual inerts =" <+> ppr ics2 ]) @@ -2357,7 +2356,7 @@ traceFireTcS ev doc = TcS $ \env -> csTraceTcM 1 $ do { n <- TcM.readTcRef (tcs_count env) ; tclvl <- TcM.getTcLevel - ; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr tclvl + ; return (hang (int n <> brackets (text "U:" <> ppr tclvl <> ppr (ctLocDepth (ctEvLoc ev))) <+> doc <> colon) 4 (ppr ev)) } @@ -2416,7 +2415,7 @@ runTcSWithEvBinds solve_deriveds ev_binds_var tcs ; count <- TcM.readTcRef step_count ; when (count > 0) $ - csTraceTcM 0 $ return (ptext (sLit "Constraint solver steps =") <+> int count) + csTraceTcM 0 $ return (text "Constraint solver steps =" <+> int count) #ifdef DEBUG ; whenIsJust ev_binds_var $ \ebv -> @@ -2702,7 +2701,7 @@ checkWellStagedDFun pred dfun_id loc do { use_stage <- TcM.getStage ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } where - pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred) + pp_thing = text "instance for" <+> quotes (ppr pred) bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 4d93912bad..c428ce9104 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -44,7 +44,6 @@ import Var import VarSet import BasicTypes ( IntWithInf, intGtLimit ) import ErrUtils ( emptyMessages ) -import FastString import qualified GHC.LanguageExtensions as LangExt import Control.Monad ( when, unless ) @@ -500,11 +499,11 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds | otherwise = do { traceTc "simplifyInfer {" $ vcat - [ ptext (sLit "sigs =") <+> ppr sigs - , ptext (sLit "binds =") <+> ppr name_taus - , ptext (sLit "rhs_tclvl =") <+> ppr rhs_tclvl - , ptext (sLit "apply_mr =") <+> ppr apply_mr - , ptext (sLit "(unzonked) wanted =") <+> ppr wanteds + [ text "sigs =" <+> ppr sigs + , text "binds =" <+> ppr name_taus + , text "rhs_tclvl =" <+> ppr rhs_tclvl + , text "apply_mr =" <+> ppr apply_mr + , text "(unzonked) wanted =" <+> ppr wanteds ] -- First do full-blown solving @@ -630,13 +629,13 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds -- All done! ; traceTc "} simplifyInfer/produced residual implication for quantification" $ - vcat [ ptext (sLit "quant_pred_candidates =") <+> ppr quant_pred_candidates - , ptext (sLit "zonked_taus") <+> ppr zonked_taus - , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs - , ptext (sLit "promote_tvs=") <+> ppr promote_tvs - , ptext (sLit "bound_theta =") <+> ppr bound_theta - , ptext (sLit "qtvs =") <+> ppr qtvs - , ptext (sLit "implic =") <+> ppr implic ] + vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates + , text "zonked_taus" <+> ppr zonked_taus + , text "zonked_tau_tvs=" <+> ppr zonked_tau_tvs + , text "promote_tvs=" <+> ppr promote_tvs + , text "bound_theta =" <+> ppr bound_theta + , text "qtvs =" <+> ppr qtvs + , text "implic =" <+> ppr implic ] ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var ) } @@ -722,10 +721,10 @@ decideQuantification apply_mr sigs name_taus constraints ; let mr_bites = constrained_tvs `intersectsVarSet` zonked_tkvs ; warnTc (warn_mono && mr_bites) $ hang (text "The Monomorphism Restriction applies to the binding" - <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs) + <> plural bndrs <+> text "for" <+> pp_bndrs) 2 (text "Consider giving a type signature for" <+> if isSingleton bndrs then pp_bndrs - else ptext (sLit "these binders")) + else text "these binders") -- All done ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs @@ -1018,14 +1017,14 @@ simpl_loop n limit floated_eqs no_new_scs = return wc -- Done! | n `intGtLimit` limit - = do { warnTcS (hang (ptext (sLit "solveWanteds: too many iterations") - <+> parens (ptext (sLit "limit =") <+> ppr limit)) - 2 (vcat [ ptext (sLit "Unsolved:") <+> ppr wc + = do { warnTcS (hang (text "solveWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Unsolved:" <+> ppr wc , ppUnless (isEmptyBag floated_eqs) $ - ptext (sLit "Floated equalities:") <+> ppr floated_eqs + text "Floated equalities:" <+> ppr floated_eqs , ppUnless no_new_scs $ - ptext (sLit "New superclasses found") - , ptext (sLit "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit") + text "New superclasses found" + , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" ])) ; return wc } diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index ab2e30cb31..fe13226c60 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -45,7 +45,6 @@ import TcType import Outputable import TcExpr import SrcLoc -import FastString import THNames import TcUnify import TcEnv @@ -103,6 +102,7 @@ import Unique import VarSet ( isEmptyVarSet, filterVarSet ) import Data.List ( find ) import Data.Maybe +import FastString import BasicTypes hiding( SuccessFlag(..) ) import Maybes( MaybeErr(..) ) import DynFlags @@ -226,7 +226,7 @@ tcTExpTy tau quotationCtxtDoc :: HsBracket Name -> SDoc quotationCtxtDoc br_body - = hang (ptext (sLit "In the Template Haskell quotation")) + = hang (text "In the Template Haskell quotation") 2 (ppr br_body) @@ -497,14 +497,14 @@ tcTopSplice expr res_ty spliceCtxtDoc :: HsSplice Name -> SDoc spliceCtxtDoc splice - = hang (ptext (sLit "In the Template Haskell splice")) + = hang (text "In the Template Haskell splice") 2 (pprSplice splice) spliceResultDoc :: LHsExpr Name -> SDoc spliceResultDoc expr - = sep [ ptext (sLit "In the result of the splice:") + = sep [ text "In the result of the splice:" , nest 2 (char '$' <> pprParendExpr expr) - , ptext (sLit "To see what the splice expanded to, use -ddump-splices")] + , text "To see what the splice expanded to, use -ddump-splices"] ------------------- tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) @@ -870,7 +870,7 @@ instance TH.Quasi TcM where bindName name = addErr $ - hang (ptext (sLit "The binder") <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) + hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") qAddModFinalizer fin = do @@ -1069,7 +1069,7 @@ getAnnotationsByTypeRep th_name tyrep reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] reifyInstances th_nm th_tys - = addErrCtxt (ptext (sLit "In the argument of reifyInstances:") + = addErrCtxt (text "In the argument of reifyInstances:" <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ do { loc <- getSrcSpanM ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys) @@ -1104,8 +1104,8 @@ reifyInstances th_nm th_tys ; let matches = lookupFamInstEnv inst_envs tc tys ; traceTc "reifyInstances2" (ppr matches) ; reifyFamilyInstances tc (map fim_instance matches) } - _ -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty)) - 2 (ptext (sLit "is not a class constraint or type family application"))) } + _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application")) } where doc = ClassInstanceCtx bale_out msg = failWithTc msg @@ -1219,12 +1219,12 @@ tcLookupTh name notInScope :: TH.Name -> SDoc notInScope th_name = quotes (text (TH.pprint th_name)) <+> - ptext (sLit "is not in scope at a reify") + text "is not in scope at a reify" -- Ugh! Rather an indirect way to display the name notInEnv :: Name -> SDoc notInEnv name = quotes (ppr name) <+> - ptext (sLit "is not in the type environment at a reify") + text "is not in the type environment at a reify" ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role] @@ -1232,7 +1232,7 @@ reifyRoles th_name = do { thing <- getThing th_name ; case thing of AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (ptext (sLit "No roles associated with") <+> (ppr thing)) + _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) } where reify_role Nominal = TH.NominalR @@ -1869,7 +1869,7 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do return $ TH.ModuleInfo usages reifyFromIface reifMod = do - iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod + iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod let usages = [modToTHMod m | usage <- mi_usages iface, Just m <- [usageToModule (moduleUnitId reifMod) usage] ] return $ TH.ModuleInfo usages @@ -1884,8 +1884,8 @@ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys noTH :: LitString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> - ptext (sLit "in Template Haskell:"), +noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> + text "in Template Haskell:", nest 2 d]) ppr_th :: TH.Ppr a => a -> SDoc diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index b7b27c286d..684853d90f 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -61,7 +61,6 @@ import SrcLoc import ListSetOps import Digraph import DynFlags -import FastString import Unique import BasicTypes import qualified GHC.LanguageExtensions as LangExt @@ -267,7 +266,7 @@ kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)] -- See Note [Kind checking for type and class decls] kcTyClGroup (TyClGroup { group_tyclds = decls }) = do { mod <- getModule - ; traceTc "kcTyClGroup" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) + ; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls)) -- Kind checking; -- 1. Bind kind variables for non-synonyms @@ -962,7 +961,7 @@ tcDefaultAssocDecl _ [] = return Nothing -- No default declaration tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (ptext (sLit "More than one default declaration for") + = failWithTc (text "More than one default declaration for" <+> ppr (tfe_tycon (unLoc d1))) tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name @@ -971,7 +970,7 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name | HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs = -- See Note [Type-checking default assoc decls] setSrcSpan loc $ - tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $ + tcAddFamInstCtxt (text "default type instance") tc_name $ do { traceTc "tcDefaultAssocDecl" (ppr tc_name) ; let shape@(fam_tc_name, fam_arity, _) = famTyConShape fam_tc @@ -2106,16 +2105,16 @@ checkValidDataCon dflags existential_ok tc con check_bang (HsSrcBang _ _ SrcLazy) _ n | not (xopt LangExt.StrictData dflags) = addErrTc - (bad_bang n (ptext (sLit "Lazy annotation (~) without StrictData"))) + (bad_bang n (text "Lazy annotation (~) without StrictData")) check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n | isSrcUnpacked want_unpack, not is_strict - = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'"))) + = addWarnTc (bad_bang n (text "UNPACK pragma lacks '!'")) | isSrcUnpacked want_unpack , case rep_bang of { HsUnpack {} -> False; _ -> True } , not (gopt Opt_OmitInterfacePragmas dflags) -- If not optimising, se don't unpack, so don't complain! -- See MkId.dataConArgRep, the (HsBang True) case - = addWarnTc (bad_bang n (ptext (sLit "Ignoring unusable UNPACK pragma"))) + = addWarnTc (bad_bang n (text "Ignoring unusable UNPACK pragma")) where is_strict = case strict_mark of NoSrcStrict -> xopt LangExt.StrictData dflags @@ -2125,8 +2124,8 @@ checkValidDataCon dflags existential_ok tc con = return () bad_bang n herald - = hang herald 2 (ptext (sLit "on the") <+> speakNth n - <+> ptext (sLit "argument of") <+> quotes (ppr con)) + = hang herald 2 (text "on the" <+> speakNth n + <+> text "argument of" <+> quotes (ppr con)) ------------------------------- checkNewDataCon :: DataCon -> TcM () -- Further checks for the data constructor of a newtype @@ -2135,14 +2134,14 @@ checkNewDataCon con -- One argument ; check_con (null eq_spec) $ - ptext (sLit "A newtype constructor must have a return type of form T a1 ... an") + text "A newtype constructor must have a return type of form T a1 ... an" -- Return type is (T a b c) ; check_con (null theta) $ - ptext (sLit "A newtype constructor cannot have a context in its type") + text "A newtype constructor cannot have a context in its type" ; check_con (null ex_tvs) $ - ptext (sLit "A newtype constructor cannot have existential type variables") + text "A newtype constructor cannot have existential type variables" -- No existentials ; checkTc (all ok_bang (dataConSrcBangs con)) @@ -2253,8 +2252,8 @@ checkFamFlag tc_name = do { idx_tys <- xoptM LangExt.TypeFamilies ; checkTc idx_tys err_msg } where - err_msg = hang (ptext (sLit "Illegal family declaration for") <+> quotes (ppr tc_name)) - 2 (ptext (sLit "Use TypeFamilies to allow indexed type families")) + err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) + 2 (text "Use TypeFamilies to allow indexed type families") {- Note [Abort when superclass cycle is detected] @@ -2357,11 +2356,11 @@ checkValidRoles tc check_ty_roles env role (TyVarTy tv) = case lookupVarEnv env tv of Just role' -> unless (role' `ltRole` role || role' == role) $ - report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+> - ptext (sLit "cannot have role") <+> ppr role <+> - ptext (sLit "because it was assigned role") <+> ppr role' - Nothing -> report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+> - ptext (sLit "missing in environment") + report_error $ text "type variable" <+> quotes (ppr tv) <+> + text "cannot have role" <+> ppr role <+> + text "because it was assigned role" <+> ppr role' + Nothing -> report_error $ text "type variable" <+> quotes (ppr tv) <+> + text "missing in environment" check_ty_roles env Representational (TyConApp tc tys) = let roles' = tyConRoles tc in @@ -2399,9 +2398,9 @@ checkValidRoles tc check_ty_roles env role ty report_error doc - = addErrTc $ vcat [ptext (sLit "Internal error in role inference:"), + = addErrTc $ vcat [text "Internal error in role inference:", doc, - ptext (sLit "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug")] + text "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug"] {- ************************************************************************ @@ -2413,7 +2412,7 @@ checkValidRoles tc tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a tcAddTyFamInstCtxt decl - = tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl) + = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) tcMkDataFamInstCtxt :: DataFamInstDecl Name -> SDoc tcMkDataFamInstCtxt decl @@ -2437,31 +2436,31 @@ tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a tcAddClosedTypeFamilyDeclCtxt tc = addErrCtxt ctxt where - ctxt = ptext (sLit "In the equations for closed type family") <+> + ctxt = text "In the equations for closed type family" <+> quotes (ppr tc) resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc resultTypeMisMatch field_name con1 con2 - = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, - ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma], - nest 2 $ ptext (sLit "but have different result types")] + = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "have a common field" <+> quotes (ppr field_name) <> comma], + nest 2 $ text "but have different result types"] fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc fieldTypeMisMatch field_name con1 con2 - = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, - ptext (sLit "give different types for field"), quotes (ppr field_name)] + = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "give different types for field", quotes (ppr field_name)] dataConCtxtName :: [Located Name] -> SDoc dataConCtxtName [con] - = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con) + = text "In the definition of data constructor" <+> quotes (ppr con) dataConCtxtName con - = ptext (sLit "In the definition of data constructors") <+> interpp'SP con + = text "In the definition of data constructors" <+> interpp'SP con dataConCtxt :: Outputable a => a -> SDoc -dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con) +dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con) classOpCtxt :: Var -> Type -> SDoc -classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"), +classOpCtxt sel_id tau = sep [text "When checking the class method:", nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] classArityErr :: Int -> Class -> SDoc @@ -2470,32 +2469,32 @@ classArityErr n cls | otherwise = mkErr "Too many" "multi-parameter" where mkErr howMany allowWhat = - vcat [ptext (sLit $ howMany ++ " parameters for class") <+> quotes (ppr cls), - parens (ptext (sLit $ "Use MultiParamTypeClasses to allow " + vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), + parens (text ("Use MultiParamTypeClasses to allow " ++ allowWhat ++ " classes"))] classFunDepsErr :: Class -> SDoc classFunDepsErr cls - = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls), - parens (ptext (sLit "Use FunctionalDependencies to allow fundeps"))] + = vcat [text "Fundeps in class" <+> quotes (ppr cls), + parens (text "Use FunctionalDependencies to allow fundeps")] badMethPred :: Id -> TcPredType -> SDoc badMethPred sel_id pred - = vcat [ hang (ptext (sLit "Constraint") <+> quotes (ppr pred) - <+> ptext (sLit "in the type of") <+> quotes (ppr sel_id)) - 2 (ptext (sLit "constrains only the class type variables")) - , ptext (sLit "Use ConstrainedClassMethods to allow it") ] + = vcat [ hang (text "Constraint" <+> quotes (ppr pred) + <+> text "in the type of" <+> quotes (ppr sel_id)) + 2 (text "constrains only the class type variables") + , text "Use ConstrainedClassMethods to allow it" ] noClassTyVarErr :: Class -> TyCon -> SDoc noClassTyVarErr clas fam_tc - = sep [ ptext (sLit "The associated type") <+> quotes (ppr fam_tc) - , ptext (sLit "mentions none of the type or kind variables of the class") <+> + = sep [ text "The associated type" <+> quotes (ppr fam_tc) + , text "mentions none of the type or kind variables of the class" <+> quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] recSynErr :: [LTyClDecl Name] -> TcRn () recSynErr syn_decls = setSrcSpan (getLoc (head sorted_decls)) $ - addErr (sep [ptext (sLit "Cycle in type synonym declarations:"), + addErr (sep [text "Cycle in type synonym declarations:", nest 2 (vcat (map ppr_decl sorted_decls))]) where sorted_decls = sortLocated syn_decls @@ -2503,55 +2502,55 @@ recSynErr syn_decls badDataConTyCon :: DataCon -> Type -> Type -> SDoc badDataConTyCon data_con res_ty_tmpl actual_res_ty - = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+> - ptext (sLit "returns type") <+> quotes (ppr actual_res_ty)) - 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl)) + = hang (text "Data constructor" <+> quotes (ppr data_con) <+> + text "returns type" <+> quotes (ppr actual_res_ty)) + 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) badGadtDecl :: Name -> SDoc badGadtDecl tc_name - = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext (sLit "Use GADTs to allow GADTs")) ] + = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) + , nest 2 (parens $ text "Use GADTs to allow GADTs") ] badExistential :: DataCon -> SDoc badExistential con - = hang (ptext (sLit "Data constructor") <+> quotes (ppr con) <+> - ptext (sLit "has existential type variables, a context, or a specialised result type")) + = hang (text "Data constructor" <+> quotes (ppr con) <+> + text "has existential type variables, a context, or a specialised result type") 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) - , parens $ ptext (sLit "Use ExistentialQuantification or GADTs to allow this") ]) + , parens $ text "Use ExistentialQuantification or GADTs to allow this" ]) badStupidTheta :: Name -> SDoc badStupidTheta tc_name - = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) + = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) newtypeConError :: Name -> Int -> SDoc newtypeConError tycon n - = sep [ptext (sLit "A newtype must have exactly one constructor,"), - nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ] + = sep [text "A newtype must have exactly one constructor,", + nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] newtypeStrictError :: DataCon -> SDoc newtypeStrictError con - = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"), - nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")] + = sep [text "A newtype constructor cannot have a strictness annotation,", + nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] newtypeFieldErr :: DataCon -> Int -> SDoc newtypeFieldErr con_name n_flds - = sep [ptext (sLit "The constructor of a newtype must have exactly one field"), - nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds] + = sep [text "The constructor of a newtype must have exactly one field", + nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] badSigTyDecl :: Name -> SDoc badSigTyDecl tc_name - = vcat [ ptext (sLit "Illegal kind signature") <+> + = vcat [ text "Illegal kind signature" <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext (sLit "Use KindSignatures to allow kind signatures")) ] + , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] emptyConDeclsErr :: Name -> SDoc emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), - nest 2 $ ptext (sLit "(EmptyDataDecls permits this)")] + = sep [quotes (ppr tycon) <+> text "has no constructors", + nest 2 $ text "(EmptyDataDecls permits this)"] wrongKindOfFamily :: TyCon -> SDoc wrongKindOfFamily family - = ptext (sLit "Wrong category of family instance; declaration was for a") + = text "Wrong category of family instance; declaration was for a" <+> kindOfFamily where kindOfFamily | isTypeFamilyTyCon family = text "type family" @@ -2560,45 +2559,45 @@ wrongKindOfFamily family wrongNumberOfParmsErr :: Arity -> SDoc wrongNumberOfParmsErr max_args - = ptext (sLit "Number of parameters must match family declaration; expected") + = text "Number of parameters must match family declaration; expected" <+> ppr max_args defaultAssocKindErr :: TyCon -> SDoc defaultAssocKindErr fam_tc - = ptext (sLit "Kind mis-match on LHS of default declaration for") + = text "Kind mis-match on LHS of default declaration for" <+> quotes (ppr fam_tc) wrongTyFamName :: Name -> Name -> SDoc wrongTyFamName fam_tc_name eqn_tc_name - = hang (ptext (sLit "Mismatched type name in type family instance.")) - 2 (vcat [ ptext (sLit "Expected:") <+> ppr fam_tc_name - , ptext (sLit " Actual:") <+> ppr eqn_tc_name ]) + = hang (text "Mismatched type name in type family instance.") + 2 (vcat [ text "Expected:" <+> ppr fam_tc_name + , text " Actual:" <+> ppr eqn_tc_name ]) badRoleAnnot :: Name -> Role -> Role -> SDoc badRoleAnnot var annot inferred - = hang (ptext (sLit "Role mismatch on variable") <+> ppr var <> colon) - 2 (sep [ ptext (sLit "Annotation says"), ppr annot - , ptext (sLit "but role"), ppr inferred - , ptext (sLit "is required") ]) + = hang (text "Role mismatch on variable" <+> ppr var <> colon) + 2 (sep [ text "Annotation says", ppr annot + , text "but role", ppr inferred + , text "is required" ]) wrongNumberOfRoles :: [a] -> LRoleAnnotDecl Name -> SDoc wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots)) - = hang (ptext (sLit "Wrong number of roles listed in role annotation;") $$ - ptext (sLit "Expected") <+> (ppr $ length tyvars) <> comma <+> - ptext (sLit "got") <+> (ppr $ length annots) <> colon) + = hang (text "Wrong number of roles listed in role annotation;" $$ + text "Expected" <+> (ppr $ length tyvars) <> comma <+> + text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) illegalRoleAnnotDecl :: LRoleAnnotDecl Name -> TcM () illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _)) = setErrCtxt [] $ setSrcSpan loc $ - addErrTc (ptext (sLit "Illegal role annotation for") <+> ppr tycon <> char ';' $$ - ptext (sLit "they are allowed only for datatypes and classes.")) + addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ + text "they are allowed only for datatypes and classes.") needXRoleAnnotations :: TyCon -> SDoc needXRoleAnnotations tc - = ptext (sLit "Illegal role annotation for") <+> ppr tc <> char ';' $$ - ptext (sLit "did you intend to use RoleAnnotations?") + = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ + text "did you intend to use RoleAnnotations?" incoherentRoles :: SDoc incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> @@ -2611,8 +2610,8 @@ addTyConCtxt tc where name = getName tc flav = text (tyConFlavour tc) - ctxt = hsep [ ptext (sLit "In the"), flav - , ptext (sLit "declaration for"), quotes (ppr name) ] + ctxt = hsep [ text "In the", flav + , text "declaration for", quotes (ppr name) ] addRoleAnnotCtxt :: Name -> TcM a -> TcM a addRoleAnnotCtxt name diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index c2f017d0cf..2517c46a2c 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -191,12 +191,12 @@ checkClassCycles :: Class -> Maybe SDoc checkClassCycles cls = do { (definite_cycle, err) <- go (unitNameSet (getName cls)) cls (mkTyVarTys (classTyVars cls)) - ; let herald | definite_cycle = ptext (sLit "Superclass cycle for") - | otherwise = ptext (sLit "Potential superclass cycle for") + ; let herald | definite_cycle = text "Superclass cycle for" + | otherwise = text "Potential superclass cycle for" ; return (vcat [ herald <+> quotes (ppr cls) , nest 2 err, hint]) } where - hint = ptext (sLit "Use UndecidableSuperClasses to accept this") + hint = text "Use UndecidableSuperClasses to accept this" -- Expand superclasses starting with (C a b), complaining -- if you find the same class a second time, or a type function @@ -218,7 +218,7 @@ checkClassCycles cls | Just (tc, tys) <- tcSplitTyConApp_maybe pred = go_tc so_far pred tc tys | hasTyVarHead pred - = Just (False, hang (ptext (sLit "one of whose superclass constraints is headed by a type variable:")) + = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:") 2 (quotes (ppr pred))) | otherwise = Nothing @@ -226,7 +226,7 @@ checkClassCycles cls go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) go_tc so_far pred tc tys | isFamilyTyCon tc - = Just (False, hang (ptext (sLit "one of whose superclass constraints is headed by a type family:")) + = Just (False, hang (text "one of whose superclass constraints is headed by a type family:") 2 (quotes (ppr pred))) | Just cls <- tyConClass_maybe tc = go_cls so_far cls tys @@ -236,12 +236,12 @@ checkClassCycles cls go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) go_cls so_far cls tys | cls_nm `elemNameSet` so_far - = Just (True, ptext (sLit "one of whose superclasses is") <+> quotes (ppr cls)) + = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) | isCTupleClass cls = go so_far cls tys | otherwise = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys - ; return (b, ptext (sLit "one of whose superclasses is") <+> quotes (ppr cls) + ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) $$ err) } where cls_nm = getName cls diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index fca5f475a3..2f00be2fe8 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -384,8 +384,8 @@ data MetaDetails | Indirect TcType instance Outputable MetaDetails where - ppr Flexi = ptext (sLit "Flexi") - ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty + ppr Flexi = text "Flexi" + ppr (Indirect ty) = text "Indirect" <+> ppr ty data TauTvFlavour = VanillaTau @@ -599,40 +599,40 @@ instance Outputable TcLevel where pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging -pprTcTyVarDetails (SkolemTv True) = ptext (sLit "ssk") -pprTcTyVarDetails (SkolemTv False) = ptext (sLit "sk") -pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") -pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") +pprTcTyVarDetails (SkolemTv True) = text "ssk" +pprTcTyVarDetails (SkolemTv False) = text "sk" +pprTcTyVarDetails (RuntimeUnk {}) = text "rt" +pprTcTyVarDetails (FlatSkol {}) = text "fsk" pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) = pp_info <> colon <> ppr tclvl where pp_info = case info of - ReturnTv -> ptext (sLit "ret") - TauTv -> ptext (sLit "tau") - SigTv -> ptext (sLit "sig") - FlatMetaTv -> ptext (sLit "fuv") + ReturnTv -> text "ret" + TauTv -> text "tau" + SigTv -> text "sig" + FlatMetaTv -> text "fuv" pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n _) = ptext (sLit "the type signature for") <+> quotes (ppr n) -pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) -pprUserTypeCtxt (RuleSigCtxt n) = ptext (sLit "a RULE for") <+> quotes (ppr n) -pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature") -pprUserTypeCtxt TypeAppCtxt = ptext (sLit "a type argument") -pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c) -pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c) -pprUserTypeCtxt (PatSynCtxt c) = ptext (sLit "the type signature for pattern synonym") <+> quotes (ppr c) -pprUserTypeCtxt ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]") -pprUserTypeCtxt PatSigCtxt = ptext (sLit "a pattern type signature") -pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature") -pprUserTypeCtxt (ForSigCtxt n) = ptext (sLit "the foreign declaration for") <+> quotes (ppr n) -pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration") -pprUserTypeCtxt InstDeclCtxt = ptext (sLit "an instance declaration") -pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma") -pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context") -pprUserTypeCtxt GhciCtxt = ptext (sLit "a type in a GHCi command") -pprUserTypeCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c) -pprUserTypeCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type") -pprUserTypeCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc) +pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) +pprUserTypeCtxt (RuleSigCtxt n) = text "a RULE for" <+> quotes (ppr n) +pprUserTypeCtxt ExprSigCtxt = text "an expression type signature" +pprUserTypeCtxt TypeAppCtxt = text "a type argument" +pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) +pprUserTypeCtxt (PatSynCtxt c) = text "the type signature for pattern synonym" <+> quotes (ppr c) +pprUserTypeCtxt ThBrackCtxt = text "a Template Haskell quotation [t|...|]" +pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" +pprUserTypeCtxt ResSigCtxt = text "a result type signature" +pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration" +pprUserTypeCtxt InstDeclCtxt = text "an instance declaration" +pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" +pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" +pprUserTypeCtxt GhciCtxt = text "a type in a GHCi command" +pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) +pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" +pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc -- (pprSigCtxt ctxt <extra> <type>) @@ -641,11 +641,11 @@ pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc -- The <extra> is either empty or "the ambiguity check for" pprSigCtxt ctxt extra pp_ty | Just n <- isSigMaybe ctxt - = vcat [ ptext (sLit "In") <+> extra <+> ptext (sLit "the type signature:") + = vcat [ text "In" <+> extra <+> ptext (sLit "the type signature:") , nest 2 (pprPrefixOcc n <+> dcolon <+> pp_ty) ] | otherwise - = hang (ptext (sLit "In") <+> extra <+> pprUserTypeCtxt ctxt <> colon) + = hang (text "In" <+> extra <+> pprUserTypeCtxt ctxt <> colon) 2 pp_ty where @@ -2109,8 +2109,8 @@ isFFIDynTy expected ty , eqType ty' expected = IsValid | otherwise - = NotValid (vcat [ ptext (sLit "Expected: Ptr/FunPtr") <+> pprParendType expected <> comma - , ptext (sLit " Actual:") <+> ppr ty ]) + = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma + , text " Actual:" <+> ppr ty ]) isFFILabelTy :: Type -> Validity -- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. @@ -2119,7 +2119,7 @@ isFFILabelTy ty = checkRepTyCon ok ty ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey = IsValid | otherwise - = NotValid (ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)")) + = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") isFFIPrimArgumentTy :: DynFlags -> Type -> Validity -- Checks for valid argument type for a 'foreign import prim' @@ -2156,14 +2156,14 @@ checkRepTyCon check_tc ty | otherwise -> case check_tc tc of IsValid -> IsValid NotValid extra -> NotValid (msg $$ extra) - Nothing -> NotValid (quotes (ppr ty) <+> ptext (sLit "is not a data type")) + Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type") where - msg = quotes (ppr ty) <+> ptext (sLit "cannot be marshalled in a foreign call") + msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" mk_nt_reason tc tys - | null tys = ptext (sLit "because its data constructor is not in scope") - | otherwise = ptext (sLit "because the data constructor for") - <+> quotes (ppr tc) <+> ptext (sLit "is not in scope") - nt_fix = ptext (sLit "Possible fix: import the data constructor to bring it into scope") + | null tys = text "because its data constructor is not in scope" + | otherwise = text "because the data constructor for" + <+> quotes (ppr tc) <+> text "is not in scope" + nt_fix = text "Possible fix: import the data constructor to bring it into scope" {- Note [Foreign import dynamic] @@ -2267,12 +2267,12 @@ legalFIPrimResultTyCon dflags tc = NotValid unlifted_only unlifted_only :: MsgDoc -unlifted_only = ptext (sLit "foreign import prim only accepts simple unlifted types") +unlifted_only = text "foreign import prim only accepts simple unlifted types" validIfUnliftedFFITypes :: DynFlags -> Validity validIfUnliftedFFITypes dflags | xopt LangExt.UnliftedFFITypes dflags = IsValid - | otherwise = NotValid (ptext (sLit "To marshal unlifted types, use UnliftedFFITypes")) + | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") {- Note [Marshalling VoidRep] diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 33525be64a..a548e8d86a 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -281,12 +281,12 @@ match_fun_tys swap_tys herald ct_orig arity orig_ty orig_old_args full_arity mk_msg full_ty ty n_args = herald <+> speakNOf full_arity (text "argument") <> comma $$ if n_args == full_arity - then ptext (sLit "its type is") <+> quotes (pprType full_ty) <> + then text "its type is" <+> quotes (pprType full_ty) <> comma $$ - ptext (sLit "it is specialized to") <+> quotes (pprType ty) - else sep [ptext (sLit "but its type") <+> quotes (pprType ty), - if n_args == 0 then ptext (sLit "has none") - else ptext (sLit "has only") <+> speakN n_args] + text "it is specialized to" <+> quotes (pprType ty) + else sep [text "but its type" <+> quotes (pprType ty), + if n_args == 0 then text "has none" + else text "has only" <+> speakN n_args] ---------------------- matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) @@ -539,9 +539,9 @@ addSubTypeCtxt ty_actual ty_expected thing_inside mk_msg tidy_env = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected - ; let msg = vcat [ hang (ptext (sLit "When checking that:")) + ; let msg = vcat [ hang (text "When checking that:") 4 (ppr ty_actual) - , nest 2 (hang (ptext (sLit "is more polymorphic than:")) + , nest 2 (hang (text "is more polymorphic than:") 2 (ppr ty_expected)) ] ; return (tidy_env, msg) } @@ -922,8 +922,8 @@ unifyTheta :: TcThetaType -> TcThetaType -> TcM [TcCoercion] -- Actual and expected types unifyTheta theta1 theta2 = do { checkTc (equalLength theta1 theta2) - (vcat [ptext (sLit "Contexts differ in length"), - nest 2 $ parens $ ptext (sLit "Use RelaxedPolyRec to allow this")]) + (vcat [text "Contexts differ in length", + nest 2 $ parens $ text "Use RelaxedPolyRec to allow this"]) ; zipWithM unifyPred theta1 theta2 } {- diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index a783fb13a0..54e04b85ec 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -51,7 +51,6 @@ import Util import ListSetOps import SrcLoc import Outputable -import FastString import BasicTypes import Module import qualified GHC.LanguageExtensions as LangExt @@ -210,9 +209,9 @@ checkAmbiguity ctxt ty = return () where mk_msg allow_ambiguous - = vcat [ ptext (sLit "In the ambiguity check for") <+> what + = vcat [ text "In the ambiguity check for" <+> what , ppUnless allow_ambiguous ambig_msg ] - ambig_msg = ptext (sLit "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes") + ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" what | Just n <- isSigMaybe ctxt = quotes (ppr n) | otherwise = pprUserTypeCtxt ctxt @@ -415,9 +414,9 @@ data Rank = ArbitraryRank -- Any rank ok | MustBeMonoType -- Monotype regardless of flags rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank -rankZeroMonoType = MonoType (ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types")) -tyConArgMonoType = MonoType (ptext (sLit "GHC doesn't yet support impredicative polymorphism")) -synArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use LiberalTypeSynonyms")) +rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes or Rank2Types") +tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism") +synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms") funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) @@ -583,11 +582,11 @@ check_arg_type env ctxt rank ty forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) forAllTyErr env rank ty = ( env - , vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr_tidy env ty) + , vcat [ hang (text "Illegal polymorphic or qualified type:") 2 (ppr_tidy env ty) , suggestion ] ) where suggestion = case rank of - LimitedRank {} -> ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types") + LimitedRank {} -> text "Perhaps you intended to use RankNTypes or Rank2Types" MonoType d -> d _ -> Outputable.empty -- Polytype is always illegal @@ -600,11 +599,11 @@ forAllEscapeErr env ty tau_kind , text "of kind:" <+> ppr_tidy env tau_kind ]) ) unliftedArgErr, ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -unliftedArgErr env ty = (env, sep [ptext (sLit "Illegal unlifted type:"), ppr_tidy env ty]) -ubxArgTyErr env ty = (env, sep [ptext (sLit "Illegal unboxed tuple type as function argument:"), ppr_tidy env ty]) +unliftedArgErr env ty = (env, sep [text "Illegal unlifted type:", ppr_tidy env ty]) +ubxArgTyErr env ty = (env, sep [text "Illegal unboxed tuple type as function argument:", ppr_tidy env ty]) kindErr :: TidyEnv -> Kind -> (TidyEnv, SDoc) -kindErr env kind = (env, sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr_tidy env kind]) +kindErr env kind = (env, sep [text "Expecting an ordinary type, but found a type of kind", ppr_tidy env kind]) {- Note [Liberal type synonyms] @@ -826,7 +825,7 @@ okIPCtxt DefaultDeclCtxt = False badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) badIPPred env pred = ( env - , ptext (sLit "Illegal implicit parameter") <+> quotes (ppr_tidy env pred) ) + , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) {- Note [Kind polymorphic type classes] @@ -852,38 +851,38 @@ Flexibility check: checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) checkThetaCtxt ctxt theta env = return ( env - , vcat [ ptext (sLit "In the context:") <+> pprTheta (tidyTypes env theta) - , ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ] ) + , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) + , text "While checking" <+> pprUserTypeCtxt ctxt ] ) eqPredTyErr, predTupleErr, predIrredErr, predSuperClassErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) eqPredTyErr env pred = ( env - , ptext (sLit "Illegal equational constraint") <+> ppr_tidy env pred $$ - parens (ptext (sLit "Use GADTs or TypeFamilies to permit this")) ) + , text "Illegal equational constraint" <+> ppr_tidy env pred $$ + parens (text "Use GADTs or TypeFamilies to permit this") ) predTupleErr env pred = ( env - , hang (ptext (sLit "Illegal tuple constraint:") <+> ppr_tidy env pred) + , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) 2 (parens constraintKindsMsg) ) predIrredErr env pred = ( env - , hang (ptext (sLit "Illegal constraint:") <+> ppr_tidy env pred) + , hang (text "Illegal constraint:" <+> ppr_tidy env pred) 2 (parens constraintKindsMsg) ) predSuperClassErr env pred = ( env - , hang (ptext (sLit "Illegal constraint") <+> quotes (ppr_tidy env pred) - <+> ptext (sLit "in a superclass context")) + , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred) + <+> text "in a superclass context") 2 (parens undecidableMsg) ) predTyVarErr :: PredType -> SDoc -- type is already tidied! predTyVarErr pred - = vcat [ hang (ptext (sLit "Non type-variable argument")) - 2 (ptext (sLit "in the constraint:") <+> ppr pred) - , parens (ptext (sLit "Use FlexibleContexts to permit this")) ] + = vcat [ hang (text "Non type-variable argument") + 2 (text "in the constraint:" <+> ppr pred) + , parens (text "Use FlexibleContexts to permit this") ] constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) constraintSynErr env kind = ( env - , hang (ptext (sLit "Illegal constraint synonym of kind:") <+> quotes (ppr_tidy env kind)) + , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) 2 (parens constraintKindsMsg) ) dupPredWarn :: TidyEnv -> [[PredType]] -> (TidyEnv, SDoc) @@ -912,13 +911,13 @@ tyConArityErr tc tks arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr what name n m - = hsep [ ptext (sLit "The") <+> text what, quotes (ppr name), ptext (sLit "should have"), + = hsep [ text "The" <+> text what, quotes (ppr name), text "should have", n_arguments <> comma, text "but has been given", if m==0 then text "none" else int m] where - n_arguments | n == 0 = ptext (sLit "no arguments") - | n == 1 = ptext (sLit "1 argument") - | True = hsep [int n, ptext (sLit "arguments")] + n_arguments | n == 0 = text "no arguments" + | n == 1 = text "1 argument" + | True = hsep [int n, text "arguments"] {- ************************************************************************ @@ -1007,7 +1006,7 @@ abstractClassKeys = [ heqTyConKey instTypeErr :: Class -> [Type] -> SDoc -> SDoc instTypeErr cls tys msg - = hang (hang (ptext (sLit "Illegal instance declaration for")) + = hang (hang (text "Illegal instance declaration for") 2 (quotes (pprClassPred cls tys))) 2 msg @@ -1100,7 +1099,7 @@ checkValidInstance ctxt hs_type ty ; return (tvs, theta, clas, inst_tys) } | otherwise - = failWithTc (ptext (sLit "Malformed instance head:") <+> ppr tau) + = failWithTc (text "Malformed instance head:" <+> ppr tau) where (tvs, theta, tau) = tcSplitSigmaTy ty @@ -1160,29 +1159,29 @@ checkInstTermination tys theta | pred_size >= head_size = addErrTc (smallerMsg what) | otherwise = return () where - what = ptext (sLit "constraint") <+> quotes (ppr pred) + what = text "constraint" <+> quotes (ppr pred) bad_tvs = fvType pred \\ head_fvs smallerMsg :: SDoc -> SDoc smallerMsg what - = vcat [ hang (ptext (sLit "The") <+> what) - 2 (ptext (sLit "is no smaller than the instance head")) + = vcat [ hang (text "The" <+> what) + 2 (text "is no smaller than the instance head") , parens undecidableMsg ] noMoreMsg :: [TcTyVar] -> SDoc -> SDoc noMoreMsg tvs what - = vcat [ hang (ptext (sLit "Variable") <> plural tvs <+> quotes (pprWithCommas ppr tvs) - <+> occurs <+> ptext (sLit "more often")) - 2 (sep [ ptext (sLit "in the") <+> what - , ptext (sLit "than in the instance head") ]) + = vcat [ hang (text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) + <+> occurs <+> text "more often") + 2 (sep [ text "in the" <+> what + , text "than in the instance head" ]) , parens undecidableMsg ] where - occurs = if isSingleton tvs then ptext (sLit "occurs") - else ptext (sLit "occur") + occurs = if isSingleton tvs then text "occurs" + else text "occur" undecidableMsg, constraintKindsMsg :: SDoc -undecidableMsg = ptext (sLit "Use UndecidableInstances to permit this") -constraintKindsMsg = ptext (sLit "Use ConstraintKinds to permit this") +undecidableMsg = text "Use UndecidableInstances to permit this" +constraintKindsMsg = text "Use ConstraintKinds to permit this" {- Note [Associated type instances] @@ -1307,14 +1306,14 @@ checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys badATErr :: Name -> Name -> SDoc badATErr clas op - = hsep [ptext (sLit "Class"), quotes (ppr clas), - ptext (sLit "does not have an associated type"), quotes (ppr op)] + = hsep [text "Class", quotes (ppr clas), + text "does not have an associated type", quotes (ppr op)] wrongATArgErr :: Type -> Type -> SDoc wrongATArgErr ty instTy = - sep [ ptext (sLit "Type indexes must match class instance head") - , ptext (sLit "Found") <+> quotes (ppr ty) - <+> ptext (sLit "but expected") <+> quotes (ppr instTy) + sep [ text "Type indexes must match class instance head" + , text "Found" <+> quotes (ppr ty) + <+> text "but expected" <+> quotes (ppr instTy) ] {- @@ -1443,7 +1442,7 @@ checkFamInstRhs lhsTys famInsts | size <= sizeTypes tys = Just (smallerMsg what) | otherwise = Nothing where - what = ptext (sLit "type family application") <+> quotes (pprType (TyConApp tc tys)) + what = text "type family application" <+> quotes (pprType (TyConApp tc tys)) bad_tvs = fvTypes tys \\ fvs checkValidFamPats :: TyCon -> [TyVar] -> [CoVar] -> [Type] -> TcM () @@ -1473,7 +1472,7 @@ checkValidFamPats fam_tc tvs cvs ty_pats wrongNumberOfParmsErr :: Arity -> SDoc wrongNumberOfParmsErr exp_arity - = ptext (sLit "Number of parameters must match family declaration; expected") + = text "Number of parameters must match family declaration; expected" <+> ppr exp_arity -- Ensure that no type family instances occur in a type. @@ -1491,26 +1490,27 @@ isTyFamFree = null . tcTyFamInsts inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc inaccessibleCoAxBranch fi_ax cur_branch - = ptext (sLit "Type family instance equation is overlapped:") $$ + = text "Type family instance equation is overlapped:" $$ nest 2 (pprCoAxBranch fi_ax cur_branch) tyFamInstIllegalErr :: Type -> SDoc tyFamInstIllegalErr ty - = hang (ptext (sLit "Illegal type synonym family application in instance") <> + = hang (text "Illegal type synonym family application in instance" <> colon) 2 $ ppr ty nestedMsg :: SDoc -> SDoc nestedMsg what - = sep [ ptext (sLit "Illegal nested") <+> what + = sep [ text "Illegal nested" <+> what , parens undecidableMsg ] famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc famPatErr fam_tc tvs pats - = hang (ptext (sLit "Family instance purports to bind type variable") <> plural tvs + = hang (text "Family instance purports to bind type variable" <> plural tvs <+> pprQuotedList tvs) - 2 (hang (ptext (sLit "but the real LHS (expanding synonyms) is:")) - 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> ptext (sLit "= ..."))) + 2 (hang (text "but the real LHS (expanding synonyms) is:") + 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> + text "= ...")) {- ************************************************************************ |