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, ifErrsTc, 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 ( 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 ifErrsTc :: TcM r -> TcM r -> TcM r
412 -- ifErrsTc bale_out main
413 -- does 'bale_out' if there are errors in errors collection
414 -- and does 'main' otherwise
415 -- Useful to avoid error cascades
417 ifErrsTc bale_out main
418 = getErrsTc `thenNF_Tc` \ (warns, errs) ->
419 if isEmptyBag errs then
424 -- (tryTc_ r m) tries m; if it succeeds it returns it,
425 -- otherwise it returns r. Any error messages added by m are discarded,
426 -- whether or not m succeeds.
427 tryTc_ :: TcM r -> TcM r -> TcM r
429 = tryTc my_recover main
431 my_recover warns_and_errs = recover
433 -- (discardErrsTc m) runs m, but throw away all its error messages.
434 discardErrsTc :: Either_TcM r -> Either_TcM r
435 discardErrsTc main down env
436 = do new_errs_var <- newIORef (emptyBag,emptyBag)
437 main (setTcErrs down new_errs_var) env
442 %************************************************************************
444 \subsection{Mutable variables}
446 %************************************************************************
449 tcNewMutVar :: a -> NF_TcM (TcRef a)
450 tcNewMutVar val down env = newIORef val
452 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
453 tcWriteMutVar var val down env = writeIORef var val
455 tcReadMutVar :: TcRef a -> NF_TcM a
456 tcReadMutVar var down env = readIORef var
458 tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar
459 tcNewMutTyVar name kind details down env = newMutTyVar name kind details
461 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
462 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
464 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
465 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
469 %************************************************************************
471 \subsection{The environment}
473 %************************************************************************
476 tcGetEnv :: NF_TcM TcEnv
477 tcGetEnv down env = return env
479 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
480 tcSetEnv new_env m down old_env = m down new_env
484 %************************************************************************
486 \subsection{Source location}
488 %************************************************************************
491 tcGetDefaultTys :: NF_TcM [Type]
492 tcGetDefaultTys down env = return (getDefaultTys down)
494 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
495 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
497 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
498 tcAddSrcLoc loc m down env = m (setLoc down loc) env
500 tcGetSrcLoc :: NF_TcM SrcLoc
501 tcGetSrcLoc down env = return (getLoc down)
503 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
504 tcGetInstLoc origin TcDown{tc_loc=loc, tc_ctxt=ctxt} env
505 = return (origin, loc, ctxt)
507 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
509 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
510 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
512 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
514 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
515 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
517 tcPopErrCtxt :: Either_TcM r -> Either_TcM r
518 tcPopErrCtxt m down env = m (popErrCtxt down) env
522 %************************************************************************
524 \subsection{Unique supply}
526 %************************************************************************
529 tcGetUnique :: NF_TcM Unique
531 = do uniq_supply <- readIORef u_var
532 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
533 uniq = uniqFromSupply uniq_s
534 writeIORef u_var new_uniq_supply
537 u_var = getUniqSupplyVar down
539 tcGetUniques :: NF_TcM [Unique]
540 tcGetUniques down env
541 = do uniq_supply <- readIORef u_var
542 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
543 uniqs = uniqsFromSupply uniq_s
544 writeIORef u_var new_uniq_supply
547 u_var = getUniqSupplyVar down
549 uniqSMToTcM :: UniqSM a -> NF_TcM a
550 uniqSMToTcM m down env
551 = do uniq_supply <- readIORef u_var
552 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
553 writeIORef u_var new_uniq_supply
554 return (initUs_ uniq_s m)
556 u_var = getUniqSupplyVar down
561 %************************************************************************
565 %************************************************************************
570 tc_dflags :: DynFlags,
571 tc_def :: [Type], -- Types used for defaulting
572 tc_us :: (TcRef UniqSupply), -- Unique supply
573 tc_loc :: SrcLoc, -- Source location
574 tc_ctxt :: ErrCtxt, -- Error context
575 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
578 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
579 -- Innermost first. Monadic so that we have a chance
580 -- to deal with bound type variables just before error
581 -- message construction
584 -- These selectors are *local* to TcMonad.lhs
587 getTcErrs (TcDown{tc_errs=errs}) = errs
588 setTcErrs down errs = down{tc_errs=errs}
590 getDefaultTys (TcDown{tc_def=def}) = def
591 setDefaultTys down def = down{tc_def=def}
593 getLoc (TcDown{tc_loc=loc}) = loc
594 setLoc down loc = down{tc_loc=loc}
596 getUniqSupplyVar (TcDown{tc_us=us}) = us
598 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
599 setErrCtxt down msg = down{tc_ctxt=[msg]}
600 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
602 popErrCtxt down = case tc_ctxt down of
604 m : ms -> down{tc_ctxt = ms}
606 doptsTc :: DynFlag -> NF_TcM Bool
607 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
608 = return (dopt dflag dflags)
610 getDOptsTc :: NF_TcM DynFlags
611 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
618 %************************************************************************
620 \subsection{TypeChecking Errors}
622 %************************************************************************
625 type TcError = Message
626 type TcWarning = Message
628 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
629 | otherwise = take 3 ctxt
631 arityErr kind name n m
632 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
633 n_arguments <> comma, text "but has been given", int m]
635 n_arguments | n == 0 = ptext SLIT("no arguments")
636 | n == 1 = ptext SLIT("1 argument")
637 | True = hsep [int n, ptext SLIT("arguments")]
642 %************************************************************************
644 \subsection[Inst-origin]{The @InstOrigin@ type}
646 %************************************************************************
648 The @InstOrigin@ type gives information about where a dictionary came from.
649 This is important for decent error message reporting because dictionaries
650 don't appear in the original source code. Doubtless this type will evolve...
652 It appears in TcMonad because there are a couple of error-message-generation
653 functions that deal with it.
656 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
659 = OccurrenceOf Name -- Occurrence of an overloaded identifier
661 | IPOcc (IPName Name) -- Occurrence of an implicit parameter
662 | IPBind (IPName Name) -- Binding site of an implicit parameter
666 | DataDeclOrigin -- Typechecking a data declaration
668 | InstanceDeclOrigin -- Typechecking an instance decl
670 | LiteralOrigin HsOverLit -- Occurrence of a literal
672 | PatOrigin RenamedPat
674 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
675 | PArrSeqOrigin RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:]
677 | SignatureOrigin -- A dict created from a type signature
678 | Rank2Origin -- A dict created when typechecking the argument
679 -- of a rank-2 typed function
681 | DoOrigin -- The monad for a do expression
683 | ClassDeclOrigin -- Manufactured during a class decl
685 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
688 -- When specialising instances the instance info attached to
689 -- each class is not yet ready, so we record it inside the
690 -- origin information. This is a bit of a hack, but it works
691 -- fine. (Patrick is to blame [WDP].)
693 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
695 -- Argument or result of a ccall
696 -- Dictionaries with this origin aren't actually mentioned in the
697 -- translated term, and so need not be bound. Nor should they
698 -- be abstracted over.
700 | CCallOrigin String -- CCall label
701 (Maybe RenamedHsExpr) -- Nothing if it's the result
702 -- Just arg, for an argument
704 | LitLitOrigin String -- the litlit
706 | UnknownOrigin -- Help! I give up...
710 pprInstLoc :: InstLoc -> SDoc
711 pprInstLoc (orig, locn, ctxt)
712 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
714 pp_orig (OccurrenceOf name)
715 = hsep [ptext SLIT("use of"), quotes (ppr name)]
717 = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
718 pp_orig (IPBind name)
719 = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)]
720 pp_orig RecordUpdOrigin
721 = ptext SLIT("a record update")
722 pp_orig DataDeclOrigin
723 = ptext SLIT("the data type declaration")
724 pp_orig InstanceDeclOrigin
725 = ptext SLIT("the instance declaration")
726 pp_orig (LiteralOrigin lit)
727 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
728 pp_orig (PatOrigin pat)
729 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
730 pp_orig (ArithSeqOrigin seq)
731 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
732 pp_orig (PArrSeqOrigin seq)
733 = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
734 pp_orig (SignatureOrigin)
735 = ptext SLIT("a type signature")
736 pp_orig (Rank2Origin)
737 = ptext SLIT("a function with an overloaded argument type")
739 = ptext SLIT("a do statement")
740 pp_orig (ClassDeclOrigin)
741 = ptext SLIT("a class declaration")
742 pp_orig (InstanceSpecOrigin clas ty)
743 = hsep [text "a SPECIALIZE instance pragma; class",
744 quotes (ppr clas), text "type:", ppr ty]
745 pp_orig (ValSpecOrigin name)
746 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
747 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
748 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
749 pp_orig (CCallOrigin clabel (Just arg_expr))
750 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
751 text "namely", quotes (ppr arg_expr)]
752 pp_orig (LitLitOrigin s)
753 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
754 pp_orig (UnknownOrigin)
755 = ptext SLIT("...oops -- I don't know where the overloading came from!")