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, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
25 addErrTcM, addInstErrTcM, failWithTcM,
28 tcGetDefaultTys, tcSetDefaultTys,
29 tcGetUnique, tcGetUniques, tcGetDFunUniq,
31 tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
32 tcAddErrCtxtM, tcSetErrCtxtM,
33 tcAddErrCtxt, tcSetErrCtxt,
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 RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
49 import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
51 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
52 import CmdLineOpts ( opt_PprStyle_Debug )
54 import Bag ( Bag, emptyBag, isEmptyBag,
55 foldBag, unitBag, unionBags, snocBag )
56 import Class ( Class )
58 import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
59 import VarEnv ( TidyEnv, emptyTidyEnv )
60 import VarSet ( TyVarSet )
61 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
63 import SrcLoc ( SrcLoc, noSrcLoc )
64 import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
65 import UniqFM ( UniqFM, emptyUFM )
66 import Unique ( Unique )
67 import BasicTypes ( Unused )
69 import FastString ( FastString )
71 import IOExts ( IORef, newIORef, readIORef, writeIORef,
72 unsafeInterleaveIO, fixIO
76 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
83 type TcTyVar = TyVar -- Might be a mutable tyvar
84 type TcTyVarSet = TyVarSet
86 type TcType = Type -- A TcType can have mutable type variables
87 -- Invariant on ForAllTy in TcTypes:
89 -- a cannot occur inside a MutTyVar in T; that is,
90 -- T is "flattened" before quantifying over a
92 type TcPredType = PredType
93 type TcThetaType = ThetaType
94 type TcRhoType = RhoType
95 type TcTauType = TauType
100 \section{TcM, NF_TcM: the type checker monads}
101 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
104 type NF_TcM s r = TcDown -> TcEnv -> IO r -- Can't raise UserError
105 type TcM s r = TcDown -> TcEnv -> IO r -- Can raise UserError
106 -- ToDo: nuke the 's' part
107 -- The difference between the two is
108 -- now for documentation purposes only
110 type Either_TcM s r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
111 -- Used only in this file for type signatures which
112 -- have a part that's polymorphic in whether it's NF_TcM or TcM
115 type TcRef a = IORef a
119 -- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
122 -> (TcRef (UniqFM a) -> TcEnv)
124 -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
126 initTc us initenv do_this
128 us_var <- newIORef us ;
129 dfun_var <- newIORef emptyFM ;
130 errs_var <- newIORef (emptyBag,emptyBag) ;
131 tvs_var <- newIORef emptyUFM ;
134 init_down = TcDown [] us_var dfun_var
137 init_env = initenv tvs_var
140 maybe_res <- catch (do { res <- do_this init_down init_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 s a
151 returnTc :: a -> TcM s a
152 returnTc v down env = return v
154 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
155 thenNF_Tc :: NF_TcM s a -> (a -> Either_TcM s b) -> Either_TcM s b
156 thenTc m k down env = do { r <- m down env; k r down env }
158 thenTc_ :: TcM s a -> TcM s b -> TcM s b
159 thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b
160 thenTc_ m k down env = do { m down env; k down env }
162 listTc :: [TcM s a] -> TcM s [a]
163 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
164 listTc [] = returnTc []
165 listTc (x:xs) = x `thenTc` \ r ->
166 listTc xs `thenTc` \ rs ->
169 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
170 mapTc_ :: (a -> TcM s b) -> [a] -> TcM s ()
171 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [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 s b) -> b -> [a] -> TcM s b
180 foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
181 foldrTc k z [] = returnTc z
182 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
185 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
186 foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
187 foldlTc k z [] = returnTc z
188 foldlTc k z (x:xs) = k z x `thenTc` \r ->
191 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
192 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([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 s (b,c,d)) -> [a] -> TcM s ([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 s b) -> Bag a -> TcM s (Bag b)
205 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (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 s a) -> TcM s a
215 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
216 fixTc m env down = fixIO (\ loop -> m loop env down)
218 recoverTc :: TcM s r -> TcM s r -> TcM s r
219 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
220 recoverTc recover m down env
221 = catch (m down env) (\ _ -> recover down env)
223 returnNF_Tc = returnTc
227 recoverNF_Tc = recoverTc
232 mapAndUnzipNF_Tc = mapAndUnzipTc
233 mapBagNF_Tc = mapBagTc
236 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
237 thread. Ideally, this elegantly ensures that it can't zap any type
238 variables that belong to the main thread. But alas, the environment
239 contains TyCon and Class environments that include TcKind stuff,
240 which is a Royal Pain. By the time this fork stuff is used they'll
241 have been unified down so there won't be any kind variables, but we
242 can't express that in the current typechecker framework.
244 So we compromise and use unsafeInterleaveSST.
246 We throw away any error messages!
249 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
250 forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env
252 -- Get a fresh unique supply
253 us <- readIORef u_var
254 let (us1, us2) = splitUniqSupply us
257 unsafeInterleaveIO (do {
258 us_var' <- newIORef us2 ;
259 err_var' <- newIORef (emptyBag,emptyBag) ;
260 tv_var' <- newIORef emptyUFM ;
261 let { down' = TcDown deflts us_var' df_var src_loc err_cxt err_var' } ;
263 -- ToDo: optionally dump any error messages
268 traceTc :: SDoc -> NF_TcM s ()
269 traceTc doc down env = printErrs doc
271 ioToTc :: IO a -> NF_TcM s a
272 ioToTc io down env = io
276 %************************************************************************
278 \subsection{Error handling}
280 %************************************************************************
283 getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
285 = readIORef (getTcErrs down)
288 failTc down env = give_up
291 give_up = IOERROR (userError "Typecheck failed")
293 failWithTc :: Message -> TcM s a -- Add an error message and fail
294 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
296 addErrTc :: Message -> NF_TcM s ()
297 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
299 -- The 'M' variants do the TidyEnv bit
300 failWithTcM :: (TidyEnv, Message) -> TcM s a -- Add an error message and fail
301 failWithTcM env_and_msg
302 = addErrTcM env_and_msg `thenNF_Tc_`
305 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
306 checkTc True err = returnTc ()
307 checkTc False err = failWithTc err
309 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
310 checkTcM True err = returnTc ()
311 checkTcM False err = err
313 checkMaybeTc :: Maybe val -> Message -> TcM s val
314 checkMaybeTc (Just val) err = returnTc val
315 checkMaybeTc Nothing err = failWithTc err
317 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
318 checkMaybeTcM (Just val) err = returnTc val
319 checkMaybeTcM Nothing err = err
321 addErrTcM :: (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail
322 addErrTcM (tidy_env, err_msg) down env
323 = add_err_tcm tidy_env err_msg ctxt loc down env
325 ctxt = getErrCtxt down
328 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail
329 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
330 = add_err_tcm tidy_env err_msg full_ctxt loc down env
332 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
334 add_err_tcm tidy_env err_msg ctxt loc down env
336 (warns, errs) <- readIORef errs_var
337 ctxt_msgs <- do_ctxt tidy_env ctxt down env
338 let err = addShortErrLocLine loc $
339 vcat (err_msg : ctxt_to_use ctxt_msgs)
340 writeIORef errs_var (warns, errs `snocBag` err)
342 errs_var = getTcErrs down
344 do_ctxt tidy_env [] down env
346 do_ctxt tidy_env (c:cs) down env
348 (tidy_env', m) <- c tidy_env down env
349 ms <- do_ctxt tidy_env' cs down env
352 -- warnings don't have an 'M' variant
353 warnTc :: Bool -> Message -> NF_TcM s ()
354 warnTc warn_if_true warn_msg down env
357 (warns,errs) <- readIORef errs_var
358 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
359 let warn = addShortWarnLocLine loc $
360 vcat (warn_msg : ctxt_to_use ctxt_msgs)
361 writeIORef errs_var (warns `snocBag` warn, errs)
365 errs_var = getTcErrs down
366 ctxt = getErrCtxt down
369 -- (tryTc r m) succeeds if m succeeds and generates no errors
370 -- If m fails then r is invoked, passing the warnings and errors from m
371 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
372 -- (it might have recovered internally)
373 -- If so, then r is invoked, passing the warnings and errors from m
375 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM s r) -- Recovery action
376 -> TcM s r -- Thing to try
378 tryTc recover main down env
380 m_errs_var <- newIORef (emptyBag,emptyBag)
381 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
383 my_recover m_errs_var
384 = do warns_and_errs <- readIORef m_errs_var
385 recover warns_and_errs down env
388 = do result <- main (setTcErrs down m_errs_var) env
390 -- Check that m has no errors; if it has internal recovery
391 -- mechanisms it might "succeed" but having found a bunch of
392 -- errors along the way.
393 (m_warns, m_errs) <- readIORef m_errs_var
394 if isEmptyBag m_errs then
397 give_up -- This triggers the catch
400 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
401 -- If m fails then (checkNoErrsTc m) fails.
402 -- If m succeeds, it checks whether m generated any errors messages
403 -- (it might have recovered internally)
404 -- If so, it fails too.
405 -- Regardless, any errors generated by m are propagated to the enclosing context.
406 checkNoErrsTc :: TcM s r -> TcM s r
408 = tryTc my_recover main
410 my_recover (m_warns, m_errs) down env
411 = do (warns, errs) <- readIORef errs_var
412 writeIORef errs_var (warns `unionBags` m_warns,
413 errs `unionBags` m_errs)
416 errs_var = getTcErrs down
419 -- (tryTc_ r m) tries m; if it succeeds it returns it,
420 -- otherwise it returns r. Any error messages added by m are discarded,
421 -- whether or not m succeeds.
422 tryTc_ :: TcM s r -> TcM s r -> TcM s r
424 = tryTc my_recover main
426 my_recover warns_and_errs = recover
428 -- (discardErrsTc m) runs m, but throw away all its error messages.
429 discardErrsTc :: Either_TcM s r -> Either_TcM s r
430 discardErrsTc main down env
431 = do new_errs_var <- newIORef (emptyBag,emptyBag)
432 main (setTcErrs down new_errs_var) env
438 tcNewMutVar :: a -> NF_TcM s (TcRef a)
439 tcNewMutVar val down env = newIORef val
441 tcWriteMutVar :: TcRef a -> a -> NF_TcM s ()
442 tcWriteMutVar var val down env = writeIORef var val
444 tcReadMutVar :: TcRef a -> NF_TcM s a
445 tcReadMutVar var down env = readIORef var
447 tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
448 tcNewMutTyVar name kind down env = newMutTyVar name kind
450 tcNewSigTyVar :: Name -> Kind -> NF_TcM s TyVar
451 tcNewSigTyVar name kind down env = newSigTyVar name kind
453 tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
454 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
456 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
457 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
464 tcGetEnv :: NF_TcM s TcEnv
465 tcGetEnv down env = return env
467 tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
468 tcSetEnv new_env m down old_env = m down new_env
475 tcGetDefaultTys :: NF_TcM s [Type]
476 tcGetDefaultTys down env = return (getDefaultTys down)
478 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
479 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
481 tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a
482 tcAddSrcLoc loc m down env = m (setLoc down loc) env
484 tcGetSrcLoc :: NF_TcM s SrcLoc
485 tcGetSrcLoc down env = return (getLoc down)
487 tcGetInstLoc :: InstOrigin -> NF_TcM s InstLoc
488 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
490 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message))
491 -> TcM s a -> TcM s a
492 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
493 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
495 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM s r -> Either_TcM s r
497 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
498 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
505 tcGetUnique :: NF_TcM s Unique
507 = do uniq_supply <- readIORef u_var
508 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
509 uniq = uniqFromSupply uniq_s
510 writeIORef u_var new_uniq_supply
513 u_var = getUniqSupplyVar down
515 tcGetUniques :: Int -> NF_TcM s [Unique]
516 tcGetUniques n down env
517 = do uniq_supply <- readIORef u_var
518 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
519 uniqs = uniqsFromSupply n uniq_s
520 writeIORef u_var new_uniq_supply
523 u_var = getUniqSupplyVar down
525 uniqSMToTcM :: UniqSM a -> NF_TcM s a
526 uniqSMToTcM m down env
527 = do uniq_supply <- readIORef u_var
528 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
529 writeIORef u_var new_uniq_supply
530 return (initUs_ uniq_s m)
532 u_var = getUniqSupplyVar down
536 \section{Dictionary function name supply
537 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
539 tcGetDFunUniq :: String -> NF_TcM s Int
540 tcGetDFunUniq key down env
541 = do dfun_supply <- readIORef d_var
542 let uniq = case lookupFM dfun_supply key of
545 let dfun_supply' = addToFM dfun_supply key uniq
546 writeIORef d_var dfun_supply'
549 d_var = getDFunSupplyVar down
559 [Type] -- Types used for defaulting
561 (TcRef UniqSupply) -- Unique supply
562 (TcRef DFunNameSupply) -- Name supply for dictionary function names
564 SrcLoc -- Source location
565 ErrCtxt -- Error context
566 (TcRef (Bag WarnMsg, Bag ErrMsg))
568 type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
569 -- Innermost first. Monadic so that we have a chance
570 -- to deal with bound type variables just before error
571 -- message construction
573 type DFunNameSupply = FiniteMap String Int
574 -- This is used as a name supply for dictionary functions
575 -- From the inst decl we derive a string, usually by glomming together
576 -- the class and tycon name -- but it doesn't matter exactly how;
577 -- this map then gives a unique int for each inst decl with that
578 -- string. (In Haskell 98 there can only be one,
579 -- but not so in more extended versions; also class CC type T
580 -- and class C type TT might both give the string CCT
582 -- We could just use one Int for all the instance decls, but this
583 -- way the uniques change less when you add an instance decl,
584 -- hence less recompilation
587 -- These selectors are *local* to TcMonad.lhs
590 getTcErrs (TcDown def us ds loc ctxt errs) = errs
591 setTcErrs (TcDown def us ds loc ctxt _ ) errs = TcDown def us ds loc ctxt errs
593 getDefaultTys (TcDown def us ds loc ctxt errs) = def
594 setDefaultTys (TcDown _ us ds loc ctxt errs) def = TcDown def us ds loc ctxt errs
596 getLoc (TcDown def us ds loc ctxt errs) = loc
597 setLoc (TcDown def us ds _ ctxt errs) loc = TcDown def us ds loc ctxt errs
599 getUniqSupplyVar (TcDown def us ds loc ctxt errs) = us
600 getDFunSupplyVar (TcDown def us ds loc ctxt errs) = ds
602 setErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc [msg] errs
603 addErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc (msg:ctxt) errs
604 getErrCtxt (TcDown def us ds loc ctxt errs) = ctxt
614 type TcError = Message
615 type TcWarning = Message
617 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
618 | otherwise = takeAtMost 3 ctxt
620 takeAtMost :: Int -> [a] -> [a]
623 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
625 arityErr kind name n m
626 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
627 n_arguments <> comma, text "but has been given", int m]
629 n_arguments | n == 0 = ptext SLIT("no arguments")
630 | n == 1 = ptext SLIT("1 argument")
631 | True = hsep [int n, ptext SLIT("arguments")]
636 %************************************************************************
638 \subsection[Inst-origin]{The @InstOrigin@ type}
640 %************************************************************************
642 The @InstOrigin@ type gives information about where a dictionary came from.
643 This is important for decent error message reporting because dictionaries
644 don't appear in the original source code. Doubtless this type will evolve...
646 It appears in TcMonad because there are a couple of error-message-generation
647 functions that deal with it.
650 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
653 = OccurrenceOf Id -- Occurrence of an overloaded identifier
657 | DataDeclOrigin -- Typechecking a data declaration
659 | InstanceDeclOrigin -- Typechecking an instance decl
661 | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal
663 | PatOrigin RenamedPat
665 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
667 | SignatureOrigin -- A dict created from a type signature
668 | Rank2Origin -- A dict created when typechecking the argument
669 -- of a rank-2 typed function
671 | DoOrigin -- The monad for a do expression
673 | ClassDeclOrigin -- Manufactured during a class decl
675 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
678 -- When specialising instances the instance info attached to
679 -- each class is not yet ready, so we record it inside the
680 -- origin information. This is a bit of a hack, but it works
681 -- fine. (Patrick is to blame [WDP].)
683 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
685 -- Argument or result of a ccall
686 -- Dictionaries with this origin aren't actually mentioned in the
687 -- translated term, and so need not be bound. Nor should they
688 -- be abstracted over.
690 | CCallOrigin String -- CCall label
691 (Maybe RenamedHsExpr) -- Nothing if it's the result
692 -- Just arg, for an argument
694 | LitLitOrigin String -- the litlit
696 | UnknownOrigin -- Help! I give up...
700 pprInstLoc :: InstLoc -> SDoc
701 pprInstLoc (orig, locn, ctxt)
702 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
704 pp_orig (OccurrenceOf id)
705 = hsep [ptext SLIT("use of"), quotes (ppr id)]
706 pp_orig (LiteralOrigin lit)
707 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
708 pp_orig (PatOrigin pat)
709 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
710 pp_orig (InstanceDeclOrigin)
711 = ptext SLIT("an instance declaration")
712 pp_orig (ArithSeqOrigin seq)
713 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
714 pp_orig (SignatureOrigin)
715 = ptext SLIT("a type signature")
716 pp_orig (Rank2Origin)
717 = ptext SLIT("a function with an overloaded argument type")
719 = ptext SLIT("a do statement")
720 pp_orig (ClassDeclOrigin)
721 = ptext SLIT("a class declaration")
722 pp_orig (InstanceSpecOrigin clas ty)
723 = hsep [text "a SPECIALIZE instance pragma; class",
724 quotes (ppr clas), text "type:", ppr ty]
725 pp_orig (ValSpecOrigin name)
726 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
727 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
728 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
729 pp_orig (CCallOrigin clabel (Just arg_expr))
730 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
731 text "namely", quotes (ppr arg_expr)]
732 pp_orig (LitLitOrigin s)
733 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
734 pp_orig (UnknownOrigin)
735 = ptext SLIT("...oops -- I don't know where the overloading came from!")