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
128 -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
130 initTc dflags tc_env do_this
132 us <- mkSplitUniqSupply 'a' ;
133 us_var <- newIORef us ;
134 dfun_var <- newIORef emptyFM ;
135 errs_var <- newIORef (emptyBag,emptyBag) ;
136 tvs_var <- newIORef emptyUFM ;
139 init_down = TcDown dflags [] us_var dfun_var
144 maybe_res <- catch (do { res <- do_this init_down tc_env ;
146 (\_ -> return Nothing) ;
148 (warns,errs) <- readIORef errs_var ;
149 return (maybe_res, (warns, errs))
152 -- Monadic operations
154 returnNF_Tc :: a -> NF_TcM a
155 returnTc :: a -> TcM a
156 returnTc v down env = return v
158 thenTc :: TcM a -> (a -> TcM b) -> TcM b
159 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
160 thenTc m k down env = do { r <- m down env; k r down env }
162 thenTc_ :: TcM a -> TcM b -> TcM b
163 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
164 thenTc_ m k down env = do { m down env; k down env }
166 listTc :: [TcM a] -> TcM [a]
167 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
168 listTc [] = returnTc []
169 listTc (x:xs) = x `thenTc` \ r ->
170 listTc xs `thenTc` \ rs ->
173 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
174 mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
175 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
176 mapTc f [] = returnTc []
177 mapTc f (x:xs) = f x `thenTc` \ r ->
178 mapTc f xs `thenTc` \ rs ->
180 mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
183 foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
184 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
185 foldrTc k z [] = returnTc z
186 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
189 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
190 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
191 foldlTc k z [] = returnTc z
192 foldlTc k z (x:xs) = k z x `thenTc` \r ->
195 mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
196 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
197 mapAndUnzipTc f [] = returnTc ([],[])
198 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
199 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
200 returnTc (r1:rs1, r2:rs2)
202 mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
203 mapAndUnzip3Tc f [] = returnTc ([],[],[])
204 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
205 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
206 returnTc (r1:rs1, r2:rs2, r3:rs3)
208 mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
209 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
211 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
213 returnTc (unionBags r1 r2))
214 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
218 fixTc :: (a -> TcM a) -> TcM a
219 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
220 fixTc m env down = fixIO (\ loop -> m loop env down)
222 recoverTc :: TcM r -> TcM r -> TcM r
223 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
224 recoverTc recover m down env
225 = catch (m down env) (\ _ -> recover down env)
227 returnNF_Tc = returnTc
231 recoverNF_Tc = recoverTc
236 mapAndUnzipNF_Tc = mapAndUnzipTc
237 mapBagNF_Tc = mapBagTc
240 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
241 thread. Ideally, this elegantly ensures that it can't zap any type
242 variables that belong to the main thread. But alas, the environment
243 contains TyCon and Class environments that include TcKind stuff,
244 which is a Royal Pain. By the time this fork stuff is used they'll
245 have been unified down so there won't be any kind variables, but we
246 can't express that in the current typechecker framework.
248 So we compromise and use unsafeInterleaveSST.
250 We throw away any error messages!
253 forkNF_Tc :: NF_TcM r -> NF_TcM r
254 forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env
256 -- Get a fresh unique supply
257 us <- readIORef u_var
258 let (us1, us2) = splitUniqSupply us
261 unsafeInterleaveIO (do {
262 us_var' <- newIORef us2 ;
263 err_var' <- newIORef (emptyBag,emptyBag) ;
264 tv_var' <- newIORef emptyUFM ;
265 let { down' = TcDown dflags deflts us_var' df_var src_loc err_cxt err_var' } ;
267 -- ToDo: optionally dump any error messages
272 traceTc :: SDoc -> NF_TcM ()
273 traceTc doc down env = printErrs doc
275 ioToTc :: IO a -> NF_TcM a
276 ioToTc io down env = io
280 %************************************************************************
282 \subsection{Error handling}
284 %************************************************************************
287 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
289 = readIORef (getTcErrs down)
292 failTc down env = give_up
295 give_up = IOERROR (userError "Typecheck failed")
297 failWithTc :: Message -> TcM a -- Add an error message and fail
298 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
300 addErrTc :: Message -> NF_TcM ()
301 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
303 addErrsTc :: [Message] -> NF_TcM ()
304 addErrsTc [] = returnNF_Tc ()
305 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
307 -- The 'M' variants do the TidyEnv bit
308 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
309 failWithTcM env_and_msg
310 = addErrTcM env_and_msg `thenNF_Tc_`
313 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
314 checkTc True err = returnTc ()
315 checkTc False err = failWithTc err
317 checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
318 checkTcM True err = returnTc ()
319 checkTcM False err = err
321 checkMaybeTc :: Maybe val -> Message -> TcM val
322 checkMaybeTc (Just val) err = returnTc val
323 checkMaybeTc Nothing err = failWithTc err
325 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
326 checkMaybeTcM (Just val) err = returnTc val
327 checkMaybeTcM Nothing err = err
329 addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
330 addErrTcM (tidy_env, err_msg) down env
331 = add_err_tcm tidy_env err_msg ctxt loc down env
333 ctxt = getErrCtxt down
336 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
337 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
338 = add_err_tcm tidy_env err_msg full_ctxt loc down env
340 full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
342 add_err_tcm tidy_env err_msg ctxt loc down env
344 (warns, errs) <- readIORef errs_var
345 ctxt_msgs <- do_ctxt tidy_env ctxt down env
346 let err = addShortErrLocLine loc $
347 vcat (err_msg : ctxt_to_use ctxt_msgs)
348 writeIORef errs_var (warns, errs `snocBag` err)
350 errs_var = getTcErrs down
352 do_ctxt tidy_env [] down env
354 do_ctxt tidy_env (c:cs) down env
356 (tidy_env', m) <- c tidy_env down env
357 ms <- do_ctxt tidy_env' cs down env
360 -- warnings don't have an 'M' variant
361 warnTc :: Bool -> Message -> NF_TcM ()
362 warnTc warn_if_true warn_msg down env
365 (warns,errs) <- readIORef errs_var
366 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
367 let warn = addShortWarnLocLine loc $
368 vcat (warn_msg : ctxt_to_use ctxt_msgs)
369 writeIORef errs_var (warns `snocBag` warn, errs)
373 errs_var = getTcErrs down
374 ctxt = getErrCtxt down
377 -- (tryTc r m) succeeds if m succeeds and generates no errors
378 -- If m fails then r is invoked, passing the warnings and errors from m
379 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
380 -- (it might have recovered internally)
381 -- If so, then r is invoked, passing the warnings and errors from m
383 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action
384 -> TcM r -- Thing to try
386 tryTc recover main down env
388 m_errs_var <- newIORef (emptyBag,emptyBag)
389 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
391 my_recover m_errs_var
392 = do warns_and_errs <- readIORef m_errs_var
393 recover warns_and_errs down env
396 = do result <- main (setTcErrs down m_errs_var) env
398 -- Check that m has no errors; if it has internal recovery
399 -- mechanisms it might "succeed" but having found a bunch of
400 -- errors along the way.
401 (m_warns, m_errs) <- readIORef m_errs_var
402 if isEmptyBag m_errs then
405 give_up -- This triggers the catch
408 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
409 -- If m fails then (checkNoErrsTc m) fails.
410 -- If m succeeds, it checks whether m generated any errors messages
411 -- (it might have recovered internally)
412 -- If so, it fails too.
413 -- Regardless, any errors generated by m are propagated to the enclosing context.
414 checkNoErrsTc :: TcM r -> TcM r
416 = tryTc my_recover main
418 my_recover (m_warns, m_errs) down env
419 = do (warns, errs) <- readIORef errs_var
420 writeIORef errs_var (warns `unionBags` m_warns,
421 errs `unionBags` m_errs)
424 errs_var = getTcErrs down
427 -- (tryTc_ r m) tries m; if it succeeds it returns it,
428 -- otherwise it returns r. Any error messages added by m are discarded,
429 -- whether or not m succeeds.
430 tryTc_ :: TcM r -> TcM r -> TcM r
432 = tryTc my_recover main
434 my_recover warns_and_errs = recover
436 -- (discardErrsTc m) runs m, but throw away all its error messages.
437 discardErrsTc :: Either_TcM r -> Either_TcM r
438 discardErrsTc main down env
439 = do new_errs_var <- newIORef (emptyBag,emptyBag)
440 main (setTcErrs down new_errs_var) env
445 %************************************************************************
447 \subsection{Mutable variables}
449 %************************************************************************
452 tcNewMutVar :: a -> NF_TcM (TcRef a)
453 tcNewMutVar val down env = newIORef val
455 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
456 tcWriteMutVar var val down env = writeIORef var val
458 tcReadMutVar :: TcRef a -> NF_TcM a
459 tcReadMutVar var down env = readIORef var
461 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
462 tcNewMutTyVar name kind down env = newMutTyVar name kind
464 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
465 tcNewSigTyVar name kind down env = newSigTyVar name kind
467 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
468 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
470 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
471 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
475 %************************************************************************
477 \subsection{The environment}
479 %************************************************************************
482 tcGetEnv :: NF_TcM TcEnv
483 tcGetEnv down env = return env
485 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
486 tcSetEnv new_env m down old_env = m down new_env
490 %************************************************************************
492 \subsection{Source location}
494 %************************************************************************
497 tcGetDefaultTys :: NF_TcM [Type]
498 tcGetDefaultTys down env = return (getDefaultTys down)
500 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
501 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
503 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
504 tcAddSrcLoc loc m down env = m (setLoc down loc) env
506 tcGetSrcLoc :: NF_TcM SrcLoc
507 tcGetSrcLoc down env = return (getLoc down)
509 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
510 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
512 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
514 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
515 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
517 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
519 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
520 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
524 %************************************************************************
526 \subsection{Unique supply}
528 %************************************************************************
531 tcGetUnique :: NF_TcM Unique
533 = do uniq_supply <- readIORef u_var
534 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
535 uniq = uniqFromSupply uniq_s
536 writeIORef u_var new_uniq_supply
539 u_var = getUniqSupplyVar down
541 tcGetUniques :: Int -> NF_TcM [Unique]
542 tcGetUniques n down env
543 = do uniq_supply <- readIORef u_var
544 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
545 uniqs = uniqsFromSupply n uniq_s
546 writeIORef u_var new_uniq_supply
549 u_var = getUniqSupplyVar down
551 uniqSMToTcM :: UniqSM a -> NF_TcM a
552 uniqSMToTcM m down env
553 = do uniq_supply <- readIORef u_var
554 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
555 writeIORef u_var new_uniq_supply
556 return (initUs_ uniq_s m)
558 u_var = getUniqSupplyVar down
563 tcGetDFunUniq :: String -> NF_TcM Int
564 tcGetDFunUniq key down env
565 = do dfun_supply <- readIORef d_var
566 let uniq = case lookupFM dfun_supply key of
569 let dfun_supply' = addToFM dfun_supply key uniq
570 writeIORef d_var dfun_supply'
573 d_var = getDFunSupplyVar down
577 %************************************************************************
581 %************************************************************************
586 tc_dflags :: DynFlags,
587 tc_def :: [Type], -- Types used for defaulting
589 tc_us :: (TcRef UniqSupply), -- Unique supply
590 tc_ds :: (TcRef DFunNameSupply), -- Name supply for
591 -- dictionary function names
593 tc_loc :: SrcLoc, -- Source location
594 tc_ctxt :: ErrCtxt, -- Error context
595 tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
598 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
599 -- Innermost first. Monadic so that we have a chance
600 -- to deal with bound type variables just before error
601 -- message construction
603 type DFunNameSupply = FiniteMap String Int
604 -- This is used as a name supply for dictionary functions
605 -- From the inst decl we derive a string, usually by glomming together
606 -- the class and tycon name -- but it doesn't matter exactly how;
607 -- this map then gives a unique int for each inst decl with that
608 -- string. (In Haskell 98 there can only be one,
609 -- but not so in more extended versions; also class CC type T
610 -- and class C type TT might both give the string CCT
612 -- We could just use one Int for all the instance decls, but this
613 -- way the uniques change less when you add an instance decl,
614 -- hence less recompilation
617 -- These selectors are *local* to TcMonad.lhs
620 getTcErrs (TcDown{tc_errs=errs}) = errs
621 setTcErrs down errs = down{tc_errs=errs}
623 getDefaultTys (TcDown{tc_def=def}) = def
624 setDefaultTys down def = down{tc_def=def}
626 getLoc (TcDown{tc_loc=loc}) = loc
627 setLoc down loc = down{tc_loc=loc}
629 getUniqSupplyVar (TcDown{tc_us=us}) = us
630 getDFunSupplyVar (TcDown{tc_ds=ds}) = ds
632 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
633 setErrCtxt down msg = down{tc_ctxt=[msg]}
634 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
636 doptsTc :: DynFlag -> TcM Bool
637 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
638 = return (dopt dflag dflags)
640 getDOptsTc :: TcM DynFlags
641 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
648 %************************************************************************
650 \subsection{TypeChecking Errors}
652 %************************************************************************
655 type TcError = Message
656 type TcWarning = Message
658 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
659 | otherwise = takeAtMost 3 ctxt
661 takeAtMost :: Int -> [a] -> [a]
664 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
666 arityErr kind name n m
667 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
668 n_arguments <> comma, text "but has been given", int m]
670 n_arguments | n == 0 = ptext SLIT("no arguments")
671 | n == 1 = ptext SLIT("1 argument")
672 | True = hsep [int n, ptext SLIT("arguments")]
677 %************************************************************************
679 \subsection[Inst-origin]{The @InstOrigin@ type}
681 %************************************************************************
683 The @InstOrigin@ type gives information about where a dictionary came from.
684 This is important for decent error message reporting because dictionaries
685 don't appear in the original source code. Doubtless this type will evolve...
687 It appears in TcMonad because there are a couple of error-message-generation
688 functions that deal with it.
691 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
694 = OccurrenceOf Id -- Occurrence of an overloaded identifier
698 | DataDeclOrigin -- Typechecking a data declaration
700 | InstanceDeclOrigin -- Typechecking an instance decl
702 | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal
704 | PatOrigin RenamedPat
706 | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
708 | SignatureOrigin -- A dict created from a type signature
709 | Rank2Origin -- A dict created when typechecking the argument
710 -- of a rank-2 typed function
712 | DoOrigin -- The monad for a do expression
714 | ClassDeclOrigin -- Manufactured during a class decl
716 | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
719 -- When specialising instances the instance info attached to
720 -- each class is not yet ready, so we record it inside the
721 -- origin information. This is a bit of a hack, but it works
722 -- fine. (Patrick is to blame [WDP].)
724 | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
726 -- Argument or result of a ccall
727 -- Dictionaries with this origin aren't actually mentioned in the
728 -- translated term, and so need not be bound. Nor should they
729 -- be abstracted over.
731 | CCallOrigin String -- CCall label
732 (Maybe RenamedHsExpr) -- Nothing if it's the result
733 -- Just arg, for an argument
735 | LitLitOrigin String -- the litlit
737 | UnknownOrigin -- Help! I give up...
741 pprInstLoc :: InstLoc -> SDoc
742 pprInstLoc (orig, locn, ctxt)
743 = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
745 pp_orig (OccurrenceOf id)
746 = hsep [ptext SLIT("use of"), quotes (ppr id)]
747 pp_orig (LiteralOrigin lit)
748 = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
749 pp_orig (PatOrigin pat)
750 = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
751 pp_orig (InstanceDeclOrigin)
752 = ptext SLIT("an instance declaration")
753 pp_orig (ArithSeqOrigin seq)
754 = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
755 pp_orig (SignatureOrigin)
756 = ptext SLIT("a type signature")
757 pp_orig (Rank2Origin)
758 = ptext SLIT("a function with an overloaded argument type")
760 = ptext SLIT("a do statement")
761 pp_orig (ClassDeclOrigin)
762 = ptext SLIT("a class declaration")
763 pp_orig (InstanceSpecOrigin clas ty)
764 = hsep [text "a SPECIALIZE instance pragma; class",
765 quotes (ppr clas), text "type:", ppr ty]
766 pp_orig (ValSpecOrigin name)
767 = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
768 pp_orig (CCallOrigin clabel Nothing{-ccall result-})
769 = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
770 pp_orig (CCallOrigin clabel (Just arg_expr))
771 = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
772 text "namely", quotes (ppr arg_expr)]
773 pp_orig (LitLitOrigin s)
774 = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
775 pp_orig (UnknownOrigin)
776 = ptext SLIT("...oops -- I don't know where the overloading came from!")