This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, master has been updated
via dc4fec02812b88810791de9f023e2a8ace19c559 (commit)
from 52e4c692763d28cc97aea0956e1c8fb4135b4d78 (commit)
Summary of changes:
snap-core.cabal | 22 +--------
src/Snap/Internal/Debug.hs | 103 +++++++++++++++++++++++++++-------------
test/runTestsAndCoverage.sh | 1 +
test/snap-core-testsuite.cabal | 15 ------
4 files changed, 72 insertions(+), 69 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit dc4fec02812b88810791de9f023e2a8ace19c559
Author: Gregory Collins <[email protected]>
Date: Tue Sep 21 12:48:21 2010 -0400
Major changes to debug mechanism
What we used to do to enable debug logging is this: give the "-f debug"
flag to
cabal when installing snap-core, which used the C preprocessor to select a
compile-time implementation for the "debug" function.
What we're doing now instead is using "unsafePerformIO" to test the "DEBUG"
environment variable the first time you call the debug function; subsequent
calls to "debug" will re-use the fully-evaluated thunk, so you shouldn't
pay a
performance penalty if debug logging is turned off. We do pay a slight
penalty
because we can no longer inline calls to "debug", so debug overhead when
debugging is off goes from a no-op to a call into a function pointer;
benchmarks say the price to pay is slight and the productivity gains are
enormous: set "DEBUG=1" when you invoke your server to get debugging output
without recompiling the entire snap library stack.
diff --git a/snap-core.cabal b/snap-core.cabal
index 9497faf..4a08864 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -98,15 +98,6 @@ extra-source-files:
test/suite/Snap/Util/GZip/Tests.hs
-Flag debug
- Description: Enable debug logging to stderr
- Default: False
-
-Flag testsuite
- Description: Are we running the testsuite? Causes arguments to \"debug\" to
- be evaluated but not printed.
- Default: False
-
Flag portable
Description: Compile in cross-platform mode. No platform-specific code or
optimizations such as C routines will be used.
@@ -115,13 +106,6 @@ Flag portable
Library
hs-source-dirs: src
- if flag(debug)
- cpp-options: -DDEBUG
-
- if flag(testsuite)
- cpp-options: -DDEBUG_TEST
- build-depends: deepseq >= 1.1 && <1.2
-
if flag(portable) || os(windows)
cpp-options: -DPORTABLE
else
@@ -150,6 +134,7 @@ Library
bytestring-nums,
cereal >= 0.3 && < 0.4,
containers,
+ deepseq >= 1.1 && <1.2,
directory,
dlist >= 0.5 && < 0.6,
filepath,
@@ -174,10 +159,6 @@ Library
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
Executable snap
- if flag(testsuite)
- cpp-options: -DDEBUG_TEST
- build-depends: deepseq >= 1.1 && <1.2
-
hs-source-dirs: src
main-is: Snap/Starter.hs
@@ -190,6 +171,7 @@ Executable snap
bytestring-nums,
cereal >= 0.3 && < 0.4,
containers,
+ deepseq >= 1.1 && <1.2,
directory,
directory-tree,
dlist >= 0.5 && < 0.6,
diff --git a/src/Snap/Internal/Debug.hs b/src/Snap/Internal/Debug.hs
index aeaf875..4bd0493 100644
--- a/src/Snap/Internal/Debug.hs
+++ b/src/Snap/Internal/Debug.hs
@@ -1,77 +1,112 @@
-- | An internal Snap module for (optionally) printing debugging
--- messages. Normally 'debug' does nothing, but you can pass \"-fdebug\" to
--- @cabal install@ to build a @snap-core@ which debugs to stderr.
+-- messages. Normally 'debug' does nothing, but if you set @DEBUG=1@ in the
+-- environment you'll get debugging messages. We use 'unsafePerformIO' to make
+-- sure that the call to 'getEnv' is only made once.
--
-- /N.B./ this is an internal interface, please don't write external code that
-- depends on it.
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-cse #-}
-module Snap.Internal.Debug where
-
-import Control.Monad.Trans
-
-#ifdef DEBUG_TEST
-import Control.DeepSeq
-debug :: (MonadIO m) => String -> m ()
-debug !s = let !s' = rnf s in return $! s' `deepseq` ()
-{-# INLINE debug #-}
-
-debugErrno :: (MonadIO m) => String -> m ()
-debugErrno !s = let !s' = rnf s in return $! s' `deepseq` ()
-
-#elif defined(DEBUG)
+module Snap.Internal.Debug where
------------------------------------------------------------------------------
import Control.Concurrent
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad.Trans
+import Data.Char
import Data.List
import Data.Maybe
import Foreign.C.Error
+import System.Environment
import System.IO
import System.IO.Unsafe
import Text.Printf
------------------------------------------------------------------------------
+
+
+{-# NOINLINE debug #-}
+debug :: forall m . (MonadIO m => String -> m ())
+debug = let !x = unsafePerformIO $! do
+ !e <- try $ getEnv "DEBUG"
+
+ !f <- either (\(_::SomeException) -> return debugIgnore)
+ (\x -> if x == "1" || x == "on"
+ then return debugOn
+ else if x == "testsuite"
+ then return debugSeq
+ else return debugIgnore)
+ (fmap (map toLower) e)
+ return $! f
+ in x
+
+
+{-# NOINLINE debugErrno #-}
+debugErrno :: forall m . (MonadIO m => String -> m ())
+debugErrno = let !x = unsafePerformIO $ do
+ e <- try $ getEnv "DEBUG"
+
+ !f <- either (\(_::SomeException) -> return debugErrnoIgnore)
+ (\x -> if x == "1" || x == "on"
+ then return debugErrnoOn
+ else if x == "testsuite"
+ then return debugErrnoSeq
+ else return debugErrnoIgnore)
+ (fmap (map toLower) e)
+ return $! f
+ in x
+
+
+------------------------------------------------------------------------------
+debugSeq :: (MonadIO m) => String -> m ()
+debugSeq !s = let !s' = rnf s in return $! s' `deepseq` ()
+{-# NOINLINE debugSeq #-}
+
+debugErrnoSeq :: (MonadIO m) => String -> m ()
+debugErrnoSeq !s = let !s' = rnf s in return $! s' `deepseq` ()
+{-# NOINLINE debugErrnoSeq #-}
+
------------------------------------------------------------------------------
_debugMVar :: MVar ()
_debugMVar = unsafePerformIO $ newMVar ()
{-# NOINLINE _debugMVar #-}
+
------------------------------------------------------------------------------
-debug :: (MonadIO m) => String -> m ()
-debug s = liftIO $ withMVar _debugMVar $ \_ -> do
- tid <- myThreadId
- hPutStrLn stderr $ s' tid
- hFlush stderr
+debugOn :: (MonadIO m) => String -> m ()
+debugOn s = liftIO $ withMVar _debugMVar $ \_ -> do
+ tid <- myThreadId
+ hPutStrLn stderr $ s' tid
+ hFlush stderr
where
chop x = let y = fromMaybe x $ stripPrefix "ThreadId " x
in printf "%8s" y
s' t = "[" ++ chop (show t) ++ "] " ++ s
-{-# INLINE debug #-}
+{-# NOINLINE debugOn #-}
------------------------------------------------------------------------------
-debugErrno :: (MonadIO m) => String -> m ()
-debugErrno loc = liftIO $ do
+debugErrnoOn :: (MonadIO m) => String -> m ()
+debugErrnoOn loc = liftIO $ do
err <- getErrno
let ex = errnoToIOError loc err Nothing Nothing
debug $ show ex
------------------------------------------------------------------------------
-#else
------------------------------------------------------------------------------
-debug :: (MonadIO m) => String -> m ()
-debug _ = return ()
-{-# INLINE debug #-}
+debugIgnore :: (MonadIO m) => String -> m ()
+debugIgnore _ = return ()
+{-# NOINLINE debugIgnore #-}
-debugErrno :: (MonadIO m) => String -> m ()
-debugErrno _ = return ()
+debugErrnoIgnore :: (MonadIO m) => String -> m ()
+debugErrnoIgnore _ = return ()
------------------------------------------------------------------------------
-
-#endif
diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh
index 2e6ba77..260c339 100755
--- a/test/runTestsAndCoverage.sh
+++ b/test/runTestsAndCoverage.sh
@@ -2,6 +2,7 @@
set -e
+export DEBUG=testsuite
SUITE=./dist/build/testsuite/testsuite
export LC_ALL=C
diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal
index a566650..180ef35 100644
--- a/test/snap-core-testsuite.cabal
+++ b/test/snap-core-testsuite.cabal
@@ -3,15 +3,6 @@ version: 0.1.1
build-type: Simple
cabal-version: >= 1.6
-Flag debug
- Description: Enable debug logging to stderr
- Default: False
-
-Flag testsuite
- Description: Are we running the testsuite? Causes arguments to \"debug\" to
- be evaluated but not printed.
- Default: True
-
Flag portable
Description: Compile in cross-platform mode. No platform-specific code or
optimizations such as C routines will be used.
@@ -21,12 +12,6 @@ Executable testsuite
hs-source-dirs: ../src suite
main-is: TestSuite.hs
- if flag(debug)
- cpp-options: -DDEBUG
-
- if flag(testsuite)
- cpp-options: -DDEBUG_TEST
-
if flag(portable) || os(windows)
cpp-options: -DPORTABLE
else
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
