Use IP based CallStack in error and undefined
authorEric Seidel <gridaphobe@gmail.com>
Wed, 2 Sep 2015 08:22:01 +0000 (10:22 +0200)
committerBen Gamari <ben@smart-cactus.org>
Wed, 2 Sep 2015 11:21:43 +0000 (13:21 +0200)
This patch modifies `error`, `undefined`, and `assertError` to use
implicit call-stacks to provide better error messages to users.

There are a few knock-on effects:

- `GHC.Classes.IP` is now wired-in so it can be used in the wired-in
  types for `error` and `undefined`.

- `TysPrim.tyVarList` has been replaced with a new function
  `TysPrim.mkTemplateTyVars`. `tyVarList` made it easy to introduce
  subtle bugs when you need tyvars of different kinds. The naive

  ```
  tv1 = head $ tyVarList kind1
  tv2 = head $ tyVarList kind2
  ```

  would result in `tv1` and `tv2` sharing a `Unique`, thus substitutions
  would be applied incorrectly, treating `tv1` and `tv2` as the same
  tyvar. `mkTemplateTyVars` avoids this pitfall by taking a list of kinds
  and producing a single tyvar of each kind.

- The types `GHC.SrcLoc.SrcLoc` and `GHC.Stack.CallStack` now live in
  ghc-prim.

- The type `GHC.Exception.ErrorCall` has a new constructor
  `ErrorCallWithLocation` that takes two `String`s instead of one, the
  2nd one being arbitrary metadata about the error (but usually the
  call-stack). A bi-directional pattern synonym `ErrorCall` continues to
  provide the old API.

Updates Cabal, array, and haddock submodules.

Reviewers: nh2, goldfire, simonpj, hvr, rwbarton, austin, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, rodlogic, goldfire, maoe, simonmar, carter,
liyang, bgamari, thomie

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

GHC Trac Issues: #5273

48 files changed:
compiler/basicTypes/MkId.hs
compiler/coreSyn/MkCore.hs
compiler/iface/IfaceType.hs
compiler/prelude/PrelNames.hs
compiler/prelude/TysPrim.hs
compiler/prelude/TysWiredIn.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcTypeNats.hs
compiler/types/Type.hs
compiler/types/TypeRep.hs
docs/users_guide/7.12.1-notes.xml
docs/users_guide/glasgow_exts.xml
libraries/Cabal
libraries/array
libraries/base/Control/Exception.hs
libraries/base/Control/Exception/Base.hs
libraries/base/GHC/Err.hs
libraries/base/GHC/Exception.hs
libraries/base/GHC/Exception.hs-boot
libraries/base/GHC/IO/Exception.hs
libraries/base/GHC/SrcLoc.hs [deleted file]
libraries/base/GHC/Stack.hsc
libraries/base/base.cabal
libraries/base/tests/assert.stderr
libraries/ghc-prim/GHC/Types.hs
testsuite/tests/annotations/should_fail/annfail12.stderr
testsuite/tests/cabal/cabal07/cabal07.stderr
testsuite/tests/deriving/should_run/T9576.stderr
testsuite/tests/driver/T1372/T1372.stderr
testsuite/tests/ghci.debugger/scripts/break009.stdout
testsuite/tests/ghci.debugger/scripts/break011.stdout
testsuite/tests/ghci.debugger/scripts/break017.stdout
testsuite/tests/ghci/scripts/T10501.stderr
testsuite/tests/ghci/scripts/T5557.stdout
testsuite/tests/ghci/scripts/ghci055.stdout
testsuite/tests/perf/compiler/all.T
testsuite/tests/simplCore/should_compile/EvalTest.stdout
testsuite/tests/simplCore/should_compile/T4930.hs
testsuite/tests/simplCore/should_compile/T4930.stderr
testsuite/tests/th/T5358.stderr
testsuite/tests/th/T5976.stderr
testsuite/tests/th/T7276a.stdout
testsuite/tests/th/T8987.stderr
testsuite/tests/th/TH_exn2.stderr
utils/haddock

index 6895677..ad584a3 100644 (file)
@@ -1088,7 +1088,7 @@ proxyHashId
     ty      = mkForAllTys [kv, tv] (mkProxyPrimTy k t)
     kv      = kKiVar
     k       = mkTyVarTy kv
-    tv:_    = tyVarList k
+    [tv]    = mkTemplateTyVars [k]
     t       = mkTyVarTy tv
 
 ------------------------------------------------
index 8bdee4a..3c115f4 100644 (file)
@@ -717,19 +717,30 @@ errorName :: Name
 errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
 
 eRROR_ID :: Id
-eRROR_ID = pc_bottoming_Id1 errorName errorTy
+eRROR_ID = pc_bottoming_Id2 errorName errorTy
 
 errorTy  :: Type   -- See Note [Error and friends have an "open-tyvar" forall]
-errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
+errorTy  = mkSigmaTy [openAlphaTyVar] []
+             (mkFunTys [ mkClassPred
+                           ipClass
+                           [ mkStrLitTy (fsLit "callStack")
+                           , mkTyConTy callStackTyCon ]
+                       , mkListTy charTy]
+                       openAlphaTy)
 
 undefinedName :: Name
 undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID
 
 uNDEFINED_ID :: Id
-uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy
+uNDEFINED_ID = pc_bottoming_Id1 undefinedName undefinedTy
 
 undefinedTy  :: Type   -- See Note [Error and friends have an "open-tyvar" forall]
-undefinedTy  = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
+undefinedTy  = mkSigmaTy [openAlphaTyVar] []
+                 (mkFunTy (mkClassPred
+                             ipClass
+                             [ mkStrLitTy (fsLit "callStack")
+                             , mkTyConTy callStackTyCon ])
+                          openAlphaTy)
 
 {-
 Note [Error and friends have an "open-tyvar" forall]
@@ -773,10 +784,11 @@ pc_bottoming_Id1 name ty
     strict_sig = mkClosedStrictSig [evalDmd] botRes
     -- These "bottom" out, no matter what their arguments
 
-pc_bottoming_Id0 :: Name -> Type -> Id
--- Same but arity zero
-pc_bottoming_Id0 name ty
+pc_bottoming_Id2 :: Name -> Type -> Id
+-- Same but arity two
+pc_bottoming_Id2 name ty
  = mkVanillaGlobalWithInfo name ty bottoming_info
  where
     bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
-    strict_sig = mkClosedStrictSig [] botRes
+                                   `setArityInfo`      2
+    strict_sig = mkClosedStrictSig [evalDmd, evalDmd] botRes
index 9d95b48..8be97df 100644 (file)
@@ -61,7 +61,7 @@ import Var
 -- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv )
 import TysWiredIn
 import TysPrim
-import PrelNames( funTyConKey, ipClassName )
+import PrelNames( funTyConKey )
 import Name
 import BasicTypes
 import Binary
@@ -636,7 +636,7 @@ pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args)
 
 pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc
 pprTyTcApp ctxt_prec tc tys dflags
-  | ifaceTyConName tc == ipClassName
+  | ifaceTyConName tc == getName ipTyCon
   , ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type ty ITC_Nil) <- tys
   = char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty
 
