diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index b6693aa0d437cd3f9437738a8c28d4387f38b531..d65cc42cc3908589e2548331a44c28c127e8c8c0 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 eb36f62332ee51c69a7f0de2d2c1b44e0e57bb60..168578d8c1b21f2ae317396f8ee671ed9ff056da 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 a13d93e6e50159e16d0ee228ff3d8ea86b2e8f3d..9d8c581137ba8211def920b3baab4546372e8085 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 9eef643c9e4e3bfcb30d73e85c78ea4c5547c3c6..70baef463738fbf89adad56bb9aeafcda44ef1ae 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 0adeea47e062564a3df6bff1a6dd30186fcd602c..96ab8a96c1be8987ef23a90f96d52481804ef777 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 4dfd5e9953fdf71d0ba43d40c6e749cb59f93927..6e742f2442e0887bffa5158030400862e11cfc36 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 62e106c2def8ce6b2bc2bf1d5811cb97e447c252..3adfd793c43a06b2ce350f0e9023ce58400ff5fb 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 43b236615ec10239fc036dd5e40a0868b8cc9ddd..b7c8f4167dabcfeb2ae2994187dcab4ad86be791 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 9029c7405bb21aec0ed13e9e82d8a978c7c8eb2e..adb152b38fa521f9093c8ddca88a4767398253f2 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 0000000000000000000000000000000000000000..16ebbab74c6e0cc5e2661e6cb186f805ee6a51e6
--- /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 0aa4d1768dd28904adab30179e41a00a25a7225c..8c9f0c1f414506b06687bf403f11430103168844 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 9296b3ffa158b9bfef4008ecf5257d05291fc904..fd1c3d8c3f028e7a50b7789ab1e47c897d7bc092 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 0000000000000000000000000000000000000000..ffc377b2c9a94d5a6e359da2a313fdfd4531db37
--- /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 0000000000000000000000000000000000000000..6dca7214d6aec8393c38a9238eb857482ca56a0b
--- /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 55b88cf30f71dff5f07d8e6027d0eecc9299f884..9cf7a806d0d0db8a307f13713ffeba7e4d62aae1 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',''])