diff options
author | Eric Seidel <gridaphobe@gmail.com> | 2015-12-12 16:53:50 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2015-12-12 18:39:22 +0100 |
commit | 3ec8288a18d57fb856e257905897daae237a1d5d (patch) | |
tree | 089c791781000e8685cac8f70c53e12a971288b7 | |
parent | 1883afb2eee88c828adf6aa8014bab64dd6e8096 (diff) | |
download | haskell-3ec8288a18d57fb856e257905897daae237a1d5d.tar.gz |
Rework the Implicit CallStack solver to handle local lets.
We can't just solve CallStack constraints indiscriminately when they
occur in the RHS of a let-binder. The top-level given CallStack (if
any) will not be in scope, so I've re-worked the CallStack solver as
follows:
1. CallStacks are treated like regular IPs unless one of the following
two rules apply.
2. In a function call, we push the call-site onto a NEW wanted
CallStack, which GHC will solve as a regular IP (either directly from a
given, or by quantifying over it in a local let).
3. If, after the constraint solver is done, any wanted CallStacks
remain, we default them to the empty CallStack. This rule exists mainly
to clean up after rule 2 in a top-level binder with no given CallStack.
In rule (2) we have to be careful to emit the new wanted with an
IPOccOrigin instead of an OccurrenceOf origin, so rule (2) doesn't fire
again. This is a bit shady but I've updated the Note to explain the
trick.
Test Plan: validate
Reviewers: simonpj, austin, bgamari, hvr
Reviewed By: simonpj, bgamari
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1422
GHC Trac Issues: #10845
38 files changed, 626 insertions, 539 deletions
diff --git a/.gitignore b/.gitignore index 82c81c0676..bfd567eaf6 100644 --- a/.gitignore +++ b/.gitignore @@ -98,6 +98,7 @@ _darcs/ /docs/users_guide/build-html /docs/users_guide/build-pdf /docs/users_guide/.doctrees-* +/docs/users_guide/.doctrees/ /driver/ghci/ghc-pkg-inplace /driver/ghci/ghci-inplace /driver/ghci/ghci.res diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index ca2d49d9e3..9932fb0dfb 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -1195,6 +1195,5 @@ dsEvCallStack cs = do let ip_co = unwrapIP (exprType tmExpr) return (pushCS nameExpr locExpr (mkCastDs 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" + EvCsEmpty -> return emptyCS diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 032cc54730..78901156e4 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -394,9 +394,6 @@ data EvCallStack | 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 ) {- @@ -511,57 +508,79 @@ Note [Overview of implicit CallStacks] 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. +to implicit parameters of type GHC.Stack.CallStack. - head [] = error (show (?loc :: CallStack)) - head (x:_) = x +Implicit CallStacks are regular implicit parameters, augmented with two +extra rules in the constraint solver: -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 +1. Occurrences of CallStack IPs are solved directly from the given IP, + just like a regular IP. For example, the occurrence of `?stk` in - head :: (?loc :: CallStack) => [a] -> a - head [] = error (show (?loc :: CallStack)) - head (x:_) = x + error :: (?stk :: CallStack) => String -> a + error s = raise (ErrorCall (s ++ show ?stk)) + + will be solved for the `?stk` in `error`s context as before. + +2. In a function call, instead of simply passing the given IP, we first + append the current call-site to it. For example, consider a + call to the callstack-aware `error` above. + + undefined :: (?stk :: CallStack) => a + undefined = error "undefined!" + + Here we want to take the given `?stk` and append the current + call-site, before passing it to `error`. In essence, we want to + rewrite `error "undefined!"` to + + let ?stk = pushCallStack <error's location> ?stk + in error "undefined!" + + We achieve this effect by emitting a NEW wanted -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 + [W] d :: IP "stk" CallStack - EvCsTop "?loc" <?loc's location> EvCsEmpty + from which we build the evidence term -and in the second we'll have a given constraint + EvCsPushCall "error" <error's location> (EvId d) - [G] d :: IP "loc" CallStack + that we use to solve the call to `error`. The new wanted `d` will + then be solved per rule (1), ie as a regular IP. -in scope, and will create an evidence term + (see TcInteract.interactDict) - EvCsTop "?loc" <?loc's location> d +3. We default any insoluble CallStacks to the empty CallStack. Suppose + `undefined` did not request a CallStack, ie -When we call a function that uses a CallStack IP, e.g. + undefinedNoStk :: a + undefinedNoStk = error "undefined!" - f = head xs + Under the usual IP rules, the new wanted from rule (2) would be + insoluble as there's no given IP from which to solve it, so we + would get an "unbound implicit parameter" error. -we create an evidence term + We don't ever want to emit an insoluble CallStack IP, so we add a + defaulting pass to default any remaining wanted CallStacks to the + empty CallStack with the evidence term - EvCsPushCall "head" <head's location> EvCsEmpty + EvCsEmpty -again pushing onto a given evidence term if one exists. + (see TcSimplify.simpl_top and TcSimplify.defaultCallStacks) 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: +For example, using the above definition of `undefined`: - f :: [a] -> a - f = head + head :: [a] -> a + head [] = undefined + head (x:_) = x + + g = head [] - g = f [] +the resulting CallStack will include the call to `undefined` in `head` +and the call to `error` in `undefined`, but *not* the call to `head` +in `g`, because `head` did not explicitly request a CallStack. -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. @@ -572,21 +591,6 @@ Important Details: 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. @@ -600,21 +604,19 @@ Important Details: 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) + standard scoping rules of implicit-parameters. - 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 +- When we emit a new wanted CallStack from rule (2) we set its origin to + `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` + (see TcInteract.interactDict). - (?stk :: CallStack) => [a] -> a - ~ - (?stk :: CallStack) => [a] -> a + This is a bit shady, but is how we ensure that the new wanted is + solved like a regular IP. - constraint that arises from the ambiguity check on `head`s type signature. - (See TcEvidence.isCallStackIP) -} mkEvCast :: EvTerm -> TcCoercion -> EvTerm @@ -674,7 +676,6 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges evVarsOfCallStack :: EvCallStack -> VarSet evVarsOfCallStack cs = case cs of EvCsEmpty -> emptyVarSet - EvCsTop _ _ tm -> evVarsOfTerm tm EvCsPushCall _ _ tm -> evVarsOfTerm tm evVarsOfTypeable :: EvTypeable -> VarSet @@ -763,10 +764,8 @@ instance Outputable EvLit where 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 + = ppr (name,loc) <+> ptext (sLit ":") <+> ppr tm instance Outputable EvTypeable where ppr (EvTypeableTyCon ts) = ptext (sLit "TC") <+> ppr ts diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 2b57a400a8..51f3c2f561 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -1264,8 +1264,6 @@ zonkEvTerm env (EvTypeable ty ev) = 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')) } diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 75399f13ca..c78d6bbaf2 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -2,13 +2,15 @@ module TcInteract ( solveSimpleGivens, -- Solves [EvVar],GivenLoc - solveSimpleWanteds -- Solves Cts + solveSimpleWanteds, -- Solves Cts + + solveCallStack, -- for use in TcSimplify ) where #include "HsVersions.h" import BasicTypes ( infinity, IntWithInf, intGtLimit ) -import HsTypes ( hsIPNameFS ) +import HsTypes ( HsIPName(..) ) import FastString import TcCanonical import TcFlatten @@ -21,7 +23,7 @@ import Var import TcType import Name import PrelNames ( knownNatClassName, knownSymbolClassName, - callStackTyConKey, typeableClassName, coercibleTyConKey, + typeableClassName, coercibleTyConKey, heqTyConKey ) import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind, heqDataCon, coercibleDataCon ) @@ -683,24 +685,30 @@ 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. + | isWanted ev_w + , Just ip_name <- isCallStackCt workItem + , OccurrenceOf func <- ctLocOrigin (ctEvLoc ev_w) + -- If we're given a CallStack constraint that arose from a function + -- call, we need to push the current call-site onto the stack instead + -- of solving it directly from a given. -- See Note [Overview of implicit CallStacks] - | Just mkEvCs <- isCallStackIP loc cls tys - , isWanted ev_w - = do let ev_cs = - case lookupInertDict inerts 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) (wrapIP ip_ty) - addSolvedDict ev_w cls tys - setWantedEvBind (ctEvId ev_w) ev_tm - stopWith ev_w "Wanted CallStack IP" + = do { let loc = ctEvLoc ev_w + + -- First we emit a new constraint that will capture the + -- given CallStack. + ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name)) + -- We change the origin to IPOccOrigin so + -- this rule does not fire again. + -- See Note [Overview of implicit CallStacks] + + ; mb_new <- newWantedEvVar new_loc (ctEvPred ev_w) + ; emitWorkNC (freshGoals [mb_new]) + + -- Then we solve the wanted by pushing the call-site onto the + -- newly emitted CallStack. + ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (getEvTerm mb_new) + ; solveCallStack ev_w ev_cs + ; stopWith ev_w "Wanted CallStack IP" } | Just ctev_i <- lookupInertDict inerts cls tys = do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w @@ -720,8 +728,6 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs | otherwise = do { addFunDepWork inerts ev_w cls ; continueWith workItem } - where - loc = ctEvLoc ev_w interactDict _ wi = pprPanic "interactDict" (ppr wi) @@ -777,25 +783,6 @@ interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) --- | Is the constraint for an implicit CallStack parameter? --- i.e. (IP "name" CallStack) -isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack) -isCallStackIP loc cls tys - | cls == ipClass - , [_ip_name, ty] <- tys - , Just (tc, _) <- splitTyConApp_maybe ty - , tc `hasKey` callStackTyConKey - = occOrigin (ctLocOrigin loc) - | otherwise - = Nothing - where - locSpan = ctLocSpan loc - - -- 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 {- Note [Shadowing of Implicit Parameters] @@ -2102,6 +2089,14 @@ a TypeRep for them. For qualified but not polymorphic types, like For now we leave it off, until we have a better story for impredicativity. -} +solveCallStack :: CtEvidence -> EvCallStack -> TcS () +solveCallStack ev ev_cs = do + -- We're given 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`. See Note [Overview of implicit CallStacks] + let ev_tm = mkEvCast (EvCallStack ev_cs) (wrapIP (ctEvPred ev)) + setWantedEvBind (ctEvId ev) ev_tm + {- ******************************************************************** * * Class lookup for lifted equality diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 932b7ddcc7..b0c2e8072f 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -67,7 +67,7 @@ module TcRnTypes( isCDictCan_Maybe, isCFunEqCan_maybe, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt, - isUserTypeErrorCt, getUserTypeErrorMsg, + isUserTypeErrorCt, isCallStackCt, getUserTypeErrorMsg, ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, mkTcEqPredLikeEv, mkNonCanonical, mkNonCanonicalCt, @@ -127,6 +127,7 @@ import HsSyn import CoreSyn import HscTypes import TcEvidence +import TysWiredIn ( callStackTyCon, ipClass ) import Type import CoAxiom ( Role ) import Class ( Class ) @@ -1731,6 +1732,20 @@ isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of Just _ -> True _ -> False +-- | Is the constraint for an Implicit CallStack +-- (i.e. @IP "name" CallStack@)? +-- +-- If so, returns @Just "name"@. +isCallStackCt :: Ct -> Maybe FastString +isCallStackCt CDictCan { cc_class = cls, cc_tyargs = tys } + | cls == ipClass + , [ip_name_ty, ty] <- tys + , Just (tc, _) <- splitTyConApp_maybe ty + , tc == callStackTyCon + = isStrLitTy ip_name_ty +isCallStackCt _ + = Nothing + instance Outputable Ct where ppr ct = ppr (cc_ev ct) <+> parens pp_sort where diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 11e71362cd..190c6c4e66 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -154,7 +154,41 @@ simpl_top wanteds ; if something_happened then do { wc_residual <- nestTcS (solveWantedsAndDrop wc) ; try_class_defaulting wc_residual } - else return wc } + -- See Note [Overview of implicit CallStacks] + else try_callstack_defaulting wc } + + try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints + try_callstack_defaulting wc + | isEmptyWC wc + = return wc + | otherwise + = defaultCallStacks wc + +-- | Default any remaining @CallStack@ constraints to empty @CallStack@s. +defaultCallStacks :: WantedConstraints -> TcS WantedConstraints +-- See Note [Overview of implicit CallStacks] +defaultCallStacks wanteds + = do simples <- handle_simples (wc_simple wanteds) + implics <- mapBagM handle_implic (wc_impl wanteds) + return (wanteds { wc_simple = simples, wc_impl = implics }) + + where + + handle_simples simples + = catBagMaybes <$> mapBagM defaultCallStack simples + + handle_implic implic = do + wanteds <- defaultCallStacks (ic_wanted implic) + return (implic { ic_wanted = wanteds }) + + defaultCallStack ct@(CDictCan { cc_ev = ev_w }) + | Just _ <- isCallStackCt ct + = do { solveCallStack ev_w EvCsEmpty + ; return Nothing } + + defaultCallStack ct + = return (Just ct) + -- | Type-check a thing, returning the result and any EvBinds produced -- during solving. Emits errors -- but does not fail -- if there is trouble. @@ -227,7 +261,7 @@ Option (i) had many disadvantages: untouchable. Instead our new defaulting story is to pull defaulting out of the solver loop and -go with option (i), implemented at SimplifyTop. Namely: +go with option (ii), implemented at SimplifyTop. Namely: - First, have a go at solving the residual constraint of the whole program - Try to approximate it with a simple constraint diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 8f30f0076e..b539fa6869 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -113,7 +113,6 @@ import GHC.Fingerprint import GHC.Show ( showMultiLineString ) #if __GLASGOW_HASKELL__ > 710 import GHC.Stack -import GHC.Exception #endif {- @@ -1071,8 +1070,8 @@ pprTraceIt desc x = pprTrace desc (ppr x) x -- | If debug output is on, show some 'SDoc' on the screen along -- with a call stack when available. #if __GLASGOW_HASKELL__ > 710 -pprSTrace :: (?location :: CallStack) => SDoc -> a -> a -pprSTrace = pprTrace (showCallStack ?location) +pprSTrace :: (?callStack :: CallStack) => SDoc -> a -> a +pprSTrace = pprTrace (prettyCallStack ?callStack) #else pprSTrace :: SDoc -> a -> a pprSTrace = pprTrace "no callstack info" diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst index ff240917e8..8ce40e8271 100644 --- a/docs/users_guide/7.12.1-notes.rst +++ b/docs/users_guide/7.12.1-notes.rst @@ -31,28 +31,25 @@ Language -- | Just a normal sum Sum :: Int -> Int -> Expr Int -- Implicit parameters of the new ghc-prim type ``GHC.Types.CallStack`` - are treated specially, and automatically solved for the current - source location. For example +- Implicit parameters of the new ``base`` type ``GHC.Stack.CallStack`` + are treated specially in function calls, the solver automatically + appends the source location of the call to the ``CallStack`` in + the environment. For example :: + myerror :: (?callStack :: CallStack) => String -> a + myerror msg = error (msg ++ "\n" ++ prettyCallStack ?callStack) - f = print (?stk :: CallStack) + ghci> myerror "die" + *** Exception: die + CallStack (from ImplicitParams): + myerror, called at <interactive>:2:1 in interactive:Ghci1 - will print the singleton stack containing the occurrence of ``?stk``. - If there is another ``CallStack`` implicit in-scope, the new location - will be appended to the existing stack, e.g. + prints the call-site of ``myerror``. The name of the implicit + parameter does not matter, but within ``base`` we call it + ``?callStack``. - :: - - f :: (?stk :: CallStack) => IO () - f = print (?stk :: CallStack) - - will print the occurrence of ``?stk`` and the call-site of ``f``. The - name of the implicit parameter does not matter. - - See the release notes for ghc-prim for a description of the - ``CallStack`` type. + See :ref:`lib-base` for a description of the ``CallStack`` type. - To conform to the common case, the default role assigned to parameters of datatypes declared in ``hs-boot`` files is @@ -279,19 +276,22 @@ array - Version number XXXXX (was 0.5.0.0) + +.. _lib-base: + base ~~~~ - Version number 4.9.0.0 (was 4.7.0.0) -- A new module ``GHC.SrcLoc`` was added, exporting a new type - ``SrcLoc``. A ``SrcLoc`` contains package, module, and file names, as - well as start and end positions. - -- A new type ``CallStack`` was added for use with the new implicit - callstack parameters. A ``CallStack`` is a ``[(String, SrcLoc)]``, +- ``GHC.Stack`` exports two new types ``SrcLoc`` and ``CallStack``. A + ``SrcLoc`` contains package, module, and file names, as well as start + and end positions. A ``CallStack`` is a ``[(String, SrcLoc)]``, sorted by most-recent call. +- ``error`` and ``undefined`` will now report a partial stack-trace + using the new ``CallStack`` feature (and the ``-prof`` stack if available). + - A new function, ``interruptible``, was added to ``GHC.IO`` allowing an ``IO`` action to be run such that it can be interrupted by an asynchronous exception, even if exceptions are masked (except if diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index ca30bddf26..3c98dc71e1 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -8151,37 +8151,46 @@ a type signature for ``y``, then ``y`` will get type Special implicit parameters ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC treats implicit parameters of type ``GHC.Types.CallStack`` -specially, by resolving them to the current location in the program. -Consider: +Implicit parameters of the new ``base`` type ``GHC.Stack.CallStack`` are +treated specially in function calls, the solver automatically appends +the source location of the call to the ``CallStack`` in the +environment. For example :: + myerror :: (?callStack :: CallStack) => String -> a + myerror msg = error (msg ++ "\n" ++ prettyCallStack ?callStack) - f :: String - f = show (?loc :: CallStack) + ghci> myerror "die" + *** Exception: die + CallStack (from ImplicitParams): + myerror, called at <interactive>:2:1 in interactive:Ghci1 -GHC will automatically resolve ``?loc`` to its source location. If -another implicit parameter with type ``CallStack`` is in scope, GHC will -append the two locations, creating an explicit call-stack. For example: +prints the call-site of ``myerror``. The name of the implicit +parameter does not matter, but within ``base`` we call it +``?callStack``. -:: - - f :: (?stk :: CallStack) => String - f = show (?stk :: CallStack) - -will produce the location of ``?stk``, followed by ``f``\'s call-site. -Note that the name of the implicit parameter does not matter (we used -``?loc`` above), GHC will solve any implicit parameter with the right -type. The name does, however, matter when pushing new locations onto -existing stacks. Consider: +The ``CallStack`` will only extend as far as the types allow it, for +example :: + head :: (?callStack :: CallStack) => [a] -> a + head [] = myerror "empty" + head (x:xs) = x + + bad :: Int + bad = head [] + + ghci> bad + *** Exception: empty + CallStack (from ImplicitParams): + myerror, called at Bad.hs:8:15 in main:Bad + head, called at Bad.hs:12:7 in main:Bad - f :: (?stk :: CallStack) => String - f = show (?loc :: CallStack) +includes the call-site of ``myerror`` in ``head``, and of ``head`` in +``bad``, but not the call-site of ``bad`` at the GHCi prompt. -When we call ``f``, the stack will include the use of ``?loc``, but not -the call to ``f``; in this case the names must match. +GHC will never report an unbound implicit ``CallStack``, and will +instead default such occurrences to the empty ``CallStack``. ``CallStack`` is kept abstract, but GHC provides a function @@ -8192,15 +8201,9 @@ the call to ``f``; in this case the names must match. to access the individual call-sites in the stack. The ``String`` is the name of the function that was called, and the ``SrcLoc`` 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 ``?loc :: CallStack`` as a type constraint, which means that -functions must explicitly ask to be told about their call-sites. - -A potential "gotcha" when using implicit ``CallStack``\ s is that the -``:type`` command in GHCi will not report the ``?loc :: CallStack`` -constraint, as the typechecker will immediately solve it. Use ``:info`` -instead to print the unsolved type. +GHC will infer ``CallStack`` constraints using the same rules as for +ordinary implicit parameters. + .. _kinding: diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs index afd1a50f4a..80761ada75 100644 --- a/libraries/base/GHC/Exception.hs +++ b/libraries/base/GHC/Exception.hs @@ -27,9 +27,9 @@ module GHC.Exception , SomeException(..), ErrorCall(..,ErrorCall), ArithException(..) , divZeroException, overflowException, ratioZeroDenomException , errorCallException, errorCallWithCallStackException - , showCallStack, popCallStack, showSrcLoc -- re-export CallStack and SrcLoc from GHC.Types - , CallStack(..), SrcLoc(..) + , CallStack, getCallStack, prettyCallStack + , SrcLoc(..), prettySrcLoc ) where import Data.Maybe @@ -187,7 +187,7 @@ errorCallWithCallStackException :: String -> CallStack -> SomeException errorCallWithCallStackException s stk = unsafeDupablePerformIO $ do ccsStack <- currentCallStack let - implicitParamCallStack = showCallStackLines (popCallStack stk) + implicitParamCallStack = prettyCallStackLines stk ccsCallStack = showCCSStack ccsStack stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack return $ toException (ErrorCallWithLocation s stack) @@ -196,11 +196,14 @@ showCCSStack :: [String] -> [String] showCCSStack [] = [] showCCSStack stk = "CallStack (from -prof):" : map (" " ++) (reverse stk) +-- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot +-- files. See Note [Definition of CallStack] + -- | Pretty print 'SrcLoc' -- --- @since 4.9.0.0 -showSrcLoc :: SrcLoc -> String -showSrcLoc SrcLoc {..} +-- @since 4.8.1.0 +prettySrcLoc :: SrcLoc -> String +prettySrcLoc SrcLoc {..} = foldr (++) "" [ srcLocFile, ":" , show srcLocStartLine, ":" @@ -210,22 +213,17 @@ showSrcLoc SrcLoc {..} -- | Pretty print 'CallStack' -- --- @since 4.9.0.0 -showCallStack :: CallStack -> String -showCallStack = intercalate "\n" . showCallStackLines - -showCallStackLines :: CallStack -> [String] -showCallStackLines (CallStack stk) = - "CallStack (from ImplicitParams):" : map ((" " ++) . showCallSite) stk +-- @since 4.8.1.0 +prettyCallStack :: CallStack -> String +prettyCallStack = intercalate "\n" . prettyCallStackLines + +prettyCallStackLines :: CallStack -> [String] +prettyCallStackLines cs = case getCallStack cs of + [] -> [] + stk -> "CallStack (from ImplicitParams):" + : map ((" " ++) . prettyCallSite) stk where - showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc - --- | Remove the most recent callsite from the 'CallStack' --- --- @since 4.9.0.0 -popCallStack :: CallStack -> CallStack -popCallStack (CallStack (_:rest)) = CallStack rest -popCallStack _ = error "CallStack cannot be empty!" + prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc -- |Arithmetic exceptions. data ArithException diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs index 7e483deea1..933ce943e6 100644 --- a/libraries/base/GHC/IO/Exception.hs +++ b/libraries/base/GHC/IO/Exception.hs @@ -357,7 +357,7 @@ assertError predicate v | predicate = lazy v | otherwise = throw (AssertionFailed ("Assertion failed\n" - ++ showCallStack (popCallStack ?callStack))) + ++ prettyCallStack ?callStack)) unsupportedOperation :: IOError unsupportedOperation = diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs index f6fe41f06f..8f57239a84 100644 --- a/libraries/base/GHC/Stack.hs +++ b/libraries/base/GHC/Stack.hs @@ -23,7 +23,10 @@ module GHC.Stack ( errorWithStackTrace, -- * Implicit parameter call stacks - SrcLoc(..), CallStack(..), + CallStack, getCallStack, pushCallStack, prettyCallStack, + + -- * Source locations + SrcLoc(..), prettySrcLoc, -- * Internals CostCentreStack, @@ -40,6 +43,7 @@ module GHC.Stack ( ) where import GHC.Stack.CCS +import GHC.Stack.Types import GHC.IO import GHC.Base import GHC.List diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs index a43fe9a66c..f877f7e38a 100644 --- a/libraries/base/GHC/Stack/Types.hs +++ b/libraries/base/GHC/Stack/Types.hs @@ -18,7 +18,9 @@ module GHC.Stack.Types ( -- * Implicit parameter call stacks - SrcLoc(..), CallStack(..), + CallStack, getCallStack, pushCallStack, + -- * Source locations + SrcLoc(..) ) where {- @@ -44,22 +46,28 @@ import GHC.Integer () -- Explicit call-stacks built via ImplicitParams ---------------------------------------------------------------------- --- | @CallStack@s are an alternate method of obtaining the call stack at a given --- point in the program. +-- | Implicit @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, +-- GHC has two built-in rules for solving implicit-parameters of type +-- @CallStack@. +-- +-- 1. If the @CallStack@ occurs in a function call, it appends the +-- source location of the call to the @CallStack@ in the environment. +-- 2. @CallStack@s that cannot be solved normally (i.e. unbound +-- occurrences) are defaulted to the empty @CallStack@. +-- +-- Otherwise implicit @CallStack@s behave just like ordinary implicit +-- parameters. For example: -- -- @ --- myerror :: (?loc :: CallStack) => String -> a --- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc) +-- myerror :: (?callStack :: CallStack) => String -> a +-- myerror msg = error (msg ++ "\n" ++ prettyCallStack ?callStack) -- @ +-- -- ghci> myerror "die" -- *** Exception: die --- CallStack: --- ?loc, called at MyError.hs:7:51 in main:MyError +-- CallStack (from ImplicitParams): -- myerror, called at <interactive>:2:1 in interactive:Ghci1 -- -- @CallStack@s do not interact with the RTS and do not require compilation with @@ -71,13 +79,38 @@ import GHC.Integer () -- 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 +-- @since 4.8.1.0 data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)] } -- See Note [Overview of implicit CallStacks] --- | A single location in the source code. + +-- Note [Definition of CallStack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Implicit CallStacks are defined very early in base because they are +-- used by error and undefined. At this point in the dependency graph, +-- we do not have enough functionality to (conveniently) write a nice +-- pretty-printer for CallStack. The sensible place to define the +-- pretty-printer would be GHC.Stack, which is the main access point, +-- but unfortunately GHC.Stack imports GHC.Exception, which *needs* +-- the pretty-printer. So the CallStack type and functions are split +-- between three modules: +-- +-- 1. GHC.Stack.Types: defines the type and *simple* functions +-- 2. GHC.Exception: defines the pretty-printer +-- 3. GHC.Stack: exports everything and acts as the main access point + + +-- | Push a call-site onto the stack. -- -- @since 4.9.0.0 +pushCallStack :: ([Char], SrcLoc) -> CallStack -> CallStack +pushCallStack callSite (CallStack stk) + = CallStack (callSite : stk) + + +-- | A single location in the source code. +-- +-- @since 4.8.1.0 data SrcLoc = SrcLoc { srcLocPackage :: [Char] , srcLocModule :: [Char] diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 3cf39e39d4..e4d12ed2ca 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -34,7 +34,15 @@ * New `GHC.Generics.packageName` operation - * New `GHC.Stack.CallStack` data type + * New `GHC.Stack.Types` module now contains the definition of + `CallStack` and `SrcLoc` + + * New `GHC.Stack.Types.pushCallStack` function pushes a call-site onto a `CallStack` + + * `GHC.SrcLoc` has been removed + + * `GHC.Stack.showCallStack` and `GHC.SrcLoc.showSrcLoc` are now called + `GHC.Stack.prettyCallStack` and `GHC.Stack.prettySrcLoc` respectively * `Complex` now has `Generic`, `Generic1`, `Functor`, `Foldable`, `Traversable`, `Applicative`, and `Monad` instances @@ -113,7 +121,7 @@ * `Lifetime` is now exported from `GHC.Event` - * Implicit-parameter based source location support exposed in `GHC.SrcLoc`. + * Implicit-parameter based source location support exposed in `GHC.SrcLoc` and `GHC.Stack`. See GHC User's Manual for more information. ## 4.8.0.0 *Mar 2015* diff --git a/testsuite/.gitignore b/testsuite/.gitignore index 0bb80823f6..ef3e720e24 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -1551,6 +1551,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk /tests/typecheck/should_run/T9497c-run /tests/typecheck/should_run/T9858c /tests/typecheck/should_run/T9858d +/tests/typecheck/should_run/T10845 /tests/typecheck/should_run/TcCoercible /tests/typecheck/should_run/TcNullaryTC /tests/typecheck/should_run/TcTypeNatSimpleRun diff --git a/testsuite/tests/codeGen/should_run/cgrun059.stderr b/testsuite/tests/codeGen/should_run/cgrun059.stderr index 2365a03ee5..af01704f99 100644 --- a/testsuite/tests/codeGen/should_run/cgrun059.stderr +++ b/testsuite/tests/codeGen/should_run/cgrun059.stderr @@ -1,3 +1,4 @@ cgrun059: Error: File not found CallStack (from ImplicitParams): error, called at cgrun059.hs:12:28 in main:Main + raiseError, called at cgrun059.hs:25:29 in main:Main diff --git a/testsuite/tests/concurrent/should_run/conc021.stderr b/testsuite/tests/concurrent/should_run/conc021.stderr index b48a068ba7..4c70f77f54 100644 --- a/testsuite/tests/concurrent/should_run/conc021.stderr +++ b/testsuite/tests/concurrent/should_run/conc021.stderr @@ -1,3 +1,4 @@ conc021: wurble CallStack (from ImplicitParams): error, called at conc021.hs:9:9 in main:Main + foo, called at conc021.hs:6:1 in main:Main diff --git a/testsuite/tests/ghci.debugger/scripts/break011.stdout b/testsuite/tests/ghci.debugger/scripts/break011.stdout index 69cbcc4373..dee4d94360 100644 --- a/testsuite/tests/ghci.debugger/scripts/break011.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break011.stdout @@ -9,12 +9,12 @@ _exception :: e = _ -2 : main (../Test7.hs:2:8-29) <end of history> Logged breakpoint at ../Test7.hs:2:18-28 -_result :: a14 +_result :: a3 Logged breakpoint at ../Test7.hs:2:8-29 -_result :: IO a14 +_result :: IO a3 no more logged breakpoints Logged breakpoint at ../Test7.hs:2:18-28 -_result :: a14 +_result :: a3 Stopped at <exception thrown> _exception :: e already at the beginning of the history @@ -23,7 +23,7 @@ _exception = SomeException "foo" "CallStack (from ImplicitParams): error, called at ../Test7.hs:2:18 in main:Main") -_result :: a14 = _ +_result :: a3 = _ _exception :: SomeException = SomeException (ErrorCallWithLocation "foo" diff --git a/testsuite/tests/ghci.debugger/scripts/break017.stdout b/testsuite/tests/ghci.debugger/scripts/break017.stdout index 2bc2c23837..e7e1817ecf 100644 --- a/testsuite/tests/ghci.debugger/scripts/break017.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break017.stdout @@ -9,7 +9,8 @@ as = 'b' : 'c' : (_t1::[Char]) Forcing *** Exception: Prelude.undefined CallStack (from ImplicitParams): - error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err undefined, called at <interactive>:3:17 in interactive:Ghci1 + it, called at <interactive>:3:1 in interactive:Ghci1 Printing 2 as = 'b' : 'c' : (_t2::[Char]) diff --git a/testsuite/tests/ghci.debugger/scripts/print033.stdout b/testsuite/tests/ghci.debugger/scripts/print033.stdout index 62b39bbaea..1aa12c7465 100644 --- a/testsuite/tests/ghci.debugger/scripts/print033.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print033.stdout @@ -1 +1 @@ -u = (_t1::ST s (forall s'. ST s' a)) +u = (_t1::(?callStack::CallStack) => ST s (forall s'. ST s' a)) diff --git a/testsuite/tests/ghci/scripts/T5557.stdout b/testsuite/tests/ghci/scripts/T5557.stdout index 86df6ab67c..835d351d75 100644 --- a/testsuite/tests/ghci/scripts/T5557.stdout +++ b/testsuite/tests/ghci/scripts/T5557.stdout @@ -1,8 +1,10 @@ *** Exception: Prelude.undefined CallStack (from ImplicitParams): - error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err undefined, called at <interactive>:2:12 in interactive:Ghci1 + it, called at <interactive>:2:1 in interactive:Ghci1 *** Exception: Prelude.undefined CallStack (from ImplicitParams): - error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err undefined, called at <interactive>:3:12 in interactive:Ghci1 + it, called at <interactive>:3:1 in interactive:Ghci1 diff --git a/testsuite/tests/ghci/scripts/T8959.stdout b/testsuite/tests/ghci/scripts/T8959.stdout index 4631732c55..77d1b7d63b 100644 --- a/testsuite/tests/ghci/scripts/T8959.stdout +++ b/testsuite/tests/ghci/scripts/T8959.stdout @@ -1,6 +1,9 @@ lookup :: Eq a => a -> [(a, b)] -> Maybe b -undefined :: (forall a. a -> a) -> a :: (forall a1. a1 -> a1) -> a +undefined :: (forall a. a -> a) -> a + :: (?callStack::CallStack) => (forall a1. a1 -> a1) -> a lookup ∷ Eq a ⇒ a → [(a, b)] → Maybe b -undefined :: (forall a. a -> a) -> a ∷ (∀ a1. a1 → a1) → a +undefined :: (forall a. a -> a) -> a + ∷ (?callStack::CallStack) ⇒ (∀ a1. a1 → a1) → a lookup :: Eq a => a -> [(a, b)] -> Maybe b -undefined :: (forall a. a -> a) -> a :: (forall a1. a1 -> a1) -> a +undefined :: (forall a. a -> a) -> a + :: (?callStack::CallStack) => (forall a1. a1 -> a1) -> a diff --git a/testsuite/tests/ghci/scripts/ghci013.stdout b/testsuite/tests/ghci/scripts/ghci013.stdout index 6d99b877ba..245881f02b 100644 --- a/testsuite/tests/ghci/scripts/ghci013.stdout +++ b/testsuite/tests/ghci/scripts/ghci013.stdout @@ -1 +1 @@ -f :: Monad m => (m a, r) -> m b +f :: (Monad m, ?callStack::CallStack) => (m a, r) -> m b diff --git a/testsuite/tests/ghci/scripts/ghci046.stdout b/testsuite/tests/ghci/scripts/ghci046.stdout index c4e7cf3fc7..8b112976af 100644 --- a/testsuite/tests/ghci/scripts/ghci046.stdout +++ b/testsuite/tests/ghci/scripts/ghci046.stdout @@ -2,5 +2,5 @@ AND HTrue HTrue :: * = HTrue AND (OR HFalse HTrue) (OR HTrue HFalse) :: * = HTrue -t :: HTrue -t :: HFalse +t :: (?callStack::CallStack) => HTrue +t :: (?callStack::CallStack) => HFalse diff --git a/testsuite/tests/ghci/scripts/ghci055.stdout b/testsuite/tests/ghci/scripts/ghci055.stdout index 578740d6de..6011c68f26 100644 --- a/testsuite/tests/ghci/scripts/ghci055.stdout +++ b/testsuite/tests/ghci/scripts/ghci055.stdout @@ -1,6 +1,3 @@ -*** Exception: Prelude.undefined -CallStack (from ImplicitParams): - error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err - undefined, called at <interactive>:1:7 in interactive:Ghci1 -x :: r = _ +x = _ +x :: ?callStack::CallStack => r = _ y :: Integer = 3 diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr index 965d492754..0c0410d0f2 100644 --- a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr +++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr @@ -1,231 +1,231 @@ -TYPE SIGNATURES
- !! :: forall a. [a] -> Int -> a
- $ :: forall a b. (a -> b) -> a -> b
- $! :: forall a b. (a -> b) -> a -> b
- && :: Bool -> Bool -> Bool
- * :: forall a. Num a => a -> a -> a
- ** :: forall a. Floating a => a -> a -> a
- + :: forall a. Num a => a -> a -> a
- ++ :: forall a. [a] -> [a] -> [a]
- - :: forall a. Num a => a -> a -> a
- . :: forall b c a. (b -> c) -> (a -> b) -> a -> c
- / :: forall a. Fractional a => a -> a -> a
- /= :: forall a. Eq a => a -> a -> Bool
- < :: forall a. Ord a => a -> a -> Bool
- <= :: forall a. Ord a => a -> a -> Bool
- =<< ::
- forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
- == :: forall a. Eq a => a -> a -> Bool
- > :: forall a. Ord a => a -> a -> Bool
- >= :: forall a. Ord a => a -> a -> Bool
- >> :: forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
- >>= ::
- forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
- ^ :: forall a b. (Integral b, Num a) => a -> b -> a
- ^^ :: forall a b. (Fractional a, Integral b) => a -> b -> a
- abs :: forall a. Num a => a -> a
- acos :: forall a. Floating a => a -> a
- acosh :: forall a. Floating a => a -> a
- all ::
- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
- and :: forall (t :: * -> *). Foldable t => t Bool -> Bool
- any ::
- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
- appendFile :: FilePath -> String -> IO ()
- asTypeOf :: forall a. a -> a -> a
- asin :: forall a. Floating a => a -> a
- asinh :: forall a. Floating a => a -> a
- atan :: forall a. Floating a => a -> a
- atan2 :: forall a. RealFloat a => a -> a -> a
- atanh :: forall a. Floating a => a -> a
- break :: forall a. (a -> Bool) -> [a] -> ([a], [a])
- ceiling :: forall a b. (Integral b, RealFrac a) => a -> b
- compare :: forall a. Ord a => a -> a -> Ordering
- concat :: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
- concatMap ::
- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
- const :: forall a b. a -> b -> a
- cos :: forall a. Floating a => a -> a
- cosh :: forall a. Floating a => a -> a
- curry :: forall a b c. ((a, b) -> c) -> a -> b -> c
- cycle :: forall a. [a] -> [a]
- decodeFloat :: forall a. RealFloat a => a -> (Integer, Int)
- div :: forall a. Integral a => a -> a -> a
- divMod :: forall a. Integral a => a -> a -> (a, a)
- drop :: forall a. Int -> [a] -> [a]
- dropWhile :: forall a. (a -> Bool) -> [a] -> [a]
- either :: forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
- elem ::
- forall (t :: * -> *) a. (Eq a, Foldable t) => a -> t a -> Bool
- encodeFloat :: forall a. RealFloat a => Integer -> Int -> a
- enumFrom :: forall a. Enum a => a -> [a]
- enumFromThen :: forall a. Enum a => a -> a -> [a]
- enumFromThenTo :: forall a. Enum a => a -> a -> a -> [a]
- enumFromTo :: forall a. Enum a => a -> a -> [a]
- error :: forall a. [Char] -> a
- even :: forall a. Integral a => a -> Bool
- exp :: forall a. Floating a => a -> a
- exponent :: forall a. RealFloat a => a -> Int
- fail :: forall (m :: * -> *) a. Monad m => String -> m a
- filter :: forall a. (a -> Bool) -> [a] -> [a]
- flip :: forall a b c. (a -> b -> c) -> b -> a -> c
- floatDigits :: forall a. RealFloat a => a -> Int
- floatRadix :: forall a. RealFloat a => a -> Integer
- floatRange :: forall a. RealFloat a => a -> (Int, Int)
- floor :: forall a b. (Integral b, RealFrac a) => a -> b
- fmap ::
- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
- foldl ::
- forall (t :: * -> *) b a.
- Foldable t =>
- (b -> a -> b) -> b -> t a -> b
- foldl1 ::
- forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
- foldr ::
- forall (t :: * -> *) a b.
- Foldable t =>
- (a -> b -> b) -> b -> t a -> b
- foldr1 ::
- forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
- fromEnum :: forall a. Enum a => a -> Int
- fromInteger :: forall a. Num a => Integer -> a
- fromIntegral :: forall a b. (Integral a, Num b) => a -> b
- fromRational :: forall a. Fractional a => Rational -> a
- fst :: forall a b. (a, b) -> a
- gcd :: forall a. Integral a => a -> a -> a
- getChar :: IO Char
- getContents :: IO String
- getLine :: IO String
- head :: forall a. [a] -> a
- id :: forall a. a -> a
- init :: forall a. [a] -> [a]
- interact :: (String -> String) -> IO ()
- ioError :: forall a. IOError -> IO a
- isDenormalized :: forall a. RealFloat a => a -> Bool
- isIEEE :: forall a. RealFloat a => a -> Bool
- isInfinite :: forall a. RealFloat a => a -> Bool
- isNaN :: forall a. RealFloat a => a -> Bool
- isNegativeZero :: forall a. RealFloat a => a -> Bool
- iterate :: forall a. (a -> a) -> a -> [a]
- last :: forall a. [a] -> a
- lcm :: forall a. Integral a => a -> a -> a
- length :: forall (t :: * -> *) a. Foldable t => t a -> Int
- lex :: ReadS String
- lines :: String -> [String]
- log :: forall a. Floating a => a -> a
- logBase :: forall a. Floating a => a -> a -> a
- lookup :: forall a b. Eq a => a -> [(a, b)] -> Maybe b
- map :: forall a b. (a -> b) -> [a] -> [b]
- mapM ::
- forall (t :: * -> *) (m :: * -> *) a b.
- (Monad m, Traversable t) =>
- (a -> m b) -> t a -> m (t b)
- mapM_ ::
- forall (t :: * -> *) (m :: * -> *) a b.
- (Monad m, Foldable t) =>
- (a -> m b) -> t a -> m ()
- max :: forall a. Ord a => a -> a -> a
- maxBound :: forall t. Bounded t => t
- maximum :: forall (t :: * -> *) a. (Ord a, Foldable t) => t a -> a
- maybe :: forall b a. b -> (a -> b) -> Maybe a -> b
- min :: forall a. Ord a => a -> a -> a
- minBound :: forall t. Bounded t => t
- minimum :: forall (t :: * -> *) a. (Ord a, Foldable t) => t a -> a
- mod :: forall a. Integral a => a -> a -> a
- negate :: forall a. Num a => a -> a
- not :: Bool -> Bool
- notElem ::
- forall (t :: * -> *) a. (Eq a, Foldable t) => a -> t a -> Bool
- null :: forall (t :: * -> *) a. Foldable t => t a -> Bool
- odd :: forall a. Integral a => a -> Bool
- or :: forall (t :: * -> *). Foldable t => t Bool -> Bool
- otherwise :: Bool
- pi :: forall t. Floating t => t
- pred :: forall a. Enum a => a -> a
- print :: forall a. Show a => a -> IO ()
- product :: forall (t :: * -> *) a. (Num a, Foldable t) => t a -> a
- properFraction ::
- forall a b. (Integral b, RealFrac a) => a -> (b, a)
- putChar :: Char -> IO ()
- putStr :: String -> IO ()
- putStrLn :: String -> IO ()
- quot :: forall a. Integral a => a -> a -> a
- quotRem :: forall a. Integral a => a -> a -> (a, a)
- read :: forall a. Read a => String -> a
- readFile :: FilePath -> IO String
- readIO :: forall a. Read a => String -> IO a
- readList :: forall a. Read a => ReadS [a]
- readLn :: forall a. Read a => IO a
- readParen :: forall a. Bool -> ReadS a -> ReadS a
- reads :: forall a. Read a => ReadS a
- readsPrec :: forall a. Read a => Int -> ReadS a
- realToFrac :: forall a b. (Fractional b, Real a) => a -> b
- recip :: forall a. Fractional a => a -> a
- rem :: forall a. Integral a => a -> a -> a
- repeat :: forall a. a -> [a]
- replicate :: forall a. Int -> a -> [a]
- return :: forall (m :: * -> *) a. Monad m => a -> m a
- reverse :: forall a. [a] -> [a]
- round :: forall a b. (Integral b, RealFrac a) => a -> b
- scaleFloat :: forall a. RealFloat a => Int -> a -> a
- scanl :: forall b a. (b -> a -> b) -> b -> [a] -> [b]
- scanl1 :: forall a. (a -> a -> a) -> [a] -> [a]
- scanr :: forall a b. (a -> b -> b) -> b -> [a] -> [b]
- scanr1 :: forall a. (a -> a -> a) -> [a] -> [a]
- seq :: forall a b. a -> b -> b
- sequence ::
- forall (t :: * -> *) (m :: * -> *) a.
- (Monad m, Traversable t) =>
- t (m a) -> m (t a)
- sequence_ ::
- forall (t :: * -> *) (m :: * -> *) a.
- (Monad m, Foldable t) =>
- t (m a) -> m ()
- show :: forall a. Show a => a -> String
- showChar :: Char -> ShowS
- showList :: forall a. Show a => [a] -> ShowS
- showParen :: Bool -> ShowS -> ShowS
- showString :: String -> ShowS
- shows :: forall a. Show a => a -> ShowS
- showsPrec :: forall a. Show a => Int -> a -> ShowS
- significand :: forall a. RealFloat a => a -> a
- signum :: forall a. Num a => a -> a
- sin :: forall a. Floating a => a -> a
- sinh :: forall a. Floating a => a -> a
- snd :: forall a b. (a, b) -> b
- span :: forall a. (a -> Bool) -> [a] -> ([a], [a])
- splitAt :: forall a. Int -> [a] -> ([a], [a])
- sqrt :: forall a. Floating a => a -> a
- subtract :: forall a. Num a => a -> a -> a
- succ :: forall a. Enum a => a -> a
- sum :: forall (t :: * -> *) a. (Num a, Foldable t) => t a -> a
- tail :: forall a. [a] -> [a]
- take :: forall a. Int -> [a] -> [a]
- takeWhile :: forall a. (a -> Bool) -> [a] -> [a]
- tan :: forall a. Floating a => a -> a
- tanh :: forall a. Floating a => a -> a
- toEnum :: forall a. Enum a => Int -> a
- toInteger :: forall a. Integral a => a -> Integer
- toRational :: forall a. Real a => a -> Rational
- truncate :: forall a b. (Integral b, RealFrac a) => a -> b
- uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c
- undefined :: forall t. t
- unlines :: [String] -> String
- until :: forall a. (a -> Bool) -> (a -> a) -> a -> a
- unwords :: [String] -> String
- unzip :: forall a b. [(a, b)] -> ([a], [b])
- unzip3 :: forall a b c. [(a, b, c)] -> ([a], [b], [c])
- userError :: String -> IOError
- words :: String -> [String]
- writeFile :: FilePath -> String -> IO ()
- zip :: forall a b. [a] -> [b] -> [(a, b)]
- zip3 :: forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
- zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
- zipWith3 ::
- forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
- || :: Bool -> Bool -> Bool
-TYPE CONSTRUCTORS
-COERCION AXIOMS
-Dependent modules: []
-Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
- integer-gmp-1.0.0.0]
+TYPE SIGNATURES + !! :: forall a. [a] -> Int -> a + $ :: forall a b. (a -> b) -> a -> b + $! :: forall a b. (a -> b) -> a -> b + && :: Bool -> Bool -> Bool + * :: forall a. Num a => a -> a -> a + ** :: forall a. Floating a => a -> a -> a + + :: forall a. Num a => a -> a -> a + ++ :: forall a. [a] -> [a] -> [a] + - :: forall a. Num a => a -> a -> a + . :: forall b c a. (b -> c) -> (a -> b) -> a -> c + / :: forall a. Fractional a => a -> a -> a + /= :: forall a. Eq a => a -> a -> Bool + < :: forall a. Ord a => a -> a -> Bool + <= :: forall a. Ord a => a -> a -> Bool + =<< :: + forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b + == :: forall a. Eq a => a -> a -> Bool + > :: forall a. Ord a => a -> a -> Bool + >= :: forall a. Ord a => a -> a -> Bool + >> :: forall (m :: * -> *) a b. Monad m => m a -> m b -> m b + >>= :: + forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b + ^ :: forall a b. (Integral b, Num a) => a -> b -> a + ^^ :: forall a b. (Fractional a, Integral b) => a -> b -> a + abs :: forall a. Num a => a -> a + acos :: forall a. Floating a => a -> a + acosh :: forall a. Floating a => a -> a + all :: + forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool + and :: forall (t :: * -> *). Foldable t => t Bool -> Bool + any :: + forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool + appendFile :: FilePath -> String -> IO () + asTypeOf :: forall a. a -> a -> a + asin :: forall a. Floating a => a -> a + asinh :: forall a. Floating a => a -> a + atan :: forall a. Floating a => a -> a + atan2 :: forall a. RealFloat a => a -> a -> a + atanh :: forall a. Floating a => a -> a + break :: forall a. (a -> Bool) -> [a] -> ([a], [a]) + ceiling :: forall a b. (Integral b, RealFrac a) => a -> b + compare :: forall a. Ord a => a -> a -> Ordering + concat :: forall (t :: * -> *) a. Foldable t => t [a] -> [a] + concatMap :: + forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] + const :: forall a b. a -> b -> a + cos :: forall a. Floating a => a -> a + cosh :: forall a. Floating a => a -> a + curry :: forall a b c. ((a, b) -> c) -> a -> b -> c + cycle :: forall a. [a] -> [a] + decodeFloat :: forall a. RealFloat a => a -> (Integer, Int) + div :: forall a. Integral a => a -> a -> a + divMod :: forall a. Integral a => a -> a -> (a, a) + drop :: forall a. Int -> [a] -> [a] + dropWhile :: forall a. (a -> Bool) -> [a] -> [a] + either :: forall a c b. (a -> c) -> (b -> c) -> Either a b -> c + elem :: + forall (t :: * -> *) a. (Eq a, Foldable t) => a -> t a -> Bool + encodeFloat :: forall a. RealFloat a => Integer -> Int -> a + enumFrom :: forall a. Enum a => a -> [a] + enumFromThen :: forall a. Enum a => a -> a -> [a] + enumFromThenTo :: forall a. Enum a => a -> a -> a -> [a] + enumFromTo :: forall a. Enum a => a -> a -> [a] + error :: forall a. (?callStack::CallStack) => [Char] -> a + even :: forall a. Integral a => a -> Bool + exp :: forall a. Floating a => a -> a + exponent :: forall a. RealFloat a => a -> Int + fail :: forall (m :: * -> *) a. Monad m => String -> m a + filter :: forall a. (a -> Bool) -> [a] -> [a] + flip :: forall a b c. (a -> b -> c) -> b -> a -> c + floatDigits :: forall a. RealFloat a => a -> Int + floatRadix :: forall a. RealFloat a => a -> Integer + floatRange :: forall a. RealFloat a => a -> (Int, Int) + floor :: forall a b. (Integral b, RealFrac a) => a -> b + fmap :: + forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b + foldl :: + forall (t :: * -> *) b a. + Foldable t => + (b -> a -> b) -> b -> t a -> b + foldl1 :: + forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a + foldr :: + forall (t :: * -> *) a b. + Foldable t => + (a -> b -> b) -> b -> t a -> b + foldr1 :: + forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a + fromEnum :: forall a. Enum a => a -> Int + fromInteger :: forall a. Num a => Integer -> a + fromIntegral :: forall a b. (Integral a, Num b) => a -> b + fromRational :: forall a. Fractional a => Rational -> a + fst :: forall a b. (a, b) -> a + gcd :: forall a. Integral a => a -> a -> a + getChar :: IO Char + getContents :: IO String + getLine :: IO String + head :: forall a. [a] -> a + id :: forall a. a -> a + init :: forall a. [a] -> [a] + interact :: (String -> String) -> IO () + ioError :: forall a. IOError -> IO a + isDenormalized :: forall a. RealFloat a => a -> Bool + isIEEE :: forall a. RealFloat a => a -> Bool + isInfinite :: forall a. RealFloat a => a -> Bool + isNaN :: forall a. RealFloat a => a -> Bool + isNegativeZero :: forall a. RealFloat a => a -> Bool + iterate :: forall a. (a -> a) -> a -> [a] + last :: forall a. [a] -> a + lcm :: forall a. Integral a => a -> a -> a + length :: forall (t :: * -> *) a. Foldable t => t a -> Int + lex :: ReadS String + lines :: String -> [String] + log :: forall a. Floating a => a -> a + logBase :: forall a. Floating a => a -> a -> a + lookup :: forall a b. Eq a => a -> [(a, b)] -> Maybe b + map :: forall a b. (a -> b) -> [a] -> [b] + mapM :: + forall (t :: * -> *) (m :: * -> *) a b. + (Monad m, Traversable t) => + (a -> m b) -> t a -> m (t b) + mapM_ :: + forall (t :: * -> *) (m :: * -> *) a b. + (Monad m, Foldable t) => + (a -> m b) -> t a -> m () + max :: forall a. Ord a => a -> a -> a + maxBound :: forall t. Bounded t => t + maximum :: forall (t :: * -> *) a. (Ord a, Foldable t) => t a -> a + maybe :: forall b a. b -> (a -> b) -> Maybe a -> b + min :: forall a. Ord a => a -> a -> a + minBound :: forall t. Bounded t => t + minimum :: forall (t :: * -> *) a. (Ord a, Foldable t) => t a -> a + mod :: forall a. Integral a => a -> a -> a + negate :: forall a. Num a => a -> a + not :: Bool -> Bool + notElem :: + forall (t :: * -> *) a. (Eq a, Foldable t) => a -> t a -> Bool + null :: forall (t :: * -> *) a. Foldable t => t a -> Bool + odd :: forall a. Integral a => a -> Bool + or :: forall (t :: * -> *). Foldable t => t Bool -> Bool + otherwise :: Bool + pi :: forall t. Floating t => t + pred :: forall a. Enum a => a -> a + print :: forall a. Show a => a -> IO () + product :: forall (t :: * -> *) a. (Num a, Foldable t) => t a -> a + properFraction :: + forall a b. (Integral b, RealFrac a) => a -> (b, a) + putChar :: Char -> IO () + putStr :: String -> IO () + putStrLn :: String -> IO () + quot :: forall a. Integral a => a -> a -> a + quotRem :: forall a. Integral a => a -> a -> (a, a) + read :: forall a. Read a => String -> a + readFile :: FilePath -> IO String + readIO :: forall a. Read a => String -> IO a + readList :: forall a. Read a => ReadS [a] + readLn :: forall a. Read a => IO a + readParen :: forall a. Bool -> ReadS a -> ReadS a + reads :: forall a. Read a => ReadS a + readsPrec :: forall a. Read a => Int -> ReadS a + realToFrac :: forall a b. (Fractional b, Real a) => a -> b + recip :: forall a. Fractional a => a -> a + rem :: forall a. Integral a => a -> a -> a + repeat :: forall a. a -> [a] + replicate :: forall a. Int -> a -> [a] + return :: forall (m :: * -> *) a. Monad m => a -> m a + reverse :: forall a. [a] -> [a] + round :: forall a b. (Integral b, RealFrac a) => a -> b + scaleFloat :: forall a. RealFloat a => Int -> a -> a + scanl :: forall b a. (b -> a -> b) -> b -> [a] -> [b] + scanl1 :: forall a. (a -> a -> a) -> [a] -> [a] + scanr :: forall a b. (a -> b -> b) -> b -> [a] -> [b] + scanr1 :: forall a. (a -> a -> a) -> [a] -> [a] + seq :: forall a b. a -> b -> b + sequence :: + forall (t :: * -> *) (m :: * -> *) a. + (Monad m, Traversable t) => + t (m a) -> m (t a) + sequence_ :: + forall (t :: * -> *) (m :: * -> *) a. + (Monad m, Foldable t) => + t (m a) -> m () + show :: forall a. Show a => a -> String + showChar :: Char -> ShowS + showList :: forall a. Show a => [a] -> ShowS + showParen :: Bool -> ShowS -> ShowS + showString :: String -> ShowS + shows :: forall a. Show a => a -> ShowS + showsPrec :: forall a. Show a => Int -> a -> ShowS + significand :: forall a. RealFloat a => a -> a + signum :: forall a. Num a => a -> a + sin :: forall a. Floating a => a -> a + sinh :: forall a. Floating a => a -> a + snd :: forall a b. (a, b) -> b + span :: forall a. (a -> Bool) -> [a] -> ([a], [a]) + splitAt :: forall a. Int -> [a] -> ([a], [a]) + sqrt :: forall a. Floating a => a -> a + subtract :: forall a. Num a => a -> a -> a + succ :: forall a. Enum a => a -> a + sum :: forall (t :: * -> *) a. (Num a, Foldable t) => t a -> a + tail :: forall a. [a] -> [a] + take :: forall a. Int -> [a] -> [a] + takeWhile :: forall a. (a -> Bool) -> [a] -> [a] + tan :: forall a. Floating a => a -> a + tanh :: forall a. Floating a => a -> a + toEnum :: forall a. Enum a => Int -> a + toInteger :: forall a. Integral a => a -> Integer + toRational :: forall a. Real a => a -> Rational + truncate :: forall a b. (Integral b, RealFrac a) => a -> b + uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c + undefined :: forall t. (?callStack::CallStack) => t + unlines :: [String] -> String + until :: forall a. (a -> Bool) -> (a -> a) -> a -> a + unwords :: [String] -> String + unzip :: forall a b. [(a, b)] -> ([a], [b]) + unzip3 :: forall a b c. [(a, b, c)] -> ([a], [b], [c]) + userError :: String -> IOError + words :: String -> [String] + writeFile :: FilePath -> String -> IO () + zip :: forall a b. [a] -> [b] -> [(a, b)] + zip3 :: forall a b c. [a] -> [b] -> [c] -> [(a, b, c)] + zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] + zipWith3 :: + forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] + || :: Bool -> Bool -> Bool +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/partial-sigs/should_fail/T10999.stderr b/testsuite/tests/partial-sigs/should_fail/T10999.stderr index c74719addf..408529185f 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10999.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10999.stderr @@ -1,6 +1,7 @@ T10999.hs:5:6: error: - Found constraint wildcard ‘_’ standing for ‘Ord a’ + Found constraint wildcard ‘_’ standing for ‘(Ord a, + ?callStack::CallStack)’ To use the inferred type, enable PartialTypeSignatures In the type signature: f :: _ => () -> _ @@ -8,7 +9,9 @@ T10999.hs:5:6: error: T10999.hs:5:17: error: • Found type wildcard ‘_’ standing for ‘Set.Set a’ Where: ‘a’ is a rigid type variable bound by - the inferred type of f :: Ord a => () -> Set.Set a at T10999.hs:6:1 + the inferred type of + f :: (Ord a, ?callStack::CallStack) => () -> Set.Set a + at T10999.hs:6:1 To use the inferred type, enable PartialTypeSignatures • In the type signature: f :: _ => () -> _ diff --git a/testsuite/tests/pmcheck/should_compile/T3927b.stderr b/testsuite/tests/pmcheck/should_compile/T3927b.stderr index fb4449ced9..e69de29bb2 100644 --- a/testsuite/tests/pmcheck/should_compile/T3927b.stderr +++ b/testsuite/tests/pmcheck/should_compile/T3927b.stderr @@ -1,39 +0,0 @@ -T3927b.hs:58:5: warning: - • Redundant constraint: Restrict op (Implements 'Dealer) - • In the type signature for: - f :: Restrict op (Implements 'Dealer) => - SockOp 'Dealer op -> Operation op - In an equation for ‘dealer’: - dealer - = Socket (Proxy :: Proxy Dealer) f - where - f :: - Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op - f SRead = undefined - f SWrite = undefined - -T3927b.hs:65:5: warning: - • Redundant constraint: Restrict op (Implements 'Push) - • In the type signature for: - f :: Restrict op (Implements 'Push) => - SockOp 'Push op -> Operation op - In an equation for ‘push’: - push - = Socket (Proxy :: Proxy Push) f - where - f :: - Restrict op (Implements Push) => SockOp Push op -> Operation op - f SWrite = undefined - -T3927b.hs:71:5: warning: - • Redundant constraint: Restrict op (Implements 'Pull) - • In the type signature for: - f :: Restrict op (Implements 'Pull) => - SockOp 'Pull op -> Operation op - In an equation for ‘pull’: - pull - = Socket (Proxy :: Proxy Pull) f - where - f :: - Restrict op (Implements Pull) => SockOp Pull op -> Operation op - f SRead = undefined diff --git a/testsuite/tests/th/T1849.script b/testsuite/tests/th/T1849.script index 5ae77b9023..cee251ae67 100644 --- a/testsuite/tests/th/T1849.script +++ b/testsuite/tests/th/T1849.script @@ -1,9 +1,9 @@ :set -XTemplateHaskell import Language.Haskell.TH let seeType n = do VarI _ t _ <- reify n; runIO $ putStrLn $ show t; [| return True |] -let f = undefined :: Int -> Int -let g = undefined :: [Int] -let h = undefined :: (Int, Int) +let f :: Int -> Int; f = undefined +let g :: [Int] ; g = undefined +let h :: (Int, Int); h = undefined $(seeType (mkName "f")) $(seeType (mkName "g")) $(seeType (mkName "h")) diff --git a/testsuite/tests/typecheck/should_run/IPLocation.hs b/testsuite/tests/typecheck/should_run/IPLocation.hs index 63f73d2ccb..75575e0d16 100644 --- a/testsuite/tests/typecheck/should_run/IPLocation.hs +++ b/testsuite/tests/typecheck/should_run/IPLocation.hs @@ -2,21 +2,14 @@ {-# OPTIONS_GHC -dcore-lint #-} module Main where -import GHC.Exception -import GHC.Types +import GHC.Stack -f0 = putStrLn $ showCallStack ?loc - -- should just show the location of ?loc +f0 = putStrLn $ prettyCallStack ?loc + -- should be empty 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 +f1 = putStrLn $ prettyCallStack ?loc + -- should show the location of f1's call-site f3 :: ((?loc :: CallStack) => () -> IO ()) -> IO () f3 x = x () @@ -32,14 +25,13 @@ 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 0 = putStrLn $ prettyCallStack ?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) + f3 (\ () -> putStrLn $ prettyCallStack ?loc) + f4 (\ () -> putStrLn $ prettyCallStack ?loc) + f5 (\ () -> putStrLn $ prettyCallStack ?loc3) f6 5 diff --git a/testsuite/tests/typecheck/should_run/IPLocation.stdout b/testsuite/tests/typecheck/should_run/IPLocation.stdout index d02250f8de..92c0cd45b2 100644 --- a/testsuite/tests/typecheck/should_run/IPLocation.stdout +++ b/testsuite/tests/typecheck/should_run/IPLocation.stdout @@ -1,28 +1,16 @@ + CallStack (from ImplicitParams): - ?loc, called at IPLocation.hs:8:31 in main:Main + f1, called at IPLocation.hs:34:11 in main:Main CallStack (from ImplicitParams): - ?loc, called at IPLocation.hs:12:31 in main:Main - f1, called at IPLocation.hs:40:11 in main:Main + x, called at IPLocation.hs:16:8 in main:Main CallStack (from ImplicitParams): - ?loc, called at IPLocation.hs:16:34 in main:Main - f2, called at IPLocation.hs:41:11 in main:Main + x, called at IPLocation.hs:21:8 in main:Main + f4, called at IPLocation.hs:36:11 in main:Main + CallStack (from ImplicitParams): - ?loc, called at IPLocation.hs:17:34 in main:Main - f2, called at IPLocation.hs:41:11 in main:Main -CallStack (from ImplicitParams): - ?loc, called at IPLocation.hs:42:48 in main:Main - x, called at IPLocation.hs:22:8 in main:Main -CallStack (from ImplicitParams): - ?loc, called at IPLocation.hs:43:48 in main:Main - x, called at IPLocation.hs:27:8 in main:Main - f4, called at IPLocation.hs:43:11 in main:Main -CallStack (from ImplicitParams): - ?loc3, called at IPLocation.hs:44:48 in main:Main -CallStack (from ImplicitParams): - ?loc, called at IPLocation.hs:35:33 in main:Main - f6, called at IPLocation.hs:36:8 in main:Main - f6, called at IPLocation.hs:36:8 in main:Main - f6, called at IPLocation.hs:36:8 in main:Main - f6, called at IPLocation.hs:36:8 in main:Main - f6, called at IPLocation.hs:36:8 in main:Main - f6, called at IPLocation.hs:45:11 in main:Main + f6, called at IPLocation.hs:30:8 in main:Main + f6, called at IPLocation.hs:30:8 in main:Main + f6, called at IPLocation.hs:30:8 in main:Main + f6, called at IPLocation.hs:30:8 in main:Main + f6, called at IPLocation.hs:30:8 in main:Main + f6, called at IPLocation.hs:38:11 in main:Main diff --git a/testsuite/tests/typecheck/should_run/T10845.hs b/testsuite/tests/typecheck/should_run/T10845.hs new file mode 100644 index 0000000000..3d813fc40f --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T10845.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ImplicitParams #-} +{-# OPTIONS_GHC -dcore-lint #-} + +import GHC.Stack + +f1 :: (?loc :: CallStack) => CallStack +-- we can infer a CallStack for let-binders +f1 = let y x = (?loc :: CallStack) + in y 0 + +f2 :: (?loc :: CallStack) => CallStack +-- but only when we would infer an IP. +-- i.e. the monomorphism restriction prevents us +-- from inferring a CallStack. +f2 = let y = (?loc :: CallStack) + in y + +main :: IO () +main = do putStrLn $ prettyCallStack f1 + putStrLn $ prettyCallStack f2 diff --git a/testsuite/tests/typecheck/should_run/T10845.stdout b/testsuite/tests/typecheck/should_run/T10845.stdout new file mode 100644 index 0000000000..af39ed4728 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T10845.stdout @@ -0,0 +1,5 @@ +CallStack (from ImplicitParams): + y, called at T10845.hs:10:9 in main:Main + f1, called at T10845.hs:20:36 in main:Main +CallStack (from ImplicitParams): + f2, called at T10845.hs:21:36 in main:Main diff --git a/testsuite/tests/typecheck/should_run/T10846.hs b/testsuite/tests/typecheck/should_run/T10846.hs new file mode 100644 index 0000000000..e9ec573726 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T10846.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} + +module Main where + +import GHC.Stack + +f1 :: (?loc :: CallStack) => String +f1 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc + +f2 :: (?loc :: CallStack) => _ +f2 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc + +f3 :: (?loc :: CallStack, _) => String +f3 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc + +main :: IO () +main = do + putStrLn f1 + putStrLn f2 + putStrLn f3 diff --git a/testsuite/tests/typecheck/should_run/T10846.stdout b/testsuite/tests/typecheck/should_run/T10846.stdout new file mode 100644 index 0000000000..04ad2fd65a --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T10846.stdout @@ -0,0 +1,3 @@ +[18] +[19] +[20] diff --git a/testsuite/tests/typecheck/should_run/T8119.stdout b/testsuite/tests/typecheck/should_run/T8119.stdout index cda6b1de02..e796b66d24 100644 --- a/testsuite/tests/typecheck/should_run/T8119.stdout +++ b/testsuite/tests/typecheck/should_run/T8119.stdout @@ -1,2 +1,3 @@ -test `asTypeOf` (undefined :: a -> b) :: Int -> Int +test `asTypeOf` (undefined :: a -> b) + :: (?callStack::CallStack) => Int -> Int \x -> test x :: Int -> Int diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index 217f75e5a0..def9ede7ff 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/testsuite/tests/typecheck/should_run/all.T @@ -78,6 +78,8 @@ test('testeq2', normal, compile_and_run, ['']) test('T1624', normal, compile_and_run, ['']) test('IPRun', normal, compile_and_run, ['']) test('IPLocation', normal, compile_and_run, ['']) +test('T10845', normal, compile_and_run, ['']) +test('T10846', normal, compile_and_run, ['']) # Support files for T1735 are in directory T1735_Help/ test('T1735', normal, multimod_compile_and_run, ['T1735','']) |