diff --git a/Debug/Trace/LocationTH.hs b/Debug/Trace/LocationTH.hs new file mode 100644 --- /dev/null +++ b/Debug/Trace/LocationTH.hs @@ -0,0 +1,144 @@ +-- | +-- Module : Debug.Trace.LocationTH +-- Copyright : (c) Tomas Janousek 2011 +-- License : BSD-style +-- Maintainer : tomi@nomi.cz +-- Stability : experimental +-- Portability : non-portable (requires Template haskell) +-- Tested : GHC 7.0.3 +-- +-- This module provides a Template Haskell based mechanism to tag failures +-- with the location of the failure call. The location message includes the +-- file name, line and column numbers. +-- + +{-# LANGUAGE TemplateHaskell #-} +module Debug.Trace.LocationTH + ( __LOCATION__ + , assert + , failure + , undef + , check + , checkIO + ) where + +import qualified Control.Exception as C +import Control.Exception (throw, AssertionFailed(..)) +import Language.Haskell.TH.Ppr (pprint) +import Language.Haskell.TH.Syntax (location, Loc(..), Q, Exp, lift) +import System.IO.Unsafe (unsafePerformIO) +import Text.PrettyPrint.HughesPJ + +ppUnless :: Bool -> Doc -> Doc +ppUnless True _ = empty +ppUnless False doc = doc + +-- | Pretty print Loc. Mostly copypasted pprUserSpan from GHC 7. +pprLoc :: Loc -> Doc +pprLoc (Loc { loc_filename = src_path + , loc_start = (sline, start_col) + , loc_end = (eline, end_col) }) + | sline == eline = hcat + [ text src_path <> colon + , int sline, char ':', int start_col + , ppUnless (end_col - start_col <= 1) + (char '-' <> int (end_col-1)) + ] + | otherwise = hcat + [ text src_path <> colon + , parens (int sline <> char ',' <> int start_col) + , char '-' + , parens (int eline <> char ',' <> + if end_col == 0 then int end_col else int (end_col-1)) + ] + +-- +-- | Get the location of current splice as a 'String'. +-- +-- @$__LOCATION__ :: 'String'@ +-- +-- >>> $__LOCATION__ +-- ":1:1-13" +-- +__LOCATION__ :: Q Exp +__LOCATION__ = lift =<< (render . pprLoc) `fmap` location + +-- +-- | If the first argument evaluates to 'True', then the result is the second +-- argument. Otherwise an 'AssertionFailed' exception is raised, containing a +-- 'String' with the source file and line number of the call to 'assert'. +-- +-- @$(assert [| 'False' |]) :: a -> a@ +-- +-- >>> $(assert [| 5 + 5 == 9 |]) "foo" +-- "*** Exception: :1:3-25: Assertion `(5 GHC.Num.+ 5) GHC.Classes.== 9' failed +-- +assert :: Q Exp -> Q Exp +assert t = do + st <- pprint `fmap` t + [| + \cont -> if not $t + then throw $ AssertionFailed $ + $__LOCATION__ ++ ": Assertion `" ++ st ++ "' failed" + else cont + |] + +-- +-- | A location-emitting 'error' call. +-- +-- @$failure :: 'String' -> a@ +-- +-- >>> $failure "no such thing." +-- *** Exception: :1:1-8: no such thing. +-- +failure :: Q Exp +failure = [| \t -> error $ $__LOCATION__ ++ ": " ++ t |] + +-- +-- | A location-emitting 'undefined'. +-- +-- @$undef :: a@ +-- +-- >>> $undef +-- *** Exception: :1:1-6: undefined +-- +undef :: Q Exp +undef = [| $failure "undefined" |] + +-- +-- | '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 :: c -> c@ +-- +-- >>> $check $ head [] +-- *** Exception: :1:1-6: Prelude.head: empty list +-- +-- Be careful with laziness as the argument is only evaluated to weak head +-- normal form: +-- +-- >>> $check $ Just $ head "" +-- Just *** Exception: Prelude.head: empty list +-- >>> $check $ join deepseq $ Just $ head "" +-- *** Exception: :1:1-6: Prelude.head: empty list +-- +check :: Q Exp +check = [| unsafePerformIO . $checkIO . C.evaluate |] + +-- +-- | '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. +-- +-- @$checkIO :: IO a -> IO a@ +-- +-- >>> $checkIO $ readFile "/foo" +-- "*** Exception: :1:1-8: /foo: openFile: does not exist (No such file or directory) +-- +checkIO :: Q Exp +checkIO = [| \a -> C.catch a $ \e -> return $ $failure (showEx e) |] + +showEx :: C.SomeException -> String +showEx = show diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Tomas Janousek + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tomas Janousek nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/loch-th.cabal b/loch-th.cabal new file mode 100644 --- /dev/null +++ b/loch-th.cabal @@ -0,0 +1,19 @@ +Name: loch-th +Version: 0.1 +Synopsis: Support for precise error locations in source files (Template Haskell version) +Description: This module provides a Template Haskell based mechanism to + tag failures with the location of the failure call. The + location message includes the file name, line and column + numbers. +Homepage: https://github.com/liskin/loch-th +License: BSD3 +License-file: LICENSE +Author: Tomas Janousek +Maintainer: tomi@nomi.cz +Category: Development +Build-type: Simple +Cabal-version: >=1.2 + +Library + Exposed-modules: Debug.Trace.LocationTH + Build-depends: base >=4 && <5, template-haskell, pretty