Incorrect behaviour of implicit CallStack with GHC 7.10.2

IncorrectImplicitCallStackBehaviour.hs

-- Example of incorrect behaviour of implicit call stack parameters
-- when let bindings are involved in GHC 7.10.2.
--
-- Probably related to following issues:
--   https://ghc.haskell.org/trac/ghc/ticket/11298
--   https://ghc.haskell.org/trac/ghc/ticket/10845

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams             #-}
{-# LANGUAGE RecordWildCards            #-}
module Main  where

import           GHC.Stack (CallStack, showCallStack)

-- Copied from GHC.SrcLoc
data SrcLoc = SrcLoc
  { srcLocPackage   :: String
  , srcLocModule    :: String
  , srcLocFile      :: String
  , srcLocStartLine :: Int
  , srcLocStartCol  :: Int
  , srcLocEndLine   :: Int
  , srcLocEndCol    :: Int
  } deriving (Show, Read, Eq)

-- Copied from GHC.SrcLoc
showSrcLoc :: SrcLoc -> String
showSrcLoc SrcLoc {..}
  = concat [ srcLocFile, ":"
           , show srcLocStartLine, ":"
           , show srcLocStartCol, " in "
           , srcLocPackage, ":", srcLocModule
           ]

-- Copied from GHC.Stack
data CallStack' = CallStack { getCallStack :: [(String, SrcLoc)] } deriving (Show, Read, Eq)

-- take a shown CallStack read into fake CallStack' and print it the way showCallStack should
prettyShownCallStack :: String -> String
prettyShownCallStack s = unlines . undent . map pretty . getCallStack . read $ s
  where pretty (sf, loc) = "  " ++ sf ++ ", " ++ showSrcLoc loc
        undent ((_:_:h):r) = h:r
        undent _ = error "prettyShownCallStack - CallStack can never be empty"


-- Test functions
someA :: (?loc :: CallStack) => String
someA = showCallStack ?loc

someB :: (?loc :: CallStack) => String
someB = prettyShownCallStack (show ?loc)

callA :: (?loc :: CallStack) => () -> String
callA _ = showCallStack ?loc

callB :: (?loc :: CallStack) => () -> String
callB _ = prettyShownCallStack (show ?loc)

callCallA :: (?loc :: CallStack) => () -> String
callCallA a = callA a

callCallB :: (?loc :: CallStack) => () -> String
callCallB a = callB a

callLetA :: (?loc :: CallStack) => () -> String
callLetA _ = let s = showCallStack ?loc in "" ++ s

callLetB :: (?loc :: CallStack) => () -> String
callLetB _ = let s = prettyShownCallStack (show ?loc) in "" ++ s

callCallLetA :: (?loc :: CallStack) => () -> String
callCallLetA a = callLetA a

callCallLetB :: (?loc :: CallStack) => () -> String
callCallLetB a = callLetB a



main :: IO ()
main = do
  putStrLn "someA" >> putStrLn someA
  putStrLn "someB" >> putStrLn someB
  putStrLn "callA" >> putStrLn (callA ())
  putStrLn "callB" >> putStrLn (callB ())
  putStrLn "callCallA" >> putStrLn (callCallA ())
  putStrLn "callCallB" >> putStrLn (callCallB ())
  putStrLn "callLetA" >> putStrLn (callLetA ())
  putStrLn "callLetB" >> putStrLn (callLetB ())
  putStrLn "callCallLetA" >> putStrLn (callCallLetA ())
  putStrLn "callCallLetB" >> putStrLn (callCallLetB ())

{-- output for GHC 7.10.2 on OS X El Capitan version 10.11.2 (15C50)
someA
?loc, called at CallStackError.hs:41:23 in main:Main
  someA, called at CallStackError.hs:74:32 in main:Main

someB
?loc, CallStackError.hs:44:36 in main:Main
  someB, CallStackError.hs:75:32 in main:Main

callA
?loc, called at CallStackError.hs:47:25 in main:Main
  callA, called at CallStackError.hs:76:33 in main:Main

callB
?loc, CallStackError.hs:50:38 in main:Main
  callB, CallStackError.hs:77:33 in main:Main

callCallA
?loc, called at CallStackError.hs:47:25 in main:Main
  callA, called at CallStackError.hs:53:15 in main:Main
  callCallA, called at CallStackError.hs:78:37 in main:Main

callCallB
?loc, CallStackError.hs:50:38 in main:Main
  callB, CallStackError.hs:56:15 in main:Main
  callCallB, CallStackError.hs:79:37 in main:Main

callLetA
?loc, called at CallStackError.hs:59:36 in main:Main

callLetB
?loc, CallStackError.hs:62:49 in main:Main
  callLetB, CallStackError.hs:81:36 in main:Main

callCallLetA
?loc, called at CallStackError.hs:59:36 in main:Main

callCallLetB
?loc, CallStackError.hs:62:49 in main:Main
  callLetB, CallStackError.hs:68:18 in main:Main
  callCallLetB, CallStackError.hs:83:40 in main:Main
--}