index 12a1543..e56307f 100644 (file)
@@ -320,9 +320,6 @@ basicKnownKeyNames
         -- Type-level naturals
         knownNatClassName, knownSymbolClassName,
 
-        -- Implicit parameters
-        ipClassName,
-
         -- Source locations
         callStackDataConName, callStackTyConName,
         srcLocDataConName,
@@ -1172,18 +1169,14 @@ knownNatClassName     = clsQual gHC_TYPELITS (fsLit "KnownNat") knownNatClassNam
 knownSymbolClassName :: Name
 knownSymbolClassName  = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey
 
--- Implicit parameters
-ipClassName :: Name
-ipClassName         = clsQual gHC_CLASSES (fsLit "IP") ipClassNameKey
-
 -- Source Locations
 callStackDataConName, callStackTyConName, srcLocDataConName :: Name
 callStackDataConName
-  = dcQual gHC_STACK  (fsLit "CallStack") callStackDataConKey
+  = dcQual gHC_TYPES  (fsLit "CallStack") callStackDataConKey
 callStackTyConName
-  = tcQual  gHC_STACK (fsLit "CallStack") callStackTyConKey
+  = tcQual  gHC_TYPES (fsLit "CallStack") callStackTyConKey
 srcLocDataConName
-  = dcQual gHC_SRCLOC (fsLit "SrcLoc")   srcLocDataConKey
+  = dcQual gHC_TYPES (fsLit "SrcLoc")   srcLocDataConKey
 
 -- plugins
 pLUGINS :: Module
@@ -1312,9 +1305,6 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43
 ghciIoClassKey :: Unique
 ghciIoClassKey = mkPreludeClassUnique 44
 
-ipClassNameKey :: Unique
-ipClassNameKey = mkPreludeClassUnique 45
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1540,6 +1530,14 @@ callStackTyConKey = mkPreludeTyConUnique 182
 typeRepTyConKey :: Unique
 typeRepTyConKey = mkPreludeTyConUnique 183
 
+-- Implicit Parameters
+ipTyConKey :: Unique
+ipTyConKey = mkPreludeTyConUnique 184
+
+ipCoNameKey :: Unique
+ipCoNameKey = mkPreludeTyConUnique 185
+
+
 ---------------- Template Haskell -------------------
 --      USES TyConUniques 200-299
 -----------------------------------------------------
@@ -1615,6 +1613,9 @@ callStackDataConKey, srcLocDataConKey :: Unique
 callStackDataConKey                     = mkPreludeDataConUnique 36
 srcLocDataConKey                        = mkPreludeDataConUnique 37
 
+ipDataConKey :: Unique
+ipDataConKey                            = mkPreludeDataConUnique 38
+
 {-
 ************************************************************************
 *                                                                      *
index d45c688..5ce89ad 100644 (file)
@@ -10,7 +10,8 @@
 -- | This module defines TyCons that can't be expressed in Haskell.
 --   They are all, therefore, wired-in TyCons.  C.f module TysWiredIn
 module TysPrim(
-        tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
+        mkTemplateTyVars,
+        alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
         alphaTy, betaTy, gammaTy, deltaTy,
         openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
         kKiVar,
@@ -205,18 +206,19 @@ alphaTyVars is a list of type variables for use in templates:
         ["a", "b", ..., "z", "t1", "t2", ... ]
 -}
 
-tyVarList :: Kind -> [TyVar]
-tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u)
-                                (mkTyVarOccFS (mkFastString name))
-                                noSrcSpan) kind
-                 | u <- [2..],
-                   let name | c <= 'z'  = [c]
-                            | otherwise = 't':show u
-                            where c = chr (u-2 + ord 'a')
-                 ]
+mkTemplateTyVars :: [Kind] -> [TyVar]
+mkTemplateTyVars kinds =
+  [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u)
+                            (mkTyVarOccFS (mkFastString name))
+                            noSrcSpan) k
+  | (k,u) <- zip kinds [2..],
+    let name | c <= 'z'  = [c]
+             | otherwise = 't':show u
+          where c = chr (u-2 + ord 'a')
+  ]
 
 alphaTyVars :: [TyVar]
-alphaTyVars = tyVarList liftedTypeKind
+alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind
 
 betaTyVars :: [TyVar]
 betaTyVars = tail alphaTyVars
@@ -234,14 +236,15 @@ alphaTy, betaTy, gammaTy, deltaTy :: Type
         -- result type for "error", so that we can have (error Int# "Help")
 openAlphaTyVars :: [TyVar]
 openAlphaTyVar, openBetaTyVar :: TyVar
-openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) = tyVarList openTypeKind
+openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_)
+  = mkTemplateTyVars $ repeat openTypeKind
 
 openAlphaTy, openBetaTy :: Type
 openAlphaTy = mkTyVarTy openAlphaTyVar
 openBetaTy  = mkTyVarTy openBetaTyVar
 
 kKiVar :: KindVar
-kKiVar = (tyVarList superKind) !! 10
+kKiVar = (mkTemplateTyVars $ repeat superKind) !! 10
 
 {-
 ************************************************************************
index f8ee24f..449377d 100644 (file)
@@ -75,6 +75,11 @@ module TysWiredIn (
         eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
         coercibleTyCon, coercibleDataCon, coercibleClass,
 
+        -- * Implicit Parameters
+        ipTyCon, ipDataCon, ipClass,
+
+        callStackTyCon,
+
         mkWiredInTyConName -- This is used in TcTypeNats to define the
                            -- built-in functions for evaluation.
     ) where
@@ -88,6 +93,8 @@ import PrelNames
 import TysPrim
 
 -- others:
+import CoAxiom
+import Coercion
 import Constants        ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
 import Module           ( Module )
 import Type             ( mkTyConApp )
@@ -160,6 +167,7 @@ wiredInTyCons = [ unitTyCon     -- Not treated like other tuples, because
               , coercibleTyCon
               , typeNatKindCon
               , typeSymbolKindCon
+              , ipTyCon
               ]
 
 mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -174,6 +182,13 @@ mkWiredInDataConName built_in modu fs unique datacon
                   (AConLike (RealDataCon datacon))    -- Relevant DataCon
                   built_in
 
+mkWiredInCoAxiomName :: BuiltInSyntax -> Module -> FastString -> Unique
+                     -> CoAxiom Branched -> Name
+mkWiredInCoAxiomName built_in modu fs unique ax
+  = mkWiredInName modu (mkTcOccFS fs) unique
+                  (ACoAxiom ax)        -- Relevant CoAxiom
+                  built_in
+
 -- See Note [Kind-changing of (~) and Coercible]
 eqTyConName, eqBoxDataConName :: Name
 eqTyConName      = mkWiredInTyConName   BuiltInSyntax gHC_TYPES (fsLit "~")   eqTyConKey      eqTyCon
@@ -896,14 +911,14 @@ eqTyCon = mkAlgTyCon eqTyConName
   where
     kv = kKiVar
     k = mkTyVarTy kv
-    a:b:_ = tyVarList k
+    [a,b] = mkTemplateTyVars [k,k]
 
 eqBoxDataCon :: DataCon
 eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVarTy args)] eqTyCon
   where
     kv = kKiVar
     k = mkTyVarTy kv
