data-pprint 0.1 → 0.2

raw patch · 10 files changed

+112/−87 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Exception/Pure.hs +45/−0
• Data/Data/Compare.hs +1/−0
• Data/Data/GenRep.hs +22/−34
• Data/Data/GenRep/Doc.hs +1/−0
• Data/Data/GenRep/Functions.hs +24/−44
• Data/PPrint.hs +6/−6
• LICENSE +1/−1
• System/SimpleTimeout.hs +1/−1
• System/SimpleTimeout/Limits.hs +7/−0
• data-pprint.cabal +4/−1

@@ -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)++++

@@ -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 

@@ -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  

@@ -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

@@ -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' -> '₁'

@@ -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)  ----------------------

@@ -1,4 +1,4 @@-Copyright Péter Diviánszky 2008+Copyright Péter Diviánszky 2008-2011  All rights reserved. 

@@ -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

@@ -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) ++ "%" + 

@@ -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 <http://pnyf.inf.elte.hu/fp/Show_en.xml>+    .+    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