Commit c024af13 authored by Eric Seidel's avatar Eric Seidel Committed by Austin Seipp

Expose source locations via Implicit Parameters of type GHC.Location.Location

Summary:
IPs with this type will always be solved for the current source
location. If another IP of the same type is in scope, the two locations will be
appended, creating a call-stack. The Location type is kept abstract so users
cannot create them, but a Location can be turned into a list of SrcLocs, which
correspond to individual locations in a program. Each SrcLoc contains a
package/module/file name and start/end lines and columns.

The only thing missing from the SrcLoc in my opinion is the name of the
top-level definition it inhabits. I suspect that would also be useful, but it's
not clear to me how to extract the current top-level binder from within the
constraint solver. (Surely I'm just missing something here?)

I made the (perhaps controversial) decision to have GHC completely ignore
the names of Location IPs, meaning that in the following code:

    bar :: (?myloc :: Location) => String
    bar = foo

    foo :: (?loc :: Location) => String
    foo = show ?loc

if I call `bar`, the resulting call-stack will include locations for

1. the use of `?loc` inside `foo`,
2. `foo`s call-site inside `bar`, and
3. `bar`s call-site, wherever that may be.

This makes Location IPs very special indeed, and I'm happy to change it if the
dissonance is too great.

I've also left out any changes to base to make use of Location IPs, since there
were some concerns about a snowball effect. I think it would be reasonable to
mark this as an experimental feature for now (it is!), and defer using it in
base until we have more experience with it. It is, after all, quite easy to
define your own version of `error`, `undefined`, etc. that use Location IPs.

Test Plan: validate, new test-case is testsuite/tests/typecheck/should_run/IPLocation.hs

Reviewers: austin, hvr, simonpj

Reviewed By: simonpj

Subscribers: simonmar, rodlogic, carter, thomie

Differential Revision: https://phabricator.haskell.org/D578

GHC Trac Issues: #9049
parent c77eecdc
......@@ -36,19 +36,19 @@ import CoreArity ( etaExpand )
import CoreUnfold
import CoreFVs
import UniqSupply
import Unique( Unique )
import Digraph
import PrelNames
import TyCon ( isTupleTyCon, tyConDataCons_maybe )
import TcEvidence
import TcType
import Type
import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon, mkListTy
, mkBoxedTupleTy, stringTy )
import Id
import Class
import DataCon ( dataConWorkId )
import DataCon ( dataConTyCon, dataConWorkId )
import Name
import MkId ( seqId )
import IdInfo ( IdDetails(..) )
......@@ -57,6 +57,7 @@ import VarSet
import Rules
import VarEnv
import Outputable
import Module
import SrcLoc
import Maybes
import OrdList
......@@ -876,6 +877,61 @@ dsEvTerm (EvLit l) =
EvNum n -> mkIntegerExpr n
EvStr s -> mkStringExprFS s
dsEvTerm (EvCallStack cs) = dsEvCallStack cs
dsEvCallStack :: EvCallStack -> DsM CoreExpr
-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
dsEvCallStack cs = do
df <- getDynFlags
m <- getModule
srcLocDataCon <- dsLookupDataCon srcLocDataConName
let srcLocTyCon = dataConTyCon srcLocDataCon
let srcLocTy = mkTyConTy srcLocTyCon
let mkSrcLoc l =
liftM (mkCoreConApps srcLocDataCon)
(sequence [ mkStringExprFS (packageKeyFS $ modulePackageKey m)
, mkStringExprFS (moduleNameFS $ moduleName m)
, mkStringExprFS (srcSpanFile l)
, return $ mkIntExprInt df (srcSpanStartLine l)
, return $ mkIntExprInt df (srcSpanStartCol l)
, return $ mkIntExprInt df (srcSpanEndLine l)
, return $ mkIntExprInt df (srcSpanEndCol l)
])
let callSiteTy = mkBoxedTupleTy [stringTy, srcLocTy]
matchId <- newSysLocalDs $ mkListTy callSiteTy
callStackDataCon <- dsLookupDataCon callStackDataConName
let callStackTyCon = dataConTyCon callStackDataCon
let callStackTy = mkTyConTy callStackTyCon
let emptyCS = mkCoreConApps callStackDataCon [mkNilExpr callSiteTy]
let pushCS name loc rest =
mkWildCase rest callStackTy callStackTy
[( DataAlt callStackDataCon
, [matchId]
, mkCoreConApps callStackDataCon
[mkConsExpr callSiteTy
(mkCoreTup [name, loc])
(Var matchId)]
)]
let mkPush name loc tm = do
nameExpr <- mkStringExprFS name
locExpr <- mkSrcLoc loc
case tm of
EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)
_ -> do tmExpr <- dsEvTerm tm
-- at this point tmExpr :: IP sym CallStack
-- but we need the actual CallStack to pass to pushCS,
-- so we use unwrapIP to strip the dictionary wrapper
-- See Note [Overview of implicit CallStacks]
let ip_co = unwrapIP (exprType tmExpr)
return (pushCS nameExpr locExpr (mkCast tmExpr ip_co))
case cs of
EvCsTop name loc tm -> mkPush name loc tm
EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
EvCsEmpty -> panic "Cannot have an empty CallStack"
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
-- This is the crucial function that moves
......
......@@ -323,6 +323,10 @@ basicKnownKeyNames
-- Implicit parameters
ipClassName,
-- Source locations
callStackDataConName, callStackTyConName,
srcLocDataConName,
-- Annotation type checking
toAnnotationWrapperName
......@@ -455,6 +459,12 @@ gHC_IP = mkBaseModule (fsLit "GHC.IP")
gHC_PARR' :: Module
gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
gHC_SRCLOC :: Module
gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")
gHC_STACK :: Module
gHC_STACK = mkBaseModule (fsLit "GHC.Stack")
gHC_STATICPTR :: Module
gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
......@@ -1167,6 +1177,15 @@ knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolCl
ipClassName :: Name
ipClassName = clsQual gHC_IP (fsLit "IP") ipClassNameKey
-- Source Locations
callStackDataConName, callStackTyConName, srcLocDataConName :: Name
callStackDataConName
= conName gHC_STACK (fsLit "CallStack") callStackDataConKey
callStackTyConName
= tcQual gHC_STACK (fsLit "CallStack") callStackTyConKey
srcLocDataConName
= conName gHC_SRCLOC (fsLit "SrcLoc") srcLocDataConKey
-- plugins
pLUGINS :: Module
pLUGINS = mkThisGhcModule (fsLit "Plugins")
......@@ -1517,6 +1536,9 @@ staticPtrTyConKey = mkPreludeTyConUnique 180
staticPtrInfoTyConKey :: Unique
staticPtrInfoTyConKey = mkPreludeTyConUnique 181
callStackTyConKey :: Unique
callStackTyConKey = mkPreludeTyConUnique 182
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
-----------------------------------------------------
......@@ -1589,6 +1611,10 @@ staticPtrInfoDataConKey = mkPreludeDataConUnique 34
fingerprintDataConKey :: Unique
fingerprintDataConKey = mkPreludeDataConUnique 35
callStackDataConKey, srcLocDataConKey :: Unique
callStackDataConKey = mkPreludeDataConUnique 36
srcLocDataConKey = mkPreludeDataConUnique 37
{-
************************************************************************
* *
......
......@@ -646,5 +646,3 @@ tyVarsOfImplic (Implic { ic_skols = skols
tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
......@@ -56,7 +56,6 @@ import BasicTypes
import Outputable
import FastString
import Type(mkStrLitTy)
import Class(classTyCon)
import PrelNames(ipClassName)
import TcValidity (checkValidType)
......@@ -253,10 +252,8 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
-- Coerces a `t` into a dictionry for `IP "x" t`.
-- co : t -> IP "x" t
toDict ipClass x ty =
case unwrapNewTyCon_maybe (classTyCon ipClass) of
Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcSymCo $ mkTcUnbranchedAxInstCo Representational ax [x,ty]
Nothing -> panic "The dictionary for `IP` is not a newtype?"
toDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
wrapIP $ mkClassPred ipClass [x,ty]
{-
Note [Implicit parameter untouchables]
......
......@@ -16,6 +16,7 @@ module TcEvidence (
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
EvTerm(..), mkEvCast, evVarsOfTerm,
EvLit(..), evTermCoercion,
EvCallStack(..),
-- TcCoercion
TcCoercion(..), LeftOrRight(..), pickLR,
......@@ -27,7 +28,8 @@ module TcEvidence (
mkTcAxiomRuleCo, mkTcPhantomCo,
tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo,
isTcReflCo, getTcCoVar_maybe,
tcCoercionRole, eqVarRole
tcCoercionRole, eqVarRole,
unwrapIP, wrapIP
) where
#include "HsVersions.h"
......@@ -54,6 +56,7 @@ import Data.Traversable (traverse, sequenceA)
import qualified Data.Data as Data
import Outputable
import FastString
import SrcLoc
import Data.IORef( IORef )
{-
......@@ -722,13 +725,27 @@ data EvTerm
| EvLit EvLit -- Dictionary for KnownNat and KnownSymbol classes.
-- Note [KnownNat & KnownSymbol and EvLit]
deriving( Data.Data, Data.Typeable)
| EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters
deriving( Data.Data, Data.Typeable )
data EvLit
= EvNum Integer
| EvStr FastString
deriving( Data.Data, Data.Typeable)
deriving( Data.Data, Data.Typeable )
-- | Evidence for @CallStack@ implicit parameters.
data EvCallStack
-- See Note [Overview of implicit CallStacks]
= EvCsEmpty
| EvCsPushCall Name RealSrcSpan EvTerm
-- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at
-- @loc@, in a calling context @stk@.
| EvCsTop FastString RealSrcSpan EvTerm
-- ^ @EvCsTop name loc stk@ represents a use of an implicit parameter
-- @?name@, occurring at @loc@, in a calling context @stk@.
deriving( Data.Data, Data.Typeable )
{-
Note [Coercion evidence terms]
......@@ -819,6 +836,119 @@ The story for kind `Symbol` is analogous:
* class KnownSymbol
* newtype SSymbol
* Evidence: EvLit (EvStr n)
Note [Overview of implicit CallStacks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(See https://ghc.haskell.org/trac/ghc/wiki/ExplicitCallStack/ImplicitLocations)
The goal of CallStack evidence terms is to reify locations
in the program source as runtime values, without any support
from the RTS. We accomplish this by assigning a special meaning
to implicit parameters of type GHC.Stack.CallStack. A use of
a CallStack IP, e.g.
head [] = error (show (?loc :: CallStack))
head (x:_) = x
will be solved with the source location that gave rise to the IP
constraint (here, the use of ?loc). If there is already
a CallStack IP in scope, e.g. passed-in as an argument
head :: (?loc :: CallStack) => [a] -> a
head [] = error (show (?loc :: CallStack))
head (x:_) = x
we will push the new location onto the CallStack that was passed
in. These two cases are reflected by the EvCallStack evidence
type. In the first case, we will create an evidence term
EvCsTop "?loc" <?loc's location> EvCsEmpty
and in the second we'll have a given constraint
[G] d :: IP "loc" CallStack
in scope, and will create an evidence term
EvCsTop "?loc" <?loc's location> d
When we call a function that uses a CallStack IP, e.g.
f = head xs
we create an evidence term
EvCsPushCall "head" <head's location> EvCsEmpty
again pushing onto a given evidence term if one exists.
This provides a lightweight mechanism for building up call-stacks
explicitly, but is notably limited by the fact that the stack will
stop at the first function whose type does not include a CallStack IP.
For example, using the above definition of head:
f :: [a] -> a
f = head
g = f []
the resulting CallStack will include use of ?loc inside head and
the call to head inside f, but NOT the call to f inside g, because f
did not explicitly request a CallStack.
Important Details:
- GHC should NEVER report an insoluble CallStack constraint.
- A CallStack (defined in GHC.Stack) is a [(String, SrcLoc)], where the String
is the name of the binder that is used at the SrcLoc. SrcLoc is defined in
GHC.SrcLoc and contains the package/module/file name, as well as the full
source-span. Both CallStack and SrcLoc are kept abstract so only GHC can
construct new values.
- Consider the use of ?stk in:
head :: (?stk :: CallStack) => [a] -> a
head [] = error (show ?stk)
When solving the use of ?stk we'll have a given
[G] d :: IP "stk" CallStack
in scope. In the interaction phase, GHC would normally solve the use of ?stk
directly from the given, i.e. re-using the dicionary. But this is NOT what we
want! We want to generate a *new* CallStack with ?loc's SrcLoc pushed onto
the given CallStack. So we must take care in TcInteract.interactDict to
prioritize solving wanted CallStacks.
- We will automatically solve any wanted CallStack regardless of the name of the
IP, i.e.
f = show (?stk :: CallStack)
g = show (?loc :: CallStack)
are both valid. However, we will only push new SrcLocs onto existing
CallStacks when the IP names match, e.g. in
head :: (?loc :: CallStack) => [a] -> a
head [] = error (show (?stk :: CallStack))
the printed CallStack will NOT include head's call-site. This reflects the
standard scoping rules of implicit-parameters. (See TcInteract.interactDict)
- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`.
The desugarer will need to unwrap the IP newtype before pushing a new
call-site onto a given stack (See DsBinds.dsEvCallStack)
- We only want to intercept constraints that arose due to the use of an IP or a
function call. In particular, we do NOT want to intercept the
(?stk :: CallStack) => [a] -> a
~
(?stk :: CallStack) => [a] -> a
constraint that arises from the ambiguity check on `head`s type signature.
(See TcEvidence.isCallStackIP)
-}
mkEvCast :: EvTerm -> TcCoercion -> EvTerm
......@@ -853,10 +983,17 @@ evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo c
evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs
evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
evVarsOfTerm (EvLit _) = emptyVarSet
evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs
evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm
evVarsOfCallStack :: EvCallStack -> VarSet
evVarsOfCallStack cs = case cs of
EvCsEmpty -> emptyVarSet
EvCsTop _ _ tm -> evVarsOfTerm tm
EvCsPushCall _ _ tm -> evVarsOfTerm tm
{-
************************************************************************
* *
......@@ -920,9 +1057,40 @@ instance Outputable EvTerm where
ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
ppr (EvLit l) = ppr l
ppr (EvCallStack cs) = ppr cs
ppr (EvDelayedError ty msg) = ptext (sLit "error")
<+> sep [ char '@' <> ppr ty, ppr msg ]
instance Outputable EvLit where
ppr (EvNum n) = integer n
ppr (EvStr s) = text (show s)
instance Outputable EvCallStack where
ppr EvCsEmpty
= ptext (sLit "[]")
ppr (EvCsTop name loc tm)
= angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm
ppr (EvCsPushCall name loc tm)
= angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm
----------------------------------------------------------------------
-- Helper functions for dealing with IP newtype-dictionaries
----------------------------------------------------------------------
-- | Create a 'Coercion' that unwraps an implicit-parameter dictionary
-- to expose the underlying value. We expect the 'Type' to have the form
-- `IP sym ty`, return a 'Coercion' `co :: IP sym ty ~ ty`.
unwrapIP :: Type -> Coercion
unwrapIP ty =
case unwrapNewTyCon_maybe tc of
Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys
Nothing -> pprPanic "unwrapIP" $
text "The dictionary for" <+> quotes (ppr tc)
<+> text "is not a newtype!"
where
(tc, tys) = splitTyConApp ty
-- | Create a 'Coercion' that wraps a value in an implicit-parameter
-- dictionary. See 'unwrapIP'.
wrapIP :: Type -> Coercion
wrapIP ty = mkSymCo (unwrapIP ty)
......@@ -196,10 +196,8 @@ tcExpr (HsIPVar x) res_ty
; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty }
where
-- Coerces a dictionary for `IP "x" t` into `t`.
fromDict ipClass x ty =
case unwrapNewTyCon_maybe (classTyCon ipClass) of
Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcUnbranchedAxInstCo Representational ax [x,ty]
Nothing -> panic "The dictionary for `IP` is not a newtype?"
fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
unwrapIP $ mkClassPred ipClass [x,ty]
tcExpr (HsLam match) res_ty
= do { (co_fn, match') <- tcMatchLambda match res_ty
......
......@@ -1246,6 +1246,13 @@ zonkEvTerm env (EvTupleSel tm n) = do { tm' <- zonkEvTerm env tm
zonkEvTerm env (EvTupleMk tms) = do { tms' <- mapM (zonkEvTerm env) tms
; return (EvTupleMk tms') }
zonkEvTerm _ (EvLit l) = return (EvLit l)
zonkEvTerm env (EvCallStack cs)
= case cs of
EvCsEmpty -> return (EvCallStack cs)
EvCsTop n l tm -> do { tm' <- zonkEvTerm env tm
; return (EvCallStack (EvCsTop n l tm')) }
EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm
; return (EvCallStack (EvCsPushCall n l tm')) }
zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
; return (EvSuperClass d' n) }
zonkEvTerm env (EvDFunApp df tys tms)
......
......@@ -8,6 +8,8 @@ module TcInteract (
#include "HsVersions.h"
import BasicTypes ()
import HsTypes ( hsIPNameFS )
import FastString
import TcCanonical
import TcFlatten
import VarSet
......@@ -18,7 +20,8 @@ import CoAxiom(sfInteractTop, sfInteractInert)
import Var
import TcType
import PrelNames (knownNatClassName, knownSymbolClassName, ipClassNameKey )
import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey,
callStackTyConKey )
import Id( idType )
import Class
import TyCon
......@@ -42,7 +45,6 @@ import Control.Monad
import Maybes( isJust )
import Pair (Pair(..))
import Unique( hasKey )
import FastString ( sLit )
import DynFlags
import Util
......@@ -606,6 +608,26 @@ interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
-- don't ever try to solve CallStack IPs directly from other dicts,
-- we always build new dicts instead.
-- See Note [Overview of implicit CallStacks]
| [_ip, ty] <- tys
, isWanted ev_w
, Just mkEvCs <- isCallStackIP (ctEvLoc ev_w) cls ty
= do let ev_cs =
case lookupInertDict inerts (ctEvLoc ev_w) cls tys of
Just ev | isGiven ev -> mkEvCs (ctEvTerm ev)
_ -> mkEvCs (EvCallStack EvCsEmpty)
-- now we have ev_cs :: CallStack, but the evidence term should
-- be a dictionary, so we have to coerce ev_cs to a
-- dictionary for `IP ip CallStack`
let ip_ty = mkClassPred cls tys
let ev_tm = mkEvCast (EvCallStack ev_cs) (TcCoercion $ wrapIP ip_ty)
addSolvedDict ev_w cls tys
setWantedEvBind (ctEvId ev_w) ev_tm
stopWith ev_w "Wanted CallStack IP"
| Just ctev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys
= do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w
; case inert_effect of
......@@ -1732,3 +1754,23 @@ overlapping checks. There we are interested in validating the following principl
But for the Given Overlap check our goal is just related to completeness of
constraint solving.
-}
-- | Is the constraint for an implicit CallStack parameter?
isCallStackIP :: CtLoc -> Class -> Type -> Maybe (EvTerm -> EvCallStack)
isCallStackIP loc cls ty
| Just (tc, []) <- splitTyConApp_maybe ty
, cls `hasKey` ipClassNameKey && tc `hasKey` callStackTyConKey
= occOrigin (ctLocOrigin loc)
where
-- We only want to grab constraints that arose due to the use of an IP or a
-- function call. See Note [Overview of implicit CallStacks]
occOrigin (OccurrenceOf n)
= Just (EvCsPushCall n locSpan)
occOrigin (IPOccOrigin n)
= Just (EvCsTop ('?' `consFS` hsIPNameFS n) locSpan)
occOrigin _
= Nothing
locSpan
= ctLocSpan loc
isCallStackIP _ _ _
= Nothing
......@@ -34,6 +34,32 @@
TODO FIXME.
</para>
</listitem>
<listitem>
<para>
Implicit parameters of the new base type
<literal>GHC.Stack.CallStack</literal> are treated
specially, and automatically solved for the current source
location. For example
<programlisting>
f = print (?stk :: CallStack)
</programlisting>
will print the singleton stack containing the occurrence of
<literal>?stk</literal>. If there is another
<literal>CallStack</literal> implicit in-scope, the new location
will be appended to the existing stack, e.g.
<programlisting>
f :: (?stk :: CallStack) => IO ()
f = print (?stk :: CallStack)
</programlisting>
will print the occurrence of <literal>?stk</literal> and the
call-site of <literal>f</literal>. The name of the implicit
parameter does not matter.
</para>
<para>
See the release notes for base for a description of the
<literal>CallStack</literal> type.
</para>
</listitem>
</itemizedlist>
</sect3>
......@@ -129,6 +155,23 @@
Version number XXXXX (was 4.7.0.0)
</para>
</listitem>
<listitem>
<para>
A new module <literal>GHC.SrcLoc</literal> was added,
exporting a new type <literal>SrcLoc</literal>. A
<literal>SrcLoc</literal> contains package, module,
and file names, as well as start and end positions.
</para>
</listitem>
<listitem>
<para>
A new type <literal>CallStack</literal> was added for use
with the new implicit callstack parameters. A
<literal>CallStack</literal> is a
<literal>[(String, SrcLoc)]</literal>, sorted by most-recent
call.
</para>
</listitem>
</itemizedlist>
</sect3>
......
......@@ -7701,6 +7701,56 @@ inner binding of <literal>?x</literal>, so <literal>(f 9)</literal> will return
<literal>14</literal>.
</para>
</sect3>
<sect3><title>Special implicit parameters</title>
<para>
GHC treats implicit parameters of type <literal>GHC.Stack.CallStack</literal>
specially, by resolving them to the current location in the program. Consider:
<programlisting>
f :: String
f = show (?loc :: CallStack)
</programlisting>
GHC will automatically resolve <literal>?loc</literal> to its source
location. If another implicit parameter with type <literal>CallStack</literal> is
in scope, GHC will append the two locations, creating an explicit call-stack. For example:
<programlisting>
f :: (?stk :: CallStack) => String
f = show (?stk :: CallStack)
</programlisting>
will produce the location of <literal>?stk</literal>, followed by
<literal>f</literal>'s call-site. Note that the name of the implicit parameter does not
matter (we used <literal>?loc</literal> above), GHC will solve any implicit parameter
with the right type. The name does, however, matter when pushing new locations onto
existing stacks. Consider:
<programlisting>
f :: (?stk :: CallStack) => String
f = show (?loc :: CallStack)
</programlisting>
When we call <literal>f</literal>, the stack will include the use of <literal>?loc</literal>,
but not the call to <literal>f</literal>; in this case the names must match.
</para>
<para>
<literal>CallStack</literal> is kept abstract, but
GHC provides a function
<programlisting>
getCallStack :: CallStack -> [(String, SrcLoc)]
</programlisting>
to access the individual call-sites in the stack. The <literal>String</literal>
is the name of the function that was called, and the <literal>SrcLoc</literal>
provides the package, module, and file name, as well as the line and column
numbers. The stack will never be empty, as the first call-site
will be the location at which the implicit parameter was used. GHC will also
never infer <literal>?loc :: CallStack</literal> as a type constraint, which
means that functions must explicitly ask to be told about their call-sites.
</para>
<para>
A potential "gotcha" when using implicit <literal>CallStack</literal>s is that
the <literal>:type</literal> command in GHCi will not report the
<literal>?loc :: CallStack</literal> constraint, as the typechecker will
immediately solve it. Use <literal>:info</literal> instead to print the
unsolved type.
</para>
</sect3>
</sect2>
<sect2 id="kinding">
......
{-# LANGUAGE RecordWildCards #-}
module GHC.SrcLoc
( SrcLoc
, srcLocPackage
, srcLocModule
, srcLocFile
, srcLocStartLine
, srcLocStartCol
, srcLocEndLine
, srcLocEndCol
-- * Pretty printing
, showSrcLoc
) where
-- | A single location in the source code.
data SrcLoc = SrcLoc
{ srcLocPackage :: String
, srcLocModule :: String
, srcLocFile :: String
, srcLocStartLine :: Int
, srcLocStartCol :: Int
, srcLocEndLine :: Int
, srcLocEndCol :: Int
} deriving (Show, Eq)
showSrcLoc :: SrcLoc -> String
showSrcLoc SrcLoc {..}
= concat [ srcLocFile, ":"
, show srcLocStartLine, ":"
, show srcLocStartCol, " in "
, srcLocPackage, ":", srcLocModule
]
......@@ -17,11 +17,17 @@
{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
module GHC.Stack (
-- * Call stack
-- * Call stacks
-- ** Simulated by the RTS
currentCallStack,
whoCreated,
errorWithStackTrace,
-- ** Explicitly created via implicit-parameters
CallStack,
getCallStack,
showCallStack,
-- * Internals
CostCentreStack,
CostCentre,
......@@ -36,6 +42,8 @@ module GHC.Stack (
renderStack
) where
import Data.List ( unlines )
import Foreign
import Foreign.C
......@@ -46,6 +54,8 @@ import GHC.Foreign as GHC
import GHC.IO.Encoding
import GHC.Exception
import GHC.List ( concatMap, null, reverse )
import GHC.Show
import GHC.SrcLoc
#define PROFILING
#include "Rts.h"
......@@ -128,3 +138,48 @@ errorWithStackTrace x = unsafeDupablePerformIO $ do
if null stack
then throwIO (ErrorCall x)
else throwIO (ErrorCall (x ++ '\n' : renderStack stack))
----------------------------------------------------------------------
-- Explicit call-stacks built via ImplicitParams
----------------------------------------------------------------------
-- | @CallStack@s are an alternate method of obtaining the call stack at a given
-- point in the program.
--
-- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will
-- solve it with the current location. If another @CallStack@ implicit-parameter
-- is in-scope (e.g. as a function argument), the new location will be appended
-- to the one in-scope, creating an explicit call-stack. For example,
--