Created
January 13, 2016 12:06
-
-
Save HanStolpo/83085756c7cd69d31b15 to your computer and use it in GitHub Desktop.
Incorrect behaviour of implicit CallStack with GHC 7.10.2
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- 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 | |
--} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment