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, 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 UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
57 splitUniqSupply, mkSplitUniqSupply,
59 import SrcLoc ( SrcLoc, noSrcLoc )
60 import BasicTypes ( IPName )
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 TcDown{tc_loc=loc, tc_ctxt=ctxt} env
492 = return (origin, loc, ctxt)
494 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
496 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
497 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
499 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
501 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
502 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
504 tcPopErrCtxt :: Either_TcM r -> Either_TcM r
505 tcPopErrCtxt m down env = m (popErrCtxt down) env
509 %************************************************************************
511 \subsection{Unique supply}
513 %************************************************************************
516 tcGetUnique :: NF_TcM Unique
518 = do uniq_supply <- readIORef u_var
519 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
520 uniq = uniqFromSupply uniq_s
521 writeIORef u_var new_uniq_supply
524 u_var = getUniqSupplyVar down
526 tcGetUniques :: NF_TcM [Unique]
527 tcGetUniques down env
528 = do uniq_supply <- readIORef u_var
529 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
530 uniqs = uniqsFromSupply uniq_s
531 writeIORef u_var new_uniq_supply
534 u_var = getUniqSupplyVar down
536 uniqSMToTcM :: UniqSM a -> NF_TcM a
537 uniqSMToTcM m down env
538 = do uniq_supply <- readIORef u_var
539 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
540 writeIORef u_var new_uniq_supply
541 return (initUs_ uniq_s m)
543 u_var = getUniqSupplyVar down
548 %************************************************************************
552 %************************************************************************
557 tc_dflags :: DynFlags,
558 tc_def :: [Type], -- Types used for defaulting
559 tc_us :: (TcRef UniqSupply), -- Unique supply
560 tc_loc :: SrcLoc, -- Source location
561 tc_ctxt :: ErrCtxt, -- Error context
562 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
565 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
566 -- Innermost first. Monadic so that we have a chance
567 -- to deal with bound type variables just before error
568 -- message construction
571 -- These selectors are *local* to TcMonad.lhs
574 getTcErrs (TcDown{tc_errs=errs}) = errs
575 setTcErrs down errs = down{tc_errs=errs}
577 getDefaultTys (TcDown{tc_def=def}) = def
578 setDefaultTys down def = down{tc_def=def}
580 getLoc (TcDown{tc_loc=loc}) = loc
581 setLoc down loc = down{tc_loc=loc}
583 getUniqSupplyVar (TcDown{tc_us=us}) = us
585 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
586 setErrCtxt down msg = down{tc_ctxt=[msg]}
587 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
589 popErrCtxt down = case tc_ctxt down of
591 m : ms -> down{tc_ctxt = ms}
593 doptsTc :: DynFlag -> NF_TcM Bool
594 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
595 = return (dopt dflag dflags)
597 getDOptsTc :: NF_TcM DynFlags
598 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
605 %************************************************************************
607 \subsection{TypeChecking Errors}
609 %************************************************************************
612 type TcError = Message
613 type TcWarning = Message
615 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
616 | otherwise = take 3 ctxt
618 arityErr kind name n m
619 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
620 n_arguments <> comma, text "but has been given", int m]
622 n_arguments | n == 0 = ptext SLIT("no arguments")
623 | n == 1 = ptext SLIT("1 argument")
624 | True = hsep [int n, ptext SLIT("arguments")]
629 %************************************************************************
631 \subsection[Inst-origin]{The @InstOrigin@ type}
633 %************************************************************************
635 The @InstOrigin@ type gives information about where a dictionary came from.
636 This is important for decent error message reporting because dictionaries
637 don't appear in the original source code. Doubtless this type will evolve...
639 It appears in TcMonad because there are a couple of error-message-generation
640 functions that deal with it.
643 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
646 = OccurrenceOf Id -- Occurrence of an overloaded identifier
648 | IPOcc (IPName Name) -- Occurrence of an implicit parameter
649 | IPBind (IPName Name) -- Binding site of an implicit parameter
653 | DataDeclOrigin -- Typechecking a data declaration
655 | InstanceDeclOrigin -- Typechecking an instance decl
657 | LiteralOrigin HsOverLit -- Occurrence of a literal
659 | PatOrigin RenamedPat
661 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
663 | SignatureOrigin -- A dict created from a type signature
664 | Rank2Origin -- A dict created when typechecking the argument
665 -- of a rank-2 typed function
667 | DoOrigin -- The monad for a do expression
669 | ClassDeclOrigin -- Manufactured during a class decl
671 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
674 -- When specialising instances the instance info attached to
675 -- each class is not yet ready, so we record it inside the
676 -- origin information. This is a bit of a hack, but it works
677 -- fine. (Patrick is to blame [WDP].)
679 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
681 -- Argument or result of a ccall
682 -- Dictionaries with this origin aren't actually mentioned in the
683 -- translated term, and so need not be bound. Nor should they
684 -- be abstracted over.
686 | CCallOrigin String -- CCall label
687 (Maybe RenamedHsExpr) -- Nothing if it's the result
688 -- Just arg, for an argument
690 | LitLitOrigin String -- the litlit
692 | UnknownOrigin -- Help! I give up...
696 pprInstLoc :: InstLoc -> SDoc
697 pprInstLoc (orig, locn, ctxt)
698 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
700 pp_orig (OccurrenceOf id)
701 = hsep [ptext SLIT("use of"), quotes (ppr id)]
703 = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
704 pp_orig (IPBind name)
705 = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
706 pp_orig RecordUpdOrigin
707 = ptext SLIT("a record update")
708 pp_orig DataDeclOrigin
709 = ptext SLIT("the data type declaration")
710 pp_orig InstanceDeclOrigin
711 = ptext SLIT("the instance declaration")
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 (ArithSeqOrigin seq)
717 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
718 pp_orig (SignatureOrigin)
719 = ptext SLIT("a type signature")
720 pp_orig (Rank2Origin)
721 = ptext SLIT("a function with an overloaded argument type")
723 = ptext SLIT("a do statement")
724 pp_orig (ClassDeclOrigin)
725 = ptext SLIT("a class declaration")
726 pp_orig (InstanceSpecOrigin clas ty)
727 = hsep [text "a SPECIALIZE instance pragma; class",
728 quotes (ppr clas), text "type:", ppr ty]
729 pp_orig (ValSpecOrigin name)
730 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
731 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
732 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
733 pp_orig (CCallOrigin clabel (Just arg_expr))
734 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
735 text "namely", quotes (ppr arg_expr)]
736 pp_orig (LitLitOrigin s)
737 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
738 pp_orig (UnknownOrigin)
739 = ptext SLIT("...oops -- I don't know where the overloading came from!")