diff --git a/Control/Exception/Pure.hs b/Control/Exception/Pure.hs new file mode 100644 --- /dev/null +++ b/Control/Exception/Pure.hs @@ -0,0 +1,45 @@ +-- |Catch exceptions produced in pure code +{-# LANGUAGE ScopedTypeVariables #-} +module Control.Exception.Pure + ( catchPureErrors + , catchPureErrorsSafe + ) where + +import Control.DeepSeq (NFData, deepseq) +import Control.Exception + + + +-- | Evaluate to weak head normal form and catch +-- exceptions which can be raised by errors in pure computation. +-- See also the "Test.ChasingBottoms.IsBottom" module in ChasingBottoms package. +catchPureErrors :: a -> IO (Either String a) +catchPureErrors a + = fmap Right (evaluate a) + `catches` + [ Handler (\(e :: ErrorCall) -> f e) + , Handler (\(e :: NonTermination) -> f e) + , Handler (\(e :: PatternMatchFail) -> f e) + , Handler (\(e :: NoMethodError) -> f e) + , Handler (\(e :: ArrayException) -> f e) + , Handler (\(e :: RecConError) -> f e) + , Handler (\(e :: RecSelError) -> f e) + , Handler (\(e :: RecUpdError) -> f e) + , Handler (\(e :: ArithException) -> f e) + , Handler (\(e :: AssertionFailed) -> f e) + ] + where + f :: Show x => x -> IO (Either String a) + f = return . Left . show + +-- | Make sure that the error message is a concrete String. +catchPureErrorsSafe :: a -> IO (Either String a) +catchPureErrorsSafe a = do + e <- catchPureErrors a + case e of + Right _ -> return e + Left s -> fmap (either (Left . ("Nested error: "++)) Left) $ catchPureErrorsSafe (s `deepseq` s) + + + + diff --git a/Data/Data/Compare.hs b/Data/Data/Compare.hs --- a/Data/Data/Compare.hs +++ b/Data/Data/Compare.hs @@ -111,6 +111,7 @@ where observe x = fmap simplify $ constructor budget x $ return [] where + simplify (NestedError _) = Error "undefined error" simplify Hole = Timeout 1 simplify other = other diff --git a/Data/Data/GenRep.hs b/Data/Data/GenRep.hs --- a/Data/Data/GenRep.hs +++ b/Data/Data/GenRep.hs @@ -1,5 +1,5 @@ -- |Intended for internal use: Generic representation of 'Data' vales. -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} module Data.Data.GenRep ( ConstructorName (..) , GenericData (..) @@ -8,8 +8,9 @@ ) where import System.SimpleTimeout.Limits +import System.IO.Parallel (manyParallel) +import Control.Exception.Pure (catchPureErrors) -import Control.Exception import Control.DeepSeq (NFData, rnf) import qualified Data.Data as D import Data.Data (gmapQ, Data, Typeable) @@ -90,7 +91,8 @@ -- |Representation of 'Data' values. data GenericData = Constructor ConstructorName [GenericData] - | Error String -- ^ shown exception + | Error String -- ^ exception error message + | NestedError GenericData -- ^ error message which may contain further errors | Timeout Double -- ^ timeout, the @Double@ is between 0 and 1. -- -- * 0: evaluation of subexpression started at the beginning @@ -103,49 +105,35 @@ | ListHole -- ^ used during show deriving (Show, Typeable) + instance NFData GenericData where rnf x = case x of Constructor p s -> rnf p `seq` rnf s - Error e -> rnf e - Detail s -> rnf s - Timeout d -> rnf d + Error e -> rnf e + NestedError e -> rnf e + Detail s -> rnf s + Timeout d -> rnf d _ -> () - -- |Convert a 'Data' value to 'GenericData' given the --- 'GenericData' representation of the value's children. +-- 'GenericData' representations of the value's children. constructor :: Data a => Budget -> a -> IO [GenericData] -> IO GenericData constructor b x m = do - y <- checkBudget b 1 (return . Just . Timeout) (return $ Just Hole) (catchMany x) + y <- checkBudget b 1 (return . Left . Timeout) (return $ Left Hole) + $ fmap Right $ catchPureErrors x case y of - Just a -> return a - _ -> do + Left x -> return x + Right (Left x) -> do + fmap NestedError $ evalWithBudget b x + Right (Right x) -> do p <- decSizeBudget b (precedence x) fmap (Constructor p) m ----------------------------- - --- |Try to catch many type of exceptions while --- evaluation the weak head normal form of the parameter. -catchMany :: a -> IO (Maybe GenericData) -catchMany a - = fmap (const Nothing) (evaluate a) - `catches` - [ Handler (\(e :: ErrorCall) -> f e) - , Handler (\(e :: ArithException) -> f e) - , Handler (\(e :: NonTermination) -> f e) - , Handler (\(e :: AssertionFailed) -> f e) - , Handler (\(e :: PatternMatchFail) -> f e) - , Handler (\(e :: NoMethodError) -> f e) - , Handler (\(e :: AssertionFailed) -> f e) - , Handler (\(e :: ArrayException) -> f e) - , Handler (\(e :: RecConError) -> f e) - , Handler (\(e :: RecSelError) -> f e) - , Handler (\(e :: RecUpdError) -> f e) - ] - where - f :: Show x => x -> IO (Maybe GenericData) - f = return . Just . Error . show +evalWithBudget :: Data a => Budget -> a -> IO GenericData +evalWithBudget b x + = constructor b x + $ manyParallel + $ gmapQ (evalWithBudget b) x diff --git a/Data/Data/GenRep/Doc.hs b/Data/Data/GenRep/Doc.hs --- a/Data/Data/GenRep/Doc.hs +++ b/Data/Data/GenRep/Doc.hs @@ -41,6 +41,7 @@ Hole -> "…" -- !!! ragadás ListHole -> "……" Timeout _ -> "⊥" + NestedError e -> "⊥(" <+> toDoc e <+> ")" Error e -> text e Detail s -> showParen_ (j > 10) $ "……" <+> showsP 0 s <+> "……" Constructor (Char c) [] -> quotes $ text $ showLitCharInChar c diff --git a/Data/Data/GenRep/Functions.hs b/Data/Data/GenRep/Functions.hs --- a/Data/Data/GenRep/Functions.hs +++ b/Data/Data/GenRep/Functions.hs @@ -3,16 +3,14 @@ module Data.Data.GenRep.Functions ( mistify , numberErrors + , getErrorIndex ) where -import System.IO.Parallel -import System.SimpleTimeout.Limits +import Data.Data.GenRep.Doc (toDoc) import Data.Data.GenRep +import System.SimpleTimeout.Limits (showTimeout) -import Control.Exception -import Control.DeepSeq (deepseq) import Control.Monad.State (State, runState, get, put) -import Prelude hiding (catch) --------------------------------------- @@ -37,35 +35,16 @@ ------------------------------------------------------- --- |Collect and number of 'Error' values and replace them +-- |Collect and number 'Error' values and replace them -- by an indexed bottom sign. -- Repeated errors will get the same number. numberErrors - :: TimeLimit -- ^ time limit for showing error messages - -> SizeLimit -- ^ size penalty per errors - -> SizeLimit -- ^ global size limit - -> [GenericData] - -> IO ([GenericData], [(String, String)]) -numberErrors tl psl sl l = do - budget <- newBudget tl sl - errs <- manyParallel $ map (chk budget) errs - return (res, reverse $ concat errs) + :: [GenericData] + -> ([GenericData], [(String, String)]) +numberErrors l + = (res, reverse $ map swap errs) where - chk budget (a, b) - = checkBudget budget psl - (const $ return [(b, "Timeout in error!")]) - (return []) - (checkError a >>= \a -> - decSizeBudget budget $ chkSize a) - where - checkError :: String -> IO String - checkError e - = (e `deepseq` return e) - `catch` (\(_ :: ErrorCall) -> return "Nested error!") - - chkSize a lim = case splitAt lim a of - (a, []) -> (lim - length a, [(b, a)]) - (a, _) -> (lim - length a, [(b, a ++ "…")]) + swap (a,b) = (b,a) (res, (_, errs)) = runState (mapM replace l) (0, []) @@ -76,6 +55,10 @@ replace (Error e) = do i <- getErrorIndex e return $ Error i + replace (NestedError e) = do + e' <- replace e + i <- getErrorIndex (show $ toDoc e') + return $ Error i replace (Timeout d) = do i <- getErrorIndex $ showTimeout d return $ Error i @@ -84,20 +67,17 @@ return $ Detail s' replace x = return x - showTimeout d - = "timeout at " ++ show (round $ 100 * d :: Int) ++ "%" - - getErrorIndex :: String -> State (Int, [(String, String)]) String - getErrorIndex e = do - (len, es) <- get - case lookup e es of - Just x -> return x - Nothing -> do - let n = len+1 - x = '⊥': map toLowerIndex (show n) - put (n, (e, x): es) - return x - +getErrorIndex :: String -> State (Int, [(String, String)]) String +getErrorIndex e = do + (len, es) <- get + case lookup e es of + Just x -> return x + Nothing -> do + let n = len+1 + x = '⊥': map toLowerIndex (show n) + put (n, (e, x): es) + return x + where toLowerIndex c = case c of '0' -> '₀' '1' -> '₁' diff --git a/Data/PPrint.hs b/Data/PPrint.hs --- a/Data/PPrint.hs +++ b/Data/PPrint.hs @@ -23,9 +23,9 @@ -- followed by explanations. pprint :: Data a => a -> IO Doc pprint x = do - x <- eval 1 500 x - ([x], es) <- numberErrors 0.5 50 500 [x] - return $ toDoc x $+$ nest 2 (showBotts es) + x <- eval 1 700 x + let ([x'], es) = numberErrors [x] + return $ toDoc x' $+$ nest 2 (showBotts es) infix 0 === @@ -42,10 +42,10 @@ -- followed by explanations. (===) :: Data a => a -> a -> IO Doc a === b = do - (ans, a, b) <- compareData 0.8 0.2 500 a b + (ans, a, b) <- compareData 0.8 0.2 700 a b let x = showAnswer ans - ([a, b], es) <- numberErrors 0.5 50 500 [a, b] - return $ fsep [nest (length x + 1) (toDoc a), text x <+> toDoc b] + let ([a', b'], es) = numberErrors [a, b] + return $ fsep [nest (length x + 1) (toDoc a'), text x <+> toDoc b'] $+$ nest 2 (showBotts es) ---------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Péter Diviánszky 2008 +Copyright Péter Diviánszky 2008-2011 All rights reserved. diff --git a/System/SimpleTimeout.hs b/System/SimpleTimeout.hs --- a/System/SimpleTimeout.hs +++ b/System/SimpleTimeout.hs @@ -42,7 +42,7 @@ -- |Creates a 'TimeoutHandle'. -- --- The @Double@ parameter is the time limit in second. +-- The @Double@ parameter is the time limit in seconds. -- All operations behind 'timeout' will be stopped -- at the current time plus the time limit. timeoutHandle :: Double -> IO TimeoutHandle diff --git a/System/SimpleTimeout/Limits.hs b/System/SimpleTimeout/Limits.hs --- a/System/SimpleTimeout/Limits.hs +++ b/System/SimpleTimeout/Limits.hs @@ -6,6 +6,7 @@ , newBudget , checkBudget , decSizeBudget + , showTimeout ) where import System.SimpleTimeout (TimeoutHandle, timeoutHandle, timeout) @@ -50,4 +51,10 @@ -> IO a decSizeBudget (Budget _ sb) f = modifyMVar sb $ return . f + + +showTimeout :: Double -> String +showTimeout d + = "timeout at " ++ show (round $ 100 * d :: Int) ++ "%" + diff --git a/data-pprint.cabal b/data-pprint.cabal --- a/data-pprint.cabal +++ b/data-pprint.cabal @@ -1,5 +1,5 @@ name: data-pprint -version: 0.1 +version: 0.2 category: Testing, Text synopsis: Prettyprint and compare Data values description: @@ -39,6 +39,8 @@ > pprint $ "hello" ++ [error "x"] ++ "world!" . See also + . + Changes since 0.1: Refactoring, proper handling of nested errors stability: beta license: BSD3 license-file: LICENSE @@ -56,6 +58,7 @@ Data.Data.GenRep, Data.Data.GenRep.Functions, Data.Data.GenRep.Doc, + Control.Exception.Pure, System.SimpleTimeout, System.SimpleTimeout.Limits, System.IO.Parallel