3 TcType, TcTauType, TcPredType, TcThetaType, TcRhoType,
4 TcTyVar, TcTyVarSet, TcKind,
6 TcM, NF_TcM, TcDown, TcEnv,
9 returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
10 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
11 mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
16 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
17 fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
19 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
21 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
22 failTc, failWithTc, addErrTc, addErrsTc, warnTc,
23 recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
24 addErrTcM, addInstErrTcM, failWithTcM,
27 tcGetDefaultTys, tcSetDefaultTys,
28 tcGetUnique, tcGetUniques,
31 tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
32 tcAddErrCtxtM, tcSetErrCtxtM,
33 tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
35 tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
36 tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
38 InstOrigin(..), InstLoc, pprInstLoc,
40 TcError, TcWarning, TidyEnv, emptyTidyEnv,
44 #include "HsVersions.h"
46 import {-# SOURCE #-} TcEnv ( TcEnv )
48 import HsLit ( HsOverLit )
49 import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
50 import TcType ( Type, Kind, PredType, ThetaType, TauType, RhoType )
51 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
53 import Bag ( Bag, emptyBag, isEmptyBag,
54 foldBag, unitBag, unionBags, snocBag )
55 import Class ( Class )
57 import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
58 import VarEnv ( TidyEnv, emptyTidyEnv )
59 import VarSet ( TyVarSet )
60 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
61 splitUniqSupply, mkSplitUniqSupply,
63 import SrcLoc ( SrcLoc, noSrcLoc )
64 import UniqFM ( emptyUFM )
65 import Unique ( Unique )
69 import IOExts ( IORef, newIORef, readIORef, writeIORef,
70 unsafeInterleaveIO, fixIO
74 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
78 %************************************************************************
82 %************************************************************************
85 type TcTyVar = TyVar -- Might be a mutable tyvar
86 type TcTyVarSet = TyVarSet
88 type TcType = Type -- A TcType can have mutable type variables
89 -- Invariant on ForAllTy in TcTypes:
91 -- a cannot occur inside a MutTyVar in T; that is,
92 -- T is "flattened" before quantifying over a
94 type TcPredType = PredType
95 type TcThetaType = ThetaType
96 type TcRhoType = RhoType
97 type TcTauType = TauType
102 %************************************************************************
104 \subsection{The main monads: TcM, NF_TcM}
106 %************************************************************************
109 type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
110 type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
112 type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
113 -- Used only in this file for type signatures which
114 -- have a part that's polymorphic in whether it's NF_TcM or TcM
117 type TcRef a = IORef a
125 -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
127 initTc dflags tc_env do_this
129 us <- mkSplitUniqSupply 'a' ;
130 us_var <- newIORef us ;
131 errs_var <- newIORef (emptyBag,emptyBag) ;
132 tvs_var <- newIORef emptyUFM ;
135 init_down = TcDown { tc_dflags = dflags, tc_def = [],
136 tc_us = us_var, tc_loc = noSrcLoc,
137 tc_ctxt = [], tc_errs = errs_var }
140 maybe_res <- catch (do { res <- do_this init_down tc_env ;
142 (\_ -> return Nothing) ;
144 (warns,errs) <- readIORef errs_var ;
145 return (maybe_res, (warns, errs))
148 -- Monadic operations
150 returnNF_Tc :: a -> NF_TcM a
151 returnTc :: a -> TcM a
152 returnTc v down env = return v
154 thenTc :: TcM a -> (a -> TcM b) -> TcM b
155 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
156 thenTc m k down env = do { r <- m down env; k r down env }
158 thenTc_ :: TcM a -> TcM b -> TcM b
159 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
160 thenTc_ m k down env = do { m down env; k down env }
162 listTc :: [TcM a] -> TcM [a]
163 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
164 listTc [] = returnTc []
165 listTc (x:xs) = x `thenTc` \ r ->
166 listTc xs `thenTc` \ rs ->
169 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
170 mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
171 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
172 mapTc f [] = returnTc []
173 mapTc f (x:xs) = f x `thenTc` \ r ->
174 mapTc f xs `thenTc` \ rs ->
176 mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
179 foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
180 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
181 foldrTc k z [] = returnTc z
182 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
185 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
186 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
187 foldlTc k z [] = returnTc z
188 foldlTc k z (x:xs) = k z x `thenTc` \r ->
191 mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
192 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
193 mapAndUnzipTc f [] = returnTc ([],[])
194 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
195 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
196 returnTc (r1:rs1, r2:rs2)
198 mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
199 mapAndUnzip3Tc f [] = returnTc ([],[],[])
200 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
201 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
202 returnTc (r1:rs1, r2:rs2, r3:rs3)
204 mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
205 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
207 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
209 returnTc (unionBags r1 r2))
210 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
214 fixTc :: (a -> TcM a) -> TcM a
215 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
216 fixTc m env down = fixIO (\ loop -> m loop env down)
217 {-# NOINLINE fixTc #-}
218 -- aargh! Not inlining fixTc alleviates a space leak problem.
219 -- Normally fixTc is used with a lazy tuple match: if the optimiser is
220 -- shown the definition of fixTc, it occasionally transforms the code
221 -- in such a way that the code generator doesn't spot the selector
224 recoverTc :: TcM r -> TcM r -> TcM r
225 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
226 recoverTc recover m down env
227 = catch (m down env) (\ _ -> recover down env)
229 returnNF_Tc = returnTc
233 recoverNF_Tc = recoverTc
238 mapAndUnzipNF_Tc = mapAndUnzipTc
239 mapBagNF_Tc = mapBagTc
242 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
243 thread. Ideally, this elegantly ensures that it can't zap any type
244 variables that belong to the main thread. But alas, the environment
245 contains TyCon and Class environments that include TcKind stuff,
246 which is a Royal Pain. By the time this fork stuff is used they'll
247 have been unified down so there won't be any kind variables, but we
248 can't express that in the current typechecker framework.
250 So we compromise and use unsafeInterleaveIO.
252 We throw away any error messages!
255 forkNF_Tc :: NF_TcM r -> NF_TcM r
256 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
258 -- Get a fresh unique supply
259 us <- readIORef u_var
260 let (us1, us2) = splitUniqSupply us
263 unsafeInterleaveIO (do {
264 us_var' <- newIORef us2 ;
265 err_var' <- newIORef (emptyBag,emptyBag) ;
266 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
268 -- ToDo: optionally dump any error messages
273 traceTc :: SDoc -> NF_TcM ()
274 traceTc doc (TcDown { tc_dflags=dflags }) env
275 | dopt Opt_D_dump_tc_trace dflags = printDump doc
276 | otherwise = return ()
278 ioToTc :: IO a -> NF_TcM a
279 ioToTc io down env = io
283 %************************************************************************
285 \subsection{Error handling}
287 %************************************************************************
290 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
292 = readIORef (getTcErrs down)
295 failTc down env = give_up
298 give_up = IOERROR (userError "Typecheck failed")
300 failWithTc :: Message -> TcM a -- Add an error message and fail
301 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
303 addErrTc :: Message -> NF_TcM ()
304 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
306 addErrsTc :: [Message] -> NF_TcM ()
307 addErrsTc [] = returnNF_Tc ()
308 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
310 -- The 'M' variants do the TidyEnv bit
311 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
312 failWithTcM env_and_msg
313 = addErrTcM env_and_msg `thenNF_Tc_`
316 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
317 checkTc True err = returnTc ()
318 checkTc False err = failWithTc err
320 checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
321 checkTcM True err = returnTc ()
322 checkTcM False err = err
324 checkMaybeTc :: Maybe val -> Message -> TcM val
325 checkMaybeTc (Just val) err = returnTc val
326 checkMaybeTc Nothing err = failWithTc err
328 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
329 checkMaybeTcM (Just val) err = returnTc val
330 checkMaybeTcM Nothing err = err
332 addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
333 addErrTcM (tidy_env, err_msg) down env
334 = add_err_tcm tidy_env err_msg ctxt loc down env
336 ctxt = getErrCtxt down
339 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
340 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
341 = add_err_tcm tidy_env err_msg full_ctxt loc down env
343 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
345 add_err_tcm tidy_env err_msg ctxt loc down env
347 (warns, errs) <- readIORef errs_var
348 ctxt_msgs <- do_ctxt tidy_env ctxt down env
349 let err = addShortErrLocLine loc $
350 vcat (err_msg : ctxt_to_use ctxt_msgs)
351 writeIORef errs_var (warns, errs `snocBag` err)
353 errs_var = getTcErrs down
355 do_ctxt tidy_env [] down env
357 do_ctxt tidy_env (c:cs) down env
359 (tidy_env', m) <- c tidy_env down env
360 ms <- do_ctxt tidy_env' cs down env
363 -- warnings don't have an 'M' variant
364 warnTc :: Bool -> Message -> NF_TcM ()
365 warnTc warn_if_true warn_msg down env
368 (warns,errs) <- readIORef errs_var
369 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
370 let warn = addShortWarnLocLine loc $
371 vcat (warn_msg : ctxt_to_use ctxt_msgs)
372 writeIORef errs_var (warns `snocBag` warn, errs)
376 errs_var = getTcErrs down
377 ctxt = getErrCtxt down
380 -- (tryTc r m) succeeds if m succeeds and generates no errors
381 -- If m fails then r is invoked, passing the warnings and errors from m
382 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
383 -- (it might have recovered internally)
384 -- If so, then r is invoked, passing the warnings and errors from m
386 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action
387 -> TcM r -- Thing to try
389 tryTc recover main down env
391 m_errs_var <- newIORef (emptyBag,emptyBag)
392 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
394 my_recover m_errs_var
395 = do warns_and_errs <- readIORef m_errs_var
396 recover warns_and_errs down env
399 = do result <- main (setTcErrs down m_errs_var) env
401 -- Check that m has no errors; if it has internal recovery
402 -- mechanisms it might "succeed" but having found a bunch of
403 -- errors along the way.
404 (m_warns, m_errs) <- readIORef m_errs_var
405 if isEmptyBag m_errs then
408 give_up -- This triggers the catch
411 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
412 -- If m fails then (checkNoErrsTc m) fails.
413 -- If m succeeds, it checks whether m generated any errors messages
414 -- (it might have recovered internally)
415 -- If so, it fails too.
416 -- Regardless, any errors generated by m are propagated to the enclosing context.
417 checkNoErrsTc :: TcM r -> TcM r
419 = tryTc my_recover main
421 my_recover (m_warns, m_errs) down env
422 = do (warns, errs) <- readIORef errs_var
423 writeIORef errs_var (warns `unionBags` m_warns,
424 errs `unionBags` m_errs)
427 errs_var = getTcErrs down
430 -- (tryTc_ r m) tries m; if it succeeds it returns it,
431 -- otherwise it returns r. Any error messages added by m are discarded,
432 -- whether or not m succeeds.
433 tryTc_ :: TcM r -> TcM r -> TcM r
435 = tryTc my_recover main
437 my_recover warns_and_errs = recover
439 -- (discardErrsTc m) runs m, but throw away all its error messages.
440 discardErrsTc :: Either_TcM r -> Either_TcM r
441 discardErrsTc main down env
442 = do new_errs_var <- newIORef (emptyBag,emptyBag)
443 main (setTcErrs down new_errs_var) env
448 %************************************************************************
450 \subsection{Mutable variables}
452 %************************************************************************
455 tcNewMutVar :: a -> NF_TcM (TcRef a)
456 tcNewMutVar val down env = newIORef val
458 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
459 tcWriteMutVar var val down env = writeIORef var val
461 tcReadMutVar :: TcRef a -> NF_TcM a
462 tcReadMutVar var down env = readIORef var
464 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
465 tcNewMutTyVar name kind down env = newMutTyVar name kind
467 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
468 tcNewSigTyVar name kind down env = newSigTyVar name kind
470 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
471 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
473 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
474 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
478 %************************************************************************
480 \subsection{The environment}
482 %************************************************************************
485 tcGetEnv :: NF_TcM TcEnv
486 tcGetEnv down env = return env
488 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
489 tcSetEnv new_env m down old_env = m down new_env
493 %************************************************************************
495 \subsection{Source location}
497 %************************************************************************
500 tcGetDefaultTys :: NF_TcM [Type]
501 tcGetDefaultTys down env = return (getDefaultTys down)
503 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
504 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
506 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
507 tcAddSrcLoc loc m down env = m (setLoc down loc) env
509 tcGetSrcLoc :: NF_TcM SrcLoc
510 tcGetSrcLoc down env = return (getLoc down)
512 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
513 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
515 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
517 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
518 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
520 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
522 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
523 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
525 tcPopErrCtxt :: Either_TcM r -> Either_TcM r
526 tcPopErrCtxt m down env = m (popErrCtxt down) env
530 %************************************************************************
532 \subsection{Unique supply}
534 %************************************************************************
537 tcGetUnique :: NF_TcM Unique
539 = do uniq_supply <- readIORef u_var
540 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
541 uniq = uniqFromSupply uniq_s
542 writeIORef u_var new_uniq_supply
545 u_var = getUniqSupplyVar down
547 tcGetUniques :: NF_TcM [Unique]
548 tcGetUniques down env
549 = do uniq_supply <- readIORef u_var
550 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
551 uniqs = uniqsFromSupply uniq_s
552 writeIORef u_var new_uniq_supply
555 u_var = getUniqSupplyVar down
557 uniqSMToTcM :: UniqSM a -> NF_TcM a
558 uniqSMToTcM m down env
559 = do uniq_supply <- readIORef u_var
560 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
561 writeIORef u_var new_uniq_supply
562 return (initUs_ uniq_s m)
564 u_var = getUniqSupplyVar down
569 %************************************************************************
573 %************************************************************************
578 tc_dflags :: DynFlags,
579 tc_def :: [Type], -- Types used for defaulting
580 tc_us :: (TcRef UniqSupply), -- Unique supply
581 tc_loc :: SrcLoc, -- Source location
582 tc_ctxt :: ErrCtxt, -- Error context
583 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
586 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
587 -- Innermost first. Monadic so that we have a chance
588 -- to deal with bound type variables just before error
589 -- message construction
592 -- These selectors are *local* to TcMonad.lhs
595 getTcErrs (TcDown{tc_errs=errs}) = errs
596 setTcErrs down errs = down{tc_errs=errs}
598 getDefaultTys (TcDown{tc_def=def}) = def
599 setDefaultTys down def = down{tc_def=def}
601 getLoc (TcDown{tc_loc=loc}) = loc
602 setLoc down loc = down{tc_loc=loc}
604 getUniqSupplyVar (TcDown{tc_us=us}) = us
606 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
607 setErrCtxt down msg = down{tc_ctxt=[msg]}
608 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
610 popErrCtxt down = case tc_ctxt down of
612 m : ms -> down{tc_ctxt = ms}
614 doptsTc :: DynFlag -> TcM Bool
615 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
616 = return (dopt dflag dflags)
618 getDOptsTc :: TcM DynFlags
619 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
626 %************************************************************************
628 \subsection{TypeChecking Errors}
630 %************************************************************************
633 type TcError = Message
634 type TcWarning = Message
636 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
637 | otherwise = takeAtMost 3 ctxt
639 takeAtMost :: Int -> [a] -> [a]
642 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
644 arityErr kind name n m
645 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
646 n_arguments <> comma, text "but has been given", int m]
648 n_arguments | n == 0 = ptext SLIT("no arguments")
649 | n == 1 = ptext SLIT("1 argument")
650 | True = hsep [int n, ptext SLIT("arguments")]
655 %************************************************************************
657 \subsection[Inst-origin]{The @InstOrigin@ type}
659 %************************************************************************
661 The @InstOrigin@ type gives information about where a dictionary came from.
662 This is important for decent error message reporting because dictionaries
663 don't appear in the original source code. Doubtless this type will evolve...
665 It appears in TcMonad because there are a couple of error-message-generation
666 functions that deal with it.
669 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
672 = OccurrenceOf Id -- Occurrence of an overloaded identifier
674 | IPOcc Name -- Occurrence of an implicit parameter
675 | IPBind Name -- Binding site of an implicit parameter
679 | DataDeclOrigin -- Typechecking a data declaration
681 | InstanceDeclOrigin -- Typechecking an instance decl
683 | LiteralOrigin HsOverLit -- Occurrence of a literal
685 | PatOrigin RenamedPat
687 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
689 | SignatureOrigin -- A dict created from a type signature
690 | Rank2Origin -- A dict created when typechecking the argument
691 -- of a rank-2 typed function
693 | DoOrigin -- The monad for a do expression
695 | ClassDeclOrigin -- Manufactured during a class decl
697 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
700 -- When specialising instances the instance info attached to
701 -- each class is not yet ready, so we record it inside the
702 -- origin information. This is a bit of a hack, but it works
703 -- fine. (Patrick is to blame [WDP].)
705 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
707 -- Argument or result of a ccall
708 -- Dictionaries with this origin aren't actually mentioned in the
709 -- translated term, and so need not be bound. Nor should they
710 -- be abstracted over.
712 | CCallOrigin String -- CCall label
713 (Maybe RenamedHsExpr) -- Nothing if it's the result
714 -- Just arg, for an argument
716 | LitLitOrigin String -- the litlit
718 | UnknownOrigin -- Help! I give up...
722 pprInstLoc :: InstLoc -> SDoc
723 pprInstLoc (orig, locn, ctxt)
724 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
726 pp_orig (OccurrenceOf id)
727 = hsep [ptext SLIT("use of"), quotes (ppr id)]
729 = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
730 pp_orig (IPBind name)
731 = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
732 pp_orig (LiteralOrigin lit)
733 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
734 pp_orig (PatOrigin pat)
735 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
736 pp_orig (InstanceDeclOrigin)
737 = ptext SLIT("the instance declaration")
738 pp_orig (ArithSeqOrigin seq)
739 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
740 pp_orig (SignatureOrigin)
741 = ptext SLIT("a type signature")
742 pp_orig (Rank2Origin)
743 = ptext SLIT("a function with an overloaded argument type")
745 = ptext SLIT("a do statement")
746 pp_orig (ClassDeclOrigin)
747 = ptext SLIT("a class declaration")
748 pp_orig (InstanceSpecOrigin clas ty)
749 = hsep [text "a SPECIALIZE instance pragma; class",
750 quotes (ppr clas), text "type:", ppr ty]
751 pp_orig (ValSpecOrigin name)
752 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
753 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
754 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
755 pp_orig (CCallOrigin clabel (Just arg_expr))
756 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
757 text "namely", quotes (ppr arg_expr)]
758 pp_orig (LitLitOrigin s)
759 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
760 pp_orig (UnknownOrigin)
761 = ptext SLIT("...oops -- I don't know where the overloading came from!")