-- |
-- Module      : Debug.Trace.Location
-- Copyright   : (c) Don Stewart 2006
-- License     : BSD-style
-- Maintainer  : dons@cse.unsw.edu.au
-- Stability   : experimental
-- Portability : non-portable (requires an 'assert' that produces location information)
-- Tested      : GHC 6.4.2, GHCi, Hugs 2005
--
-- This module provides a lightweight, pure Haskell mechanism to tag
-- failures with the location of the failure call. The location message
-- includes the file name, line and column numbers. All functions are
-- passed the special symbol 'assert' as an argument, which is expanded
-- by the compiler into a location string.
-- 
-- Usage:
--
-- > import Debug.Trace.Location
--
-- > failure assert "no such thing"
--
-- Also provided is a located 'trace' for debugging purposes, and
-- generic wrappers for pure and IO code, to tag location messages to
-- exceptions:
--
-- > check assert (head [])
-- 
-- Produces:
--
-- > a.out: A.hs:18:10-15: Prelude.head: empty list
-- 
-- Or for IO functions:
-- 
-- > do x <- checkIO assert $ readFile "/f"
--
-- Resulting in:
-- 
-- > $ ./a.out        
-- > a.out: A.hs:18:20-25: /f: openFile: does not exist
--
-- While this code will run in Hugs, the Hugs assert token is not
-- expanded usefully, producing:
--
-- > Debug.Trace.Location> trace assert "works in hugs" (1+2)
-- > assertion works in hugs
-- > 3
-- 
module Debug.Trace.Location (

        -- * The assert token
        assert,             -- The assert token, reexported
        Assert,             -- A convenient type for asserts

        -- * Location emitting errors
        failure,            -- A location-handling 'error'
        trace,              -- A location-handling 'trace'
        check,              -- A location-handling wrapper for possibly-failing pure code
        checkIO,            -- A location-handling wrapper for IO code

    ) where

import Control.Exception (assert) -- rexported
import System.IO
import System.IO.Unsafe  (unsafePerformIO)
import qualified Control.Exception as C

-- | A wrapper type for the 'assert' token.
type Assert a = Bool -> IO a -> IO a

ppr :: C.Exception -> String
ppr = fst . break (== ' ') . show

--
-- | A location-emitting 'error' call. It behaves like 'error', but
-- takes an 'assert' token as an argument, producing a located error
-- message.
-- 
-- > failure assert "no such thing."
--
-- From GHCi:
--
-- > *** Exception: <interactive>:1:8-13: no such thing.
--
-- Or compiled:
--
-- > a.out: A.hs:18:12-17: no such thing.
--
failure :: Assert a -> String -> a
failure assrt str = unsafePerformIO $
    C.catch (assrt False (return (error "Debug.Trace.Location.failure"))) prettyError
    where
        prettyError e = error (ppr e ++ " " ++ str)
{-# NOINLINE failure #-}

--
-- | A location-emitting 'trace' call. It returns its third argument,
-- emitting a located trace message to stderr as a side effect.
-- 
-- For example:
--
-- > trace assert "made it here" (1+2)
--
-- Will produce:
--
-- > <interactive>:1:21-26: made it here
-- > 3
--
trace :: Assert () -> String -> a -> a
trace assrt str f =
    (unsafePerformIO $ C.catch (assrt False (return ())) printIt) `seq` f
    where
      printIt e = hPutStrLn stderr (ppr e ++ " " ++ str)
{-# NOINLINE trace #-}

--
-- | 'check' wraps a pure, partial function in a location-emitting
-- handler, should an exception be thrown. So instead of producing an
-- anonymous call to 'error', a location will be tagged to the error
-- message.
-- 
-- > check assert $ head []
--
-- Will produce:
--
-- > *** Exception: <interactive>:1:6-11: Prelude.head: empty list
--
check :: Assert a -> a -> a
check assrt a = unsafePerformIO $ checkIO assrt (C.evaluate a)
{-# NOINLINE check #-}

--
-- | 'checkIO' wraps an IO function in a location-emitting handler,
-- should an exception be thrown. So instead of producing an anonymous
-- call to 'error', a location will be tagged to the error message.
--
-- > do x <- checkIO assert (readFile "/foo")
-- >    x
--
-- Will produce:
--
-- > "*** Exception: <interactive>:1:13-18: /foo: openFile: does not exist
--
checkIO :: Assert a -> IO a -> IO a
checkIO assrt a = C.catch a $ \e -> return $ failure assrt (show e)
{-# NOINLINE checkIO #-}