4 TcTauType, TcPredType, TcThetaType, TcRhoType,
5 TcTyVar, TcTyVarSet, TcClassContext,
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 HsSyn ( HsOverLit )
51 import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
52 import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
54 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
56 import Bag ( Bag, emptyBag, isEmptyBag,
57 foldBag, unitBag, unionBags, snocBag )
58 import Class ( Class, ClassContext )
60 import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
61 import VarEnv ( TidyEnv, emptyTidyEnv )
62 import VarSet ( TyVarSet )
63 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
64 splitUniqSupply, mkSplitUniqSupply,
66 import SrcLoc ( SrcLoc, noSrcLoc )
67 import UniqFM ( emptyUFM )
68 import Unique ( Unique )
72 import IOExts ( IORef, newIORef, readIORef, writeIORef,
73 unsafeInterleaveIO, fixIO
77 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
81 %************************************************************************
85 %************************************************************************
88 type TcTyVar = TyVar -- Might be a mutable tyvar
89 type TcTyVarSet = TyVarSet
91 type TcType = Type -- A TcType can have mutable type variables
92 -- Invariant on ForAllTy in TcTypes:
94 -- a cannot occur inside a MutTyVar in T; that is,
95 -- T is "flattened" before quantifying over a
97 type TcClassContext = ClassContext
98 type TcPredType = PredType
99 type TcThetaType = ThetaType
100 type TcRhoType = RhoType
101 type TcTauType = TauType
106 %************************************************************************
108 \subsection{The main monads: TcM, NF_TcM}
110 %************************************************************************
113 type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
114 type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
116 type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
117 -- Used only in this file for type signatures which
118 -- have a part that's polymorphic in whether it's NF_TcM or TcM
121 type TcRef a = IORef a
129 -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
131 initTc dflags tc_env do_this
133 us <- mkSplitUniqSupply 'a' ;
134 us_var <- newIORef us ;
135 errs_var <- newIORef (emptyBag,emptyBag) ;
136 tvs_var <- newIORef emptyUFM ;
139 init_down = TcDown { tc_dflags = dflags, tc_def = [],
140 tc_us = us_var, tc_loc = noSrcLoc,
141 tc_ctxt = [], tc_errs = errs_var }
144 maybe_res <- catch (do { res <- do_this init_down tc_env ;
146 (\_ -> return Nothing) ;
148 (warns,errs) <- readIORef errs_var ;
149 return (maybe_res, (warns, errs))
152 -- Monadic operations
154 returnNF_Tc :: a -> NF_TcM a
155 returnTc :: a -> TcM a
156 returnTc v down env = return v
158 thenTc :: TcM a -> (a -> TcM b) -> TcM b
159 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
160 thenTc m k down env = do { r <- m down env; k r down env }
162 thenTc_ :: TcM a -> TcM b -> TcM b
163 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
164 thenTc_ m k down env = do { m down env; k down env }
166 listTc :: [TcM a] -> TcM [a]
167 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
168 listTc [] = returnTc []
169 listTc (x:xs) = x `thenTc` \ r ->
170 listTc xs `thenTc` \ rs ->
173 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
174 mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
175 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
176 mapTc f [] = returnTc []
177 mapTc f (x:xs) = f x `thenTc` \ r ->
178 mapTc f xs `thenTc` \ rs ->
180 mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
183 foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
184 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
185 foldrTc k z [] = returnTc z
186 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
189 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
190 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
191 foldlTc k z [] = returnTc z
192 foldlTc k z (x:xs) = k z x `thenTc` \r ->
195 mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
196 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
197 mapAndUnzipTc f [] = returnTc ([],[])
198 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
199 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
200 returnTc (r1:rs1, r2:rs2)
202 mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
203 mapAndUnzip3Tc f [] = returnTc ([],[],[])
204 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
205 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
206 returnTc (r1:rs1, r2:rs2, r3:rs3)
208 mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
209 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
211 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
213 returnTc (unionBags r1 r2))
214 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
218 fixTc :: (a -> TcM a) -> TcM a
219 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
220 fixTc m env down = fixIO (\ loop -> m loop env down)
222 recoverTc :: TcM r -> TcM r -> TcM r
223 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
224 recoverTc recover m down env
225 = catch (m down env) (\ _ -> recover down env)
227 returnNF_Tc = returnTc
231 recoverNF_Tc = recoverTc
236 mapAndUnzipNF_Tc = mapAndUnzipTc
237 mapBagNF_Tc = mapBagTc
240 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
241 thread. Ideally, this elegantly ensures that it can't zap any type
242 variables that belong to the main thread. But alas, the environment
243 contains TyCon and Class environments that include TcKind stuff,
244 which is a Royal Pain. By the time this fork stuff is used they'll
245 have been unified down so there won't be any kind variables, but we
246 can't express that in the current typechecker framework.
248 So we compromise and use unsafeInterleaveIO.
250 We throw away any error messages!
253 forkNF_Tc :: NF_TcM r -> NF_TcM r
254 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
256 -- Get a fresh unique supply
257 us <- readIORef u_var
258 let (us1, us2) = splitUniqSupply us
261 unsafeInterleaveIO (do {
262 us_var' <- newIORef us2 ;
263 err_var' <- newIORef (emptyBag,emptyBag) ;
264 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
266 -- ToDo: optionally dump any error messages
271 traceTc :: SDoc -> NF_TcM ()
272 traceTc doc (TcDown { tc_dflags=dflags }) env
273 | dopt Opt_D_dump_tc_trace dflags = printDump doc
274 | otherwise = return ()
276 ioToTc :: IO a -> NF_TcM a
277 ioToTc io down env = io
281 %************************************************************************
283 \subsection{Error handling}
285 %************************************************************************
288 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
290 = readIORef (getTcErrs down)
293 failTc down env = give_up
296 give_up = IOERROR (userError "Typecheck failed")
298 failWithTc :: Message -> TcM a -- Add an error message and fail
299 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
301 addErrTc :: Message -> NF_TcM ()
302 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
304 addErrsTc :: [Message] -> NF_TcM ()
305 addErrsTc [] = returnNF_Tc ()
306 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
308 -- The 'M' variants do the TidyEnv bit
309 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
310 failWithTcM env_and_msg
311 = addErrTcM env_and_msg `thenNF_Tc_`
314 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
315 checkTc True err = returnTc ()
316 checkTc False err = failWithTc err
318 checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
319 checkTcM True err = returnTc ()
320 checkTcM False err = err
322 checkMaybeTc :: Maybe val -> Message -> TcM val
323 checkMaybeTc (Just val) err = returnTc val
324 checkMaybeTc Nothing err = failWithTc err
326 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
327 checkMaybeTcM (Just val) err = returnTc val
328 checkMaybeTcM Nothing err = err
330 addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
331 addErrTcM (tidy_env, err_msg) down env
332 = add_err_tcm tidy_env err_msg ctxt loc down env
334 ctxt = getErrCtxt down
337 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
338 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
339 = add_err_tcm tidy_env err_msg full_ctxt loc down env
341 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
343 add_err_tcm tidy_env err_msg ctxt loc down env
345 (warns, errs) <- readIORef errs_var
346 ctxt_msgs <- do_ctxt tidy_env ctxt down env
347 let err = addShortErrLocLine loc $
348 vcat (err_msg : ctxt_to_use ctxt_msgs)
349 writeIORef errs_var (warns, errs `snocBag` err)
351 errs_var = getTcErrs down
353 do_ctxt tidy_env [] down env
355 do_ctxt tidy_env (c:cs) down env
357 (tidy_env', m) <- c tidy_env down env
358 ms <- do_ctxt tidy_env' cs down env
361 -- warnings don't have an 'M' variant
362 warnTc :: Bool -> Message -> NF_TcM ()
363 warnTc warn_if_true warn_msg down env
366 (warns,errs) <- readIORef errs_var
367 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
368 let warn = addShortWarnLocLine loc $
369 vcat (warn_msg : ctxt_to_use ctxt_msgs)
370 writeIORef errs_var (warns `snocBag` warn, errs)
374 errs_var = getTcErrs down
375 ctxt = getErrCtxt down
378 -- (tryTc r m) succeeds if m succeeds and generates no errors
379 -- If m fails then r is invoked, passing the warnings and errors from m
380 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
381 -- (it might have recovered internally)
382 -- If so, then r is invoked, passing the warnings and errors from m
384 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action
385 -> TcM r -- Thing to try
387 tryTc recover main down env
389 m_errs_var <- newIORef (emptyBag,emptyBag)
390 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
392 my_recover m_errs_var
393 = do warns_and_errs <- readIORef m_errs_var
394 recover warns_and_errs down env
397 = do result <- main (setTcErrs down m_errs_var) env
399 -- Check that m has no errors; if it has internal recovery
400 -- mechanisms it might "succeed" but having found a bunch of
401 -- errors along the way.
402 (m_warns, m_errs) <- readIORef m_errs_var
403 if isEmptyBag m_errs then
406 give_up -- This triggers the catch
409 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
410 -- If m fails then (checkNoErrsTc m) fails.
411 -- If m succeeds, it checks whether m generated any errors messages
412 -- (it might have recovered internally)
413 -- If so, it fails too.
414 -- Regardless, any errors generated by m are propagated to the enclosing context.
415 checkNoErrsTc :: TcM r -> TcM r
417 = tryTc my_recover main
419 my_recover (m_warns, m_errs) down env
420 = do (warns, errs) <- readIORef errs_var
421 writeIORef errs_var (warns `unionBags` m_warns,
422 errs `unionBags` m_errs)
425 errs_var = getTcErrs down
428 -- (tryTc_ r m) tries m; if it succeeds it returns it,
429 -- otherwise it returns r. Any error messages added by m are discarded,
430 -- whether or not m succeeds.
431 tryTc_ :: TcM r -> TcM r -> TcM r
433 = tryTc my_recover main
435 my_recover warns_and_errs = recover
437 -- (discardErrsTc m) runs m, but throw away all its error messages.
438 discardErrsTc :: Either_TcM r -> Either_TcM r
439 discardErrsTc main down env
440 = do new_errs_var <- newIORef (emptyBag,emptyBag)
441 main (setTcErrs down new_errs_var) env
446 %************************************************************************
448 \subsection{Mutable variables}
450 %************************************************************************
453 tcNewMutVar :: a -> NF_TcM (TcRef a)
454 tcNewMutVar val down env = newIORef val
456 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
457 tcWriteMutVar var val down env = writeIORef var val
459 tcReadMutVar :: TcRef a -> NF_TcM a
460 tcReadMutVar var down env = readIORef var
462 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
463 tcNewMutTyVar name kind down env = newMutTyVar name kind
465 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
466 tcNewSigTyVar name kind down env = newSigTyVar name kind
468 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
469 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
471 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
472 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
476 %************************************************************************
478 \subsection{The environment}
480 %************************************************************************
483 tcGetEnv :: NF_TcM TcEnv
484 tcGetEnv down env = return env
486 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
487 tcSetEnv new_env m down old_env = m down new_env
491 %************************************************************************
493 \subsection{Source location}
495 %************************************************************************
498 tcGetDefaultTys :: NF_TcM [Type]
499 tcGetDefaultTys down env = return (getDefaultTys down)
501 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
502 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
504 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
505 tcAddSrcLoc loc m down env = m (setLoc down loc) env
507 tcGetSrcLoc :: NF_TcM SrcLoc
508 tcGetSrcLoc down env = return (getLoc down)
510 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
511 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
513 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
515 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
516 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
518 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
520 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
521 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
525 %************************************************************************
527 \subsection{Unique supply}
529 %************************************************************************
532 tcGetUnique :: NF_TcM Unique
534 = do uniq_supply <- readIORef u_var
535 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
536 uniq = uniqFromSupply uniq_s
537 writeIORef u_var new_uniq_supply
540 u_var = getUniqSupplyVar down
542 tcGetUniques :: Int -> NF_TcM [Unique]
543 tcGetUniques n down env
544 = do uniq_supply <- readIORef u_var
545 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
546 uniqs = uniqsFromSupply n uniq_s
547 writeIORef u_var new_uniq_supply
550 u_var = getUniqSupplyVar down
552 uniqSMToTcM :: UniqSM a -> NF_TcM a
553 uniqSMToTcM m down env
554 = do uniq_supply <- readIORef u_var
555 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
556 writeIORef u_var new_uniq_supply
557 return (initUs_ uniq_s m)
559 u_var = getUniqSupplyVar down
564 %************************************************************************
568 %************************************************************************
573 tc_dflags :: DynFlags,
574 tc_def :: [Type], -- Types used for defaulting
575 tc_us :: (TcRef UniqSupply), -- Unique supply
576 tc_loc :: SrcLoc, -- Source location
577 tc_ctxt :: ErrCtxt, -- Error context
578 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
581 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
582 -- Innermost first. Monadic so that we have a chance
583 -- to deal with bound type variables just before error
584 -- message construction
587 -- These selectors are *local* to TcMonad.lhs
590 getTcErrs (TcDown{tc_errs=errs}) = errs
591 setTcErrs down errs = down{tc_errs=errs}
593 getDefaultTys (TcDown{tc_def=def}) = def
594 setDefaultTys down def = down{tc_def=def}
596 getLoc (TcDown{tc_loc=loc}) = loc
597 setLoc down loc = down{tc_loc=loc}
599 getUniqSupplyVar (TcDown{tc_us=us}) = us
601 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
602 setErrCtxt down msg = down{tc_ctxt=[msg]}
603 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
605 doptsTc :: DynFlag -> TcM Bool
606 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
607 = return (dopt dflag dflags)
609 getDOptsTc :: TcM DynFlags
610 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
617 %************************************************************************
619 \subsection{TypeChecking Errors}
621 %************************************************************************
624 type TcError = Message
625 type TcWarning = Message
627 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
628 | otherwise = takeAtMost 3 ctxt
630 takeAtMost :: Int -> [a] -> [a]
633 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
635 arityErr kind name n m
636 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
637 n_arguments <> comma, text "but has been given", int m]
639 n_arguments | n == 0 = ptext SLIT("no arguments")
640 | n == 1 = ptext SLIT("1 argument")
641 | True = hsep [int n, ptext SLIT("arguments")]
646 %************************************************************************
648 \subsection[Inst-origin]{The @InstOrigin@ type}
650 %************************************************************************
652 The @InstOrigin@ type gives information about where a dictionary came from.
653 This is important for decent error message reporting because dictionaries
654 don't appear in the original source code. Doubtless this type will evolve...
656 It appears in TcMonad because there are a couple of error-message-generation
657 functions that deal with it.
660 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
663 = OccurrenceOf Id -- Occurrence of an overloaded identifier
665 | IPOcc Name -- Occurrence of an implicit parameter
666 | IPBind Name -- Binding site of an implicit parameter
670 | DataDeclOrigin -- Typechecking a data declaration
672 | InstanceDeclOrigin -- Typechecking an instance decl
674 | LiteralOrigin HsOverLit -- Occurrence of a literal
676 | PatOrigin RenamedPat
678 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
680 | SignatureOrigin -- A dict created from a type signature
681 | Rank2Origin -- A dict created when typechecking the argument
682 -- of a rank-2 typed function
684 | DoOrigin -- The monad for a do expression
686 | ClassDeclOrigin -- Manufactured during a class decl
688 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
691 -- When specialising instances the instance info attached to
692 -- each class is not yet ready, so we record it inside the
693 -- origin information. This is a bit of a hack, but it works
694 -- fine. (Patrick is to blame [WDP].)
696 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
698 -- Argument or result of a ccall
699 -- Dictionaries with this origin aren't actually mentioned in the
700 -- translated term, and so need not be bound. Nor should they
701 -- be abstracted over.
703 | CCallOrigin String -- CCall label
704 (Maybe RenamedHsExpr) -- Nothing if it's the result
705 -- Just arg, for an argument
707 | LitLitOrigin String -- the litlit
709 | UnknownOrigin -- Help! I give up...
713 pprInstLoc :: InstLoc -> SDoc
714 pprInstLoc (orig, locn, ctxt)
715 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
717 pp_orig (OccurrenceOf id)
718 = hsep [ptext SLIT("use of"), quotes (ppr id)]
720 = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
721 pp_orig (IPBind name)
722 = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
723 pp_orig (LiteralOrigin lit)
724 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
725 pp_orig (PatOrigin pat)
726 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
727 pp_orig (InstanceDeclOrigin)
728 = ptext SLIT("an instance declaration")
729 pp_orig (ArithSeqOrigin seq)
730 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
731 pp_orig (SignatureOrigin)
732 = ptext SLIT("a type signature")
733 pp_orig (Rank2Origin)
734 = ptext SLIT("a function with an overloaded argument type")
736 = ptext SLIT("a do statement")
737 pp_orig (ClassDeclOrigin)
738 = ptext SLIT("a class declaration")
739 pp_orig (InstanceSpecOrigin clas ty)
740 = hsep [text "a SPECIALIZE instance pragma; class",
741 quotes (ppr clas), text "type:", ppr ty]
742 pp_orig (ValSpecOrigin name)
743 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
744 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
745 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
746 pp_orig (CCallOrigin clabel (Just arg_expr))
747 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
748 text "namely", quotes (ppr arg_expr)]
749 pp_orig (LitLitOrigin s)
750 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
751 pp_orig (UnknownOrigin)
752 = ptext SLIT("...oops -- I don't know where the overloading came from!")