3 TcM, NF_TcM, TcDown, TcEnv,
6 returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
7 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
8 mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
13 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
14 fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
16 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
18 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
19 failTc, failWithTc, addErrTc, addErrsTc, warnTc,
20 recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
21 addErrTcM, addInstErrTcM, failWithTcM,
24 tcGetDefaultTys, tcSetDefaultTys,
25 tcGetUnique, tcGetUniques,
28 tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
29 tcAddErrCtxtM, tcSetErrCtxtM,
30 tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
32 tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
33 tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
35 InstOrigin(..), InstLoc, pprInstLoc,
37 TcError, TcWarning, TidyEnv, emptyTidyEnv,
41 #include "HsVersions.h"
43 import {-# SOURCE #-} TcEnv ( TcEnv )
45 import HsLit ( HsOverLit )
46 import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
47 import TcType ( Type, Kind, PredType, ThetaType, TyVarDetails )
48 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
50 import Bag ( Bag, emptyBag, isEmptyBag,
51 foldBag, unitBag, unionBags, snocBag )
52 import Class ( Class )
54 import Var ( Id, TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
55 import VarEnv ( TidyEnv, emptyTidyEnv )
56 import VarSet ( TyVarSet )
57 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
58 splitUniqSupply, mkSplitUniqSupply,
60 import SrcLoc ( SrcLoc, noSrcLoc )
61 import UniqFM ( emptyUFM )
62 import Unique ( Unique )
66 import IOExts ( IORef, newIORef, readIORef, writeIORef,
67 unsafeInterleaveIO, fixIO
71 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
75 %************************************************************************
77 \subsection{The main monads: TcM, NF_TcM}
79 %************************************************************************
82 type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
83 type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
85 type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
86 -- Used only in this file for type signatures which
87 -- have a part that's polymorphic in whether it's NF_TcM or TcM
90 type TcRef a = IORef a
98 -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
100 initTc dflags tc_env do_this
102 us <- mkSplitUniqSupply 'a' ;
103 us_var <- newIORef us ;
104 errs_var <- newIORef (emptyBag,emptyBag) ;
105 tvs_var <- newIORef emptyUFM ;
108 init_down = TcDown { tc_dflags = dflags, tc_def = [],
109 tc_us = us_var, tc_loc = noSrcLoc,
110 tc_ctxt = [], tc_errs = errs_var }
113 maybe_res <- catch (do { res <- do_this init_down tc_env ;
115 (\_ -> return Nothing) ;
117 (warns,errs) <- readIORef errs_var ;
118 return (maybe_res, (warns, errs))
121 -- Monadic operations
123 returnNF_Tc :: a -> NF_TcM a
124 returnTc :: a -> TcM a
125 returnTc v down env = return v
127 thenTc :: TcM a -> (a -> TcM b) -> TcM b
128 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
129 thenTc m k down env = do { r <- m down env; k r down env }
131 thenTc_ :: TcM a -> TcM b -> TcM b
132 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
133 thenTc_ m k down env = do { m down env; k down env }
135 listTc :: [TcM a] -> TcM [a]
136 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
137 listTc [] = returnTc []
138 listTc (x:xs) = x `thenTc` \ r ->
139 listTc xs `thenTc` \ rs ->
142 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
143 mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
144 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
145 mapTc f [] = returnTc []
146 mapTc f (x:xs) = f x `thenTc` \ r ->
147 mapTc f xs `thenTc` \ rs ->
149 mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
152 foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
153 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
154 foldrTc k z [] = returnTc z
155 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
158 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
159 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
160 foldlTc k z [] = returnTc z
161 foldlTc k z (x:xs) = k z x `thenTc` \r ->
164 mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
165 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
166 mapAndUnzipTc f [] = returnTc ([],[])
167 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
168 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
169 returnTc (r1:rs1, r2:rs2)
171 mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
172 mapAndUnzip3Tc f [] = returnTc ([],[],[])
173 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
174 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
175 returnTc (r1:rs1, r2:rs2, r3:rs3)
177 mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
178 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
180 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
182 returnTc (unionBags r1 r2))
183 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
187 fixTc :: (a -> TcM a) -> TcM a
188 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
189 fixTc m env down = fixIO (\ loop -> m loop env down)
190 {-# NOINLINE fixTc #-}
191 -- aargh! Not inlining fixTc alleviates a space leak problem.
192 -- Normally fixTc is used with a lazy tuple match: if the optimiser is
193 -- shown the definition of fixTc, it occasionally transforms the code
194 -- in such a way that the code generator doesn't spot the selector
197 recoverTc :: TcM r -> TcM r -> TcM r
198 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
199 recoverTc recover m down env
200 = catch (m down env) (\ _ -> recover down env)
202 returnNF_Tc = returnTc
206 recoverNF_Tc = recoverTc
211 mapAndUnzipNF_Tc = mapAndUnzipTc
212 mapBagNF_Tc = mapBagTc
215 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
216 thread. Ideally, this elegantly ensures that it can't zap any type
217 variables that belong to the main thread. But alas, the environment
218 contains TyCon and Class environments that include TcKind stuff,
219 which is a Royal Pain. By the time this fork stuff is used they'll
220 have been unified down so there won't be any kind variables, but we
221 can't express that in the current typechecker framework.
223 So we compromise and use unsafeInterleaveIO.
225 We throw away any error messages!
228 forkNF_Tc :: NF_TcM r -> NF_TcM r
229 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
231 -- Get a fresh unique supply
232 us <- readIORef u_var
233 let (us1, us2) = splitUniqSupply us
236 unsafeInterleaveIO (do {
237 us_var' <- newIORef us2 ;
238 err_var' <- newIORef (emptyBag,emptyBag) ;
239 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
241 -- ToDo: optionally dump any error messages
246 traceTc :: SDoc -> NF_TcM ()
247 traceTc doc (TcDown { tc_dflags=dflags }) env
248 | dopt Opt_D_dump_tc_trace dflags = printDump doc
249 | otherwise = return ()
251 ioToTc :: IO a -> NF_TcM a
252 ioToTc io down env = io
256 %************************************************************************
258 \subsection{Error handling}
260 %************************************************************************
263 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
265 = readIORef (getTcErrs down)
268 failTc down env = give_up
271 give_up = ioError (userError "Typecheck failed")
273 failWithTc :: Message -> TcM a -- Add an error message and fail
274 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
276 addErrTc :: Message -> NF_TcM ()
277 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
279 addErrsTc :: [Message] -> NF_TcM ()
280 addErrsTc [] = returnNF_Tc ()
281 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
283 -- The 'M' variants do the TidyEnv bit
284 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
285 failWithTcM env_and_msg
286 = addErrTcM env_and_msg `thenNF_Tc_`
289 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
290 checkTc True err = returnTc ()
291 checkTc False err = failWithTc err
293 checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
294 checkTcM True err = returnTc ()
295 checkTcM False err = err
297 checkMaybeTc :: Maybe val -> Message -> TcM val
298 checkMaybeTc (Just val) err = returnTc val
299 checkMaybeTc Nothing err = failWithTc err
301 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
302 checkMaybeTcM (Just val) err = returnTc val
303 checkMaybeTcM Nothing err = err
305 addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
306 addErrTcM (tidy_env, err_msg) down env
307 = add_err_tcm tidy_env err_msg ctxt loc down env
309 ctxt = getErrCtxt down
312 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
313 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
314 = add_err_tcm tidy_env err_msg full_ctxt loc down env
316 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
318 add_err_tcm tidy_env err_msg ctxt loc down env
320 (warns, errs) <- readIORef errs_var
321 ctxt_msgs <- do_ctxt tidy_env ctxt down env
322 let err = addShortErrLocLine loc $
323 vcat (err_msg : ctxt_to_use ctxt_msgs)
324 writeIORef errs_var (warns, errs `snocBag` err)
326 errs_var = getTcErrs down
328 do_ctxt tidy_env [] down env
330 do_ctxt tidy_env (c:cs) down env
332 (tidy_env', m) <- c tidy_env down env
333 ms <- do_ctxt tidy_env' cs down env
336 -- warnings don't have an 'M' variant
337 warnTc :: Bool -> Message -> NF_TcM ()
338 warnTc warn_if_true warn_msg down env
341 (warns,errs) <- readIORef errs_var
342 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
343 let warn = addShortWarnLocLine loc $
344 vcat (warn_msg : ctxt_to_use ctxt_msgs)
345 writeIORef errs_var (warns `snocBag` warn, errs)
349 errs_var = getTcErrs down
350 ctxt = getErrCtxt down
353 -- (tryTc r m) succeeds if m succeeds and generates no errors
354 -- If m fails then r is invoked, passing the warnings and errors from m
355 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
356 -- (it might have recovered internally)
357 -- If so, then r is invoked, passing the warnings and errors from m
359 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action
360 -> TcM r -- Thing to try
362 tryTc recover main down env
364 m_errs_var <- newIORef (emptyBag,emptyBag)
365 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
367 errs_var = getTcErrs down
369 my_recover m_errs_var
370 = do warns_and_errs <- readIORef m_errs_var
371 recover warns_and_errs down env
374 = do result <- main (setTcErrs down m_errs_var) env
376 -- Check that m has no errors; if it has internal recovery
377 -- mechanisms it might "succeed" but having found a bunch of
378 -- errors along the way.
379 (m_warns, m_errs) <- readIORef m_errs_var
380 if isEmptyBag m_errs then
381 -- No errors, so return normally, but don't lose the warnings
382 if isEmptyBag m_warns then
385 do (warns, errs) <- readIORef errs_var
386 writeIORef errs_var (warns `unionBags` m_warns, errs)
389 give_up -- This triggers the catch
392 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
393 -- If m fails then (checkNoErrsTc m) fails.
394 -- If m succeeds, it checks whether m generated any errors messages
395 -- (it might have recovered internally)
396 -- If so, it fails too.
397 -- Regardless, any errors generated by m are propagated to the enclosing context.
398 checkNoErrsTc :: TcM r -> TcM r
400 = tryTc my_recover main
402 my_recover (m_warns, m_errs) down env
403 = do (warns, errs) <- readIORef errs_var
404 writeIORef errs_var (warns `unionBags` m_warns,
405 errs `unionBags` m_errs)
408 errs_var = getTcErrs down
411 -- (tryTc_ r m) tries m; if it succeeds it returns it,
412 -- otherwise it returns r. Any error messages added by m are discarded,
413 -- whether or not m succeeds.
414 tryTc_ :: TcM r -> TcM r -> TcM r
416 = tryTc my_recover main
418 my_recover warns_and_errs = recover
420 -- (discardErrsTc m) runs m, but throw away all its error messages.
421 discardErrsTc :: Either_TcM r -> Either_TcM r
422 discardErrsTc main down env
423 = do new_errs_var <- newIORef (emptyBag,emptyBag)
424 main (setTcErrs down new_errs_var) env
429 %************************************************************************
431 \subsection{Mutable variables}
433 %************************************************************************
436 tcNewMutVar :: a -> NF_TcM (TcRef a)
437 tcNewMutVar val down env = newIORef val
439 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
440 tcWriteMutVar var val down env = writeIORef var val
442 tcReadMutVar :: TcRef a -> NF_TcM a
443 tcReadMutVar var down env = readIORef var
445 tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar
446 tcNewMutTyVar name kind details down env = newMutTyVar name kind details
448 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
449 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
451 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
452 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
456 %************************************************************************
458 \subsection{The environment}
460 %************************************************************************
463 tcGetEnv :: NF_TcM TcEnv
464 tcGetEnv down env = return env
466 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
467 tcSetEnv new_env m down old_env = m down new_env
471 %************************************************************************
473 \subsection{Source location}
475 %************************************************************************
478 tcGetDefaultTys :: NF_TcM [Type]
479 tcGetDefaultTys down env = return (getDefaultTys down)
481 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
482 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
484 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
485 tcAddSrcLoc loc m down env = m (setLoc down loc) env
487 tcGetSrcLoc :: NF_TcM SrcLoc
488 tcGetSrcLoc down env = return (getLoc down)
490 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
491 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
493 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
495 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
496 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
498 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
500 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
501 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
503 tcPopErrCtxt :: Either_TcM r -> Either_TcM r
504 tcPopErrCtxt m down env = m (popErrCtxt down) env
508 %************************************************************************
510 \subsection{Unique supply}
512 %************************************************************************
515 tcGetUnique :: NF_TcM Unique
517 = do uniq_supply <- readIORef u_var
518 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
519 uniq = uniqFromSupply uniq_s
520 writeIORef u_var new_uniq_supply
523 u_var = getUniqSupplyVar down
525 tcGetUniques :: NF_TcM [Unique]
526 tcGetUniques down env
527 = do uniq_supply <- readIORef u_var
528 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
529 uniqs = uniqsFromSupply uniq_s
530 writeIORef u_var new_uniq_supply
533 u_var = getUniqSupplyVar down
535 uniqSMToTcM :: UniqSM a -> NF_TcM a
536 uniqSMToTcM m down env
537 = do uniq_supply <- readIORef u_var
538 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
539 writeIORef u_var new_uniq_supply
540 return (initUs_ uniq_s m)
542 u_var = getUniqSupplyVar down
547 %************************************************************************
551 %************************************************************************
556 tc_dflags :: DynFlags,
557 tc_def :: [Type], -- Types used for defaulting
558 tc_us :: (TcRef UniqSupply), -- Unique supply
559 tc_loc :: SrcLoc, -- Source location
560 tc_ctxt :: ErrCtxt, -- Error context
561 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
564 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
565 -- Innermost first. Monadic so that we have a chance
566 -- to deal with bound type variables just before error
567 -- message construction
570 -- These selectors are *local* to TcMonad.lhs
573 getTcErrs (TcDown{tc_errs=errs}) = errs
574 setTcErrs down errs = down{tc_errs=errs}
576 getDefaultTys (TcDown{tc_def=def}) = def
577 setDefaultTys down def = down{tc_def=def}
579 getLoc (TcDown{tc_loc=loc}) = loc
580 setLoc down loc = down{tc_loc=loc}
582 getUniqSupplyVar (TcDown{tc_us=us}) = us
584 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
585 setErrCtxt down msg = down{tc_ctxt=[msg]}
586 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
588 popErrCtxt down = case tc_ctxt down of
590 m : ms -> down{tc_ctxt = ms}
592 doptsTc :: DynFlag -> TcM Bool
593 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
594 = return (dopt dflag dflags)
596 getDOptsTc :: TcM DynFlags
597 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
604 %************************************************************************
606 \subsection{TypeChecking Errors}
608 %************************************************************************
611 type TcError = Message
612 type TcWarning = Message
614 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
615 | otherwise = take 3 ctxt
617 arityErr kind name n m
618 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
619 n_arguments <> comma, text "but has been given", int m]
621 n_arguments | n == 0 = ptext SLIT("no arguments")
622 | n == 1 = ptext SLIT("1 argument")
623 | True = hsep [int n, ptext SLIT("arguments")]
628 %************************************************************************
630 \subsection[Inst-origin]{The @InstOrigin@ type}
632 %************************************************************************
634 The @InstOrigin@ type gives information about where a dictionary came from.
635 This is important for decent error message reporting because dictionaries
636 don't appear in the original source code. Doubtless this type will evolve...
638 It appears in TcMonad because there are a couple of error-message-generation
639 functions that deal with it.
642 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
645 = OccurrenceOf Id -- Occurrence of an overloaded identifier
647 | IPOcc Name -- Occurrence of an implicit parameter
648 | IPBind Name -- Binding site of an implicit parameter
652 | DataDeclOrigin -- Typechecking a data declaration
654 | InstanceDeclOrigin -- Typechecking an instance decl
656 | LiteralOrigin HsOverLit -- Occurrence of a literal
658 | PatOrigin RenamedPat
660 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
662 | SignatureOrigin -- A dict created from a type signature
663 | Rank2Origin -- A dict created when typechecking the argument
664 -- of a rank-2 typed function
666 | DoOrigin -- The monad for a do expression
668 | ClassDeclOrigin -- Manufactured during a class decl
670 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
673 -- When specialising instances the instance info attached to
674 -- each class is not yet ready, so we record it inside the
675 -- origin information. This is a bit of a hack, but it works
676 -- fine. (Patrick is to blame [WDP].)
678 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
680 -- Argument or result of a ccall
681 -- Dictionaries with this origin aren't actually mentioned in the
682 -- translated term, and so need not be bound. Nor should they
683 -- be abstracted over.
685 | CCallOrigin String -- CCall label
686 (Maybe RenamedHsExpr) -- Nothing if it's the result
687 -- Just arg, for an argument
689 | LitLitOrigin String -- the litlit
691 | UnknownOrigin -- Help! I give up...
695 pprInstLoc :: InstLoc -> SDoc
696 pprInstLoc (orig, locn, ctxt)
697 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
699 pp_orig (OccurrenceOf id)
700 = hsep [ptext SLIT("use of"), quotes (ppr id)]
702 = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
703 pp_orig (IPBind name)
704 = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
705 pp_orig RecordUpdOrigin
706 = ptext SLIT("a record update")
707 pp_orig DataDeclOrigin
708 = ptext SLIT("the data type declaration")
709 pp_orig InstanceDeclOrigin
710 = ptext SLIT("the instance declaration")
711 pp_orig (LiteralOrigin lit)
712 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
713 pp_orig (PatOrigin pat)
714 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
715 pp_orig (ArithSeqOrigin seq)
716 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
717 pp_orig (SignatureOrigin)
718 = ptext SLIT("a type signature")
719 pp_orig (Rank2Origin)
720 = ptext SLIT("a function with an overloaded argument type")
722 = ptext SLIT("a do statement")
723 pp_orig (ClassDeclOrigin)
724 = ptext SLIT("a class declaration")
725 pp_orig (InstanceSpecOrigin clas ty)
726 = hsep [text "a SPECIALIZE instance pragma; class",
727 quotes (ppr clas), text "type:", ppr ty]
728 pp_orig (ValSpecOrigin name)
729 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
730 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
731 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
732 pp_orig (CCallOrigin clabel (Just arg_expr))
733 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
734 text "namely", quotes (ppr arg_expr)]
735 pp_orig (LitLitOrigin s)
736 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
737 pp_orig (UnknownOrigin)
738 = ptext SLIT("...oops -- I don't know where the overloading came from!")