From e3dc28046373f3183dda56b096dbebec865e3be7 Mon Sep 17 00:00:00 2001
From: Eric Seidel <gridaphobe@gmail.com>
Date: Mon, 19 Jan 2015 16:08:32 -0600
Subject: [PATCH] Expose source locations via Implicit Parameters of type
GHC.Location.Location
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
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
Cherry-Picked-From: c024af131b9e2538486eb605ba8af6a8d10fe76d
Cherry-Picked-By: Niklas Hambüchen <niklas@fpcomplete.com>
Changes for the cherry-pick:
* Commit d2b6e767 "Make the location in TcLclEnv and CtLoc into a RealSrcSpan"
was cherry-picked before to ensure that
EvCsPushCall, EvCsTop :: EvCallStack
can indeed carry `RealSrcSpan`s instead of `SrcSpan`s.
* The use of `setWantedEvBind` was replaced by `setEvBind`, as
`setWantedEvBind` is not yet present in 7.10.1; it was added to
the 7.12 series in commit 32973bf3.
* docs/users_guide/7.10.1-notes.xml was adjusted to contain the
documentation about CallStack, copied from the 7.12 notes.
---
compiler/deSugar/DsBinds.hs | 62 ++++++-
compiler/prelude/PrelNames.hs | 26 +++
compiler/typecheck/TcBinds.hs | 7 +-
compiler/typecheck/TcEvidence.hs | 172 +++++++++++++++++-
compiler/typecheck/TcExpr.hs | 6 +-
compiler/typecheck/TcHsSyn.hs | 10 +-
compiler/typecheck/TcInteract.hs | 45 ++++-
docs/users_guide/7.10.1-notes.xml | 43 +++++
docs/users_guide/glasgow_exts.xml | 50 +++++
libraries/base/GHC/SrcLoc.hs | 33 ++++
libraries/base/GHC/Stack.hsc | 57 +++++-
libraries/base/base.cabal | 1 +
.../tests/typecheck/should_run/IPLocation.hs | 44 +++++
.../typecheck/should_run/IPLocation.stdout | 28 +++
testsuite/tests/typecheck/should_run/all.T | 1 +
15 files changed, 567 insertions(+), 18 deletions(-)
create mode 100644 libraries/base/GHC/SrcLoc.hs
create mode 100644 testsuite/tests/typecheck/should_run/IPLocation.hs
create mode 100644 testsuite/tests/typecheck/should_run/IPLocation.stdout
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index b6693aa0d437..d65cc42cc390 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -37,7 +37,6 @@ import CoreUnfold
import CoreFVs
import UniqSupply
import Digraph
-import Module
import PrelNames
import TysPrim ( mkProxyPrimTy )
import TyCon ( isTupleTyCon, tyConDataCons_maybe
@@ -47,11 +46,12 @@ import TcType
import Type
import Kind (returnsConstraintKind)
import Coercion hiding (substCo)
-import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )
+import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon, mkListTy
+ , mkBoxedTupleTy, stringTy )
import Id
import MkId(proxyHashId)
import Class
-import DataCon ( dataConWorkId )
+import DataCon ( dataConTyCon, dataConWorkId )
import Name
import IdInfo ( IdDetails(..) )
import Var
@@ -59,6 +59,7 @@ import VarSet
import Rules
import VarEnv
import Outputable
+import Module
import SrcLoc
import Maybes
import OrdList
@@ -914,6 +915,8 @@ dsEvTerm (EvLit l) =
dsEvTerm (EvTypeable ev) = dsEvTypeable ev
+dsEvTerm (EvCallStack cs) = dsEvCallStack cs
+
dsEvTypeable :: EvTypeable -> DsM CoreExpr
dsEvTypeable ev =
do tyCl <- dsLookupTyCon typeableClassName
@@ -1032,6 +1035,59 @@ the proxy argument. This is what went wrong in #3245 and #9203. So we
help GHC by manually keeping the 'rep' *outside* the lambda.
-}
+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
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index eb36f62332ee..168578d8c1b2 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -331,6 +331,10 @@ basicKnownKeyNames
-- Implicit parameters
ipClassName,
+ -- Source locations
+ callStackDataConName, callStackTyConName,
+ srcLocDataConName,
+
-- Annotation type checking
toAnnotationWrapperName
@@ -463,6 +467,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")
@@ -1187,6 +1197,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")
@@ -1540,6 +1559,9 @@ staticPtrInfoTyConKey = mkPreludeTyConUnique 181
typeRepTyConKey :: Unique
typeRepTyConKey = mkPreludeTyConUnique 183
+callStackTyConKey :: Unique
+callStackTyConKey = mkPreludeTyConUnique 182
+
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
-----------------------------------------------------
@@ -1612,6 +1634,10 @@ staticPtrInfoDataConKey = mkPreludeDataConUnique 34
fingerprintDataConKey :: Unique
fingerprintDataConKey = mkPreludeDataConUnique 35
+callStackDataConKey, srcLocDataConKey :: Unique
+callStackDataConKey = mkPreludeDataConUnique 36
+srcLocDataConKey = mkPreludeDataConUnique 37
+
{-
************************************************************************
* *
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index a13d93e6e501..9d8c581137ba 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -54,7 +54,6 @@ import BasicTypes
import Outputable
import FastString
import Type(mkStrLitTy)
-import Class(classTyCon)
import PrelNames(ipClassName)
import TcValidity (checkValidType)
@@ -251,10 +250,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]
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 9eef643c9e4e..70baef463738 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -16,6 +16,7 @@ module TcEvidence (
EvTerm(..), mkEvCast, evVarsOfTerm, mkEvTupleSelectors, mkEvScSelectors,
EvLit(..), evTermCoercion,
EvTypeable(..),
+ 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"
@@ -55,6 +57,7 @@ import Data.Traversable (traverse, sequenceA)
import qualified Data.Data as Data
import Outputable
import FastString
+import SrcLoc
import Data.IORef( IORef )
{-
@@ -708,6 +711,8 @@ data EvTerm
| EvTypeable EvTypeable -- Dictionary for `Typeable`
+ | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters
+
deriving( Data.Data, Data.Typeable )
-- | Instructions on how to make a 'Typeable' dictionary.
@@ -727,7 +732,19 @@ data EvTypeable
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]
@@ -818,6 +835,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
@@ -864,6 +994,7 @@ evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs
evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
evVarsOfTerm (EvLit _) = emptyVarSet
evVarsOfTerm (EvTypeable ev) = evVarsOfTypeable ev
+evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs
evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm
@@ -875,6 +1006,12 @@ evVarsOfTypeable ev =
EvTypeableTyApp e1 e2 -> evVarsOfTerms (map fst [e1,e2])
EvTypeableTyLit _ -> emptyVarSet
+evVarsOfCallStack :: EvCallStack -> VarSet
+evVarsOfCallStack cs = case cs of
+ EvCsEmpty -> emptyVarSet
+ EvCsTop _ _ tm -> evVarsOfTerm tm
+ EvCsPushCall _ _ tm -> evVarsOfTerm tm
+
{-
************************************************************************
* *
@@ -934,6 +1071,7 @@ 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 ]
ppr (EvTypeable ev) = ppr ev
@@ -948,3 +1086,33 @@ instance Outputable EvTypeable where
EvTypeableTyCon tc ks -> parens (ppr tc <+> sep (map ppr ks))
EvTypeableTyApp t1 t2 -> parens (ppr (fst t1) <+> ppr (fst t2))
EvTypeableTyLit x -> ppr x
+
+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)
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 0adeea47e062..96ab8a96c1be 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -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
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 4dfd5e9953fd..6e742f2442e0 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -1260,6 +1260,14 @@ zonkEvTerm env (EvTypeable ev) =
t' <- zonkTcTypeToType env t
return (ev',t')
+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)
@@ -1460,7 +1468,7 @@ zonkCoToCo env co
do { (env', tv') <- zonkTyBndrX env tv
; co' <- zonkCoToCo env' co
; return (mkForAllCo tv' co') }
-
+
zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker
-- This variant collects unbound type variables in a mutable variable
-- Works on both types and kinds
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 62e106c2def8..3adfd793c43a 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -8,6 +8,8 @@ module TcInteract (
#include "HsVersions.h"
import BasicTypes ()
+import HsTypes ( hsIPNameFS )
+import FastString
import TcCanonical
import TcFlatten
import VarSet
@@ -20,7 +22,7 @@ import CoAxiom(sfInteractTop, sfInteractInert)
import Var
import TcType
import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey
- , typeableClassName )
+ , typeableClassName, callStackTyConKey )
import Id( idType )
import Class
import TyCon
@@ -43,7 +45,6 @@ import VarEnv
import Control.Monad
import Pair (Pair(..))
import Unique( hasKey )
-import FastString ( sLit )
import DynFlags
import Util
@@ -534,6 +535,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
+ setEvBind (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
@@ -2206,3 +2227,23 @@ a TypeRep for them. For qualified but not polymorphic types, like
no other class works with impredicative types.
For now we leave it off, until we have a better story for impredicativity.
-}
+
+-- | 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
diff --git a/docs/users_guide/7.10.1-notes.xml b/docs/users_guide/7.10.1-notes.xml
index 43b236615ec1..b7c8f4167dab 100644
--- a/docs/users_guide/7.10.1-notes.xml
+++ b/docs/users_guide/7.10.1-notes.xml
@@ -122,6 +122,32 @@
<sect3>
<title>Language</title>
<itemizedlist>
+ <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>
<listitem>
<para>
There is a new extension,
@@ -544,6 +570,23 @@ echo "[]" > package.conf
<para>
Version number 4.8.0.0 (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>
<listitem>
<para>
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 9029c7405bb2..adb152b38fa5 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -7680,6 +7680,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">
diff --git a/libraries/base/GHC/SrcLoc.hs b/libraries/base/GHC/SrcLoc.hs
new file mode 100644
index 000000000000..16ebbab74c6e
--- /dev/null
+++ b/libraries/base/GHC/SrcLoc.hs
@@ -0,0 +1,33 @@
+{-# 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
+ ]
diff --git a/libraries/base/GHC/Stack.hsc b/libraries/base/GHC/Stack.hsc
index 0aa4d1768dd2..8c9f0c1f4145 100644
--- a/libraries/base/GHC/Stack.hsc
+++ b/libraries/base/GHC/Stack.hsc
@@ -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,
+--
+-- @
+-- myerror :: (?loc :: CallStack) => String -> a
+-- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc)
+-- @
+-- ghci> myerror "die"
+-- *** Exception: die
+-- ?loc, called at MyError.hs:7:51 in main:MyError
+-- myerror, called at <interactive>:2:1 in interactive:Ghci1
+--
+-- @CallStack@s do not interact with the RTS and do not require compilation with
+-- @-prof@. On the other hand, as they are built up explicitly using
+-- implicit-parameters, they will generally not contain as much information as
+-- the simulated call-stacks maintained by the RTS.
+--
+-- The @CallStack@ type is abstract, but it can be converted into a
+-- @[(String, SrcLoc)]@ via 'getCallStack'. The @String@ is the name of function
+-- that was called, the 'SrcLoc' is the call-site. The list is ordered with the
+-- most recently called function at the head.
+--
+-- @since 4.9.0.0
+data CallStack = CallStack { getCallStack :: [(String, SrcLoc)] }
+ -- See Note [Overview of implicit CallStacks]
+ deriving (Show, Eq)
+
+showCallStack :: CallStack -> String
+showCallStack (CallStack (root:rest))
+ = unlines (showCallSite root : map (indent . showCallSite) rest)
+ where
+ indent l = " " ++ l
+ showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
+showCallStack _ = error "CallStack cannot be empty!"
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 9296b3ffa158..fd1c3d8c3f02 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -259,6 +259,7 @@ Library
GHC.StaticPtr
GHC.STRef
GHC.Show
+ GHC.SrcLoc
GHC.Stable
GHC.Stack
GHC.Stats
diff --git a/testsuite/tests/typecheck/should_run/IPLocation.hs b/testsuite/tests/typecheck/should_run/IPLocation.hs
new file mode 100644
index 000000000000..ffc377b2c9a9
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/IPLocation.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ImplicitParams, RankNTypes #-}
+{-# OPTIONS_GHC -dcore-lint #-}
+module Main where
+
+import GHC.Stack
+
+f0 = putStrLn $ showCallStack ?loc
+ -- should just show the location of ?loc
+
+f1 :: (?loc :: CallStack) => IO ()
+f1 = putStrLn $ showCallStack ?loc
+ -- should show the location of ?loc *and* f1's call-site
+
+f2 :: (?loc :: CallStack) => IO ()
+f2 = do putStrLn $ showCallStack ?loc
+ putStrLn $ showCallStack ?loc
+ -- each ?loc should refer to a different location, but they should
+ -- share f2's call-site
+
+f3 :: ((?loc :: CallStack) => () -> IO ()) -> IO ()
+f3 x = x ()
+ -- the call-site for the functional argument should be added to the
+ -- stack..
+
+f4 :: (?loc :: CallStack) => ((?loc :: CallStack) => () -> IO ()) -> IO ()
+f4 x = x ()
+ -- as should the call-site for f4 itself
+
+f5 :: (?loc1 :: CallStack) => ((?loc2 :: CallStack) => () -> IO ()) -> IO ()
+f5 x = x ()
+ -- we only push new call-sites onto CallStacks with the name IP name
+
+f6 :: (?loc :: CallStack) => Int -> IO ()
+f6 0 = putStrLn $ showCallStack ?loc
+f6 n = f6 (n-1)
+ -- recursive functions add a SrcLoc for each recursive call
+
+main = do f0
+ f1
+ f2
+ f3 (\ () -> putStrLn $ showCallStack ?loc)
+ f4 (\ () -> putStrLn $ showCallStack ?loc)
+ f5 (\ () -> putStrLn $ showCallStack ?loc3)
+ f6 5
diff --git a/testsuite/tests/typecheck/should_run/IPLocation.stdout b/testsuite/tests/typecheck/should_run/IPLocation.stdout
new file mode 100644
index 000000000000..6dca7214d6ae
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/IPLocation.stdout
@@ -0,0 +1,28 @@
+?loc, called at IPLocation.hs:7:31 in main:Main
+
+?loc, called at IPLocation.hs:11:31 in main:Main
+ f1, called at IPLocation.hs:39:11 in main:Main
+
+?loc, called at IPLocation.hs:15:34 in main:Main
+ f2, called at IPLocation.hs:40:11 in main:Main
+
+?loc, called at IPLocation.hs:16:34 in main:Main
+ f2, called at IPLocation.hs:40:11 in main:Main
+
+?loc, called at IPLocation.hs:41:48 in main:Main
+ x, called at IPLocation.hs:21:8 in main:Main
+
+?loc, called at IPLocation.hs:42:48 in main:Main
+ x, called at IPLocation.hs:26:8 in main:Main
+ f4, called at IPLocation.hs:42:11 in main:Main
+
+?loc3, called at IPLocation.hs:43:48 in main:Main
+
+?loc, called at IPLocation.hs:34:33 in main:Main
+ f6, called at IPLocation.hs:35:8 in main:Main
+ f6, called at IPLocation.hs:35:8 in main:Main
+ f6, called at IPLocation.hs:35:8 in main:Main
+ f6, called at IPLocation.hs:35:8 in main:Main
+ f6, called at IPLocation.hs:35:8 in main:Main
+ f6, called at IPLocation.hs:44:11 in main:Main
+
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index 55b88cf30f71..9cf7a806d0d0 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -85,6 +85,7 @@ test('church', normal, compile_and_run, [''])
test('testeq2', normal, compile_and_run, [''])
test('T1624', normal, compile_and_run, [''])
test('IPRun', normal, compile_and_run, [''])
+test('IPLocation', normal, compile_and_run, [''])
# Support files for T1735 are in directory T1735_Help/
test('T1735', normal, multimod_compile_and_run, ['T1735',''])
--
GitLab