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 DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
67 import UNSAFE_IO ( unsafeInterleaveIO )
68 import FIX_IO ( fixIO )
70 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
74 %************************************************************************
76 \subsection{The main monads: TcM, NF_TcM}
78 %************************************************************************
81 type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
82 type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
84 type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
85 -- Used only in this file for type signatures which
86 -- have a part that's polymorphic in whether it's NF_TcM or TcM
89 type TcRef a = IORef a
97 -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
99 initTc dflags tc_env do_this
101 us <- mkSplitUniqSupply 'a' ;
102 us_var <- newIORef us ;
103 errs_var <- newIORef (emptyBag,emptyBag) ;
104 tvs_var <- newIORef emptyUFM ;
107 init_down = TcDown { tc_dflags = dflags, tc_def = [],
108 tc_us = us_var, tc_loc = noSrcLoc,
109 tc_ctxt = [], tc_errs = errs_var }
112 maybe_res <- catch (do { res <- do_this init_down tc_env ;
114 (\_ -> return Nothing) ;
116 (warns,errs) <- readIORef errs_var ;
117 return (maybe_res, (warns, errs))
120 -- Monadic operations
122 returnNF_Tc :: a -> NF_TcM a
123 returnTc :: a -> TcM a
124 returnTc v down env = return v
126 thenTc :: TcM a -> (a -> TcM b) -> TcM b
127 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
128 thenTc m k down env = do { r <- m down env; k r down env }
130 thenTc_ :: TcM a -> TcM b -> TcM b
131 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
132 thenTc_ m k down env = do { m down env; k down env }
134 listTc :: [TcM a] -> TcM [a]
135 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
136 listTc [] = returnTc []
137 listTc (x:xs) = x `thenTc` \ r ->
138 listTc xs `thenTc` \ rs ->
141 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
142 mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
143 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
144 mapTc f [] = returnTc []
145 mapTc f (x:xs) = f x `thenTc` \ r ->
146 mapTc f xs `thenTc` \ rs ->
148 mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
151 foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
152 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
153 foldrTc k z [] = returnTc z
154 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
157 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
158 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
159 foldlTc k z [] = returnTc z
160 foldlTc k z (x:xs) = k z x `thenTc` \r ->
163 mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
164 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
165 mapAndUnzipTc f [] = returnTc ([],[])
166 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
167 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
168 returnTc (r1:rs1, r2:rs2)
170 mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
171 mapAndUnzip3Tc f [] = returnTc ([],[],[])
172 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
173 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
174 returnTc (r1:rs1, r2:rs2, r3:rs3)
176 mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
177 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
179 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
181 returnTc (unionBags r1 r2))
182 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
186 fixTc :: (a -> TcM a) -> TcM a
187 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
188 fixTc m env down = fixIO (\ loop -> m loop env down)
189 {-# NOINLINE fixTc #-}
190 -- aargh! Not inlining fixTc alleviates a space leak problem.
191 -- Normally fixTc is used with a lazy tuple match: if the optimiser is
192 -- shown the definition of fixTc, it occasionally transforms the code
193 -- in such a way that the code generator doesn't spot the selector
196 recoverTc :: TcM r -> TcM r -> TcM r
197 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
198 recoverTc recover m down env
199 = catch (m down env) (\ _ -> recover down env)
201 returnNF_Tc = returnTc
205 recoverNF_Tc = recoverTc
210 mapAndUnzipNF_Tc = mapAndUnzipTc
211 mapBagNF_Tc = mapBagTc
214 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
215 thread. Ideally, this elegantly ensures that it can't zap any type
216 variables that belong to the main thread. But alas, the environment
217 contains TyCon and Class environments that include TcKind stuff,
218 which is a Royal Pain. By the time this fork stuff is used they'll
219 have been unified down so there won't be any kind variables, but we
220 can't express that in the current typechecker framework.
222 So we compromise and use unsafeInterleaveIO.
224 We throw away any error messages!
227 forkNF_Tc :: NF_TcM r -> NF_TcM r
228 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
230 -- Get a fresh unique supply
231 us <- readIORef u_var
232 let (us1, us2) = splitUniqSupply us
235 unsafeInterleaveIO (do {
236 us_var' <- newIORef us2 ;
237 err_var' <- newIORef (emptyBag,emptyBag) ;
238 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
240 -- ToDo: optionally dump any error messages
245 traceTc :: SDoc -> NF_TcM ()
246 traceTc doc (TcDown { tc_dflags=dflags }) env
247 | dopt Opt_D_dump_tc_trace dflags = printDump doc
248 | otherwise = return ()
250 ioToTc :: IO a -> NF_TcM a
251 ioToTc io down env = io
255 %************************************************************************
257 \subsection{Error handling}
259 %************************************************************************
262 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
264 = readIORef (getTcErrs down)
267 failTc down env = give_up
270 give_up = ioError (userError "Typecheck failed")
272 failWithTc :: Message -> TcM a -- Add an error message and fail
273 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
275 addErrTc :: Message -> NF_TcM ()
276 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
278 addErrsTc :: [Message] -> NF_TcM ()
279 addErrsTc [] = returnNF_Tc ()
280 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
282 -- The 'M' variants do the TidyEnv bit
283 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
284 failWithTcM env_and_msg
285 = addErrTcM env_and_msg `thenNF_Tc_`
288 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
289 checkTc True err = returnTc ()
290 checkTc False err = failWithTc err
292 checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
293 checkTcM True err = returnTc ()
294 checkTcM False err = err
296 checkMaybeTc :: Maybe val -> Message -> TcM val
297 checkMaybeTc (Just val) err = returnTc val
298 checkMaybeTc Nothing err = failWithTc err
300 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
301 checkMaybeTcM (Just val) err = returnTc val
302 checkMaybeTcM Nothing err = err
304 addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
305 addErrTcM (tidy_env, err_msg) down env
306 = add_err_tcm tidy_env err_msg ctxt loc down env
308 ctxt = getErrCtxt down
311 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
312 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
313 = add_err_tcm tidy_env err_msg full_ctxt loc down env
315 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
317 add_err_tcm tidy_env err_msg ctxt loc down env
319 (warns, errs) <- readIORef errs_var
320 ctxt_msgs <- do_ctxt tidy_env ctxt down env
321 let err = addShortErrLocLine loc $
322 vcat (err_msg : ctxt_to_use ctxt_msgs)
323 writeIORef errs_var (warns, errs `snocBag` err)
325 errs_var = getTcErrs down
327 do_ctxt tidy_env [] down env
329 do_ctxt tidy_env (c:cs) down env
331 (tidy_env', m) <- c tidy_env down env
332 ms <- do_ctxt tidy_env' cs down env
335 -- warnings don't have an 'M' variant
336 warnTc :: Bool -> Message -> NF_TcM ()
337 warnTc warn_if_true warn_msg down env
340 (warns,errs) <- readIORef errs_var
341 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
342 let warn = addShortWarnLocLine loc $
343 vcat (warn_msg : ctxt_to_use ctxt_msgs)
344 writeIORef errs_var (warns `snocBag` warn, errs)
348 errs_var = getTcErrs down
349 ctxt = getErrCtxt down
352 -- (tryTc r m) succeeds if m succeeds and generates no errors
353 -- If m fails then r is invoked, passing the warnings and errors from m
354 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
355 -- (it might have recovered internally)
356 -- If so, then r is invoked, passing the warnings and errors from m
358 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action
359 -> TcM r -- Thing to try
361 tryTc recover main down env
363 m_errs_var <- newIORef (emptyBag,emptyBag)
364 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
366 errs_var = getTcErrs down
368 my_recover m_errs_var
369 = do warns_and_errs <- readIORef m_errs_var
370 recover warns_and_errs down env
373 = do result <- main (setTcErrs down m_errs_var) env
375 -- Check that m has no errors; if it has internal recovery
376 -- mechanisms it might "succeed" but having found a bunch of
377 -- errors along the way.
378 (m_warns, m_errs) <- readIORef m_errs_var
379 if isEmptyBag m_errs then
380 -- No errors, so return normally, but don't lose the warnings
381 if isEmptyBag m_warns then
384 do (warns, errs) <- readIORef errs_var
385 writeIORef errs_var (warns `unionBags` m_warns, errs)
388 give_up -- This triggers the catch
391 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
392 -- If m fails then (checkNoErrsTc m) fails.
393 -- If m succeeds, it checks whether m generated any errors messages
394 -- (it might have recovered internally)
395 -- If so, it fails too.
396 -- Regardless, any errors generated by m are propagated to the enclosing context.
397 checkNoErrsTc :: TcM r -> TcM r
399 = tryTc my_recover main
401 my_recover (m_warns, m_errs) down env
402 = do (warns, errs) <- readIORef errs_var
403 writeIORef errs_var (warns `unionBags` m_warns,
404 errs `unionBags` m_errs)
407 errs_var = getTcErrs down
410 ifErrsTc :: TcM r -> TcM r -> TcM r
411 -- ifErrsTc bale_out main
412 -- does 'bale_out' if there are errors in errors collection
413 -- and does 'main' otherwise
414 -- Useful to avoid error cascades
416 ifErrsTc bale_out main
417 = getErrsTc `thenNF_Tc` \ (warns, errs) ->
418 if isEmptyBag errs then
423 -- (tryTc_ r m) tries m; if it succeeds it returns it,
424 -- otherwise it returns r. Any error messages added by m are discarded,
425 -- whether or not m succeeds.
426 tryTc_ :: TcM r -> TcM r -> TcM r
428 = tryTc my_recover main
430 my_recover warns_and_errs = recover
432 -- (discardErrsTc m) runs m, but throw away all its error messages.
433 discardErrsTc :: Either_TcM r -> Either_TcM r
434 discardErrsTc main down env
435 = do new_errs_var <- newIORef (emptyBag,emptyBag)
436 main (setTcErrs down new_errs_var) env
441 %************************************************************************
443 \subsection{Mutable variables}
445 %************************************************************************
448 tcNewMutVar :: a -> NF_TcM (TcRef a)
449 tcNewMutVar val down env = newIORef val
451 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
452 tcWriteMutVar var val down env = writeIORef var val
454 tcReadMutVar :: TcRef a -> NF_TcM a
455 tcReadMutVar var down env = readIORef var
457 tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar
458 tcNewMutTyVar name kind details down env = newMutTyVar name kind details
460 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
461 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
463 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
464 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
468 %************************************************************************
470 \subsection{The environment}
472 %************************************************************************
475 tcGetEnv :: NF_TcM TcEnv
476 tcGetEnv down env = return env
478 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
479 tcSetEnv new_env m down old_env = m down new_env
483 %************************************************************************
485 \subsection{Source location}
487 %************************************************************************
490 tcGetDefaultTys :: NF_TcM [Type]
491 tcGetDefaultTys down env = return (getDefaultTys down)
493 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
494 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
496 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
497 tcAddSrcLoc loc m down env = m (setLoc down loc) env
499 tcGetSrcLoc :: NF_TcM SrcLoc
500 tcGetSrcLoc down env = return (getLoc down)
502 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
503 tcGetInstLoc origin TcDown{tc_loc=loc, tc_ctxt=ctxt} env
504 = return (origin, loc, ctxt)
506 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
508 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
509 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
511 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
513 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
514 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
516 tcPopErrCtxt :: Either_TcM r -> Either_TcM r
517 tcPopErrCtxt m down env = m (popErrCtxt down) env
521 %************************************************************************
523 \subsection{Unique supply}
525 %************************************************************************
528 tcGetUnique :: NF_TcM Unique
530 = do uniq_supply <- readIORef u_var
531 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
532 uniq = uniqFromSupply uniq_s
533 writeIORef u_var new_uniq_supply
536 u_var = getUniqSupplyVar down
538 tcGetUniques :: NF_TcM [Unique]
539 tcGetUniques down env
540 = do uniq_supply <- readIORef u_var
541 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
542 uniqs = uniqsFromSupply uniq_s
543 writeIORef u_var new_uniq_supply
546 u_var = getUniqSupplyVar down
548 uniqSMToTcM :: UniqSM a -> NF_TcM a
549 uniqSMToTcM m down env
550 = do uniq_supply <- readIORef u_var
551 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
552 writeIORef u_var new_uniq_supply
553 return (initUs_ uniq_s m)
555 u_var = getUniqSupplyVar down
560 %************************************************************************
564 %************************************************************************
569 tc_dflags :: DynFlags,
570 tc_def :: [Type], -- Types used for defaulting
571 tc_us :: (TcRef UniqSupply), -- Unique supply
572 tc_loc :: SrcLoc, -- Source location
573 tc_ctxt :: ErrCtxt, -- Error context
574 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
577 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
578 -- Innermost first. Monadic so that we have a chance
579 -- to deal with bound type variables just before error
580 -- message construction
583 -- These selectors are *local* to TcMonad.lhs
586 getTcErrs (TcDown{tc_errs=errs}) = errs
587 setTcErrs down errs = down{tc_errs=errs}
589 getDefaultTys (TcDown{tc_def=def}) = def
590 setDefaultTys down def = down{tc_def=def}
592 getLoc (TcDown{tc_loc=loc}) = loc
593 setLoc down loc = down{tc_loc=loc}
595 getUniqSupplyVar (TcDown{tc_us=us}) = us
597 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
598 setErrCtxt down msg = down{tc_ctxt=[msg]}
599 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
601 popErrCtxt down = case tc_ctxt down of
603 m : ms -> down{tc_ctxt = ms}
605 doptsTc :: DynFlag -> NF_TcM Bool
606 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
607 = return (dopt dflag dflags)
609 getDOptsTc :: NF_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 = take 3 ctxt
630 arityErr kind name n m
631 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
632 n_arguments <> comma, text "but has been given", int m]
634 n_arguments | n == 0 = ptext SLIT("no arguments")
635 | n == 1 = ptext SLIT("1 argument")
636 | True = hsep [int n, ptext SLIT("arguments")]
641 %************************************************************************
643 \subsection[Inst-origin]{The @InstOrigin@ type}
645 %************************************************************************
647 The @InstOrigin@ type gives information about where a dictionary came from.
648 This is important for decent error message reporting because dictionaries
649 don't appear in the original source code. Doubtless this type will evolve...
651 It appears in TcMonad because there are a couple of error-message-generation
652 functions that deal with it.
655 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
658 = OccurrenceOf Name -- Occurrence of an overloaded identifier
660 | IPOcc (IPName Name) -- Occurrence of an implicit parameter
661 | IPBind (IPName Name) -- Binding site of an implicit parameter
665 | DataDeclOrigin -- Typechecking a data declaration
667 | InstanceDeclOrigin -- Typechecking an instance decl
669 | LiteralOrigin HsOverLit -- Occurrence of a literal
671 | PatOrigin RenamedPat
673 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
674 | PArrSeqOrigin RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:]
676 | SignatureOrigin -- A dict created from a type signature
677 | Rank2Origin -- A dict created when typechecking the argument
678 -- of a rank-2 typed function
680 | DoOrigin -- The monad for a do expression
682 | ClassDeclOrigin -- Manufactured during a class decl
684 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
687 -- When specialising instances the instance info attached to
688 -- each class is not yet ready, so we record it inside the
689 -- origin information. This is a bit of a hack, but it works
690 -- fine. (Patrick is to blame [WDP].)
692 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
694 -- Argument or result of a ccall
695 -- Dictionaries with this origin aren't actually mentioned in the
696 -- translated term, and so need not be bound. Nor should they
697 -- be abstracted over.
699 | CCallOrigin String -- CCall label
700 (Maybe RenamedHsExpr) -- Nothing if it's the result
701 -- Just arg, for an argument
703 | LitLitOrigin String -- the litlit
705 | UnknownOrigin -- Help! I give up...
709 pprInstLoc :: InstLoc -> SDoc
710 pprInstLoc (orig, locn, ctxt)
711 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
713 pp_orig (OccurrenceOf name)
714 = hsep [ptext SLIT("use of"), quotes (ppr name)]
716 = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
717 pp_orig (IPBind name)
718 = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)]
719 pp_orig RecordUpdOrigin
720 = ptext SLIT("a record update")
721 pp_orig DataDeclOrigin
722 = ptext SLIT("the data type declaration")
723 pp_orig InstanceDeclOrigin
724 = ptext SLIT("the instance declaration")
725 pp_orig (LiteralOrigin lit)
726 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
727 pp_orig (PatOrigin pat)
728 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
729 pp_orig (ArithSeqOrigin seq)
730 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
731 pp_orig (PArrSeqOrigin seq)
732 = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
733 pp_orig (SignatureOrigin)
734 = ptext SLIT("a type signature")
735 pp_orig (Rank2Origin)
736 = ptext SLIT("a function with an overloaded argument type")
738 = ptext SLIT("a do statement")
739 pp_orig (ClassDeclOrigin)
740 = ptext SLIT("a class declaration")
741 pp_orig (InstanceSpecOrigin clas ty)
742 = hsep [text "a SPECIALIZE instance pragma; class",
743 quotes (ppr clas), text "type:", ppr ty]
744 pp_orig (ValSpecOrigin name)
745 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
746 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
747 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
748 pp_orig (CCallOrigin clabel (Just arg_expr))
749 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
750 text "namely", quotes (ppr arg_expr)]
751 pp_orig (LitLitOrigin s)
752 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
753 pp_orig (UnknownOrigin)
754 = ptext SLIT("...oops -- I don't know where the overloading came from!")