-    a:b:_ = tyVarList k
+    [a,b] = mkTemplateTyVars [k,k]
     args = [kv, a, b]
 
 
@@ -914,7 +929,7 @@ coercibleTyCon = mkClassTyCon
   where kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
         kv = kKiVar
         k = mkTyVarTy kv
-        a:b:_ = tyVarList k
+        [a,b] = mkTemplateTyVars [k,k]
         tvs = [kv, a, b]
         rhs = DataTyCon [coercibleDataCon] False
 
@@ -923,8 +938,59 @@ coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon
   where
     kv = kKiVar
     k = mkTyVarTy kv
-    a:b:_ = tyVarList k
+    [a,b] = mkTemplateTyVars [k,k]
     args = [kv, a, b]
 
 coercibleClass :: Class
 coercibleClass = mkClass (tyConTyVars coercibleTyCon) [] [] [] [] [] (mkAnd []) coercibleTyCon
+
+{-
+Note [The Implicit Parameter class]
+
+Implicit parameters `?x :: a` are desugared into dictionaries for the
+class `IP "x" a`, which is defined (in GHC.Classes) as
+
+  class IP (x :: Symbol) a | x -> a
+
+This class is wired-in so that `error` and `undefined`, which have
+wired-in types, can use the implicit-call-stack feature to provide
+a call-stack alongside the error message.
+-}
+
+ipDataConName, ipTyConName, ipCoName :: Name
+ipDataConName = mkWiredInDataConName UserSyntax gHC_CLASSES (fsLit "IP")
+                  ipDataConKey ipDataCon
+ipTyConName   = mkWiredInTyConName UserSyntax gHC_CLASSES (fsLit "IP")
+                  ipTyConKey ipTyCon
+ipCoName      = mkWiredInCoAxiomName BuiltInSyntax gHC_CLASSES (fsLit "NTCo:IP")
+                  ipCoNameKey (toBranchedAxiom ipCoAxiom)
+
+-- See Note [The Implicit Parameter class]
+ipTyCon :: TyCon
+ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive
+  where
+    kind = mkArrowKinds [typeSymbolKind, liftedTypeKind] constraintKind
+    [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
+    rhs = NewTyCon ipDataCon (mkTyVarTy a) ([], mkTyVarTy a) ipCoAxiom
+
+ipCoAxiom :: CoAxiom Unbranched
+ipCoAxiom = mkNewTypeCo ipCoName ipTyCon [ip,a] [Nominal, Nominal] (mkTyVarTy a)
+  where
+    [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
+
+ipDataCon :: DataCon
+ipDataCon = pcDataCon ipDataConName [ip,a] ts ipTyCon
+  where
+    [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
+    ts  = [mkTyVarTy a]
+
+ipClass :: Class
+ipClass = mkClass (tyConTyVars ipTyCon) [([ip], [a])] [] [] [] [] (mkAnd [])
+            ipTyCon
+  where
+    [ip, a] = tyConTyVars ipTyCon
+
+-- this is a fake version of the CallStack TyCon so we can refer to it
+-- in MkCore.errorTy
+callStackTyCon :: TyCon
+callStackTyCon = pcNonRecDataTyCon callStackTyConName Nothing [] []
index 8a7ca4d..897828d 100644 (file)
@@ -37,6 +37,7 @@ import FamInst( tcGetFamInstEnvs )
 import TyCon
 import TcType
 import TysPrim
+import TysWiredIn
 import Id
 import Var
 import VarSet
@@ -56,7 +57,7 @@ import BasicTypes
 import Outputable
 import FastString
 import Type(mkStrLitTy)
-import PrelNames( ipClassName, gHC_PRIM )
+import PrelNames( gHC_PRIM )
 import TcValidity (checkValidType)
 
 import Control.Monad
@@ -225,8 +226,7 @@ tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
 tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
 
 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
-  = do  { ipClass <- tcLookupClass ipClassName
-        ; (given_ips, ip_binds') <-
+  = do  { (given_ips, ip_binds') <-
             mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
 
         -- If the binding binds ?x = E, we  must now
index d2b0c59..354515a 100644 (file)
@@ -46,7 +46,7 @@ import Var
 import VarSet
 import VarEnv
 import TysWiredIn
-import TysPrim( intPrimTy, addrPrimTy )
+import TysPrim( intPrimTy )
 import PrimOp( tagToEnumKey )
 import PrelNames
 import DynFlags
@@ -191,7 +191,6 @@ tcExpr (NegApp expr neg_expr) res_ty
 
 tcExpr (HsIPVar x) res_ty
   = do { let origin = IPOccOrigin x
-       ; ipClass <- tcLookupClass ipClassName
            {- Implicit parameters must have a *tau-type* not a.
               type scheme.  We enforce this by creating a fresh
               type variable as its type.  (Because res_ty may not
@@ -1067,25 +1066,19 @@ tcInferIdWithOrig orig id_name
   = do { dflags <- getDynFlags
        ; if gopt Opt_IgnoreAsserts dflags
          then tc_infer_id orig id_name
-         else tc_infer_assert dflags orig }
+         else tc_infer_assert orig }
 
   | otherwise
   = tc_infer_id orig id_name
 
-tc_infer_assert :: DynFlags -> CtOrigin -> TcM (HsExpr TcId, TcRhoType)
+tc_infer_assert :: CtOrigin -> TcM (HsExpr TcId, TcRhoType)
 -- Deal with an occurrence of 'assert'
 -- See Note [Adding the implicit parameter to 'assert']
-tc_infer_assert dflags orig
-  = do { sloc <- getSrcSpanM
-       ; assert_error_id <- tcLookupId assertErrorName
+tc_infer_assert orig
+  = do { assert_error_id <- tcLookupId assertErrorName
        ; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id)
-       ; let (arg_ty, res_ty) = case tcSplitFunTy_maybe id_rho of
-                                   Nothing      -> pprPanic "assert type" (ppr id_rho)
-                                   Just arg_res -> arg_res
-       ; ASSERT( arg_ty `tcEqType` addrPrimTy )
-         return (HsApp (L sloc (mkHsWrap wrap (HsVar assert_error_id)))
-                       (L sloc (srcSpanPrimLit dflags sloc))
-                , res_ty) }
+       ; return (mkHsWrap wrap (HsVar assert_error_id), id_rho)
+       }
 
 tc_infer_id :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
 -- Return type is deeply instantiated
@@ -1133,17 +1126,12 @@ tc_infer_id orig id_name
       | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
       | otherwise                  = return ()
 
-srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId
-srcSpanPrimLit dflags span
-    = HsLit (HsStringPrim "" (unsafeMkByteString
-                             (showSDocOneLine dflags (ppr span))))
-
 {-
 Note [Adding the implicit parameter to 'assert']
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The typechecker transforms (assert e1 e2) to (assertError "Foo.hs:27"
-e1 e2).  This isn't really the Right Thing because there's no way to
-"undo" if you want to see the original source code in the typechecker
+The typechecker transforms (assert e1 e2) to (assertError e1 e2).
+This isn't really the Right Thing because there's no way to "undo"
+if you want to see the original source code in the typechecker
 output.  We'll have fix this in due course, when we care more about
 being able to reconstruct the exact original program.
 
index 605929e..39ab4e6 100644 (file)
@@ -72,7 +72,7 @@ import Util
 
 import Data.Maybe( isNothing )
 import Control.Monad ( unless, when, zipWithM )
-import PrelNames( ipClassName, funTyConKey, allNameStrings )
+import PrelNames( funTyConKey, allNameStrings )
 
 {-
         ----------------------------
@@ -490,7 +490,6 @@ tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind
 tc_hs_type ipTy@(HsIParamTy n ty) exp_kind
   = do { ty' <- tc_lhs_type ty ekLifted
        ; checkExpectedKind ipTy constraintKind exp_kind
-       ; ipClass <- tcLookupClass ipClassName
        ; let n' = mkStrLitTy $ hsIPNameFS n
        ; return (mkClassPred ipClass [n',ty'])
        }
index 0684fdf..6feb3f0 100644 (file)
@@ -20,9 +20,9 @@ import CoAxiom(sfInteractTop, sfInteractInert)
 
 import Var
 import TcType
-import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey,
+import PrelNames ( knownNatClassName, knownSymbolClassName,
                    callStackTyConKey, typeableClassName )
-import TysWiredIn ( typeNatKind, typeSymbolKind )
+import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind )
 import Id( idType )
 import Class
 import TyCon
@@ -704,7 +704,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs
          else
             continueWith workItem }
 
-  | cls `hasKey` ipClassNameKey
+  | cls == ipClass
   , isGiven ev_w
   = interactGivenIP inerts workItem
 
@@ -1755,7 +1755,7 @@ Other notes:
 -- i.e.   (IP "name" CallStack)
 isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack)
 isCallStackIP loc cls tys
-  | cls `hasKey` ipClassNameKey
+  | cls == ipClass
   , [_ip_name, ty] <- tys
   , Just (tc, _) <- splitTyConApp_maybe ty
   , tc `hasKey` callStackTyConKey
index 9815958..18d3b32 100644 (file)
@@ -29,7 +29,7 @@ import TysWiredIn ( typeNatKind, typeSymbolKind
                   , promotedEQDataCon
                   , promotedGTDataCon
                   )
-import TysPrim    ( tyVarList, mkArrowKinds )
+import TysPrim    ( mkArrowKinds, mkTemplateTyVars )
 import PrelNames  ( gHC_TYPELITS
                   , typeNatAddTyFamNameKey
                   , typeNatMulTyFamNameKey
@@ -106,7 +106,7 @@ typeNatLeqTyCon :: TyCon
 typeNatLeqTyCon =
   mkFamilyTyCon name
     (mkArrowKinds [ typeNatKind, typeNatKind ] boolKind)
-    (take 2 $ tyVarList typeNatKind)
+    (mkTemplateTyVars [ typeNatKind, typeNatKind ])
     (BuiltInSynFamTyCon ops)
     NoParentTyCon
 
@@ -123,7 +123,7 @@ typeNatCmpTyCon :: TyCon
 typeNatCmpTyCon =
   mkFamilyTyCon name
     (mkArrowKinds [ typeNatKind, typeNatKind ] orderingKind)
-    (take 2 $ tyVarList typeNatKind)
+    (mkTemplateTyVars [ typeNatKind, typeNatKind ])
     (BuiltInSynFamTyCon ops)
     NoParentTyCon
 
@@ -140,7 +140,7 @@ typeSymbolCmpTyCon :: TyCon
 typeSymbolCmpTyCon =
   mkFamilyTyCon name
     (mkArrowKinds [ typeSymbolKind, typeSymbolKind ] orderingKind)
-    (take 2 $ tyVarList typeSymbolKind)
+    (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ])
     (BuiltInSynFamTyCon ops)
     NoParentTyCon
 
@@ -162,7 +162,7 @@ mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
 mkTypeNatFunTyCon2 op tcb =
   mkFamilyTyCon op
     (mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind)
-    (take 2 $ tyVarList typeNatKind)
+    (mkTemplateTyVars [ typeNatKind, typeNatKind ])
     (BuiltInSynFamTyCon tcb)
     NoParentTyCon
 
index 1ee53ba..a2feeef 100644 (file)
@@ -163,7 +163,7 @@ import TyCon
 import TysPrim
 import {-# SOURCE #-} TysWiredIn ( eqTyCon, coercibleTyCon, typeNatKind, typeSymbolKind )
 import PrelNames ( eqTyConKey, coercibleTyConKey,
-                   ipClassNameKey, openTypeKindTyConKey,
+                   ipTyConKey, openTypeKindTyConKey,
                    constraintKindTyConKey, liftedTypeKindTyConKey )
 import CoAxiom
 
@@ -908,10 +908,10 @@ isIPPred ty = case tyConAppTyCon_maybe ty of
     _       -> False
 
 isIPTyCon :: TyCon -> Bool
-isIPTyCon tc = tc `hasKey` ipClassNameKey
+isIPTyCon tc = tc `hasKey` ipTyConKey
 
 isIPClass :: Class -> Bool
-isIPClass cls = cls `hasKey` ipClassNameKey
+isIPClass cls = cls `hasKey` ipTyConKey
   -- Class and it corresponding TyCon have the same Unique
 
 isCTupleClass :: Class -> Bool
index e2be8a0..291e14c 100644 (file)
@@ -703,7 +703,7 @@ pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc
 -- Used for types only; so that we can make a
 -- special case for type-level lists
 pprTyTcApp p tc tys
-  | tc `hasKey` ipClassNameKey
+  | tc `hasKey` ipTyConKey
   , [LitTy (StrTyLit n),ty] <- tys
   = maybeParen p FunPrec $
     char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty
index 386095e..5829666 100644 (file)
@@ -46,8 +46,8 @@
            </listitem>
             <listitem>
                 <para>
-                    Implicit parameters of the new base type
-                    <literal>GHC.Stack.CallStack</literal> are treated
+                    Implicit parameters of the new ghc-prim type
+                    <literal>GHC.Types.CallStack</literal> are treated
                     specially, and automatically solved for the current source
                     location. For example
                     <programlisting>
@@ -66,7 +66,7 @@
                     parameter does not matter.
                </para>
                 <para>
-                    See the release notes for base for a description of the
+                    See the release notes for ghc-prim for a description of the
                     <literal>CallStack</literal> type.
                </para>
             </listitem>
            </listitem>
             <listitem>
                 <para>
-                    A new module <literal>GHC.SrcLoc</literal> was added,
-                    exporting a new type <literal>SrcLoc</literal>. A
-                    <literal>SrcLoc</literal> contains package, module,
-                    and file names, as well as start and end positions.
+                    The functions <literal>error</literal>,
+                    <literal>undefined</literal>, and
+                    <literal>assertError</literal> now take an implicit
+                    <literal>CallStack</literal> parameter, and will
+                    output a formatted call stack alongside the error
+                    message.
                </para>
-           </listitem>
-            <listitem>
                 <para>
-                    A new type <literal>CallStack</literal> was added for use
-                    with the new implicit callstack parameters. A
-                    <literal>CallStack</literal> is a
-                    <literal>[(String, SrcLoc)]</literal>, sorted by most-recent
-                    call.
+                    See <xref linkend="implicit-parameters-special"/> for a description of the
+                    implicit call stack feature.
                </para>
            </listitem>
             <listitem>
                     Version number XXXXX (was 0.3.1.0)
                </para>
            </listitem>
+            <listitem>
+                <para>
+                    A new type <literal>SrcLoc</literal> was added. A
+                    <literal>SrcLoc</literal> contains package, module,
+                    and file names, as well as start and end positions.
+               </para>
+           </listitem>
+            <listitem>
+                <para>
+                    A new type <literal>CallStack</literal> was added for use
+                    with the new implicit callstack parameters. A
+                    <literal>CallStack</literal> is a
+                    <literal>[(String, SrcLoc)]</literal>, sorted by most-recent
+                    call.
+               </para>
+           </listitem>
        </itemizedlist>
     </sect3>
 
index 92cbdc0..f8fa9c3 100644 (file)
@@ -8124,9 +8124,9 @@ inner binding of <literal>?x</literal>, so <literal>(f 9)</literal> will return
 </para>
 </sect3>
 
-<sect3><title>Special implicit parameters</title>
+<sect3 id="implicit-parameters-special"><title>Special implicit parameters</title>
 <para>
-GHC treats implicit parameters of type <literal>GHC.Stack.CallStack</literal>
+GHC treats implicit parameters of type <literal>GHC.Types.CallStack</literal>
 specially, by resolving them to the current location in the program. Consider:
 <programlisting>
   f :: String
index f47732a..ad11363 160000 (submodule)
@@ -1 +1 @@
-Subproject commit f47732a50d4bd103c5660c2fbcd77cbce8c521b5
+Subproject commit ad1136358d10d68f3d94fa2fe0f11a25331bdf17
index 68323b2..2f5b772 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 68323b26865ec86a53237ca8974e82bf406a9716
+Subproject commit 2f5b772f4475d70a68c6f9d10390ac9812afdb7d
index 9c388f4..1383972 100644 (file)
@@ -1,5 +1,5 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-}
+{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification, PatternSynonyms #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -56,6 +56,7 @@ module Control.Exception (
         RecSelError(..),
         RecUpdError(..),
         ErrorCall(..),
+        pattern ErrorCall,
         TypeError(..),
 
         -- * Throwing exceptions
index ece5c69..ba2502f 100644 (file)
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude, MagicHash #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
 -----------------------------------------------------------------------------
@@ -38,7 +39,7 @@ module Control.Exception.Base (
         RecConError(..),
         RecSelError(..),
         RecUpdError(..),
-        ErrorCall(..),
+        ErrorCall(..), pattern ErrorCall,
         TypeError(..), -- #10284, custom error type for deferred type errors
 
         -- * Throwing exceptions
index 9bd7132..8cdb107 100644 (file)
@@ -1,5 +1,5 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude, MagicHash #-}
+{-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-}
 {-# OPTIONS_HADDOCK hide #-}
 
 -----------------------------------------------------------------------------
@@ -28,17 +28,17 @@ import GHC.Prim
 import GHC.Integer ()   -- Make sure Integer is compiled first
                         -- because GHC depends on it in a wired-in way
                         -- so the build system doesn't see the dependency
-import {-# SOURCE #-} GHC.Exception( errorCallException )
+import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException )
 
 -- | 'error' stops execution and displays an error message.
-error :: [Char] -> a
-error s = raise# (errorCallException s)
+error :: (?callStack :: CallStack) => [Char] -> a
+error s = raise# (errorCallWithCallStackException s ?callStack)
 
 -- | A special case of 'error'.
 -- It is expected that compilers will recognize this and insert error
 -- messages which are more appropriate to the context in which 'undefined'
 -- appears.
-undefined :: a
+undefined :: (?callStack :: CallStack) => a
 undefined =  error "Prelude.undefined"
 
 -- | Used for compiler-generated error message;
index b82ae11..3fbae05 100644 (file)
@@ -2,6 +2,8 @@
 {-# LANGUAGE NoImplicitPrelude
            , ExistentialQuantification
            , MagicHash
+           , RecordWildCards
+           , PatternSynonyms
   #-}
 {-# OPTIONS_HADDOCK hide #-}
 
 module GHC.Exception
        ( Exception(..)    -- Class
        , throw
-       , SomeException(..), ErrorCall(..), ArithException(..)
+       , SomeException(..), ErrorCall(..), pattern ErrorCall, ArithException(..)
        , divZeroException, overflowException, ratioZeroDenomException
-       , errorCallException
+       , errorCallException, errorCallWithCallStackException
+       , showCallStack, popCallStack, showSrcLoc
+         -- re-export CallStack and SrcLoc from GHC.Types
+       , CallStack(..), SrcLoc(..)
        ) where
 
 import Data.Maybe
@@ -158,17 +163,61 @@ throw e = raise# (toException e)
 
 -- |This is thrown when the user calls 'error'. The @String@ is the
 -- argument given to 'error'.
-newtype ErrorCall = ErrorCall String
+data ErrorCall = ErrorCallWithLocation String String
     deriving (Eq, Ord)
 
+pattern ErrorCall err <- ErrorCallWithLocation err _ where
+  ErrorCall err = ErrorCallWithLocation err ""
+
 instance Exception ErrorCall
 
 instance Show ErrorCall where
-    showsPrec _ (ErrorCall err) = showString err
+  showsPrec _ (ErrorCallWithLocation err "") = showString err
+  showsPrec _ (ErrorCallWithLocation err loc) = showString (err ++ '\n' : loc)
 
 errorCallException :: String -> SomeException
 errorCallException s = toException (ErrorCall s)
 
+errorCallWithCallStackException :: String -> CallStack -> SomeException
+errorCallWithCallStackException s stk
+  = toException (ErrorCallWithLocation s (showCallStack (popCallStack stk)))
+
+
+-- | Pretty print 'SrcLoc'
+--
+-- @since 4.8.2.0
+showSrcLoc :: SrcLoc -> String
+showSrcLoc SrcLoc {..}
+  = foldr (++) ""
+      [ srcLocFile, ":"
+      , show srcLocStartLine, ":"
+      , show srcLocStartCol, " in "
+      , srcLocPackage, ":", srcLocModule
+      ]
+
+-- | Pretty print 'CallStack'
+--
+-- @since 4.8.2.0
+showCallStack :: CallStack -> String
+showCallStack (CallStack stk@(_:_))
+  = unlines ("CallStack:" : map (indent . showCallSite) stk)
+  where
+  -- Data.OldList isn't available yet, so we repeat the definition here
+  unlines [] = []
+  unlines [l] = l
+  unlines (l:ls) = l ++ '\n' : unlines ls
+  indent l = "  " ++ l
+  showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
+showCallStack _ = error "CallStack cannot be empty!"
+
+
+-- | Remove the most recent callsite from the 'CallStack'
+--
+-- @since 4.8.2.0
+popCallStack :: CallStack -> CallStack
+popCallStack (CallStack (_:rest)) = CallStack rest
+popCallStack _ = error "CallStack cannot be empty!"
+
 -- |Arithmetic exceptions.
 data ArithException
   = Overflow
index aa19897..594f266 100644 (file)
@@ -25,10 +25,13 @@ to get a visibly-bottom value.
 -}
 
 module GHC.Exception ( SomeException, errorCallException,
+                       errorCallWithCallStackException,
                        divZeroException, overflowException, ratioZeroDenomException
     ) where
-import GHC.Types( Char )
+import GHC.Types( Char, CallStack )
 
 data SomeException
 divZeroException, overflowException, ratioZeroDenomException  :: SomeException
+
 errorCallException :: [Char] -> SomeException
+errorCallWithCallStackException :: [Char] -> CallStack -> SomeException
index 482027b..e723ebd 100644 (file)
@@ -1,6 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE DeriveGeneric, NoImplicitPrelude, MagicHash,
-             ExistentialQuantification #-}
+             ExistentialQuantification, ImplicitParams #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 {-# OPTIONS_HADDOCK hide #-}
 
@@ -352,10 +352,12 @@ instance Show IOException where
 -- Note the use of "lazy". This means that
 --     assert False (throw e)
 -- will throw the assertion failure rather than e. See trac #5561.
-assertError :: Addr# -> Bool -> a -> a
-assertError str predicate v
+assertError :: (?callStack :: CallStack) => Bool -> a -> a
+assertError predicate v
   | predicate = lazy v
-  | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
+  | otherwise = throw (AssertionFailed
+                        ("Assertion failed\n"
+                         ++ showCallStack (popCallStack ?callStack)))
 
 unsupportedOperation :: IOError
 unsupportedOperation =
diff --git a/libraries/base/GHC/SrcLoc.hs b/libraries/base/GHC/SrcLoc.hs
deleted file mode 100644 (file)
index 23a109b..0000000
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
--- | @since 4.8.2.0
-module GHC.SrcLoc
-  ( SrcLoc
-  , srcLocPackage
-  , srcLocModule
-  , srcLocFile
-  , srcLocStartLine
-  , srcLocStartCol
-  , srcLocEndLine
-  , srcLocEndCol
-
-  -- * Pretty printing
-  , showSrcLoc
-  ) where
-
--- | A single location in the source code.
---
--- @since 4.8.2.0
-data SrcLoc = SrcLoc
-  { srcLocPackage   :: String
-  , srcLocModule    :: String
-  , srcLocFile      :: String
-  , srcLocStartLine :: Int
-  , srcLocStartCol  :: Int
-  , srcLocEndLine   :: Int
-  , srcLocEndCol    :: Int
-  } deriving (Show, Eq)
-
--- | Pretty print 'SrcLoc'
---
--- @since 4.8.2.0
-showSrcLoc :: SrcLoc -> String
-showSrcLoc SrcLoc {..}
-  = concat [ srcLocFile, ":"
-           , show srcLocStartLine, ":"
-           , show srcLocStartCol, " in "
-           , srcLocPackage, ":", srcLocModule
-           ]
index 40fba7d..a2283ff 100644 (file)
 {-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
 module GHC.Stack (
     -- * Call stacks
-    -- ** Simulated by the RTS
     currentCallStack,
     whoCreated,
     errorWithStackTrace,
 
-    -- ** Explicitly created via implicit-parameters
-    --
-    -- @since 4.8.2.0
-    CallStack,
-    getCallStack,
-    showCallStack,
-
     -- * Internals
     CostCentreStack,
     CostCentre,
@@ -44,8 +36,6 @@ module GHC.Stack (
     renderStack
   ) where
 
-import Data.List ( unlines )
-
 import Foreign
 import Foreign.C
 
@@ -56,8 +46,6 @@ import GHC.Foreign as GHC
 import GHC.IO.Encoding
 import GHC.Exception
 import GHC.List ( concatMap, null, reverse )
-import GHC.Show
-import GHC.SrcLoc
 
 #define PROFILING
 #include "Rts.h"
@@ -139,52 +127,4 @@ errorWithStackTrace x = unsafeDupablePerformIO $ do
    stack <- ccsToStrings =<< getCurrentCCS x
    if null stack
       then throwIO (ErrorCall x)
-      else throwIO (ErrorCall (x ++ '\n' : renderStack stack))
-
-
-----------------------------------------------------------------------
--- Explicit call-stacks built via ImplicitParams
-----------------------------------------------------------------------
-
--- | @CallStack@s are an alternate method of obtaining the call stack at a given
--- point in the program.
---
--- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will
--- solve it with the current location. If another @CallStack@ implicit-parameter
--- is in-scope (e.g. as a function argument), the new location will be appended
--- to the one in-scope, creating an explicit call-stack. For example,
---
--- @
--- myerror :: (?loc :: CallStack) => String -> a
--- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc)
--- @
--- ghci> myerror "die"
--- *** Exception: die
--- ?loc, called at MyError.hs:7:51 in main:MyError
---   myerror, called at <interactive>:2:1 in interactive:Ghci1
---
--- @CallStack@s do not interact with the RTS and do not require compilation with
--- @-prof@. On the other hand, as they are built up explicitly using
--- implicit-parameters, they will generally not contain as much information as
--- the simulated call-stacks maintained by the RTS.
---
--- The @CallStack@ type is abstract, but it can be converted into a
--- @[(String, SrcLoc)]@ via 'getCallStack'. The @String@ is the name of function
--- that was called, the 'SrcLoc' is the call-site. The list is ordered with the
--- most recently called function at the head.
---
--- @since 4.8.2.0
-data CallStack = CallStack { getCallStack :: [(String, SrcLoc)] }
-  -- See Note [Overview of implicit CallStacks]
-  deriving (Show, Eq)
-
--- | Pretty print 'CallStack'
---
--- @since 4.8.2.0
-showCallStack :: CallStack -> String
-showCallStack (CallStack (root:rest))
-  = unlines (showCallSite root : map (indent . showCallSite) rest)
-  where
-  indent l = "  " ++ l
-  showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
-showCallStack _ = error "CallStack cannot be empty!"
+      else throwIO (ErrorCallWithLocation x (renderStack stack))
index 21a8ae7..33734a0 100644 (file)
@@ -248,7 +248,6 @@ Library
         GHC.StaticPtr
         GHC.STRef
         GHC.Show
-        GHC.SrcLoc
         GHC.Stable
         GHC.Stack
         GHC.Stats
index 8d99aa0..7183f1e 100644 (file)
@@ -1,2 +1,4 @@
-assert: assert.hs:9:11-16: Assertion failed
+assert: Assertion failed
+CallStack:
+  assert, called at assert.hs:9:11 in main:Main
 
index 7bc746f..6dcd5f1 100644 (file)
@@ -30,10 +30,11 @@ module GHC.Types (
         SPEC(..),
         Nat, Symbol,
         Coercible,
+        SrcLoc(..), CallStack(..)
     ) where
 
 import GHC.Prim
-
+import GHC.Tuple ()
 
 infixr 5 :
 
@@ -308,3 +309,51 @@ you're reading this in 2023 then things went wrong). See #8326.
 -- Libraries can specify this by using 'SPEC' data type to inform which
 -- loops should be aggressively specialized.
 data SPEC = SPEC | SPEC2
+
+-- | A single location in the source code.
+--
+-- @since 4.8.2.0
+data SrcLoc = SrcLoc
+  { srcLocPackage   :: [Char]
+  , srcLocModule    :: [Char]
+  , srcLocFile      :: [Char]
+  , srcLocStartLine :: Int
+  , srcLocStartCol  :: Int
+  , srcLocEndLine   :: Int
+  , srcLocEndCol    :: Int
+  }
+
+----------------------------------------------------------------------
+-- Explicit call-stacks built via ImplicitParams
+----------------------------------------------------------------------
+
+-- | @CallStack@s are an alternate method of obtaining the call stack at a given
+-- point in the program.
+--
+-- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will
+-- solve it with the current location. If another @CallStack@ implicit-parameter
+-- is in-scope (e.g. as a function argument), the new location will be appended
+-- to the one in-scope, creating an explicit call-stack. For example,
+--
+-- @
+-- myerror :: (?loc :: CallStack) => String -> a
+-- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc)
+-- @
+-- ghci> myerror "die"
+-- *** Exception: die
+-- CallStack:
+--   ?loc, called at MyError.hs:7:51 in main:MyError
+--   myerror, called at <interactive>:2:1 in interactive:Ghci1
+--
+-- @CallStack@s do not interact with the RTS and do not require compilation with
+-- @-prof@. On the other hand, as they are built up explicitly using
+-- implicit-parameters, they will generally not contain as much information as
+-- the simulated call-stacks maintained by the RTS.
+--
+-- A @CallStack@ is a @[(String, SrcLoc)]@. The @String@ is the name of
+-- function that was called, the 'SrcLoc' is the call-site. The list is
+-- ordered with the most recently called function at the head.
+--
+-- @since 4.8.2.0
+data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)] }
+  -- See Note [Overview of implicit CallStacks]
index b3cbb4e..37e8378 100644 (file)
@@ -1,6 +1,8 @@
 
-annfail12.hs:5:1:
+annfail12.hs:5:1: error:
     Exception when trying to run compile-time code:
       You were meant to see this error!
+CallStack:
+  error, called at annfail12.hs:5:12 in main:Annfail12
     In the annotation:
       {-# ANN f (error "You were meant to see this error!" :: Int) #-}
index 39f80ff..049d77c 100644 (file)
@@ -1,6 +1,7 @@
 
-Q.hs:3:8:
+Q.hs:3:8: error:
     Could not find module ‘Data.Set’
-    It is a member of the hidden package ‘containers-<VERSION>@<HASH>’.
+    It is a member of the hidden package ‘containers-0.5.6.2@0tT640fErehCGZtZRn6YbE’.
     Perhaps you need to add ‘containers’ to the build-depends in your .cabal file.
     Use -v to see a list of the files searched for.
+ExitFailure 1
\ No newline at end of file
index bc2a0b3..49d41a3 100644 (file)
@@ -1,4 +1,4 @@
-T9576: T9576.hs:6:31:
+T9576: T9576.hs:6:31: error:
     No instance for (Show Foo) arising from a use of ‘showsPrec’
     In the second argument of ‘(.)’, namely ‘(showsPrec 11 b1)’
     In the second argument of ‘showParen’, namely
index 2f6bb5f..d48426c 100644 (file)
@@ -1,2 +1,3 @@
-\r
-Main.hs:5:5: error: Data constructor not in scope: T\r
+
+Main.hs:5:5: error: Data constructor not in scope: T
+ExitFailure 1
\ No newline at end of file
index cd9436e..b926ed2 100644 (file)
@@ -2,3 +2,5 @@ Breakpoint 0 activated at ../Test6.hs:5:8-11
 Stopped at ../Test6.hs:5:8-11
 _result :: a = _
 *** Exception: Prelude.head: empty list
+CallStack:
+  error, called at libraries/base/GHC/List.hs:1009:3 in base:GHC.List
index b84023b..dafc1fc 100644 (file)
@@ -1,4 +1,6 @@
 *** Exception: foo
+CallStack:
+  error, called at <interactive>:2:1 in interactive:Ghci1
 Stopped at <exception thrown>
 _exception :: e = _
 Stopped at <exception thrown>
@@ -7,17 +9,29 @@ _exception :: e = _
 -2  : main (../Test7.hs:2:8-29)
 <end of history>
 Logged breakpoint at ../Test7.hs:2:18-28
-_result :: a
+_result :: a12
 Logged breakpoint at ../Test7.hs:2:8-29
-_result :: IO a
+_result :: IO a12
 no more logged breakpoints
 Logged breakpoint at ../Test7.hs:2:18-28
-_result :: a
+_result :: a12
 Stopped at <exception thrown>
 _exception :: e
 already at the beginning of the history
-_exception = SomeException "foo"
-_result :: a = _
-_exception :: SomeException = SomeException "foo"
+_exception = SomeException
+               (ErrorCallWithLocation
+                  "foo"
+                  "CallStack:
+  error, called at ../Test7.hs:2:18 in main:Main")
+_result :: a12 = _
+_exception :: SomeException = SomeException
+                                (ErrorCallWithLocation
+                                   "foo"
+                                   "CallStack:
+  error, called at ../Test7.hs:2:18 in main:Main")
 *** Exception: foo
+CallStack:
+  error, called at ../Test7.hs:2:18 in main:Main
 *** Exception: foo
+CallStack:
+  error, called at ../Test7.hs:2:18 in main:Main
index 305289d..4825e43 100644 (file)
@@ -8,5 +8,8 @@ Printing 1
 as = 'b' : 'c' : (_t1::[Char])
 Forcing
 *** Exception: Prelude.undefined
+CallStack:
+  error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err
+  undefined, called at <interactive>:3:17 in interactive:Ghci1
 Printing 2
 as = 'b' : 'c' : (_t2::[Char])
index 6c3cc16..b9e45cc 100644 (file)
@@ -1,2 +1,7 @@
 *** Exception: Prelude.head: empty list
+CallStack:
+  error, called at libraries/base/GHC/List.hs:1009:3 in base:GHC.List
 *** Exception: Prelude.undefined
+CallStack:
+  error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err
+  undefined, called at <interactive>:1:17 in interactive:Ghci1
index e8585c0..aa3a832 100644 (file)
@@ -1,2 +1,8 @@
 *** Exception: Prelude.undefined
+CallStack:
+  error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err
+  undefined, called at <interactive>:2:12 in interactive:Ghci1
 *** Exception: Prelude.undefined
+CallStack:
+  error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err
+  undefined, called at <interactive>:3:12 in interactive:Ghci1
index 1bac2ab..03245e2 100644 (file)
@@ -1,3 +1,6 @@
-*** Exception: Prelude.undefined\r
-x :: t = *** Exception: Prelude.undefined\r
-y :: Integer = 3\r
+*** Exception: Prelude.undefined
+CallStack:
+  error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err
+  undefined, called at <interactive>:1:7 in interactive:Ghci1
+x :: t = _
+y :: Integer = 3
index affc267..7ded1fe 100644 (file)
@@ -452,7 +452,7 @@ test('T5321Fun',
              #  (increase due to new codegen)
              # 2014-09-03: 299656164     (specialisation and inlining)
              # 10/12/2014: 206406188     #  Improvements in constraint solver
-            (wordsize(64), 429921312, 10)])
+            (wordsize(64), 509921312, 10)])
              # prev:       585521080
              # 29/08/2012: 713385808     #  (increase due to new codegen)
              # 15/05/2013: 628341952     #  (reason for decrease unknown)
@@ -462,6 +462,9 @@ test('T5321Fun',
              # 06/11/2014: 541287000     #  Simon's flat-skol changes to the constraint solver
              # 10/12/2014: 408110888     #  Improvements in constraint solver
              # 16/12/2014: 429921312     #  Flattener parameterized over roles
+             # 10/08/2015: 509921312
+             #  (undefined now takes an implicit parameter and GHC -O0 does
+             #  not recognize that the application is bottom)
       ],
       compile,[''])
 
@@ -474,7 +477,7 @@ test('T5321FD',
             #  (increase due to new codegen)
             # 2014-07-31: 211699816 (Windows) (-11%)
             #  (due to better optCoercion, 5e7406d9, #9233)
-           (wordsize(64), 410895536, 10)])
+           (wordsize(64), 470895536, 10)])
             # prev:       418306336
             # 29/08/2012: 492905640
             #  (increase due to new codegen)
@@ -488,6 +491,9 @@ test('T5321FD',
             #  (due to better optCoercion, 5e7406d9, #9233)
             # 2014-10-08  410895536
             #  (various changes; biggest improvements due to 949ad67 and FastString package ids)
+            # 2015-08-10: 470895536
+            #  (undefined now takes an implicit parameter and GHC -O0 does
+            #  not recognize that the application is bottom)
       ],
       compile,[''])
 
index ae5d4fd..aeab39e 100644 (file)
@@ -1,5 +1,5 @@
 module T4930 where
 
 foo :: Int -> Int
-foo n = (if n < 5 then error "Too small" else n+2) 
+foo n = (if n < 5 then foo n else n+2)
         `seq` n+5
index 3e140dd..552c8a8 100644 (file)
@@ -1,39 +1,39 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 23, types: 11, coercions: 0}
+Result size of Tidy Core = {terms: 35, types: 14, coercions: 0}
 
--- RHS size: {terms: 2, types: 0, coercions: 0}
-lvl :: [Char]
-[GblId, Str=DmdType]
-lvl = unpackCString# "Too small"#
-
--- RHS size: {terms: 2, types: 1, coercions: 0}
-T4930.foo1 :: Int
-[GblId, Str=DmdType b]
-T4930.foo1 = error @ Int lvl
+Rec {
+-- RHS size: {terms: 23, types: 6, coercions: 0}
+T4930.$wfoo [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int#
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>]
+T4930.$wfoo =
+  \ (ww :: Int#) ->
+    case case tagToEnum# @ Bool (<# ww 5#) of _ [Occ=Dead] {
+           False -> I# (+# ww 2#);
+           True -> case T4930.$wfoo ww of ww1 { __DEFAULT -> I# ww1 }
+         }
+    of _ [Occ=Dead] { I# ipv ->
+    +# ww 5#
+    }
+end Rec }
 
--- RHS size: {terms: 16, types: 5, coercions: 0}
-foo :: Int -> Int
+-- RHS size: {terms: 10, types: 4, coercions: 0}
+foo [InlPrag=INLINE[0]] :: Int -> Int
 [GblId,
  Arity=1,
+ Caf=NoCafRefs,
  Str=DmdType <S,1*U(U)>m,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
-         Tmpl= \ (n [Occ=Once!] :: Int) ->
-                 case n of _ [Occ=Dead] { I# x ->
-                 case tagToEnum# @ Bool (<# x 5#) of _ [Occ=Dead] {
-                   False -> I# (+# x 5#);
-                   True -> T4930.foo1
-                 }
+         Tmpl= \ (w [Occ=Once!] :: Int) ->
+                 case w of _ [Occ=Dead] { I# ww1 [Occ=Once] ->
+                 case T4930.$wfoo ww1 of ww2 { __DEFAULT -> I# ww2 }
                  }}]
 foo =
-  \ (n :: Int) ->
-    case n of _ [Occ=Dead] { I# x ->
-    case tagToEnum# @ Bool (<# x 5#) of _ [Occ=Dead] {
-      False -> I# (+# x 5#);
-      True -> T4930.foo1
-    }
+  \ (w :: Int) ->
+    case w of _ [Occ=Dead] { I# ww1 ->
+    case T4930.$wfoo ww1 of ww2 { __DEFAULT -> I# ww2 }
     }
 
 
index c899ed5..695c69e 100644 (file)
@@ -2,6 +2,8 @@
 T5358.hs:14:12: error:
     Exception when trying to run compile-time code:
       runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool
+CallStack:
+  error, called at T5358.hs:15:18 in main:T5358
     Code: do { VarI _ t _ <- reify (mkName "prop_x1");
                ($) error ((++) "runTest called error: " pprint t) }
     In the untyped splice:
index 64cf33a..f434458 100644 (file)
@@ -1,5 +1,7 @@
 
-T5976.hs:1:1:
+T5976.hs:1:1: error:
     Exception when trying to run compile-time code:
       bar
-      Code: error ((++) "foo " error "bar")
+CallStack:
+  error, called at T5976.hs:3:21 in main:Main
+    Code: error ((++) "foo " error "bar")
index 3e8c487..410004b 100644 (file)
@@ -1,14 +1,14 @@
 
-<interactive>:3:9: Warning:
+<interactive>:3:9: warning:
     Couldn't match type ‘[Dec]’ with ‘Exp’
     Expected type: Q Exp
       Actual type: DecsQ
     In the expression: [d| a = () |] :: Q Exp
     In an equation for ‘x’: x = [d| a = () |] :: Q Exp
 
-<interactive>:1:1:
+<interactive>:1:1: error:
     Exception when trying to run compile-time code:
-      <interactive>:3:9:
+      <interactive>:3:9: error:
     Couldn't match type ‘[Dec]’ with ‘Exp’
     Expected type: Q Exp
       Actual type: DecsQ
index 2b128bb..6df4f7d 100644 (file)
@@ -1,5 +1,8 @@
 
-T8987.hs:1:1:
+T8987.hs:1:1: error:
     Exception when trying to run compile-time code:
       Prelude.undefined
+CallStack:
+  error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err
+  undefined, called at T8987.hs:6:23 in main:T8987
     Code: (>>) reportWarning ['1', undefined] return []
index 79ec991..fb91428 100644 (file)
@@ -1,6 +1,8 @@
 
-TH_exn2.hs:1:1:
+TH_exn2.hs:1:1: error:
     Exception when trying to run compile-time code:
       Prelude.tail: empty list
-      Code: do { ds <- [d| |];
-                 return (tail ds) }
+CallStack:
+  error, called at libraries/base/GHC/List.hs:1009:3 in base:GHC.List
+    Code: do { ds <- [d| |];
+               return (tail ds) }
index 6a1d4a6..7570ed8 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 6a1d4a65010932a660ceacda93c8c20fb5e1399d
+Subproject commit 7570ed8595402bcd354b7b24de1f4b0e3e527a58