4 TcTauType, TcPredType, TcThetaType, TcRhoType,
8 TcM, NF_TcM, TcDown, TcEnv,
11 returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
12 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
13 mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
18 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
19 fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
21 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
23 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
24 failTc, failWithTc, addErrTc, addErrsTc, warnTc,
25 recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
26 addErrTcM, addInstErrTcM, failWithTcM,
29 tcGetDefaultTys, tcSetDefaultTys,
30 tcGetUnique, tcGetUniques,
33 tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
34 tcAddErrCtxtM, tcSetErrCtxtM,
35 tcAddErrCtxt, tcSetErrCtxt,
37 tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
38 tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
40 InstOrigin(..), InstLoc, pprInstLoc,
42 TcError, TcWarning, TidyEnv, emptyTidyEnv,
46 #include "HsVersions.h"
48 import {-# SOURCE #-} TcEnv ( TcEnv )
50 import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
51 import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
53 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
55 import Bag ( Bag, emptyBag, isEmptyBag,
56 foldBag, unitBag, unionBags, snocBag )
57 import Class ( Class )
59 import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
60 import VarEnv ( TidyEnv, emptyTidyEnv )
61 import VarSet ( TyVarSet )
62 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
63 splitUniqSupply, mkSplitUniqSupply,
65 import SrcLoc ( SrcLoc, noSrcLoc )
66 import UniqFM ( emptyUFM )
67 import Unique ( Unique )
71 import IOExts ( IORef, newIORef, readIORef, writeIORef,
72 unsafeInterleaveIO, fixIO
76 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
80 %************************************************************************
84 %************************************************************************
87 type TcTyVar = TyVar -- Might be a mutable tyvar
88 type TcTyVarSet = TyVarSet
90 type TcType = Type -- A TcType can have mutable type variables
91 -- Invariant on ForAllTy in TcTypes:
93 -- a cannot occur inside a MutTyVar in T; that is,
94 -- T is "flattened" before quantifying over a
96 type TcPredType = PredType
97 type TcThetaType = ThetaType
98 type TcRhoType = RhoType
99 type TcTauType = TauType
104 %************************************************************************
106 \subsection{The main monads: TcM, NF_TcM}
108 %************************************************************************
111 type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
112 type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
114 type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
115 -- Used only in this file for type signatures which
116 -- have a part that's polymorphic in whether it's NF_TcM or TcM
119 type TcRef a = IORef a
127 -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
129 initTc dflags tc_env do_this
131 us <- mkSplitUniqSupply 'a' ;
132 us_var <- newIORef us ;
133 errs_var <- newIORef (emptyBag,emptyBag) ;
134 tvs_var <- newIORef emptyUFM ;
137 init_down = TcDown { tc_dflags = dflags, tc_def = [],
138 tc_us = us_var, tc_loc = noSrcLoc,
139 tc_ctxt = [], tc_errs = errs_var }
142 maybe_res <- catch (do { res <- do_this init_down tc_env ;
144 (\_ -> return Nothing) ;
146 (warns,errs) <- readIORef errs_var ;
147 return (maybe_res, (warns, errs))
150 -- Monadic operations
152 returnNF_Tc :: a -> NF_TcM a
153 returnTc :: a -> TcM a
154 returnTc v down env = return v
156 thenTc :: TcM a -> (a -> TcM b) -> TcM b
157 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
158 thenTc m k down env = do { r <- m down env; k r down env }
160 thenTc_ :: TcM a -> TcM b -> TcM b
161 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
162 thenTc_ m k down env = do { m down env; k down env }
164 listTc :: [TcM a] -> TcM [a]
165 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
166 listTc [] = returnTc []
167 listTc (x:xs) = x `thenTc` \ r ->
168 listTc xs `thenTc` \ rs ->
171 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
172 mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
173 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
174 mapTc f [] = returnTc []
175 mapTc f (x:xs) = f x `thenTc` \ r ->
176 mapTc f xs `thenTc` \ rs ->
178 mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
181 foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
182 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
183 foldrTc k z [] = returnTc z
184 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
187 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
188 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
189 foldlTc k z [] = returnTc z
190 foldlTc k z (x:xs) = k z x `thenTc` \r ->
193 mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
194 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
195 mapAndUnzipTc f [] = returnTc ([],[])
196 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
197 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
198 returnTc (r1:rs1, r2:rs2)
200 mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
201 mapAndUnzip3Tc f [] = returnTc ([],[],[])
202 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
203 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
204 returnTc (r1:rs1, r2:rs2, r3:rs3)
206 mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
207 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
209 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
211 returnTc (unionBags r1 r2))
212 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
216 fixTc :: (a -> TcM a) -> TcM a
217 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
218 fixTc m env down = fixIO (\ loop -> m loop env down)
220 recoverTc :: TcM r -> TcM r -> TcM r
221 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
222 recoverTc recover m down env
223 = catch (m down env) (\ _ -> recover down env)
225 returnNF_Tc = returnTc
229 recoverNF_Tc = recoverTc
234 mapAndUnzipNF_Tc = mapAndUnzipTc
235 mapBagNF_Tc = mapBagTc
238 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
239 thread. Ideally, this elegantly ensures that it can't zap any type
240 variables that belong to the main thread. But alas, the environment
241 contains TyCon and Class environments that include TcKind stuff,
242 which is a Royal Pain. By the time this fork stuff is used they'll
243 have been unified down so there won't be any kind variables, but we
244 can't express that in the current typechecker framework.
246 So we compromise and use unsafeInterleaveSST.
248 We throw away any error messages!
251 forkNF_Tc :: NF_TcM r -> NF_TcM r
252 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
254 -- Get a fresh unique supply
255 us <- readIORef u_var
256 let (us1, us2) = splitUniqSupply us
259 unsafeInterleaveIO (do {
260 us_var' <- newIORef us2 ;
261 err_var' <- newIORef (emptyBag,emptyBag) ;
262 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
264 -- ToDo: optionally dump any error messages
269 traceTc :: SDoc -> NF_TcM ()
270 traceTc doc down env = printDump doc
272 ioToTc :: IO a -> NF_TcM a
273 ioToTc io down env = io
277 %************************************************************************
279 \subsection{Error handling}
281 %************************************************************************
284 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
286 = readIORef (getTcErrs down)
289 failTc down env = give_up
292 give_up = IOERROR (userError "Typecheck failed")
294 failWithTc :: Message -> TcM a -- Add an error message and fail
295 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
297 addErrTc :: Message -> NF_TcM ()
298 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
300 addErrsTc :: [Message] -> NF_TcM ()
301 addErrsTc [] = returnNF_Tc ()
302 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
304 -- The 'M' variants do the TidyEnv bit
305 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
306 failWithTcM env_and_msg
307 = addErrTcM env_and_msg `thenNF_Tc_`
310 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
311 checkTc True err = returnTc ()
312 checkTc False err = failWithTc err
314 checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
315 checkTcM True err = returnTc ()
316 checkTcM False err = err
318 checkMaybeTc :: Maybe val -> Message -> TcM val
319 checkMaybeTc (Just val) err = returnTc val
320 checkMaybeTc Nothing err = failWithTc err
322 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
323 checkMaybeTcM (Just val) err = returnTc val
324 checkMaybeTcM Nothing err = err
326 addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
327 addErrTcM (tidy_env, err_msg) down env
328 = add_err_tcm tidy_env err_msg ctxt loc down env
330 ctxt = getErrCtxt down
333 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
334 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
335 = add_err_tcm tidy_env err_msg full_ctxt loc down env
337 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
339 add_err_tcm tidy_env err_msg ctxt loc down env
341 (warns, errs) <- readIORef errs_var
342 ctxt_msgs <- do_ctxt tidy_env ctxt down env
343 let err = addShortErrLocLine loc $
344 vcat (err_msg : ctxt_to_use ctxt_msgs)
345 writeIORef errs_var (warns, errs `snocBag` err)
347 errs_var = getTcErrs down
349 do_ctxt tidy_env [] down env
351 do_ctxt tidy_env (c:cs) down env
353 (tidy_env', m) <- c tidy_env down env
354 ms <- do_ctxt tidy_env' cs down env
357 -- warnings don't have an 'M' variant
358 warnTc :: Bool -> Message -> NF_TcM ()
359 warnTc warn_if_true warn_msg down env
362 (warns,errs) <- readIORef errs_var
363 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
364 let warn = addShortWarnLocLine loc $
365 vcat (warn_msg : ctxt_to_use ctxt_msgs)
366 writeIORef errs_var (warns `snocBag` warn, errs)
370 errs_var = getTcErrs down
371 ctxt = getErrCtxt down
374 -- (tryTc r m) succeeds if m succeeds and generates no errors
375 -- If m fails then r is invoked, passing the warnings and errors from m
376 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
377 -- (it might have recovered internally)
378 -- If so, then r is invoked, passing the warnings and errors from m
380 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action
381 -> TcM r -- Thing to try
383 tryTc recover main down env
385 m_errs_var <- newIORef (emptyBag,emptyBag)
386 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
388 my_recover m_errs_var
389 = do warns_and_errs <- readIORef m_errs_var
390 recover warns_and_errs down env
393 = do result <- main (setTcErrs down m_errs_var) env
395 -- Check that m has no errors; if it has internal recovery
396 -- mechanisms it might "succeed" but having found a bunch of
397 -- errors along the way.
398 (m_warns, m_errs) <- readIORef m_errs_var
399 if isEmptyBag m_errs then
402 give_up -- This triggers the catch
405 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
406 -- If m fails then (checkNoErrsTc m) fails.
407 -- If m succeeds, it checks whether m generated any errors messages
408 -- (it might have recovered internally)
409 -- If so, it fails too.
410 -- Regardless, any errors generated by m are propagated to the enclosing context.
411 checkNoErrsTc :: TcM r -> TcM r
413 = tryTc my_recover main
415 my_recover (m_warns, m_errs) down env
416 = do (warns, errs) <- readIORef errs_var
417 writeIORef errs_var (warns `unionBags` m_warns,
418 errs `unionBags` m_errs)
421 errs_var = getTcErrs down
424 -- (tryTc_ r m) tries m; if it succeeds it returns it,
425 -- otherwise it returns r. Any error messages added by m are discarded,
426 -- whether or not m succeeds.
427 tryTc_ :: TcM r -> TcM r -> TcM r
429 = tryTc my_recover main
431 my_recover warns_and_errs = recover
433 -- (discardErrsTc m) runs m, but throw away all its error messages.
434 discardErrsTc :: Either_TcM r -> Either_TcM r
435 discardErrsTc main down env
436 = do new_errs_var <- newIORef (emptyBag,emptyBag)
437 main (setTcErrs down new_errs_var) env
442 %************************************************************************
444 \subsection{Mutable variables}
446 %************************************************************************
449 tcNewMutVar :: a -> NF_TcM (TcRef a)
450 tcNewMutVar val down env = newIORef val
452 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
453 tcWriteMutVar var val down env = writeIORef var val
455 tcReadMutVar :: TcRef a -> NF_TcM a
456 tcReadMutVar var down env = readIORef var
458 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
459 tcNewMutTyVar name kind down env = newMutTyVar name kind
461 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
462 tcNewSigTyVar name kind down env = newSigTyVar name kind
464 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
465 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
467 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
468 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
472 %************************************************************************
474 \subsection{The environment}
476 %************************************************************************
479 tcGetEnv :: NF_TcM TcEnv
480 tcGetEnv down env = return env
482 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
483 tcSetEnv new_env m down old_env = m down new_env
487 %************************************************************************
489 \subsection{Source location}
491 %************************************************************************
494 tcGetDefaultTys :: NF_TcM [Type]
495 tcGetDefaultTys down env = return (getDefaultTys down)
497 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
498 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
500 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
501 tcAddSrcLoc loc m down env = m (setLoc down loc) env
503 tcGetSrcLoc :: NF_TcM SrcLoc
504 tcGetSrcLoc down env = return (getLoc down)
506 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
507 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
509 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
511 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
512 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
514 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
516 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
517 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
521 %************************************************************************
523 \subsection{Unique supply}
525 %************************************************************************
528 tcGetUnique :: NF_TcM Unique
530 = do uniq_supply <- readIORef u_var
531 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
532 uniq = uniqFromSupply uniq_s
533 writeIORef u_var new_uniq_supply
536 u_var = getUniqSupplyVar down
538 tcGetUniques :: Int -> NF_TcM [Unique]
539 tcGetUniques n down env
540 = do uniq_supply <- readIORef u_var
541 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
542 uniqs = uniqsFromSupply n uniq_s
543 writeIORef u_var new_uniq_supply
546 u_var = getUniqSupplyVar down
548 uniqSMToTcM :: UniqSM a -> NF_TcM a
549 uniqSMToTcM m down env
550 = do uniq_supply <- readIORef u_var
551 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
552 writeIORef u_var new_uniq_supply
553 return (initUs_ uniq_s m)
555 u_var = getUniqSupplyVar down
560 %************************************************************************
564 %************************************************************************
569 tc_dflags :: DynFlags,
570 tc_def :: [Type], -- Types used for defaulting
571 tc_us :: (TcRef UniqSupply), -- Unique supply
572 tc_loc :: SrcLoc, -- Source location
573 tc_ctxt :: ErrCtxt, -- Error context
574 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
577 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
578 -- Innermost first. Monadic so that we have a chance
579 -- to deal with bound type variables just before error
580 -- message construction
583 -- These selectors are *local* to TcMonad.lhs
586 getTcErrs (TcDown{tc_errs=errs}) = errs
587 setTcErrs down errs = down{tc_errs=errs}
589 getDefaultTys (TcDown{tc_def=def}) = def
590 setDefaultTys down def = down{tc_def=def}
592 getLoc (TcDown{tc_loc=loc}) = loc
593 setLoc down loc = down{tc_loc=loc}
595 getUniqSupplyVar (TcDown{tc_us=us}) = us
597 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
598 setErrCtxt down msg = down{tc_ctxt=[msg]}
599 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
601 doptsTc :: DynFlag -> TcM Bool
602 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
603 = return (dopt dflag dflags)
605 getDOptsTc :: TcM DynFlags
606 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
613 %************************************************************************
615 \subsection{TypeChecking Errors}
617 %************************************************************************
620 type TcError = Message
621 type TcWarning = Message
623 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
624 | otherwise = takeAtMost 3 ctxt
626 takeAtMost :: Int -> [a] -> [a]
629 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
631 arityErr kind name n m
632 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
633 n_arguments <> comma, text "but has been given", int m]
635 n_arguments | n == 0 = ptext SLIT("no arguments")
636 | n == 1 = ptext SLIT("1 argument")
637 | True = hsep [int n, ptext SLIT("arguments")]
642 %************************************************************************
644 \subsection[Inst-origin]{The @InstOrigin@ type}
646 %************************************************************************
648 The @InstOrigin@ type gives information about where a dictionary came from.
649 This is important for decent error message reporting because dictionaries
650 don't appear in the original source code. Doubtless this type will evolve...
652 It appears in TcMonad because there are a couple of error-message-generation
653 functions that deal with it.
656 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
659 = OccurrenceOf Id -- Occurrence of an overloaded identifier
663 | DataDeclOrigin -- Typechecking a data declaration
665 | InstanceDeclOrigin -- Typechecking an instance decl
667 | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal
669 | PatOrigin RenamedPat
671 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
673 | SignatureOrigin -- A dict created from a type signature
674 | Rank2Origin -- A dict created when typechecking the argument
675 -- of a rank-2 typed function
677 | DoOrigin -- The monad for a do expression
679 | ClassDeclOrigin -- Manufactured during a class decl
681 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
684 -- When specialising instances the instance info attached to
685 -- each class is not yet ready, so we record it inside the
686 -- origin information. This is a bit of a hack, but it works
687 -- fine. (Patrick is to blame [WDP].)
689 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
691 -- Argument or result of a ccall
692 -- Dictionaries with this origin aren't actually mentioned in the
693 -- translated term, and so need not be bound. Nor should they
694 -- be abstracted over.
696 | CCallOrigin String -- CCall label
697 (Maybe RenamedHsExpr) -- Nothing if it's the result
698 -- Just arg, for an argument
700 | LitLitOrigin String -- the litlit
702 | UnknownOrigin -- Help! I give up...
706 pprInstLoc :: InstLoc -> SDoc
707 pprInstLoc (orig, locn, ctxt)
708 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
710 pp_orig (OccurrenceOf id)
711 = hsep [ptext SLIT("use of"), quotes (ppr id)]
712 pp_orig (LiteralOrigin lit)
713 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
714 pp_orig (PatOrigin pat)
715 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
716 pp_orig (InstanceDeclOrigin)
717 = ptext SLIT("an instance declaration")
718 pp_orig (ArithSeqOrigin seq)
719 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
720 pp_orig (SignatureOrigin)
721 = ptext SLIT("a type signature")
722 pp_orig (Rank2Origin)
723 = ptext SLIT("a function with an overloaded argument type")
725 = ptext SLIT("a do statement")
726 pp_orig (ClassDeclOrigin)
727 = ptext SLIT("a class declaration")
728 pp_orig (InstanceSpecOrigin clas ty)
729 = hsep [text "a SPECIALIZE instance pragma; class",
730 quotes (ppr clas), text "type:", ppr ty]
731 pp_orig (ValSpecOrigin name)
732 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
733 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
734 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
735 pp_orig (CCallOrigin clabel (Just arg_expr))
736 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
737 text "namely", quotes (ppr arg_expr)]
738 pp_orig (LitLitOrigin s)
739 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
740 pp_orig (UnknownOrigin)
741 = ptext SLIT("...oops -- I don't know where the overloading came from!")