4 TcTauType, TcPredType, TcThetaType, TcRhoType,
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, tcPopErrCtxt,
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 )
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 TcPredType = PredType
98 type TcThetaType = ThetaType
99 type TcRhoType = RhoType
100 type TcTauType = TauType
105 %************************************************************************
107 \subsection{The main monads: TcM, NF_TcM}
109 %************************************************************************
112 type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
113 type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
115 type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
116 -- Used only in this file for type signatures which
117 -- have a part that's polymorphic in whether it's NF_TcM or TcM
120 type TcRef a = IORef a
128 -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
130 initTc dflags tc_env do_this
132 us <- mkSplitUniqSupply 'a' ;
133 us_var <- newIORef us ;
134 errs_var <- newIORef (emptyBag,emptyBag) ;
135 tvs_var <- newIORef emptyUFM ;
138 init_down = TcDown { tc_dflags = dflags, tc_def = [],
139 tc_us = us_var, tc_loc = noSrcLoc,
140 tc_ctxt = [], tc_errs = errs_var }
143 maybe_res <- catch (do { res <- do_this init_down tc_env ;
145 (\_ -> return Nothing) ;
147 (warns,errs) <- readIORef errs_var ;
148 return (maybe_res, (warns, errs))
151 -- Monadic operations
153 returnNF_Tc :: a -> NF_TcM a
154 returnTc :: a -> TcM a
155 returnTc v down env = return v
157 thenTc :: TcM a -> (a -> TcM b) -> TcM b
158 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
159 thenTc m k down env = do { r <- m down env; k r down env }
161 thenTc_ :: TcM a -> TcM b -> TcM b
162 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
163 thenTc_ m k down env = do { m down env; k down env }
165 listTc :: [TcM a] -> TcM [a]
166 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
167 listTc [] = returnTc []
168 listTc (x:xs) = x `thenTc` \ r ->
169 listTc xs `thenTc` \ rs ->
172 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
173 mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
174 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
175 mapTc f [] = returnTc []
176 mapTc f (x:xs) = f x `thenTc` \ r ->
177 mapTc f xs `thenTc` \ rs ->
179 mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
182 foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
183 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
184 foldrTc k z [] = returnTc z
185 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
188 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
189 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
190 foldlTc k z [] = returnTc z
191 foldlTc k z (x:xs) = k z x `thenTc` \r ->
194 mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
195 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
196 mapAndUnzipTc f [] = returnTc ([],[])
197 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
198 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
199 returnTc (r1:rs1, r2:rs2)
201 mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
202 mapAndUnzip3Tc f [] = returnTc ([],[],[])
203 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
204 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
205 returnTc (r1:rs1, r2:rs2, r3:rs3)
207 mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
208 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
210 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
212 returnTc (unionBags r1 r2))
213 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
217 fixTc :: (a -> TcM a) -> TcM a
218 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
219 fixTc m env down = fixIO (\ loop -> m loop env down)
220 {-# NOINLINE fixTc #-}
221 -- aargh! Not inlining fixTc alleviates a space leak problem.
222 -- Normally fixTc is used with a lazy tuple match: if the optimiser is
223 -- shown the definition of fixTc, it occasionally transforms the code
224 -- in such a way that the code generator doesn't spot the selector
227 recoverTc :: TcM r -> TcM r -> TcM r
228 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
229 recoverTc recover m down env
230 = catch (m down env) (\ _ -> recover down env)
232 returnNF_Tc = returnTc
236 recoverNF_Tc = recoverTc
241 mapAndUnzipNF_Tc = mapAndUnzipTc
242 mapBagNF_Tc = mapBagTc
245 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
246 thread. Ideally, this elegantly ensures that it can't zap any type
247 variables that belong to the main thread. But alas, the environment
248 contains TyCon and Class environments that include TcKind stuff,
249 which is a Royal Pain. By the time this fork stuff is used they'll
250 have been unified down so there won't be any kind variables, but we
251 can't express that in the current typechecker framework.
253 So we compromise and use unsafeInterleaveIO.
255 We throw away any error messages!
258 forkNF_Tc :: NF_TcM r -> NF_TcM r
259 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
261 -- Get a fresh unique supply
262 us <- readIORef u_var
263 let (us1, us2) = splitUniqSupply us
266 unsafeInterleaveIO (do {
267 us_var' <- newIORef us2 ;
268 err_var' <- newIORef (emptyBag,emptyBag) ;
269 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
271 -- ToDo: optionally dump any error messages
276 traceTc :: SDoc -> NF_TcM ()
277 traceTc doc (TcDown { tc_dflags=dflags }) env
278 | dopt Opt_D_dump_tc_trace dflags = printDump doc
279 | otherwise = return ()
281 ioToTc :: IO a -> NF_TcM a
282 ioToTc io down env = io
286 %************************************************************************
288 \subsection{Error handling}
290 %************************************************************************
293 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
295 = readIORef (getTcErrs down)
298 failTc down env = give_up
301 give_up = IOERROR (userError "Typecheck failed")
303 failWithTc :: Message -> TcM a -- Add an error message and fail
304 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
306 addErrTc :: Message -> NF_TcM ()
307 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
309 addErrsTc :: [Message] -> NF_TcM ()
310 addErrsTc [] = returnNF_Tc ()
311 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
313 -- The 'M' variants do the TidyEnv bit
314 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
315 failWithTcM env_and_msg
316 = addErrTcM env_and_msg `thenNF_Tc_`
319 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
320 checkTc True err = returnTc ()
321 checkTc False err = failWithTc err
323 checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
324 checkTcM True err = returnTc ()
325 checkTcM False err = err
327 checkMaybeTc :: Maybe val -> Message -> TcM val
328 checkMaybeTc (Just val) err = returnTc val
329 checkMaybeTc Nothing err = failWithTc err
331 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
332 checkMaybeTcM (Just val) err = returnTc val
333 checkMaybeTcM Nothing err = err
335 addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
336 addErrTcM (tidy_env, err_msg) down env
337 = add_err_tcm tidy_env err_msg ctxt loc down env
339 ctxt = getErrCtxt down
342 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
343 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
344 = add_err_tcm tidy_env err_msg full_ctxt loc down env
346 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
348 add_err_tcm tidy_env err_msg ctxt loc down env
350 (warns, errs) <- readIORef errs_var
351 ctxt_msgs <- do_ctxt tidy_env ctxt down env
352 let err = addShortErrLocLine loc $
353 vcat (err_msg : ctxt_to_use ctxt_msgs)
354 writeIORef errs_var (warns, errs `snocBag` err)
356 errs_var = getTcErrs down
358 do_ctxt tidy_env [] down env
360 do_ctxt tidy_env (c:cs) down env
362 (tidy_env', m) <- c tidy_env down env
363 ms <- do_ctxt tidy_env' cs down env
366 -- warnings don't have an 'M' variant
367 warnTc :: Bool -> Message -> NF_TcM ()
368 warnTc warn_if_true warn_msg down env
371 (warns,errs) <- readIORef errs_var
372 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
373 let warn = addShortWarnLocLine loc $
374 vcat (warn_msg : ctxt_to_use ctxt_msgs)
375 writeIORef errs_var (warns `snocBag` warn, errs)
379 errs_var = getTcErrs down
380 ctxt = getErrCtxt down
383 -- (tryTc r m) succeeds if m succeeds and generates no errors
384 -- If m fails then r is invoked, passing the warnings and errors from m
385 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
386 -- (it might have recovered internally)
387 -- If so, then r is invoked, passing the warnings and errors from m
389 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action
390 -> TcM r -- Thing to try
392 tryTc recover main down env
394 m_errs_var <- newIORef (emptyBag,emptyBag)
395 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
397 my_recover m_errs_var
398 = do warns_and_errs <- readIORef m_errs_var
399 recover warns_and_errs down env
402 = do result <- main (setTcErrs down m_errs_var) env
404 -- Check that m has no errors; if it has internal recovery
405 -- mechanisms it might "succeed" but having found a bunch of
406 -- errors along the way.
407 (m_warns, m_errs) <- readIORef m_errs_var
408 if isEmptyBag m_errs then
411 give_up -- This triggers the catch
414 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
415 -- If m fails then (checkNoErrsTc m) fails.
416 -- If m succeeds, it checks whether m generated any errors messages
417 -- (it might have recovered internally)
418 -- If so, it fails too.
419 -- Regardless, any errors generated by m are propagated to the enclosing context.
420 checkNoErrsTc :: TcM r -> TcM r
422 = tryTc my_recover main
424 my_recover (m_warns, m_errs) down env
425 = do (warns, errs) <- readIORef errs_var
426 writeIORef errs_var (warns `unionBags` m_warns,
427 errs `unionBags` m_errs)
430 errs_var = getTcErrs down
433 -- (tryTc_ r m) tries m; if it succeeds it returns it,
434 -- otherwise it returns r. Any error messages added by m are discarded,
435 -- whether or not m succeeds.
436 tryTc_ :: TcM r -> TcM r -> TcM r
438 = tryTc my_recover main
440 my_recover warns_and_errs = recover
442 -- (discardErrsTc m) runs m, but throw away all its error messages.
443 discardErrsTc :: Either_TcM r -> Either_TcM r
444 discardErrsTc main down env
445 = do new_errs_var <- newIORef (emptyBag,emptyBag)
446 main (setTcErrs down new_errs_var) env
451 %************************************************************************
453 \subsection{Mutable variables}
455 %************************************************************************
458 tcNewMutVar :: a -> NF_TcM (TcRef a)
459 tcNewMutVar val down env = newIORef val
461 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
462 tcWriteMutVar var val down env = writeIORef var val
464 tcReadMutVar :: TcRef a -> NF_TcM a
465 tcReadMutVar var down env = readIORef var
467 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
468 tcNewMutTyVar name kind down env = newMutTyVar name kind
470 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
471 tcNewSigTyVar name kind down env = newSigTyVar name kind
473 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
474 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
476 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
477 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
481 %************************************************************************
483 \subsection{The environment}
485 %************************************************************************
488 tcGetEnv :: NF_TcM TcEnv
489 tcGetEnv down env = return env
491 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
492 tcSetEnv new_env m down old_env = m down new_env
496 %************************************************************************
498 \subsection{Source location}
500 %************************************************************************
503 tcGetDefaultTys :: NF_TcM [Type]
504 tcGetDefaultTys down env = return (getDefaultTys down)
506 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
507 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
509 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
510 tcAddSrcLoc loc m down env = m (setLoc down loc) env
512 tcGetSrcLoc :: NF_TcM SrcLoc
513 tcGetSrcLoc down env = return (getLoc down)
515 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
516 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
518 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
520 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
521 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
523 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
525 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
526 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
528 tcPopErrCtxt :: Either_TcM r -> Either_TcM r
529 tcPopErrCtxt m down env = m (popErrCtxt down) env
533 %************************************************************************
535 \subsection{Unique supply}
537 %************************************************************************
540 tcGetUnique :: NF_TcM Unique
542 = do uniq_supply <- readIORef u_var
543 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
544 uniq = uniqFromSupply uniq_s
545 writeIORef u_var new_uniq_supply
548 u_var = getUniqSupplyVar down
550 tcGetUniques :: NF_TcM [Unique]
551 tcGetUniques down env
552 = do uniq_supply <- readIORef u_var
553 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
554 uniqs = uniqsFromSupply uniq_s
555 writeIORef u_var new_uniq_supply
558 u_var = getUniqSupplyVar down
560 uniqSMToTcM :: UniqSM a -> NF_TcM a
561 uniqSMToTcM m down env
562 = do uniq_supply <- readIORef u_var
563 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
564 writeIORef u_var new_uniq_supply
565 return (initUs_ uniq_s m)
567 u_var = getUniqSupplyVar down
572 %************************************************************************
576 %************************************************************************
581 tc_dflags :: DynFlags,
582 tc_def :: [Type], -- Types used for defaulting
583 tc_us :: (TcRef UniqSupply), -- Unique supply
584 tc_loc :: SrcLoc, -- Source location
585 tc_ctxt :: ErrCtxt, -- Error context
586 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
589 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
590 -- Innermost first. Monadic so that we have a chance
591 -- to deal with bound type variables just before error
592 -- message construction
595 -- These selectors are *local* to TcMonad.lhs
598 getTcErrs (TcDown{tc_errs=errs}) = errs
599 setTcErrs down errs = down{tc_errs=errs}
601 getDefaultTys (TcDown{tc_def=def}) = def
602 setDefaultTys down def = down{tc_def=def}
604 getLoc (TcDown{tc_loc=loc}) = loc
605 setLoc down loc = down{tc_loc=loc}
607 getUniqSupplyVar (TcDown{tc_us=us}) = us
609 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
610 setErrCtxt down msg = down{tc_ctxt=[msg]}
611 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
613 popErrCtxt down = case tc_ctxt down of
615 m : ms -> down{tc_ctxt = ms}
617 doptsTc :: DynFlag -> TcM Bool
618 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
619 = return (dopt dflag dflags)
621 getDOptsTc :: TcM DynFlags
622 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
629 %************************************************************************
631 \subsection{TypeChecking Errors}
633 %************************************************************************
636 type TcError = Message
637 type TcWarning = Message
639 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
640 | otherwise = takeAtMost 3 ctxt
642 takeAtMost :: Int -> [a] -> [a]
645 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
647 arityErr kind name n m
648 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
649 n_arguments <> comma, text "but has been given", int m]
651 n_arguments | n == 0 = ptext SLIT("no arguments")
652 | n == 1 = ptext SLIT("1 argument")
653 | True = hsep [int n, ptext SLIT("arguments")]
658 %************************************************************************
660 \subsection[Inst-origin]{The @InstOrigin@ type}
662 %************************************************************************
664 The @InstOrigin@ type gives information about where a dictionary came from.
665 This is important for decent error message reporting because dictionaries
666 don't appear in the original source code. Doubtless this type will evolve...
668 It appears in TcMonad because there are a couple of error-message-generation
669 functions that deal with it.
672 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
675 = OccurrenceOf Id -- Occurrence of an overloaded identifier
677 | IPOcc Name -- Occurrence of an implicit parameter
678 | IPBind Name -- Binding site of an implicit parameter
682 | DataDeclOrigin -- Typechecking a data declaration
684 | InstanceDeclOrigin -- Typechecking an instance decl
686 | LiteralOrigin HsOverLit -- Occurrence of a literal
688 | PatOrigin RenamedPat
690 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
692 | SignatureOrigin -- A dict created from a type signature
693 | Rank2Origin -- A dict created when typechecking the argument
694 -- of a rank-2 typed function
696 | DoOrigin -- The monad for a do expression
698 | ClassDeclOrigin -- Manufactured during a class decl
700 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
703 -- When specialising instances the instance info attached to
704 -- each class is not yet ready, so we record it inside the
705 -- origin information. This is a bit of a hack, but it works
706 -- fine. (Patrick is to blame [WDP].)
708 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
710 -- Argument or result of a ccall
711 -- Dictionaries with this origin aren't actually mentioned in the
712 -- translated term, and so need not be bound. Nor should they
713 -- be abstracted over.
715 | CCallOrigin String -- CCall label
716 (Maybe RenamedHsExpr) -- Nothing if it's the result
717 -- Just arg, for an argument
719 | LitLitOrigin String -- the litlit
721 | UnknownOrigin -- Help! I give up...
725 pprInstLoc :: InstLoc -> SDoc
726 pprInstLoc (orig, locn, ctxt)
727 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
729 pp_orig (OccurrenceOf id)
730 = hsep [ptext SLIT("use of"), quotes (ppr id)]
732 = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
733 pp_orig (IPBind name)
734 = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
735 pp_orig (LiteralOrigin lit)
736 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
737 pp_orig (PatOrigin pat)
738 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
739 pp_orig (InstanceDeclOrigin)
740 = ptext SLIT("the instance declaration")
741 pp_orig (ArithSeqOrigin seq)
742 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
743 pp_orig (SignatureOrigin)
744 = ptext SLIT("a type signature")
745 pp_orig (Rank2Origin)
746 = ptext SLIT("a function with an overloaded argument type")
748 = ptext SLIT("a do statement")
749 pp_orig (ClassDeclOrigin)
750 = ptext SLIT("a class declaration")
751 pp_orig (InstanceSpecOrigin clas ty)
752 = hsep [text "a SPECIALIZE instance pragma; class",
753 quotes (ppr clas), text "type:", ppr ty]
754 pp_orig (ValSpecOrigin name)
755 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
756 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
757 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
758 pp_orig (CCallOrigin clabel (Just arg_expr))
759 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
760 text "namely", quotes (ppr arg_expr)]
761 pp_orig (LitLitOrigin s)
762 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
763 pp_orig (UnknownOrigin)
764 = ptext SLIT("...oops -- I don't know where the overloading came from!")