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 errs_var = getTcErrs down
396 my_recover m_errs_var
397 = do warns_and_errs <- readIORef m_errs_var
398 recover warns_and_errs down env
401 = do result <- main (setTcErrs down m_errs_var) env
403 -- Check that m has no errors; if it has internal recovery
404 -- mechanisms it might "succeed" but having found a bunch of
405 -- errors along the way.
406 (m_warns, m_errs) <- readIORef m_errs_var
407 if isEmptyBag m_errs then
408 -- No errors, so return normally, but don't lose the warnings
409 if isEmptyBag m_warns then
412 do (warns, errs) <- readIORef errs_var
413 writeIORef errs_var (warns `unionBags` m_warns, errs)
416 give_up -- This triggers the catch
419 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
420 -- If m fails then (checkNoErrsTc m) fails.
421 -- If m succeeds, it checks whether m generated any errors messages
422 -- (it might have recovered internally)
423 -- If so, it fails too.
424 -- Regardless, any errors generated by m are propagated to the enclosing context.
425 checkNoErrsTc :: TcM r -> TcM r
427 = tryTc my_recover main
429 my_recover (m_warns, m_errs) down env
430 = do (warns, errs) <- readIORef errs_var
431 writeIORef errs_var (warns `unionBags` m_warns,
432 errs `unionBags` m_errs)
435 errs_var = getTcErrs down
438 -- (tryTc_ r m) tries m; if it succeeds it returns it,
439 -- otherwise it returns r. Any error messages added by m are discarded,
440 -- whether or not m succeeds.
441 tryTc_ :: TcM r -> TcM r -> TcM r
443 = tryTc my_recover main
445 my_recover warns_and_errs = recover
447 -- (discardErrsTc m) runs m, but throw away all its error messages.
448 discardErrsTc :: Either_TcM r -> Either_TcM r
449 discardErrsTc main down env
450 = do new_errs_var <- newIORef (emptyBag,emptyBag)
451 main (setTcErrs down new_errs_var) env
456 %************************************************************************
458 \subsection{Mutable variables}
460 %************************************************************************
463 tcNewMutVar :: a -> NF_TcM (TcRef a)
464 tcNewMutVar val down env = newIORef val
466 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
467 tcWriteMutVar var val down env = writeIORef var val
469 tcReadMutVar :: TcRef a -> NF_TcM a
470 tcReadMutVar var down env = readIORef var
472 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
473 tcNewMutTyVar name kind down env = newMutTyVar name kind
475 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
476 tcNewSigTyVar name kind down env = newSigTyVar name kind
478 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
479 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
481 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
482 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
486 %************************************************************************
488 \subsection{The environment}
490 %************************************************************************
493 tcGetEnv :: NF_TcM TcEnv
494 tcGetEnv down env = return env
496 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
497 tcSetEnv new_env m down old_env = m down new_env
501 %************************************************************************
503 \subsection{Source location}
505 %************************************************************************
508 tcGetDefaultTys :: NF_TcM [Type]
509 tcGetDefaultTys down env = return (getDefaultTys down)
511 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
512 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
514 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
515 tcAddSrcLoc loc m down env = m (setLoc down loc) env
517 tcGetSrcLoc :: NF_TcM SrcLoc
518 tcGetSrcLoc down env = return (getLoc down)
520 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
521 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
523 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
525 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
526 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
528 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
530 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
531 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
533 tcPopErrCtxt :: Either_TcM r -> Either_TcM r
534 tcPopErrCtxt m down env = m (popErrCtxt down) env
538 %************************************************************************
540 \subsection{Unique supply}
542 %************************************************************************
545 tcGetUnique :: NF_TcM Unique
547 = do uniq_supply <- readIORef u_var
548 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
549 uniq = uniqFromSupply uniq_s
550 writeIORef u_var new_uniq_supply
553 u_var = getUniqSupplyVar down
555 tcGetUniques :: NF_TcM [Unique]
556 tcGetUniques down env
557 = do uniq_supply <- readIORef u_var
558 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
559 uniqs = uniqsFromSupply uniq_s
560 writeIORef u_var new_uniq_supply
563 u_var = getUniqSupplyVar down
565 uniqSMToTcM :: UniqSM a -> NF_TcM a
566 uniqSMToTcM m down env
567 = do uniq_supply <- readIORef u_var
568 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
569 writeIORef u_var new_uniq_supply
570 return (initUs_ uniq_s m)
572 u_var = getUniqSupplyVar down
577 %************************************************************************
581 %************************************************************************
586 tc_dflags :: DynFlags,
587 tc_def :: [Type], -- Types used for defaulting
588 tc_us :: (TcRef UniqSupply), -- Unique supply
589 tc_loc :: SrcLoc, -- Source location
590 tc_ctxt :: ErrCtxt, -- Error context
591 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
594 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
595 -- Innermost first. Monadic so that we have a chance
596 -- to deal with bound type variables just before error
597 -- message construction
600 -- These selectors are *local* to TcMonad.lhs
603 getTcErrs (TcDown{tc_errs=errs}) = errs
604 setTcErrs down errs = down{tc_errs=errs}
606 getDefaultTys (TcDown{tc_def=def}) = def
607 setDefaultTys down def = down{tc_def=def}
609 getLoc (TcDown{tc_loc=loc}) = loc
610 setLoc down loc = down{tc_loc=loc}
612 getUniqSupplyVar (TcDown{tc_us=us}) = us
614 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
615 setErrCtxt down msg = down{tc_ctxt=[msg]}
616 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
618 popErrCtxt down = case tc_ctxt down of
620 m : ms -> down{tc_ctxt = ms}
622 doptsTc :: DynFlag -> TcM Bool
623 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
624 = return (dopt dflag dflags)
626 getDOptsTc :: TcM DynFlags
627 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
634 %************************************************************************
636 \subsection{TypeChecking Errors}
638 %************************************************************************
641 type TcError = Message
642 type TcWarning = Message
644 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
645 | otherwise = takeAtMost 3 ctxt
647 takeAtMost :: Int -> [a] -> [a]
650 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
652 arityErr kind name n m
653 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
654 n_arguments <> comma, text "but has been given", int m]
656 n_arguments | n == 0 = ptext SLIT("no arguments")
657 | n == 1 = ptext SLIT("1 argument")
658 | True = hsep [int n, ptext SLIT("arguments")]
663 %************************************************************************
665 \subsection[Inst-origin]{The @InstOrigin@ type}
667 %************************************************************************
669 The @InstOrigin@ type gives information about where a dictionary came from.
670 This is important for decent error message reporting because dictionaries
671 don't appear in the original source code. Doubtless this type will evolve...
673 It appears in TcMonad because there are a couple of error-message-generation
674 functions that deal with it.
677 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
680 = OccurrenceOf Id -- Occurrence of an overloaded identifier
682 | IPOcc Name -- Occurrence of an implicit parameter
683 | IPBind Name -- Binding site of an implicit parameter
687 | DataDeclOrigin -- Typechecking a data declaration
689 | InstanceDeclOrigin -- Typechecking an instance decl
691 | LiteralOrigin HsOverLit -- Occurrence of a literal
693 | PatOrigin RenamedPat
695 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
697 | SignatureOrigin -- A dict created from a type signature
698 | Rank2Origin -- A dict created when typechecking the argument
699 -- of a rank-2 typed function
701 | DoOrigin -- The monad for a do expression
703 | ClassDeclOrigin -- Manufactured during a class decl
705 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
708 -- When specialising instances the instance info attached to
709 -- each class is not yet ready, so we record it inside the
710 -- origin information. This is a bit of a hack, but it works
711 -- fine. (Patrick is to blame [WDP].)
713 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
715 -- Argument or result of a ccall
716 -- Dictionaries with this origin aren't actually mentioned in the
717 -- translated term, and so need not be bound. Nor should they
718 -- be abstracted over.
720 | CCallOrigin String -- CCall label
721 (Maybe RenamedHsExpr) -- Nothing if it's the result
722 -- Just arg, for an argument
724 | LitLitOrigin String -- the litlit
726 | UnknownOrigin -- Help! I give up...
730 pprInstLoc :: InstLoc -> SDoc
731 pprInstLoc (orig, locn, ctxt)
732 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
734 pp_orig (OccurrenceOf id)
735 = hsep [ptext SLIT("use of"), quotes (ppr id)]
737 = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
738 pp_orig (IPBind name)
739 = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
740 pp_orig (LiteralOrigin lit)
741 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
742 pp_orig (PatOrigin pat)
743 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
744 pp_orig (InstanceDeclOrigin)
745 = ptext SLIT("the instance declaration")
746 pp_orig (ArithSeqOrigin seq)
747 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
748 pp_orig (SignatureOrigin)
749 = ptext SLIT("a type signature")
750 pp_orig (Rank2Origin)
751 = ptext SLIT("a function with an overloaded argument type")
753 = ptext SLIT("a do statement")
754 pp_orig (ClassDeclOrigin)
755 = ptext SLIT("a class declaration")
756 pp_orig (InstanceSpecOrigin clas ty)
757 = hsep [text "a SPECIALIZE instance pragma; class",
758 quotes (ppr clas), text "type:", ppr ty]
759 pp_orig (ValSpecOrigin name)
760 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
761 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
762 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
763 pp_orig (CCallOrigin clabel (Just arg_expr))
764 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
765 text "namely", quotes (ppr arg_expr)]
766 pp_orig (LitLitOrigin s)
767 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
768 pp_orig (UnknownOrigin)
769 = ptext SLIT("...oops -- I don't know where the overloading came from!")