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 ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, Message, WarnMsg )
53 import CmdLineOpts ( opt_PprStyle_Debug )
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 ( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
61 import VarSet ( TyVarSet )
62 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
64 import SrcLoc ( SrcLoc, noSrcLoc )
65 import FiniteMap ( FiniteMap, emptyFM )
66 import UniqFM ( UniqFM, emptyUFM )
67 import Unique ( Unique )
68 import BasicTypes ( Unused )
71 import FastString ( FastString )
73 import IOExts ( IORef, newIORef, readIORef, writeIORef,
74 unsafeInterleaveIO, fixIO
78 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
85 type TcTyVar = TyVar -- Might be a mutable tyvar
86 type TcTyVarSet = TyVarSet
88 type TcType = Type -- A TcType can have mutable type variables
89 -- Invariant on ForAllTy in TcTypes:
91 -- a cannot occur inside a MutTyVar in T; that is,
92 -- T is "flattened" before quantifying over a
94 type TcPredType = PredType
95 type TcThetaType = ThetaType
96 type TcRhoType = RhoType
97 type TcTauType = TauType
102 \section{TcM, NF_TcM: the type checker monads}
103 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
106 type NF_TcM s r = TcDown -> TcEnv -> IO r -- Can't raise UserError
107 type TcM s r = TcDown -> TcEnv -> IO r -- Can raise UserError
108 -- ToDo: nuke the 's' part
109 -- The difference between the two is
110 -- now for documentation purposes only
112 type Either_TcM s r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
113 -- Used only in this file for type signatures which
114 -- have a part that's polymorphic in whether it's NF_TcM or TcM
117 type TcRef a = IORef a
121 -- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
124 -> (TcRef (UniqFM a) -> TcEnv)
126 -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
128 initTc us initenv do_this
130 us_var <- newIORef us ;
131 errs_var <- newIORef (emptyBag,emptyBag) ;
132 tvs_var <- newIORef emptyUFM ;
135 init_down = TcDown [] us_var
138 init_env = initenv tvs_var
141 maybe_res <- catch (do { res <- do_this init_down init_env ;
143 (\_ -> return Nothing) ;
145 (warns,errs) <- readIORef errs_var ;
146 return (maybe_res, warns, errs)
149 -- Monadic operations
151 returnNF_Tc :: a -> NF_TcM s a
152 returnTc :: a -> TcM s a
153 returnTc v down env = return v
155 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
156 thenNF_Tc :: NF_TcM s a -> (a -> Either_TcM s b) -> Either_TcM s b
157 thenTc m k down env = do { r <- m down env; k r down env }
159 thenTc_ :: TcM s a -> TcM s b -> TcM s b
160 thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b
161 thenTc_ m k down env = do { m down env; k down env }
163 listTc :: [TcM s a] -> TcM s [a]
164 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
165 listTc [] = returnTc []
166 listTc (x:xs) = x `thenTc` \ r ->
167 listTc xs `thenTc` \ rs ->
170 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
171 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
172 mapTc f [] = returnTc []
173 mapTc f (x:xs) = f x `thenTc` \ r ->
174 mapTc f xs `thenTc` \ rs ->
177 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
178 foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
179 foldrTc k z [] = returnTc z
180 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
183 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
184 foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
185 foldlTc k z [] = returnTc z
186 foldlTc k z (x:xs) = k z x `thenTc` \r ->
189 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
190 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
191 mapAndUnzipTc f [] = returnTc ([],[])
192 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
193 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
194 returnTc (r1:rs1, r2:rs2)
196 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
197 mapAndUnzip3Tc f [] = returnTc ([],[],[])
198 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
199 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
200 returnTc (r1:rs1, r2:rs2, r3:rs3)
202 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
203 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
205 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
207 returnTc (unionBags r1 r2))
208 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
212 fixTc :: (a -> TcM s a) -> TcM s a
213 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
214 fixTc m env down = fixIO (\ loop -> m loop env down)
216 recoverTc :: TcM s r -> TcM s r -> TcM s r
217 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
218 recoverTc recover m down env
219 = catch (m down env) (\ _ -> recover down env)
221 returnNF_Tc = returnTc
225 recoverNF_Tc = recoverTc
230 mapAndUnzipNF_Tc = mapAndUnzipTc
231 mapBagNF_Tc = mapBagTc
234 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
235 thread. Ideally, this elegantly ensures that it can't zap any type
236 variables that belong to the main thread. But alas, the environment
237 contains TyCon and Class environments that include TcKind stuff,
238 which is a Royal Pain. By the time this fork stuff is used they'll
239 have been unified down so there won't be any kind variables, but we
240 can't express that in the current typechecker framework.
242 So we compromise and use unsafeInterleaveSST.
244 We throw away any error messages!
247 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
248 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
250 -- Get a fresh unique supply
251 us <- readIORef u_var
252 let (us1, us2) = splitUniqSupply us
255 unsafeInterleaveIO (do {
256 us_var' <- newIORef us2 ;
257 err_var' <- newIORef (emptyBag,emptyBag) ;
258 tv_var' <- newIORef emptyUFM ;
259 let { down' = TcDown deflts us_var' src_loc err_cxt err_var' } ;
261 -- ToDo: optionally dump any error messages
266 traceTc :: SDoc -> NF_TcM s ()
267 traceTc doc down env = printErrs doc
269 ioToTc :: IO a -> NF_TcM s a
270 ioToTc io down env = io
274 %************************************************************************
276 \subsection{Error handling}
278 %************************************************************************
281 getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
283 = readIORef (getTcErrs down)
286 failTc down env = give_up
289 give_up = IOERROR (userError "Typecheck failed")
291 failWithTc :: Message -> TcM s a -- Add an error message and fail
292 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
294 addErrTc :: Message -> NF_TcM s ()
295 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
297 -- The 'M' variants do the TidyEnv bit
298 failWithTcM :: (TidyEnv, Message) -> TcM s a -- Add an error message and fail
299 failWithTcM env_and_msg
300 = addErrTcM env_and_msg `thenNF_Tc_`
303 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
304 checkTc True err = returnTc ()
305 checkTc False err = failWithTc err
307 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
308 checkTcM True err = returnTc ()
309 checkTcM False err = err
311 checkMaybeTc :: Maybe val -> Message -> TcM s val
312 checkMaybeTc (Just val) err = returnTc val
313 checkMaybeTc Nothing err = failWithTc err
315 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
316 checkMaybeTcM (Just val) err = returnTc val
317 checkMaybeTcM Nothing err = err
319 addErrTcM :: (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail
320 addErrTcM (tidy_env, err_msg) down env
321 = add_err_tcm tidy_env err_msg ctxt loc down env
323 ctxt = getErrCtxt down
326 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail
327 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
328 = add_err_tcm tidy_env err_msg full_ctxt loc down env
330 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
332 add_err_tcm tidy_env err_msg ctxt loc down env
334 (warns, errs) <- readIORef errs_var
335 ctxt_msgs <- do_ctxt tidy_env ctxt down env
336 let err = addShortErrLocLine loc $
337 vcat (err_msg : ctxt_to_use ctxt_msgs)
338 writeIORef errs_var (warns, errs `snocBag` err)
340 errs_var = getTcErrs down
342 do_ctxt tidy_env [] down env
344 do_ctxt tidy_env (c:cs) down env
346 (tidy_env', m) <- c tidy_env down env
347 ms <- do_ctxt tidy_env' cs down env
350 -- warnings don't have an 'M' variant
351 warnTc :: Bool -> Message -> NF_TcM s ()
352 warnTc warn_if_true warn_msg down env
355 (warns,errs) <- readIORef errs_var
356 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
357 let warn = addShortWarnLocLine loc $
358 vcat (warn_msg : ctxt_to_use ctxt_msgs)
359 writeIORef errs_var (warns `snocBag` warn, errs)
363 errs_var = getTcErrs down
364 ctxt = getErrCtxt down
367 -- (tryTc r m) succeeds if m succeeds and generates no errors
368 -- If m fails then r is invoked, passing the warnings and errors from m
369 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
370 -- (it might have recovered internally)
371 -- If so, then r is invoked, passing the warnings and errors from m
373 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM s r) -- Recovery action
374 -> TcM s r -- Thing to try
376 tryTc recover main down env
378 m_errs_var <- newIORef (emptyBag,emptyBag)
379 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
381 my_recover m_errs_var
382 = do warns_and_errs <- readIORef m_errs_var
383 recover warns_and_errs down env
386 = do result <- main (setTcErrs down m_errs_var) env
388 -- Check that m has no errors; if it has internal recovery
389 -- mechanisms it might "succeed" but having found a bunch of
390 -- errors along the way.
391 (m_warns, m_errs) <- readIORef m_errs_var
392 if isEmptyBag m_errs then
395 give_up -- This triggers the catch
398 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
399 -- If m fails then (checkNoErrsTc m) fails.
400 -- If m succeeds, it checks whether m generated any errors messages
401 -- (it might have recovered internally)
402 -- If so, it fails too.
403 -- Regardless, any errors generated by m are propagated to the enclosing context.
404 checkNoErrsTc :: TcM s r -> TcM s r
406 = tryTc my_recover main
408 my_recover (m_warns, m_errs) down env
409 = do (warns, errs) <- readIORef errs_var
410 writeIORef errs_var (warns `unionBags` m_warns,
411 errs `unionBags` m_errs)
414 errs_var = getTcErrs down
417 -- (tryTc_ r m) tries m; if it succeeds it returns it,
418 -- otherwise it returns r. Any error messages added by m are discarded,
419 -- whether or not m succeeds.
420 tryTc_ :: TcM s r -> TcM s r -> TcM s r
422 = tryTc my_recover main
424 my_recover warns_and_errs = recover
426 -- (discardErrsTc m) runs m, but throw away all its error messages.
427 discardErrsTc :: Either_TcM s r -> Either_TcM s r
428 discardErrsTc main down env
429 = do new_errs_var <- newIORef (emptyBag,emptyBag)
430 main (setTcErrs down new_errs_var) env
436 tcNewMutVar :: a -> NF_TcM s (TcRef a)
437 tcNewMutVar val down env = newIORef val
439 tcWriteMutVar :: TcRef a -> a -> NF_TcM s ()
440 tcWriteMutVar var val down env = writeIORef var val
442 tcReadMutVar :: TcRef a -> NF_TcM s a
443 tcReadMutVar var down env = readIORef var
445 tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
446 tcNewMutTyVar name kind down env = newMutTyVar name kind
448 tcNewSigTyVar :: Name -> Kind -> NF_TcM s TyVar
449 tcNewSigTyVar name kind down env = newSigTyVar name kind
451 tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
452 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
454 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
455 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
462 tcGetEnv :: NF_TcM s TcEnv
463 tcGetEnv down env = return env
465 tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
466 tcSetEnv new_env m down old_env = m down new_env
473 tcGetDefaultTys :: NF_TcM s [Type]
474 tcGetDefaultTys down env = return (getDefaultTys down)
476 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
477 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
479 tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a
480 tcAddSrcLoc loc m down env = m (setLoc down loc) env
482 tcGetSrcLoc :: NF_TcM s SrcLoc
483 tcGetSrcLoc down env = return (getLoc down)
485 tcGetInstLoc :: InstOrigin -> NF_TcM s InstLoc
486 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
488 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message))
489 -> TcM s a -> TcM s a
490 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
491 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
493 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM s r -> Either_TcM s r
495 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
496 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
503 tcGetUnique :: NF_TcM s Unique
505 = do uniq_supply <- readIORef u_var
506 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
507 uniq = uniqFromSupply uniq_s
508 writeIORef u_var new_uniq_supply
511 u_var = getUniqSupplyVar down
513 tcGetUniques :: Int -> NF_TcM s [Unique]
514 tcGetUniques n down env
515 = do uniq_supply <- readIORef u_var
516 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
517 uniqs = uniqsFromSupply n uniq_s
518 writeIORef u_var new_uniq_supply
521 u_var = getUniqSupplyVar down
523 uniqSMToTcM :: UniqSM a -> NF_TcM s a
524 uniqSMToTcM m down env
525 = do uniq_supply <- readIORef u_var
526 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
527 writeIORef u_var new_uniq_supply
528 return (initUs_ uniq_s m)
530 u_var = getUniqSupplyVar down
540 [Type] -- Types used for defaulting
542 (TcRef UniqSupply) -- Unique supply
544 SrcLoc -- Source location
545 ErrCtxt -- Error context
549 type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
550 -- Innermost first. Monadic so that we have a chance
551 -- to deal with bound type variables just before error
552 -- message construction
555 -- These selectors are *local* to TcMonad.lhs
558 getTcErrs (TcDown def us loc ctxt errs) = errs
559 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
561 getDefaultTys (TcDown def us loc ctxt errs) = def
562 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
564 getLoc (TcDown def us loc ctxt errs) = loc
565 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
567 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
569 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
570 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
571 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
581 type TcError = Message
582 type TcWarning = Message
584 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
585 | otherwise = takeAtMost 3 ctxt
587 takeAtMost :: Int -> [a] -> [a]
590 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
592 arityErr kind name n m
593 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
594 n_arguments <> comma, text "but has been given", int m]
596 n_arguments | n == 0 = ptext SLIT("no arguments")
597 | n == 1 = ptext SLIT("1 argument")
598 | True = hsep [int n, ptext SLIT("arguments")]
603 %************************************************************************
605 \subsection[Inst-origin]{The @InstOrigin@ type}
607 %************************************************************************
609 The @InstOrigin@ type gives information about where a dictionary came from.
610 This is important for decent error message reporting because dictionaries
611 don't appear in the original source code. Doubtless this type will evolve...
613 It appears in TcMonad because there are a couple of error-message-generation
614 functions that deal with it.
617 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
620 = OccurrenceOf Id -- Occurrence of an overloaded identifier
624 | DataDeclOrigin -- Typechecking a data declaration
626 | InstanceDeclOrigin -- Typechecking an instance decl
628 | LiteralOrigin HsLit -- Occurrence of a literal
630 | PatOrigin RenamedPat
632 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
634 | SignatureOrigin -- A dict created from a type signature
635 | Rank2Origin -- A dict created when typechecking the argument
636 -- of a rank-2 typed function
638 | DoOrigin -- The monad for a do expression
640 | ClassDeclOrigin -- Manufactured during a class decl
642 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
645 -- When specialising instances the instance info attached to
646 -- each class is not yet ready, so we record it inside the
647 -- origin information. This is a bit of a hack, but it works
648 -- fine. (Patrick is to blame [WDP].)
650 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
652 -- Argument or result of a ccall
653 -- Dictionaries with this origin aren't actually mentioned in the
654 -- translated term, and so need not be bound. Nor should they
655 -- be abstracted over.
657 | CCallOrigin String -- CCall label
658 (Maybe RenamedHsExpr) -- Nothing if it's the result
659 -- Just arg, for an argument
661 | LitLitOrigin String -- the litlit
663 | UnknownOrigin -- Help! I give up...
667 pprInstLoc :: InstLoc -> SDoc
668 pprInstLoc (orig, locn, ctxt)
669 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
671 pp_orig (OccurrenceOf id)
672 = hsep [ptext SLIT("use of"), quotes (ppr id)]
673 pp_orig (LiteralOrigin lit)
674 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
675 pp_orig (PatOrigin pat)
676 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
677 pp_orig (InstanceDeclOrigin)
678 = ptext SLIT("an instance declaration")
679 pp_orig (ArithSeqOrigin seq)
680 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
681 pp_orig (SignatureOrigin)
682 = ptext SLIT("a type signature")
683 pp_orig (Rank2Origin)
684 = ptext SLIT("a function with an overloaded argument type")
686 = ptext SLIT("a do statement")
687 pp_orig (ClassDeclOrigin)
688 = ptext SLIT("a class declaration")
689 pp_orig (InstanceSpecOrigin clas ty)
690 = hsep [text "a SPECIALIZE instance pragma; class",
691 quotes (ppr clas), text "type:", ppr ty]
692 pp_orig (ValSpecOrigin name)
693 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
694 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
695 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
696 pp_orig (CCallOrigin clabel (Just arg_expr))
697 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
698 text "namely", quotes (ppr arg_expr)]
699 pp_orig (LitLitOrigin s)
700 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
701 pp_orig (UnknownOrigin)
702 = ptext SLIT("...oops -- I don't know where the overloading came from!")