pprDemands :: [Demand] -> Bool -> SDoc
pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot
where
- pp_bot | bot = ptext SLIT("B")
+ pp_bot | bot = ptext (sLit "B")
| otherwise = empty
instance Outputable Demand where
ppr (WwLazy False) = empty
- ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand
+ ppr other_demand = ptext (sLit "__D") <+> pprDemand other_demand
instance Show Demand where
showsPrec p d = showsPrecSDoc p (ppr d)
-- For pretty debugging
instance Outputable AbsVal where
- ppr Top = ptext SLIT("Top")
- ppr (Fun r) = ptext SLIT("Fun->") <> (parens.ppr) r
- ppr Tuple = ptext SLIT("Tuple ")
- ppr Bot = ptext SLIT("Bot")
+ ppr Top = ptext (sLit "Top")
+ ppr (Fun r) = ptext (sLit "Fun->") <> (parens.ppr) r
+ ppr Tuple = ptext (sLit "Tuple ")
+ ppr Bot = ptext (sLit "Bot")
-- lub takes the lowest upper bound of two abstract values, standard.
MakeStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "box", ty1, ilxOp "newobj void", repStablePtr {- ty1 -}, ilxOp "::.ctor(class [mscorlib]System.Object)"])
{- a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) -}
MakeStableNameOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "pop newobj void", repStableName {- ty1 -}, ilxOp "::.ctor()"])
- -- primOpInfo MakeStableNameOp = mkGenPrimOp SLIT("makeStableName#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))
+ -- primOpInfo MakeStableNameOp = mkGenPrimOp (sLit "makeStableName#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))
EqStableNameOp -> ty1_op (\ty1 -> ilxOp "ceq")
-- [alphaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy alphaTy] (intPrimTy)
--
-- The common (PassFlag addOpt) action puts the static flag into the bunch of
-- things that are searched up by the top-level definitions like
--- opt_foo = lookUp FSLIT("-dfoo")
+-- opt_foo = lookUp (fsLit "-dfoo")
-- Note that ordering is important in the following list: any flag which
-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
CmmReg (CmmGlobal GCEnter1)
| not opt_PIC
-> cmmExprConFold referenceKind $
- CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
+ CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| not opt_PIC
-> cmmExprConFold referenceKind $
- CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
+ CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_fun")))
#endif
CmmReg (CmmGlobal mid)
do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
pprAlign bytes =
- IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
+ IF_ARCH_alpha(ptext (sLit ".align ") <> int pow2,
IF_ARCH_i386(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
IF_ARCH_x86_64(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
IF_ARCH_sparc(ptext (sLit ".align ") <> int bytes,
= do -- make a trivial let-binding for the top-level function
uniq <- getUniqueMM
let
- new_var = mkSysLocal FSLIT("sf") uniq var_type
+ new_var = mkSysLocal (fsLit "sf") uniq var_type
return ( (new_var, old_var) : bindings, StgVarArg new_var )
where
var_type = idType old_var
newSATName :: Id -> Type -> SatM Id
newSATName _ ty
- = SatM $ \us env -> (mkSysLocal FSLIT("$sat") (uniqFromSupply us) ty, env)
+ = SatM $ \us env -> (mkSysLocal (fsLit "$sat") (uniqFromSupply us) ty, env)
getArgLists :: CoreExpr -> ([Staticness Type], [Staticness Id])
getArgLists expr
-- top-level or exported somehow.)
-- A better fix is to use binder directly but with the TopLevel
-- tag (or Exported tag) modified.
- fake_binder = mkSysLocal FSLIT("sat")
+ fake_binder = mkSysLocal (fsLit "sat")
(getUnique binder)
(idType binder)
rec_body = mkLams non_static_args
mkAbsApproxFun d val = AbsApproxFun [d] val
instance Outputable AbsVal where
- ppr AbsTop = ptext SLIT("AbsTop")
- ppr AbsBot = ptext SLIT("AbsBot")
- ppr (AbsProd prod) = hsep [ptext SLIT("AbsProd"), ppr prod]
- ppr (AbsFun bndr_ty body) = ptext SLIT("AbsFun")
+ ppr AbsTop = ptext (sLit "AbsTop")
+ ppr AbsBot = ptext (sLit "AbsBot")
+ ppr (AbsProd prod) = hsep [ptext (sLit "AbsProd"), ppr prod]
+ ppr (AbsFun bndr_ty body) = ptext (sLit "AbsFun")
ppr (AbsApproxFun demands val)
- = ptext SLIT("AbsApprox") <+> brackets (interpp'SP demands) <+> ppr val
+ = ptext (sLit "AbsApprox") <+> brackets (interpp'SP demands) <+> ppr val
\end{code}
%-----------
else demanded)
pp_stats (SaStats tlam dlam tc dc tlet dlet)
- = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
- ptext SLIT("; Case vars: "), int (iBox dc), char '/', int (iBox tc),
- ptext SLIT("; Let vars: "), int (iBox dlet), char '/', int (iBox tlet)
+ = hcat [ptext (sLit "Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
+ ptext (sLit "; Case vars: "), int (iBox dc), char '/', int (iBox tc),
+ ptext (sLit "; Let vars: "), int (iBox dlet), char '/', int (iBox tlet)
]
#else /* OMIT_STRANAL_STATS */
ty1' <- zonkTcKind ty1
ty2' <- zonkTcKind ty2
let
- msg = hang (ptext SLIT("Couldn't match kind"))
+ msg = hang (ptext (sLit "Couldn't match kind"))
2 (sep [quotes (ppr ty1'),
- ptext SLIT("against"),
+ ptext (sLit "against"),
quotes (ppr ty2')])
failWithTc msg
-- tv1 and ty2 are zonked already
= return msg
where
- msg = (env2, ptext SLIT("When matching the kinds of") <+>
- sep [quotes pp_expected <+> ptext SLIT("and"), quotes pp_actual])
+ msg = (env2, ptext (sLit "When matching the kinds of") <+>
+ sep [quotes pp_expected <+> ptext (sLit "and"), quotes pp_actual])
(pp_expected, pp_actual) | swapped = (pp2, pp1)
| otherwise = (pp1, pp2)
extra = sep [ppr tidy_ty1, char '=', ppr tidy_ty2]
; failWithTcM (env2, hang msg 2 extra) }
where
- msg = ptext SLIT("Occurs check: cannot construct the infinite type:")
+ msg = ptext (sLit "Occurs check: cannot construct the infinite type:")
\end{code}
%************************************************************************
newCoVars :: [(TcType,TcType)] -> TcM [CoVar]
newCoVars spec
= do { us <- newUniqueSupply
- ; return [ mkCoVar (mkSysTvName uniq FSLIT("co"))
+ ; return [ mkCoVar (mkSysTvName uniq (fsLit "co"))
(mkCoKind ty1 ty2)
| ((ty1,ty2), uniq) <- spec `zip` uniqsFromSupply us] }
; ref <- newMutVar Flexi
; let name = mkSysTvName uniq fs
fs = case box_info of
- BoxTv -> FSLIT("t")
- TauTv -> FSLIT("t")
- SigTv _ -> FSLIT("a")
+ BoxTv -> fsLit "t"
+ TauTv -> fsLit "t"
+ SigTv _ -> fsLit "a"
-- We give BoxTv and TauTv the same string, because
-- otherwise we get user-visible differences in error
-- messages, which are confusing. If you want to see
; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
----------------------------------------
-forAllTyErr ty = sep [ptext SLIT("Illegal polymorphic or qualified type:"), ppr ty]
-unliftedArgErr ty = sep [ptext SLIT("Illegal unlifted type:"), ppr ty]
-ubxArgTyErr ty = sep [ptext SLIT("Illegal unboxed tuple type as function argument:"), ppr ty]
-kindErr kind = sep [ptext SLIT("Expecting an ordinary type, but found a type of kind"), ppr kind]
+forAllTyErr ty = sep [ptext (sLit "Illegal polymorphic or qualified type:"), ppr ty]
+unliftedArgErr ty = sep [ptext (sLit "Illegal unlifted type:"), ppr ty]
+ubxArgTyErr ty = sep [ptext (sLit "Illegal unboxed tuple type as function argument:"), ppr ty]
+kindErr kind = sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr kind]
\end{code}
Note [Liberal type synonyms]
| InstThetaCtxt -- Context of an instance decl
-- instance <S> => C [a] where ...
-pprSourceTyCtxt (ClassSCCtxt c) = ptext SLIT("the super-classes of class") <+> quotes (ppr c)
-pprSourceTyCtxt SigmaCtxt = ptext SLIT("the context of a polymorphic type")
-pprSourceTyCtxt (DataTyCtxt tc) = ptext SLIT("the context of the data type declaration for") <+> quotes (ppr tc)
-pprSourceTyCtxt InstThetaCtxt = ptext SLIT("the context of an instance declaration")
-pprSourceTyCtxt TypeCtxt = ptext SLIT("the context of a type")
+pprSourceTyCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c)
+pprSourceTyCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type")
+pprSourceTyCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc)
+pprSourceTyCtxt InstThetaCtxt = ptext (sLit "the context of an instance declaration")
+pprSourceTyCtxt TypeCtxt = ptext (sLit "the context of a type")
\end{code}
\begin{code}
arity = classArity cls
n_tys = length tys
arity_err = arityErr "Class" class_name arity n_tys
- how_to_allow = parens (ptext SLIT("Use -XFlexibleContexts to permit this"))
+ how_to_allow = parens (ptext (sLit "Use -XFlexibleContexts to permit this"))
check_pred_ty dflags ctxt pred@(EqPred ty1 ty2)
= do { -- Equational constraints are valid in all contexts if type
not (ct_var `elemVarSet` extended_tau_vars)
ambigErr pred
- = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),
- nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$
- ptext SLIT("must be reachable from the type after the '=>'"))]
+ = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred),
+ nest 4 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$
+ ptext (sLit "must be reachable from the type after the '=>'"))]
\end{code}
In addition, GHC insists that at least one type variable
complain pred = addErrTc (freeErr pred)
freeErr pred
- = sep [ ptext SLIT("All of the type variables in the constraint") <+>
+ = sep [ ptext (sLit "All of the type variables in the constraint") <+>
quotes (pprPred pred)
- , ptext SLIT("are already in scope") <+>
- ptext SLIT("(at least one must be universally quantified here)")
+ , ptext (sLit "are already in scope") <+>
+ ptext (sLit "(at least one must be universally quantified here)")
, nest 4 $
- ptext SLIT("(Use -XFlexibleContexts to lift this restriction)")
+ ptext (sLit "(Use -XFlexibleContexts to lift this restriction)")
]
\end{code}
\begin{code}
checkThetaCtxt ctxt theta
- = vcat [ptext SLIT("In the context:") <+> pprTheta theta,
- ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ]
+ = vcat [ptext (sLit "In the context:") <+> pprTheta theta,
+ ptext (sLit "While checking") <+> pprSourceTyCtxt ctxt ]
-badPredTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty
-eqPredTyErr sty = ptext SLIT("Illegal equational constraint") <+> pprPred sty
+badPredTyErr sty = ptext (sLit "Illegal constraint") <+> pprPred sty
+eqPredTyErr sty = ptext (sLit "Illegal equational constraint") <+> pprPred sty
$$
- parens (ptext SLIT("Use -XTypeFamilies to permit this"))
-predTyVarErr pred = sep [ptext SLIT("Non type-variable argument"),
- nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]
-dupPredWarn dups = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
+ parens (ptext (sLit "Use -XTypeFamilies to permit this"))
+predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"),
+ nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)]
+dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
arityErr kind name n m
- = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
+ = hsep [ text kind, quotes (ppr name), ptext (sLit "should have"),
n_arguments <> comma, text "but has been given", 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 = ptext (sLit "no arguments")
+ | n == 1 = ptext (sLit "1 argument")
+ | True = hsep [int n, ptext (sLit "arguments")]
-----------------
notMonoType ty
= do { ty' <- zonkTcType ty
; env0 <- tcInitTidyEnv
; let (env1, tidy_ty) = tidyOpenType env0 ty'
- msg = ptext SLIT("Cannot match a monotype with") <+> quotes (ppr tidy_ty)
+ msg = ptext (sLit "Cannot match a monotype with") <+> quotes (ppr tidy_ty)
; failWithTcM (env1, msg) }
notMonoArgs ty
= do { ty' <- zonkTcType ty
; env0 <- tcInitTidyEnv
; let (env1, tidy_ty) = tidyOpenType env0 ty'
- msg = ptext SLIT("Arguments of type synonym families must be monotypes") <+> quotes (ppr tidy_ty)
+ msg = ptext (sLit "Arguments of type synonym families must be monotypes") <+> quotes (ppr tidy_ty)
; failWithTcM (env1, msg) }
\end{code}
text "Use -XMultiParamTypeClasses if you want to allow more.")
instTypeErr pp_ty msg
- = sep [ptext SLIT("Illegal instance declaration for") <+> quotes pp_ty,
+ = sep [ptext (sLit "Illegal instance declaration for") <+> quotes pp_ty,
nest 4 msg]
\end{code}
(instTypeErr (pprClassPred clas inst_tys) msg)
}
where
- msg = parens (vcat [ptext SLIT("the Coverage Condition fails for one of the functional dependencies;"),
+ msg = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"),
undecidableMsg])
\end{code}
= Nothing
predUndecErr pred msg = sep [msg,
- nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]
+ nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)]
-nomoreMsg = ptext SLIT("Variable occurs more often in a constraint than in the instance head")
-smallerMsg = ptext SLIT("Constraint is no smaller than the instance head")
-undecidableMsg = ptext SLIT("Use -fallow-undecidable-instances to permit this")
+nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head")
+smallerMsg = ptext (sLit "Constraint is no smaller than the instance head")
+undecidableMsg = ptext (sLit "Use -fallow-undecidable-instances to permit this")
\end{code}
-- Error messages
tyFamInstInIndexErr ty
- = hang (ptext SLIT("Illegal type family application in type instance") <>
+ = hang (ptext (sLit "Illegal type family application in type instance") <>
colon) 4 $
ppr ty
polyTyErr ty
- = hang (ptext SLIT("Illegal polymorphic type in type instance") <> colon) 4 $
+ = hang (ptext (sLit "Illegal polymorphic type in type instance") <> colon) 4 $
ppr ty
famInstUndecErr ty msg
= sep [msg,
- nest 2 (ptext SLIT("in the type family application:") <+>
+ nest 2 (ptext (sLit "in the type family application:") <+>
pprType ty)]
-nestedMsg = ptext SLIT("Nested type family application")
-nomoreVarMsg = ptext SLIT("Variable occurs more often than in instance head")
-smallerAppMsg = ptext SLIT("Application is no smaller than the instance head")
+nestedMsg = ptext (sLit "Nested type family application")
+nomoreVarMsg = ptext (sLit "Variable occurs more often than in instance head")
+smallerAppMsg = ptext (sLit "Application is no smaller than the instance head")
\end{code}
; return (res, binds) }
-------------------
-unBoxPatBndrType ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name))
-unBoxWildCardType ty = unBoxArgType ty (ptext SLIT("A wild-card pattern"))
-unBoxViewPatType ty pat = unBoxArgType ty (ptext SLIT("The view pattern") <+> ppr pat)
+unBoxPatBndrType ty name = unBoxArgType ty (ptext (sLit "The variable") <+> quotes (ppr name))
+unBoxWildCardType ty = unBoxArgType ty (ptext (sLit "A wild-card pattern"))
+unBoxViewPatType ty pat = unBoxArgType ty (ptext (sLit "The view pattern") <+> ppr pat)
unBoxArgType :: BoxyType -> SDoc -> TcM TcType
-- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind;
; unifyType ty' ty2
; return ty' }}
where
- msg = pp_this <+> ptext SLIT("cannot be bound to an unboxed tuple")
+ msg = pp_this <+> ptext (sLit "cannot be bound to an unboxed tuple")
\end{code}
= do { loc <- getInstLoc orig
; res_tau <- zapToMonotype res_ty
; new_uniq <- newUnique
- ; let lit_nm = mkSystemVarName new_uniq FSLIT("lit")
+ ; let lit_nm = mkSystemVarName new_uniq (fsLit "lit")
lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit,
tci_ty = res_tau, tci_loc = loc}
; extendLIE lit_inst
patCtxt (VarPat _) = Nothing
patCtxt (ParPat _) = Nothing
patCtxt (AsPat _ _) = Nothing
-patCtxt pat = Just (hang (ptext SLIT("In the pattern:"))
+patCtxt pat = Just (hang (ptext (sLit "In the pattern:"))
4 (ppr pat))
-----------------------------------------------
(env2, tidy_pat_tys) = tidyOpenTypes env1 pat_tys'
(env3, tidy_body_ty) = tidyOpenType env2 body_ty'
; return (env3,
- sep [ptext SLIT("When checking an existential match that binds"),
+ sep [ptext (sLit "When checking an existential match that binds"),
nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
- ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
- ptext SLIT("The body has type:") <+> ppr tidy_body_ty
+ ptext (sLit "The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
+ ptext (sLit "The body has type:") <+> ppr tidy_body_ty
]) }
where
bound_ids = collectPatsBinders pats
badFieldCon :: DataCon -> Name -> SDoc
badFieldCon con field
- = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
- ptext SLIT("does not have field"), quotes (ppr field)]
+ = hsep [ptext (sLit "Constructor") <+> quotes (ppr con),
+ ptext (sLit "does not have field"), quotes (ppr field)]
polyPatSig :: TcType -> SDoc
polyPatSig sig_ty
- = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
+ = hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
2 (ppr sig_ty)
-badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
+badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
existentialProcPat :: DataCon -> SDoc
existentialProcPat con
- = hang (ptext SLIT("Illegal constructor") <+> quotes (ppr con) <+> ptext SLIT("in a 'proc' pattern"))
- 2 (ptext SLIT("Proc patterns cannot use existentials or GADTs"))
+ = hang (ptext (sLit "Illegal constructor") <+> quotes (ppr con) <+> ptext (sLit "in a 'proc' pattern"))
+ 2 (ptext (sLit "Proc patterns cannot use existentials or GADTs"))
lazyPatErr pat tvs
= failWithTc $
- hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables"))
+ hang (ptext (sLit "A lazy (~) pattern cannot bind existential type variables"))
2 (vcat (map pprSkolTvBinding tvs))
nonRigidMatch con
- = hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con))
- 2 (ptext SLIT("Solution: add a type signature"))
+ = hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))
+ 2 (ptext (sLit "Solution: add a type signature"))
nonRigidResult res_ty
= do { env0 <- tcInitTidyEnv
; let (env1, res_ty') = tidyOpenType env0 res_ty
- msg = hang (ptext SLIT("GADT pattern match with non-rigid result type")
+ msg = hang (ptext (sLit "GADT pattern match with non-rigid result type")
<+> quotes (ppr res_ty'))
- 2 (ptext SLIT("Solution: add a type signature"))
+ 2 (ptext (sLit "Solution: add a type signature"))
; failWithTcM (env1, msg) }
inaccessibleAlt msg
- = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
+ = hang (ptext (sLit "Inaccessible case alternative:")) 2 msg
\end{code}
mk_msg res_ty n_actual
= error_herald <> comma $$
- sep [ptext SLIT("but its type") <+> quotes (pprType res_ty),
- if n_actual == 0 then ptext SLIT("has none")
- else ptext SLIT("has only") <+> speakN n_actual]
+ sep [ptext (sLit "but its type") <+> quotes (pprType res_ty),
+ if n_actual == 0 then ptext (sLit "has none")
+ else ptext (sLit "has only") <+> speakN n_actual]
\end{code}
\begin{code}
| null arg_tys
= return co_fn_res
| otherwise
- = do { arg_ids <- newSysLocalIds FSLIT("sub") arg_tys
+ = do { arg_ids <- newSysLocalIds (fsLit "sub") arg_tys
; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpApps arg_ids) }
\end{code}
-- Acutal and expected types
unifyTheta theta1 theta2
= do { checkTc (equalLength theta1 theta2)
- (vcat [ptext SLIT("Contexts differ in length"),
- nest 2 $ parens $ ptext SLIT("Use -fglasgow-exts to allow this")])
+ (vcat [ptext (sLit "Contexts differ in length"),
+ nest 2 $ parens $ ptext (sLit "Use -fglasgow-exts to allow this")])
; uList unifyPred theta1 theta2
}
-- for this particular ty1,ty2
instance Outputable Outer where
- ppr (Unify c ty1 ty2) = pp_c <+> pprParendType ty1 <+> ptext SLIT("~")
+ ppr (Unify c ty1 ty2) = pp_c <+> pprParendType ty1 <+> ptext (sLit "~")
<+> pprParendType ty2
where
- pp_c = if c then ptext SLIT("Top") else ptext SLIT("NonTop")
+ pp_c = if c then ptext (sLit "Top") else ptext (sLit "NonTop")
-------------------------
| otherwise = brackets (equals <+> ppr ty2)
; traceTc (text "uVar" <+> ppr outer <+> ppr swapped <+>
sep [ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1 ),
- nest 2 (ptext SLIT(" <-> ")),
+ nest 2 (ptext (sLit " <-> ")),
ppr ps_ty2 <+> dcolon <+> ppr (typeKind ty2) <+> expansion])
; details <- lookupTcTyVar tv1
; case details of
; return (env2, message) }
wrongArgsCtxt too_many_or_few fun
- = ptext SLIT("Probable cause:") <+> quotes (ppr fun)
- <+> ptext SLIT("is applied to") <+> text too_many_or_few
- <+> ptext SLIT("arguments")
+ = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
+ <+> ptext (sLit "is applied to") <+> text too_many_or_few
+ <+> ptext (sLit "arguments")
------------------
unifyForAllCtxt tvs phi1 phi2 env
(env', tvs') = tidyOpenTyVars env tvs -- NB: not tidyTyVarBndrs
(env1, phi1') = tidyOpenType env' phi1
(env2, phi2') = tidyOpenType env1 phi2
- msg = vcat [ptext SLIT("When matching") <+> quotes (ppr (mkForAllTys tvs' phi1')),
- ptext SLIT(" and") <+> quotes (ppr (mkForAllTys tvs' phi2'))]
+ msg = vcat [ptext (sLit "When matching") <+> quotes (ppr (mkForAllTys tvs' phi1')),
+ ptext (sLit " and") <+> quotes (ppr (mkForAllTys tvs' phi2'))]
\end{code}
| isLiftedTypeKind k = return liftedTypeKind
| isUnliftedTypeKind k = return unliftedTypeKind
go sw k@(TyVarTy _) = return k -- KindVars are always simple
- go swapped kind = failWithTc (ptext SLIT("Unexpected kind unification failure:")
+ go swapped kind = failWithTc (ptext (sLit "Unexpected kind unification failure:")
<+> ppr orig_swapped <+> ppr orig_kind)
-- I think this can't actually happen
----------------
kindOccurCheckErr tyvar ty
- = hang (ptext SLIT("Occurs check: cannot construct the infinite kind:"))
+ = hang (ptext (sLit "Occurs check: cannot construct the infinite kind:"))
2 (sep [ppr tyvar, char '=', ppr ty])
\end{code}
(env2, tidy_act_kind) = tidyKind env1 act_kind
err | n_exp_as < n_act_as -- E.g. [Maybe]
- = quotes (ppr ty) <+> ptext SLIT("is not applied to enough type arguments")
+ = quotes (ppr ty) <+> ptext (sLit "is not applied to enough type arguments")
-- Now n_exp_as >= n_act_as. In the next two cases,
-- n_exp_as == 0, and hence so is n_act_as
| isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind
- = ptext SLIT("Expecting a lifted type, but") <+> quotes (ppr ty)
- <+> ptext SLIT("is unlifted")
+ = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty)
+ <+> ptext (sLit "is unlifted")
| isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind
- = ptext SLIT("Expecting an unlifted type, but") <+> quotes (ppr ty)
- <+> ptext SLIT("is lifted")
+ = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty)
+ <+> ptext (sLit "is lifted")
| otherwise -- E.g. Monad [Int]
- = ptext SLIT("Kind mis-match")
+ = ptext (sLit "Kind mis-match")
- more_info = sep [ ptext SLIT("Expected kind") <+>
+ more_info = sep [ ptext (sLit "Expected kind") <+>
quotes (pprKind tidy_exp_kind) <> comma,
- ptext SLIT("but") <+> quotes (ppr ty) <+>
- ptext SLIT("has kind") <+> quotes (pprKind tidy_act_kind)]
+ ptext (sLit "but") <+> quotes (ppr ty) <+>
+ ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)]
failWithTcM (env2, err $$ more_info)
\end{code}
; (env3, msgs) <- foldlM check (env2, []) (tidy_tvs `zip` tidy_zonked_tvs)
; failWithTcM (env3, main_msg $$ nest 2 (vcat msgs)) }
where
- main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
+ main_msg = ptext (sLit "Inferred type is less polymorphic than expected")
check (tidy_env, msgs) (sig_tv, zonked_tv)
| not (zonked_tv `elemVarSet` globals) = return (tidy_env, msgs)
-----------------------
escape_msg sig_tv zonked_tv globs
| notNull globs
- = vcat [sep [msg, ptext SLIT("is mentioned in the environment:")],
+ = vcat [sep [msg, ptext (sLit "is mentioned in the environment:")],
nest 2 (vcat globs)]
| otherwise
- = msg <+> ptext SLIT("escapes")
+ = msg <+> ptext (sLit "escapes")
-- Sigh. It's really hard to give a good error message
-- all the time. One bad case is an existential pattern match.
-- We rely on the "When..." context to help.
where
- msg = ptext SLIT("Quantified type variable") <+> quotes (ppr sig_tv) <+> is_bound_to
+ msg = ptext (sLit "Quantified type variable") <+> quotes (ppr sig_tv) <+> is_bound_to
is_bound_to
| sig_tv == zonked_tv = empty
- | otherwise = ptext SLIT("is unified with") <+> quotes (ppr zonked_tv) <+> ptext SLIT("which")
+ | otherwise = ptext (sLit "is unified with") <+> quotes (ppr zonked_tv) <+> ptext (sLit "which")
\end{code}
These two context are used with checkSigTyVars
(env1, tidy_sig_tvs) = tidyOpenTyVars tidy_env sig_tvs
(env2, tidy_sig_rho) = tidyOpenType env1 (mkPhiTy sig_theta sig_tau)
(env3, tidy_actual_tau) = tidyOpenType env2 actual_tau
- sub_msg = vcat [ptext SLIT("Signature type: ") <+> pprType (mkForAllTys tidy_sig_tvs tidy_sig_rho),
- ptext SLIT("Type to generalise:") <+> pprType tidy_actual_tau
+ sub_msg = vcat [ptext (sLit "Signature type: ") <+> pprType (mkForAllTys tidy_sig_tvs tidy_sig_rho),
+ ptext (sLit "Type to generalise:") <+> pprType tidy_actual_tau
]
- msg = vcat [ptext SLIT("When trying to generalise the type inferred for") <+> quotes (ppr id),
+ msg = vcat [ptext (sLit "When trying to generalise the type inferred for") <+> quotes (ppr id),
nest 2 sub_msg]
return (env3, msg)
instance Outputable Refinement where
ppr (Reft _in_scope env)
- = ptext SLIT("Refinement") <+>
+ = ptext (sLit "Refinement") <+>
braces (ppr env)
emptyRefinement :: Refinement
\begin{code}
misMatch :: Type -> Type -> SDoc
misMatch t1 t2
- = ptext SLIT("Can't match types") <+> quotes (ppr t1) <+>
- ptext SLIT("and") <+> quotes (ppr t2)
+ = ptext (sLit "Can't match types") <+> quotes (ppr t1) <+>
+ ptext (sLit "and") <+> quotes (ppr t2)
lengthMisMatch :: [Type] -> [Type] -> SDoc
lengthMisMatch tys1 tys2
- = sep [ptext SLIT("Can't match unequal length lists"),
+ = sep [ptext (sLit "Can't match unequal length lists"),
nest 2 (ppr tys1), nest 2 (ppr tys2) ]
kindMisMatch :: TyVar -> Type -> SDoc
kindMisMatch tv1 t2
- = vcat [ptext SLIT("Can't match kinds") <+> quotes (ppr (tyVarKind tv1)) <+>
- ptext SLIT("and") <+> quotes (ppr (typeKind t2)),
- ptext SLIT("when matching") <+> quotes (ppr tv1) <+>
- ptext SLIT("with") <+> quotes (ppr t2)]
+ = vcat [ptext (sLit "Can't match kinds") <+> quotes (ppr (tyVarKind tv1)) <+>
+ ptext (sLit "and") <+> quotes (ppr (typeKind t2)),
+ ptext (sLit "when matching") <+> quotes (ppr tv1) <+>
+ ptext (sLit "with") <+> quotes (ppr t2)]
occursCheck :: TyVar -> Type -> SDoc
occursCheck tv ty
- = hang (ptext SLIT("Can't construct the infinite type"))
+ = hang (ptext (sLit "Can't construct the infinite type"))
2 (ppr tv <+> equals <+> ppr ty)
\end{code}
{-
FastString: A compact, hash-consed, representation of character strings.
Comparison is O(1), and you can get a Unique from them.
- Generated by the FSLIT macro
+ Generated by fsLit
Turn into SDoc with Outputable.ftext
LitString: Just a wrapper for the Addr# of a C string (Ptr CChar).
Practically no operations
Outputing them is fast
- Generated by the SLIT macro
+ Generated by sLit
Turn into SDoc with Outputable.ptext
Use LitString unless you want the facilities of FastString
projects / ghc-hetmet.git / commitdiff