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, tcGetDFunUniq,
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 RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
51 import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
53 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
55 import Bag ( Bag, emptyBag, isEmptyBag,
56 foldBag, unitBag, unionBags, snocBag )
57 import Class ( Class )
59 import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
60 import VarEnv ( TidyEnv, emptyTidyEnv )
61 import VarSet ( TyVarSet )
62 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
63 splitUniqSupply, mkSplitUniqSupply,
65 import SrcLoc ( SrcLoc )
66 import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
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
129 -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
131 initTc dflags tc_env src_loc do_this
133 us <- mkSplitUniqSupply 'a' ;
134 us_var <- newIORef us ;
135 dfun_var <- newIORef emptyFM ;
136 errs_var <- newIORef (emptyBag,emptyBag) ;
137 tvs_var <- newIORef emptyUFM ;
140 init_down = TcDown dflags [] us_var dfun_var
145 maybe_res <- catch (do { res <- do_this init_down tc_env ;
147 (\_ -> return Nothing) ;
149 (warns,errs) <- readIORef errs_var ;
150 return (maybe_res, (warns, errs))
153 -- Monadic operations
155 returnNF_Tc :: a -> NF_TcM a
156 returnTc :: a -> TcM a
157 returnTc v down env = return v
159 thenTc :: TcM a -> (a -> TcM b) -> TcM b
160 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
161 thenTc m k down env = do { r <- m down env; k r down env }
163 thenTc_ :: TcM a -> TcM b -> TcM b
164 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
165 thenTc_ m k down env = do { m down env; k down env }
167 listTc :: [TcM a] -> TcM [a]
168 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
169 listTc [] = returnTc []
170 listTc (x:xs) = x `thenTc` \ r ->
171 listTc xs `thenTc` \ rs ->
174 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
175 mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
176 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
177 mapTc f [] = returnTc []
178 mapTc f (x:xs) = f x `thenTc` \ r ->
179 mapTc f xs `thenTc` \ rs ->
181 mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
184 foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
185 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
186 foldrTc k z [] = returnTc z
187 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
190 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
191 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
192 foldlTc k z [] = returnTc z
193 foldlTc k z (x:xs) = k z x `thenTc` \r ->
196 mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
197 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
198 mapAndUnzipTc f [] = returnTc ([],[])
199 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
200 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
201 returnTc (r1:rs1, r2:rs2)
203 mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
204 mapAndUnzip3Tc f [] = returnTc ([],[],[])
205 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
206 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
207 returnTc (r1:rs1, r2:rs2, r3:rs3)
209 mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
210 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
212 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
214 returnTc (unionBags r1 r2))
215 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
219 fixTc :: (a -> TcM a) -> TcM a
220 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
221 fixTc m env down = fixIO (\ loop -> m loop env down)
223 recoverTc :: TcM r -> TcM r -> TcM r
224 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
225 recoverTc recover m down env
226 = catch (m down env) (\ _ -> recover down env)
228 returnNF_Tc = returnTc
232 recoverNF_Tc = recoverTc
237 mapAndUnzipNF_Tc = mapAndUnzipTc
238 mapBagNF_Tc = mapBagTc
241 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
242 thread. Ideally, this elegantly ensures that it can't zap any type
243 variables that belong to the main thread. But alas, the environment
244 contains TyCon and Class environments that include TcKind stuff,
245 which is a Royal Pain. By the time this fork stuff is used they'll
246 have been unified down so there won't be any kind variables, but we
247 can't express that in the current typechecker framework.
249 So we compromise and use unsafeInterleaveSST.
251 We throw away any error messages!
254 forkNF_Tc :: NF_TcM r -> NF_TcM r
255 forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env
257 -- Get a fresh unique supply
258 us <- readIORef u_var
259 let (us1, us2) = splitUniqSupply us
262 unsafeInterleaveIO (do {
263 us_var' <- newIORef us2 ;
264 err_var' <- newIORef (emptyBag,emptyBag) ;
265 tv_var' <- newIORef emptyUFM ;
266 let { down' = TcDown dflags deflts us_var' df_var src_loc err_cxt err_var' } ;
268 -- ToDo: optionally dump any error messages
273 traceTc :: SDoc -> NF_TcM ()
274 traceTc doc down env = printErrs doc
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 tcGetDFunUniq :: String -> NF_TcM Int
565 tcGetDFunUniq key down env
566 = do dfun_supply <- readIORef d_var
567 let uniq = case lookupFM dfun_supply key of
570 let dfun_supply' = addToFM dfun_supply key uniq
571 writeIORef d_var dfun_supply'
574 d_var = getDFunSupplyVar down
578 %************************************************************************
582 %************************************************************************
587 tc_dflags :: DynFlags,
588 tc_def :: [Type], -- Types used for defaulting
590 tc_us :: (TcRef UniqSupply), -- Unique supply
591 tc_ds :: (TcRef DFunNameSupply), -- Name supply for
592 -- dictionary function names
594 tc_loc :: SrcLoc, -- Source location
595 tc_ctxt :: ErrCtxt, -- Error context
596 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
599 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
600 -- Innermost first. Monadic so that we have a chance
601 -- to deal with bound type variables just before error
602 -- message construction
604 type DFunNameSupply = FiniteMap String Int
605 -- This is used as a name supply for dictionary functions
606 -- From the inst decl we derive a string, usually by glomming together
607 -- the class and tycon name -- but it doesn't matter exactly how;
608 -- this map then gives a unique int for each inst decl with that
609 -- string. (In Haskell 98 there can only be one,
610 -- but not so in more extended versions; also class CC type T
611 -- and class C type TT might both give the string CCT
613 -- We could just use one Int for all the instance decls, but this
614 -- way the uniques change less when you add an instance decl,
615 -- hence less recompilation
618 -- These selectors are *local* to TcMonad.lhs
621 getTcErrs (TcDown{tc_errs=errs}) = errs
622 setTcErrs down errs = down{tc_errs=errs}
624 getDefaultTys (TcDown{tc_def=def}) = def
625 setDefaultTys down def = down{tc_def=def}
627 getLoc (TcDown{tc_loc=loc}) = loc
628 setLoc down loc = down{tc_loc=loc}
630 getUniqSupplyVar (TcDown{tc_us=us}) = us
631 getDFunSupplyVar (TcDown{tc_ds=ds}) = ds
633 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
634 setErrCtxt down msg = down{tc_ctxt=[msg]}
635 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
637 doptsTc :: DynFlag -> TcM Bool
638 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
639 = return (dopt dflag dflags)
641 getDOptsTc :: TcM DynFlags
642 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
649 %************************************************************************
651 \subsection{TypeChecking Errors}
653 %************************************************************************
656 type TcError = Message
657 type TcWarning = Message
659 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
660 | otherwise = takeAtMost 3 ctxt
662 takeAtMost :: Int -> [a] -> [a]
665 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
667 arityErr kind name n m
668 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
669 n_arguments <> comma, text "but has been given", int m]
671 n_arguments | n == 0 = ptext SLIT("no arguments")
672 | n == 1 = ptext SLIT("1 argument")
673 | True = hsep [int n, ptext SLIT("arguments")]
678 %************************************************************************
680 \subsection[Inst-origin]{The @InstOrigin@ type}
682 %************************************************************************
684 The @InstOrigin@ type gives information about where a dictionary came from.
685 This is important for decent error message reporting because dictionaries
686 don't appear in the original source code. Doubtless this type will evolve...
688 It appears in TcMonad because there are a couple of error-message-generation
689 functions that deal with it.
692 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
695 = OccurrenceOf Id -- Occurrence of an overloaded identifier
699 | DataDeclOrigin -- Typechecking a data declaration
701 | InstanceDeclOrigin -- Typechecking an instance decl
703 | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal
705 | PatOrigin RenamedPat
707 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
709 | SignatureOrigin -- A dict created from a type signature
710 | Rank2Origin -- A dict created when typechecking the argument
711 -- of a rank-2 typed function
713 | DoOrigin -- The monad for a do expression
715 | ClassDeclOrigin -- Manufactured during a class decl
717 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
720 -- When specialising instances the instance info attached to
721 -- each class is not yet ready, so we record it inside the
722 -- origin information. This is a bit of a hack, but it works
723 -- fine. (Patrick is to blame [WDP].)
725 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
727 -- Argument or result of a ccall
728 -- Dictionaries with this origin aren't actually mentioned in the
729 -- translated term, and so need not be bound. Nor should they
730 -- be abstracted over.
732 | CCallOrigin String -- CCall label
733 (Maybe RenamedHsExpr) -- Nothing if it's the result
734 -- Just arg, for an argument
736 | LitLitOrigin String -- the litlit
738 | UnknownOrigin -- Help! I give up...
742 pprInstLoc :: InstLoc -> SDoc
743 pprInstLoc (orig, locn, ctxt)
744 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
746 pp_orig (OccurrenceOf id)
747 = hsep [ptext SLIT("use of"), quotes (ppr id)]
748 pp_orig (LiteralOrigin lit)
749 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
750 pp_orig (PatOrigin pat)
751 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
752 pp_orig (InstanceDeclOrigin)
753 = ptext SLIT("an instance declaration")
754 pp_orig (ArithSeqOrigin seq)
755 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
756 pp_orig (SignatureOrigin)
757 = ptext SLIT("a type signature")
758 pp_orig (Rank2Origin)
759 = ptext SLIT("a function with an overloaded argument type")
761 = ptext SLIT("a do statement")
762 pp_orig (ClassDeclOrigin)
763 = ptext SLIT("a class declaration")
764 pp_orig (InstanceSpecOrigin clas ty)
765 = hsep [text "a SPECIALIZE instance pragma; class",
766 quotes (ppr clas), text "type:", ppr ty]
767 pp_orig (ValSpecOrigin name)
768 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
769 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
770 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
771 pp_orig (CCallOrigin clabel (Just arg_expr))
772 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
773 text "namely", quotes (ppr arg_expr)]
774 pp_orig (LitLitOrigin s)
775 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
776 pp_orig (UnknownOrigin)
777 = ptext SLIT("...oops -- I don't know where the overloading came from!")