diff options
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','']) |