4 TcTauType, TcPredType, TcThetaType, TcRhoType,
8 TcM, NF_TcM, TcDown, TcEnv,
11 returnTc, thenTc, thenTc_, 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, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
25 addErrTcM, addInstErrTcM, failWithTcM,
28 tcGetDefaultTys, tcSetDefaultTys,
29 tcGetUnique, tcGetUniques,
31 tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
32 tcAddErrCtxtM, tcSetErrCtxtM,
33 tcAddErrCtxt, tcSetErrCtxt,
35 tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
36 tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
38 InstOrigin(..), InstLoc, pprInstLoc,
40 TcError, TcWarning, TidyEnv, emptyTidyEnv,
44 #include "HsVersions.h"
46 import {-# SOURCE #-} TcEnv ( TcEnv )
48 import HsSyn ( HsLit )
49 import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
50 import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
52 import PprType ( {- instance Outputable Type -} )
53 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, Message, WarnMsg )
54 import CmdLineOpts ( opt_PprStyle_Debug )
56 import Bag ( Bag, emptyBag, isEmptyBag,
57 foldBag, unitBag, unionBags, snocBag )
58 import Class ( Class )
60 import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
61 import VarEnv ( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
62 import VarSet ( TyVarSet )
63 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
65 import SrcLoc ( SrcLoc, noSrcLoc )
66 import FiniteMap ( FiniteMap, emptyFM )
67 import UniqFM ( UniqFM, emptyUFM )
68 import Unique ( Unique )
69 import BasicTypes ( Unused )
72 import FastString ( FastString )
74 import IOExts ( IORef, newIORef, readIORef, writeIORef,
75 unsafeInterleaveIO, fixIO
79 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
86 type TcTyVar = TyVar -- Might be a mutable tyvar
87 type TcTyVarSet = TyVarSet
89 type TcType = Type -- A TcType can have mutable type variables
90 -- Invariant on ForAllTy in TcTypes:
92 -- a cannot occur inside a MutTyVar in T; that is,
93 -- T is "flattened" before quantifying over a
95 type TcPredType = PredType
96 type TcThetaType = ThetaType
97 type TcRhoType = RhoType
98 type TcTauType = TauType
103 \section{TcM, NF_TcM: the type checker monads}
104 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
107 type NF_TcM s r = TcDown -> TcEnv -> IO r -- Can't raise UserError
108 type TcM s r = TcDown -> TcEnv -> IO r -- Can raise UserError
109 -- ToDo: nuke the 's' part
110 -- The difference between the two is
111 -- now for documentation purposes only
113 type Either_TcM s r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
114 -- Used only in this file for type signatures which
115 -- have a part that's polymorphic in whether it's NF_TcM or TcM
118 type TcRef a = IORef a
122 -- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
125 -> (TcRef (UniqFM a) -> TcEnv)
127 -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
129 initTc us initenv do_this
131 us_var <- newIORef us ;
132 errs_var <- newIORef (emptyBag,emptyBag) ;
133 tvs_var <- newIORef emptyUFM ;
136 init_down = TcDown [] us_var
139 init_env = initenv tvs_var
142 maybe_res <- catch (do { res <- do_this init_down init_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 s a
153 returnTc :: a -> TcM s a
154 returnTc v down env = return v
156 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
157 thenNF_Tc :: NF_TcM s a -> (a -> Either_TcM s b) -> Either_TcM s b
158 thenTc m k down env = do { r <- m down env; k r down env }
160 thenTc_ :: TcM s a -> TcM s b -> TcM s b
161 thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b
162 thenTc_ m k down env = do { m down env; k down env }
164 listTc :: [TcM s a] -> TcM s [a]
165 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
166 listTc [] = returnTc []
167 listTc (x:xs) = x `thenTc` \ r ->
168 listTc xs `thenTc` \ rs ->
171 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
172 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
173 mapTc f [] = returnTc []
174 mapTc f (x:xs) = f x `thenTc` \ r ->
175 mapTc f xs `thenTc` \ rs ->
178 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
179 foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
180 foldrTc k z [] = returnTc z
181 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
184 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
185 foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
186 foldlTc k z [] = returnTc z
187 foldlTc k z (x:xs) = k z x `thenTc` \r ->
190 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
191 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
192 mapAndUnzipTc f [] = returnTc ([],[])
193 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
194 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
195 returnTc (r1:rs1, r2:rs2)
197 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
198 mapAndUnzip3Tc f [] = returnTc ([],[],[])
199 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
200 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
201 returnTc (r1:rs1, r2:rs2, r3:rs3)
203 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
204 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
206 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
208 returnTc (unionBags r1 r2))
209 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
213 fixTc :: (a -> TcM s a) -> TcM s a
214 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
215 fixTc m env down = fixIO (\ loop -> m loop env down)
217 recoverTc :: TcM s r -> TcM s r -> TcM s r
218 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
219 recoverTc recover m down env
220 = catch (m down env) (\ _ -> recover down env)
222 returnNF_Tc = returnTc
226 recoverNF_Tc = recoverTc
231 mapAndUnzipNF_Tc = mapAndUnzipTc
232 mapBagNF_Tc = mapBagTc
235 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
236 thread. Ideally, this elegantly ensures that it can't zap any type
237 variables that belong to the main thread. But alas, the environment
238 contains TyCon and Class environments that include TcKind stuff,
239 which is a Royal Pain. By the time this fork stuff is used they'll
240 have been unified down so there won't be any kind variables, but we
241 can't express that in the current typechecker framework.
243 So we compromise and use unsafeInterleaveSST.
245 We throw away any error messages!
248 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
249 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
251 -- Get a fresh unique supply
252 us <- readIORef u_var
253 let (us1, us2) = splitUniqSupply us
256 unsafeInterleaveIO (do {
257 us_var' <- newIORef us2 ;
258 err_var' <- newIORef (emptyBag,emptyBag) ;
259 tv_var' <- newIORef emptyUFM ;
260 let { down' = TcDown deflts us_var' src_loc err_cxt err_var' } ;
262 -- ToDo: optionally dump any error messages
267 traceTc :: SDoc -> NF_TcM s ()
268 traceTc doc down env = printErrs doc
270 ioToTc :: IO a -> NF_TcM s a
271 ioToTc io down env = io
275 %************************************************************************
277 \subsection{Error handling}
279 %************************************************************************
282 getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
284 = readIORef (getTcErrs down)
287 failTc down env = give_up
290 give_up = IOERROR (userError "Typecheck failed")
292 failWithTc :: Message -> TcM s a -- Add an error message and fail
293 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
295 addErrTc :: Message -> NF_TcM s ()
296 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
298 -- The 'M' variants do the TidyEnv bit
299 failWithTcM :: (TidyEnv, Message) -> TcM s a -- Add an error message and fail
300 failWithTcM env_and_msg
301 = addErrTcM env_and_msg `thenNF_Tc_`
304 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
305 checkTc True err = returnTc ()
306 checkTc False err = failWithTc err
308 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
309 checkTcM True err = returnTc ()
310 checkTcM False err = err
312 checkMaybeTc :: Maybe val -> Message -> TcM s val
313 checkMaybeTc (Just val) err = returnTc val
314 checkMaybeTc Nothing err = failWithTc err
316 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
317 checkMaybeTcM (Just val) err = returnTc val
318 checkMaybeTcM Nothing err = err
320 addErrTcM :: (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail
321 addErrTcM (tidy_env, err_msg) down env
322 = add_err_tcm tidy_env err_msg ctxt loc down env
324 ctxt = getErrCtxt down
327 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail
328 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
329 = add_err_tcm tidy_env err_msg full_ctxt loc down env
331 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
333 add_err_tcm tidy_env err_msg ctxt loc down env
335 (warns, errs) <- readIORef errs_var
336 ctxt_msgs <- do_ctxt tidy_env ctxt down env
337 let err = addShortErrLocLine loc $
338 vcat (err_msg : ctxt_to_use ctxt_msgs)
339 writeIORef errs_var (warns, errs `snocBag` err)
341 errs_var = getTcErrs down
343 do_ctxt tidy_env [] down env
345 do_ctxt tidy_env (c:cs) down env
347 (tidy_env', m) <- c tidy_env down env
348 ms <- do_ctxt tidy_env' cs down env
351 -- warnings don't have an 'M' variant
352 warnTc :: Bool -> Message -> NF_TcM s ()
353 warnTc warn_if_true warn_msg down env
356 (warns,errs) <- readIORef errs_var
357 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
358 let warn = addShortWarnLocLine loc $
359 vcat (warn_msg : ctxt_to_use ctxt_msgs)
360 writeIORef errs_var (warns `snocBag` warn, errs)
364 errs_var = getTcErrs down
365 ctxt = getErrCtxt down
368 -- (tryTc r m) succeeds if m succeeds and generates no errors
369 -- If m fails then r is invoked, passing the warnings and errors from m
370 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
371 -- (it might have recovered internally)
372 -- If so, then r is invoked, passing the warnings and errors from m
374 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM s r) -- Recovery action
375 -> TcM s r -- Thing to try
377 tryTc recover main down env
379 m_errs_var <- newIORef (emptyBag,emptyBag)
380 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
382 my_recover m_errs_var
383 = do warns_and_errs <- readIORef m_errs_var
384 recover warns_and_errs down env
387 = do result <- main (setTcErrs down m_errs_var) env
389 -- Check that m has no errors; if it has internal recovery
390 -- mechanisms it might "succeed" but having found a bunch of
391 -- errors along the way.
392 (m_warns, m_errs) <- readIORef m_errs_var
393 if isEmptyBag m_errs then
396 give_up -- This triggers the catch
399 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
400 -- If m fails then (checkNoErrsTc m) fails.
401 -- If m succeeds, it checks whether m generated any errors messages
402 -- (it might have recovered internally)
403 -- If so, it fails too.
404 -- Regardless, any errors generated by m are propagated to the enclosing context.
405 checkNoErrsTc :: TcM s r -> TcM s r
407 = tryTc my_recover main
409 my_recover (m_warns, m_errs) down env
410 = do (warns, errs) <- readIORef errs_var
411 writeIORef errs_var (warns `unionBags` m_warns,
412 errs `unionBags` m_errs)
415 errs_var = getTcErrs down
418 -- (tryTc_ r m) tries m; if it succeeds it returns it,
419 -- otherwise it returns r. Any error messages added by m are discarded,
420 -- whether or not m succeeds.
421 tryTc_ :: TcM s r -> TcM s r -> TcM s r
423 = tryTc my_recover main
425 my_recover warns_and_errs = recover
427 -- (discardErrsTc m) runs m, but throw away all its error messages.
428 discardErrsTc :: Either_TcM s r -> Either_TcM s r
429 discardErrsTc main down env
430 = do new_errs_var <- newIORef (emptyBag,emptyBag)
431 main (setTcErrs down new_errs_var) env
437 tcNewMutVar :: a -> NF_TcM s (TcRef a)
438 tcNewMutVar val down env = newIORef val
440 tcWriteMutVar :: TcRef a -> a -> NF_TcM s ()
441 tcWriteMutVar var val down env = writeIORef var val
443 tcReadMutVar :: TcRef a -> NF_TcM s a
444 tcReadMutVar var down env = readIORef var
446 tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
447 tcNewMutTyVar name kind down env = newMutTyVar name kind
449 tcNewSigTyVar :: Name -> Kind -> NF_TcM s TyVar
450 tcNewSigTyVar name kind down env = newSigTyVar name kind
452 tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
453 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
455 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
456 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
463 tcGetEnv :: NF_TcM s TcEnv
464 tcGetEnv down env = return env
466 tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
467 tcSetEnv new_env m down old_env = m down new_env
474 tcGetDefaultTys :: NF_TcM s [Type]
475 tcGetDefaultTys down env = return (getDefaultTys down)
477 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
478 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
480 tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a
481 tcAddSrcLoc loc m down env = m (setLoc down loc) env
483 tcGetSrcLoc :: NF_TcM s SrcLoc
484 tcGetSrcLoc down env = return (getLoc down)
486 tcGetInstLoc :: InstOrigin -> NF_TcM s InstLoc
487 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
489 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message))
490 -> TcM s a -> TcM s a
491 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
492 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
494 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM s r -> Either_TcM s r
496 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
497 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
504 tcGetUnique :: NF_TcM s Unique
506 = do uniq_supply <- readIORef u_var
507 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
508 uniq = uniqFromSupply uniq_s
509 writeIORef u_var new_uniq_supply
512 u_var = getUniqSupplyVar down
514 tcGetUniques :: Int -> NF_TcM s [Unique]
515 tcGetUniques n down env
516 = do uniq_supply <- readIORef u_var
517 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
518 uniqs = uniqsFromSupply n uniq_s
519 writeIORef u_var new_uniq_supply
522 u_var = getUniqSupplyVar down
524 uniqSMToTcM :: UniqSM a -> NF_TcM s a
525 uniqSMToTcM m down env
526 = do uniq_supply <- readIORef u_var
527 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
528 writeIORef u_var new_uniq_supply
529 return (initUs_ uniq_s m)
531 u_var = getUniqSupplyVar down
541 [Type] -- Types used for defaulting
543 (TcRef UniqSupply) -- Unique supply
545 SrcLoc -- Source location
546 ErrCtxt -- Error context
550 type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
551 -- Innermost first. Monadic so that we have a chance
552 -- to deal with bound type variables just before error
553 -- message construction
556 -- These selectors are *local* to TcMonad.lhs
559 getTcErrs (TcDown def us loc ctxt errs) = errs
560 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
562 getDefaultTys (TcDown def us loc ctxt errs) = def
563 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
565 getLoc (TcDown def us loc ctxt errs) = loc
566 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
568 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
570 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
571 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
572 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
582 type TcError = Message
583 type TcWarning = Message
585 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
586 | otherwise = takeAtMost 3 ctxt
588 takeAtMost :: Int -> [a] -> [a]
591 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
593 arityErr kind name n m
594 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
595 n_arguments <> comma, text "but has been given", int m]
597 n_arguments | n == 0 = ptext SLIT("no arguments")
598 | n == 1 = ptext SLIT("1 argument")
599 | True = hsep [int n, ptext SLIT("arguments")]
604 %************************************************************************
606 \subsection[Inst-origin]{The @InstOrigin@ type}
608 %************************************************************************
610 The @InstOrigin@ type gives information about where a dictionary came from.
611 This is important for decent error message reporting because dictionaries
612 don't appear in the original source code. Doubtless this type will evolve...
614 It appears in TcMonad because there are a couple of error-message-generation
615 functions that deal with it.
618 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
621 = OccurrenceOf Id -- Occurrence of an overloaded identifier
625 | DataDeclOrigin -- Typechecking a data declaration
627 | InstanceDeclOrigin -- Typechecking an instance decl
629 | LiteralOrigin HsLit -- Occurrence of a literal
631 | PatOrigin RenamedPat
633 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
635 | SignatureOrigin -- A dict created from a type signature
636 | Rank2Origin -- A dict created when typechecking the argument
637 -- of a rank-2 typed function
639 | DoOrigin -- The monad for a do expression
641 | ClassDeclOrigin -- Manufactured during a class decl
643 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
646 -- When specialising instances the instance info attached to
647 -- each class is not yet ready, so we record it inside the
648 -- origin information. This is a bit of a hack, but it works
649 -- fine. (Patrick is to blame [WDP].)
651 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
653 -- Argument or result of a ccall
654 -- Dictionaries with this origin aren't actually mentioned in the
655 -- translated term, and so need not be bound. Nor should they
656 -- be abstracted over.
658 | CCallOrigin String -- CCall label
659 (Maybe RenamedHsExpr) -- Nothing if it's the result
660 -- Just arg, for an argument
662 | LitLitOrigin String -- the litlit
664 | UnknownOrigin -- Help! I give up...
668 pprInstLoc :: InstLoc -> SDoc
669 pprInstLoc (orig, locn, ctxt)
670 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
672 pp_orig (OccurrenceOf id)
673 = hsep [ptext SLIT("use of"), quotes (ppr id)]
674 pp_orig (LiteralOrigin lit)
675 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
676 pp_orig (PatOrigin pat)
677 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
678 pp_orig (InstanceDeclOrigin)
679 = ptext SLIT("an instance declaration")
680 pp_orig (ArithSeqOrigin seq)
681 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
682 pp_orig (SignatureOrigin)
683 = ptext SLIT("a type signature")
684 pp_orig (Rank2Origin)
685 = ptext SLIT("a function with an overloaded argument type")
687 = ptext SLIT("a do statement")
688 pp_orig (ClassDeclOrigin)
689 = ptext SLIT("a class declaration")
690 pp_orig (InstanceSpecOrigin clas ty)
691 = hsep [text "a SPECIALIZE instance pragma; class",
692 quotes (ppr clas), text "type:", ppr ty]
693 pp_orig (ValSpecOrigin name)
694 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
695 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
696 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
697 pp_orig (CCallOrigin clabel (Just arg_expr))
698 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
699 text "namely", quotes (ppr arg_expr)]
700 pp_orig (LitLitOrigin s)
701 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
702 pp_orig (UnknownOrigin)
703 = ptext SLIT("...oops -- I don't know where the overloading came from!")