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, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
25 addErrTcM, addInstErrTcM, failWithTcM,
28 tcGetDefaultTys, tcSetDefaultTys,
29 tcGetUnique, tcGetUniques, tcGetDFunUniq,
32 tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
33 tcAddErrCtxtM, tcSetErrCtxtM,
34 tcAddErrCtxt, tcSetErrCtxt,
36 tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
37 tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
39 InstOrigin(..), InstLoc, pprInstLoc,
41 TcError, TcWarning, TidyEnv, emptyTidyEnv,
45 #include "HsVersions.h"
47 import {-# SOURCE #-} TcEnv ( TcEnv )
49 import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
50 import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
52 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
53 import CmdLineOpts ( DynFlags, opt_PprStyle_Debug )
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, noSrcLoc )
66 import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
67 import UniqFM ( UniqFM, emptyUFM )
68 import Unique ( Unique )
69 import BasicTypes ( Unused )
71 import FastString ( FastString )
73 import IOExts ( IORef, newIORef, readIORef, writeIORef,
74 unsafeInterleaveIO, fixIO
78 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
82 %************************************************************************
86 %************************************************************************
89 type TcTyVar = TyVar -- Might be a mutable tyvar
90 type TcTyVarSet = TyVarSet
92 type TcType = Type -- A TcType can have mutable type variables
93 -- Invariant on ForAllTy in TcTypes:
95 -- a cannot occur inside a MutTyVar in T; that is,
96 -- T is "flattened" before quantifying over a
98 type TcPredType = PredType
99 type TcThetaType = ThetaType
100 type TcRhoType = RhoType
101 type TcTauType = TauType
106 %************************************************************************
108 \subsection{The main monads: TcM, NF_TcM}
110 %************************************************************************
113 type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
114 type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
115 -- ToDo: nuke the 's' part
116 -- The difference between the two is
117 -- now for documentation purposes only
119 type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
120 -- Used only in this file for type signatures which
121 -- have a part that's polymorphic in whether it's NF_TcM or TcM
124 type TcRef a = IORef a
133 -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
135 initTc dflags tc_env src_loc do_this
137 us <- mkSplitUniqSupply 'a' ;
138 us_var <- newIORef us ;
139 dfun_var <- newIORef emptyFM ;
140 errs_var <- newIORef (emptyBag,emptyBag) ;
141 tvs_var <- newIORef emptyUFM ;
144 init_down = TcDown dflags [] us_var dfun_var
149 maybe_res <- catch (do { res <- do_this init_down tc_env ;
151 (\_ -> return Nothing) ;
153 (warns,errs) <- readIORef errs_var ;
154 return (maybe_res, (warns, errs))
157 -- Monadic operations
159 returnNF_Tc :: a -> NF_TcM a
160 returnTc :: a -> TcM a
161 returnTc v down env = return v
163 thenTc :: TcM a -> (a -> TcM b) -> TcM b
164 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
165 thenTc m k down env = do { r <- m down env; k r down env }
167 thenTc_ :: TcM a -> TcM b -> TcM b
168 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
169 thenTc_ m k down env = do { m down env; k down env }
171 listTc :: [TcM a] -> TcM [a]
172 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
173 listTc [] = returnTc []
174 listTc (x:xs) = x `thenTc` \ r ->
175 listTc xs `thenTc` \ rs ->
178 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
179 mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
180 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
181 mapTc f [] = returnTc []
182 mapTc f (x:xs) = f x `thenTc` \ r ->
183 mapTc f xs `thenTc` \ rs ->
185 mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
188 foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
189 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
190 foldrTc k z [] = returnTc z
191 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
194 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
195 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
196 foldlTc k z [] = returnTc z
197 foldlTc k z (x:xs) = k z x `thenTc` \r ->
200 mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
201 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
202 mapAndUnzipTc f [] = returnTc ([],[])
203 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
204 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
205 returnTc (r1:rs1, r2:rs2)
207 mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
208 mapAndUnzip3Tc f [] = returnTc ([],[],[])
209 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
210 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
211 returnTc (r1:rs1, r2:rs2, r3:rs3)
213 mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
214 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
216 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
218 returnTc (unionBags r1 r2))
219 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
223 fixTc :: (a -> TcM a) -> TcM a
224 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
225 fixTc m env down = fixIO (\ loop -> m loop env down)
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 unsafeInterleaveSST.
255 We throw away any error messages!
258 forkNF_Tc :: NF_TcM r -> NF_TcM r
259 forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_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 tv_var' <- newIORef emptyUFM ;
270 let { down' = TcDown dflags deflts us_var' df_var src_loc err_cxt err_var' } ;
272 -- ToDo: optionally dump any error messages
277 traceTc :: SDoc -> NF_TcM ()
278 traceTc doc down env = printErrs doc
280 ioToTc :: IO a -> NF_TcM a
281 ioToTc io down env = io
285 %************************************************************************
287 \subsection{Error handling}
289 %************************************************************************
292 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
294 = readIORef (getTcErrs down)
297 failTc down env = give_up
300 give_up = IOERROR (userError "Typecheck failed")
302 failWithTc :: Message -> TcM a -- Add an error message and fail
303 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
305 addErrTc :: Message -> NF_TcM ()
306 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
308 addErrsTc :: [Message] -> NF_TcM ()
309 addErrsTc [] = returnNF_Tc ()
310 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
312 -- The 'M' variants do the TidyEnv bit
313 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
314 failWithTcM env_and_msg
315 = addErrTcM env_and_msg `thenNF_Tc_`
318 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
319 checkTc True err = returnTc ()
320 checkTc False err = failWithTc err
322 checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
323 checkTcM True err = returnTc ()
324 checkTcM False err = err
326 checkMaybeTc :: Maybe val -> Message -> TcM val
327 checkMaybeTc (Just val) err = returnTc val
328 checkMaybeTc Nothing err = failWithTc err
330 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
331 checkMaybeTcM (Just val) err = returnTc val
332 checkMaybeTcM Nothing err = err
334 addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
335 addErrTcM (tidy_env, err_msg) down env
336 = add_err_tcm tidy_env err_msg ctxt loc down env
338 ctxt = getErrCtxt down
341 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
342 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
343 = add_err_tcm tidy_env err_msg full_ctxt loc down env
345 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
347 add_err_tcm tidy_env err_msg ctxt loc down env
349 (warns, errs) <- readIORef errs_var
350 ctxt_msgs <- do_ctxt tidy_env ctxt down env
351 let err = addShortErrLocLine loc $
352 vcat (err_msg : ctxt_to_use ctxt_msgs)
353 writeIORef errs_var (warns, errs `snocBag` err)
355 errs_var = getTcErrs down
357 do_ctxt tidy_env [] down env
359 do_ctxt tidy_env (c:cs) down env
361 (tidy_env', m) <- c tidy_env down env
362 ms <- do_ctxt tidy_env' cs down env
365 -- warnings don't have an 'M' variant
366 warnTc :: Bool -> Message -> NF_TcM ()
367 warnTc warn_if_true warn_msg down env
370 (warns,errs) <- readIORef errs_var
371 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
372 let warn = addShortWarnLocLine loc $
373 vcat (warn_msg : ctxt_to_use ctxt_msgs)
374 writeIORef errs_var (warns `snocBag` warn, errs)
378 errs_var = getTcErrs down
379 ctxt = getErrCtxt down
382 -- (tryTc r m) succeeds if m succeeds and generates no errors
383 -- If m fails then r is invoked, passing the warnings and errors from m
384 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
385 -- (it might have recovered internally)
386 -- If so, then r is invoked, passing the warnings and errors from m
388 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action
389 -> TcM r -- Thing to try
391 tryTc recover main down env
393 m_errs_var <- newIORef (emptyBag,emptyBag)
394 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
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
410 give_up -- This triggers the catch
413 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
414 -- If m fails then (checkNoErrsTc m) fails.
415 -- If m succeeds, it checks whether m generated any errors messages
416 -- (it might have recovered internally)
417 -- If so, it fails too.
418 -- Regardless, any errors generated by m are propagated to the enclosing context.
419 checkNoErrsTc :: TcM r -> TcM r
421 = tryTc my_recover main
423 my_recover (m_warns, m_errs) down env
424 = do (warns, errs) <- readIORef errs_var
425 writeIORef errs_var (warns `unionBags` m_warns,
426 errs `unionBags` m_errs)
429 errs_var = getTcErrs down
432 -- (tryTc_ r m) tries m; if it succeeds it returns it,
433 -- otherwise it returns r. Any error messages added by m are discarded,
434 -- whether or not m succeeds.
435 tryTc_ :: TcM r -> TcM r -> TcM r
437 = tryTc my_recover main
439 my_recover warns_and_errs = recover
441 -- (discardErrsTc m) runs m, but throw away all its error messages.
442 discardErrsTc :: Either_TcM r -> Either_TcM r
443 discardErrsTc main down env
444 = do new_errs_var <- newIORef (emptyBag,emptyBag)
445 main (setTcErrs down new_errs_var) env
450 %************************************************************************
452 \subsection{Mutable variables}
454 %************************************************************************
457 tcNewMutVar :: a -> NF_TcM (TcRef a)
458 tcNewMutVar val down env = newIORef val
460 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
461 tcWriteMutVar var val down env = writeIORef var val
463 tcReadMutVar :: TcRef a -> NF_TcM a
464 tcReadMutVar var down env = readIORef var
466 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
467 tcNewMutTyVar name kind down env = newMutTyVar name kind
469 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
470 tcNewSigTyVar name kind down env = newSigTyVar name kind
472 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
473 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
475 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
476 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
480 %************************************************************************
482 \subsection{The environment}
484 %************************************************************************
487 tcGetEnv :: NF_TcM TcEnv
488 tcGetEnv down env = return env
490 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
491 tcSetEnv new_env m down old_env = m down new_env
495 %************************************************************************
497 \subsection{Source location}
499 %************************************************************************
502 tcGetDefaultTys :: NF_TcM [Type]
503 tcGetDefaultTys down env = return (getDefaultTys down)
505 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
506 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
508 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
509 tcAddSrcLoc loc m down env = m (setLoc down loc) env
511 tcGetSrcLoc :: NF_TcM SrcLoc
512 tcGetSrcLoc down env = return (getLoc down)
514 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
515 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
517 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
519 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
520 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
522 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
524 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
525 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
529 %************************************************************************
531 \subsection{Unique supply}
533 %************************************************************************
536 tcGetUnique :: NF_TcM Unique
538 = do uniq_supply <- readIORef u_var
539 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
540 uniq = uniqFromSupply uniq_s
541 writeIORef u_var new_uniq_supply
544 u_var = getUniqSupplyVar down
546 tcGetUniques :: Int -> NF_TcM [Unique]
547 tcGetUniques n down env
548 = do uniq_supply <- readIORef u_var
549 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
550 uniqs = uniqsFromSupply n uniq_s
551 writeIORef u_var new_uniq_supply
554 u_var = getUniqSupplyVar down
556 uniqSMToTcM :: UniqSM a -> NF_TcM a
557 uniqSMToTcM m down env
558 = do uniq_supply <- readIORef u_var
559 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
560 writeIORef u_var new_uniq_supply
561 return (initUs_ uniq_s m)
563 u_var = getUniqSupplyVar down
568 tcGetDFunUniq :: String -> NF_TcM Int
569 tcGetDFunUniq key down env
570 = do dfun_supply <- readIORef d_var
571 let uniq = case lookupFM dfun_supply key of
574 let dfun_supply' = addToFM dfun_supply key uniq
575 writeIORef d_var dfun_supply'
578 d_var = getDFunSupplyVar down
582 %************************************************************************
586 %************************************************************************
591 tc_dflags :: DynFlags,
592 tc_def :: [Type], -- Types used for defaulting
594 tc_us :: (TcRef UniqSupply), -- Unique supply
595 tc_ds :: (TcRef DFunNameSupply), -- Name supply for
596 -- dictionary function names
598 tc_loc :: SrcLoc, -- Source location
599 tc_ctxt :: ErrCtxt, -- Error context
600 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
603 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
604 -- Innermost first. Monadic so that we have a chance
605 -- to deal with bound type variables just before error
606 -- message construction
608 type DFunNameSupply = FiniteMap String Int
609 -- This is used as a name supply for dictionary functions
610 -- From the inst decl we derive a string, usually by glomming together
611 -- the class and tycon name -- but it doesn't matter exactly how;
612 -- this map then gives a unique int for each inst decl with that
613 -- string. (In Haskell 98 there can only be one,
614 -- but not so in more extended versions; also class CC type T
615 -- and class C type TT might both give the string CCT
617 -- We could just use one Int for all the instance decls, but this
618 -- way the uniques change less when you add an instance decl,
619 -- hence less recompilation
622 -- These selectors are *local* to TcMonad.lhs
625 getTcErrs (TcDown{tc_errs=errs}) = errs
626 setTcErrs down errs = down{tc_errs=errs}
628 getDefaultTys (TcDown{tc_def=def}) = def
629 setDefaultTys down def = down{tc_def=def}
631 getLoc (TcDown{tc_loc=loc}) = loc
632 setLoc down loc = down{tc_loc=loc}
634 getUniqSupplyVar (TcDown{tc_us=us}) = us
635 getDFunSupplyVar (TcDown{tc_ds=ds}) = ds
637 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
638 setErrCtxt down msg = down{tc_ctxt=[msg]}
639 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
641 doptsTc :: (DynFlags -> Bool) -> TcM Bool
642 doptsTc dopt (TcDown{tc_dflags=dflags}) env_down
643 = return (dopt dflags)
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!")