packages feed

data-pprint (empty) → 0.1

raw patch · 12 files changed

+910/−0 lines, 12 filesdep +basedep +deepseqdep +mtlsetup-changed

Dependencies added: base, deepseq, mtl, parallel, pretty, time

Files

+ Data/Data/Compare.hs view
@@ -0,0 +1,146 @@+-- |Compare two 'Data' value with time and size limit+{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-}+module Data.Data.Compare +    ( Answer (..)+    , showAnswer+    , compareData+    ) where++import Data.Data.GenRep+import System.IO.Parallel (twoParallel, manyParallel)+import Data.Data.Eval (evalWithBudget)+import System.SimpleTimeout.Limits++import Control.DeepSeq (NFData, rnf)+import Data.Data (Data, Typeable, gmapQi, toConstr)+import Data.List (minimumBy)+import Data.Ord (comparing)++------------------------++-- |Answer with possibility+--+--      * 'No': no+--+--      * @'Maybe' d@: maybe with d possibility (0-1, 1 denotes yes)+--+--      * 'Yes': yes+data Answer+    = No | Maybe Double | Yes+        deriving (Eq, Ord, Show, Typeable, Data)++instance NFData Answer where+    rnf x = case x of+        Maybe a ->  rnf a+        _       ->  ()++-- |Show an 'Answer' as an equality operator.+showAnswer :: Answer -> String+showAnswer No          = "=/=" +showAnswer (Maybe _)   = "=?=" +showAnswer Yes         = "===" ++-----------------------------++-- |Compare two 'Data' value with time and size limit.+compareData +    :: (Data a) +    => TimeLimit    -- ^ time limit for comparison decision+    -> TimeLimit    -- ^ time limit for highlighting the difference+    -> SizeLimit    -- ^ size limit for the output (in characters)+    -> a            -- ^ first value+    -> a            -- ^ second value+    -> IO (Answer, GenericData, GenericData)+compareData t1 t2 s x y = do+    b1 <- newBudget t1 maxBound+    (ans, l) <- decideEquality b1 x y+    b2 <- newBudget t2 s+    (x, y) <- fmap assemble $ manyParallel $ map (showPart b2) $ collapsePath l+    return (ans, x, y)+ where+    showPart budget (is, (DData x, DData y)) = do+        p <- twoParallel (evalPath budget is x) (evalPath budget is y)+        return (is, p)++data DData = forall a. Data a => DData a++type Path a = [([Int], (a, a))]++collapsePath :: Path DData -> Path DData+collapsePath xs = case splitAt 3 xs of+    (l, []) -> l+    (l, m) -> l ++ case splitAt 3 $ reverse m of+        (m, []) -> reverse m+        (m, k) -> case reverse k of+            (i,p):k -> (i ++ concatMap fst k, p): reverse m+            _       -> error "collapsePath"++assemble :: Path GenericData -> (GenericData, GenericData)+assemble [([], p)] = p+assemble ((is, (x, y)) : xys) = case assemble xys of+    (x', y') -> (g is x x', g is y y')+  where+    g [] _ x' = x'+    g (i:is) (Constructor c l) x' = Constructor c $ rep i l $ \x -> g is x x'+    g (_:is) _ x' = detail $ g is Hole x'++    detail (Detail x) = Detail x+    detail x = Detail x++    rep 0 (x:xs) f = f x: xs+    rep i (x:xs) f = x: rep (i-1) xs f+    rep _ _ _ = error "rep"+assemble _ = error "assemble"+++evalPath :: Data a => Budget -> [Int] -> a -> IO GenericData+evalPath budget [] x +    = evalWithBudget budget x+evalPath budget (j:is) x +    = constructor budget x+    $ manyParallel +      [ gmapQi i (if i==j then evalPath budget is else evalWithBudget budget) x+      | i <- [0..arity x - 1]]+++decideEquality :: (Data a, Data b) => Budget -> a -> b -> IO (Answer, Path DData)+decideEquality budget x y = do+    a <- observe x+    b <- observe y+    a `f` b+  where+    observe x = fmap simplify $ constructor budget x $ return []+      where+        simplify Hole  = Timeout 1+        simplify other = other++    Error _   `f` Error _    = yes+    Timeout b `f` Timeout b' = may $ 1 - abs (b - b')+    Timeout b `f` Error _    = may $ 1 - b+    Error _   `f` Timeout b  = may $ 1 - b+    Timeout b `f` _          = may b+    _         `f` Timeout b  = may b+    Error _   `f` _          = no+    _         `f` Error _    = no+    _         `f` _         | toConstr x /= toConstr y +                             = no+    _         `f` _          = do++        r <- manyParallel +              [ gmapQi i (gmapQi i (decideEquality' i) x) y | i <- [0..arity x - 1]]+        case r of+            [] -> yes+            xs -> return $ minimumBy (comparing fst) xs++    pair = (DData x, DData y)++    yes   = return (Yes, [([], pair)])+    may z = return (Maybe z, [([], pair)])+    no    = stop >> return (No, [([], pair)])+      where+        stop = decSizeBudget budget $ const (-1,())++    decideEquality' i x y = do+        (ans, ps) <- decideEquality budget x y+        return (ans, ([i], pair):ps)+
+ Data/Data/Eval.hs view
@@ -0,0 +1,29 @@+-- |Conversion to 'GenericData' with time and space limit.+module Data.Data.Eval +    ( eval+    , evalWithBudget+    ) where++import Data.Data.GenRep (GenericData, constructor)+import System.IO.Parallel (manyParallel)+import System.SimpleTimeout.Limits++import Data.Data (Data, gmapQ)++-------------------------++-- |Evaluation with time an size limit.+eval :: Data a => TimeLimit -> SizeLimit -> a -> IO GenericData+eval seconds chars x = do+    b <- newBudget seconds chars+    evalWithBudget b x++-- |Gives more control over the resources+evalWithBudget :: Data a => Budget -> a -> IO GenericData+evalWithBudget b x+    = constructor b x+    $ manyParallel+    $ gmapQ (evalWithBudget b) x+++
+ Data/Data/GenRep.hs view
@@ -0,0 +1,151 @@+-- |Intended for internal use: Generic representation of 'Data' vales.+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}+module Data.Data.GenRep +    ( ConstructorName (..)+    , GenericData (..)+    , constructor+    , arity+    ) where++import System.SimpleTimeout.Limits++import Control.Exception+import Control.DeepSeq (NFData, rnf)+import qualified Data.Data as D+import Data.Data (gmapQ, Data, Typeable)++---------------------------------------++-- |Name and precedence of constructors.+data ConstructorName+    = Prefix String     -- ^ used also for literals except characters+    | Char Char         -- ^ character literal+    | Infix Int String+    | Infixr Int String+    | Infixl Int String+    | Tuple Int         -- ^ tuple with n elements+    | Cons              -- ^ nonempty list constructor+    | Nil               -- ^ empty list constructor+        deriving (Eq, Show, Typeable)++instance NFData ConstructorName where+    rnf x = case x of+        Prefix s    -> rnf s+        Infix i s   -> rnf i `seq` rnf s+        Infixr i s  -> rnf i `seq` rnf s+        Infixl i s  -> rnf i `seq` rnf s+        Tuple i     -> rnf i+        Char c      -> rnf c+        _ -> ()+++-- |Arity of the toplevel constructor.+arity :: Data a => a -> Int+arity = length . gmapQ (const ())++-- | Extract the name and precedence of a 'Data' value.+precedence :: D.Data a => a -> SizeLimit -> (SizeLimit, ConstructorName)+precedence x v = case D.constrRep c of+    D.CharConstr char  -> (v-1, Char char)+    D.FloatConstr r +        | t == "Prelude.Double" -> prefix (realToFrac r :: Double)+        | t == "Prelude.Float"  -> prefix (realToFrac r :: Float)+        | otherwise             -> prefix (realToFrac r :: Rational)+    D.IntConstr i   -> prefix i+    D.AlgConstr _   -> case n of+        "[]"  -> (v-2, Nil)+        "(:)" -> (v-1, Cons)+        '(':l | all (==',') (init l) && last l == ')' +              -> (v-length l-1, Tuple (length l))+        _     -> case D.constrFixity c of+            D.Prefix    -> (v - length n, Prefix n)+            D.Infix     -> (v - length n, Infix 9 n)         -- sorry we can't do better+  where+    prefix :: Show a => a -> (Int, ConstructorName)+    prefix a = (v', Prefix s') where (v', s') = limitString v (show a)++    c = D.toConstr x+    n = D.showConstr c+    t = D.dataTypeName $ D.constrType c+++-- |Limit the length of a string by replacing the middle of+-- the string by an ellipsis.+-- The function returns the limit reduced by the final length of the string.+limitString :: SizeLimit -> String -> (SizeLimit, String)+limitString v s = f $ case splitAt i s of+    (_, []) -> s+    (a, b) -> case splitAt (j+1) $ reverse b of+        (_, []) -> s+        (c, _)  -> a ++ "…" ++ reverse (take j c)+ where+    f ss = (v-length ss, ss)++    i = max 4 (v `div` 2)+    j = max 3 (i-2)+++---------------------------------++-- |Representation of 'Data' values.+data GenericData+    = Constructor ConstructorName [GenericData]+    | Error String          -- ^ shown exception+    | Timeout Double        -- ^ timeout, the @Double@ is between 0 and 1. +                            -- +                            --      * 0: evaluation of subexpression started at the beginning+                            -- +                            --      * towards 1: evaluation of subexpression started near the end of time limit+                            -- +                            --      * 1: evaluation of subexpression started after time limit (rare)+    | Hole                  -- ^ this is caused space shortage, shown as three dots+    | Detail GenericData    -- ^ also caused by space shortage but this omission a relevant part+    | 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+        _   -> ()++++-- |Convert a 'Data' value to 'GenericData' given the+-- 'GenericData' representation 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)+    case y of+        Just a -> return a+        _ -> 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++
+ Data/Data/GenRep/Doc.hs view
@@ -0,0 +1,87 @@+-- |Conversion from 'GenericData' to 'Doc'+{-# LANGUAGE OverloadedStrings, PatternGuards #-}+module Data.Data.GenRep.Doc+    ( Doc+    , toDoc+    ) where++import Data.Data.GenRep+import Data.Char (ord, showLitChar)+import Data.String++import Text.PrettyPrint.HughesPJ+import Data.List (intersperse)++----------------++-- |'IsString' instance for 'Doc'+instance IsString Doc where fromString = text++-------------------------++-- |Show a character literal. Unicode characters are not escaped.+showLitCharInChar :: Char -> String+showLitCharInChar c | ord c >= 161 = [c]+showLitCharInChar c = showLitChar c ""++-- |Show a character in a string literal. Unicode characters are not escaped.+showLitCharInString :: Char -> String+showLitCharInString '\''  = "'"+showLitCharInString '"'   = "\\\""+showLitCharInString c     = showLitCharInChar c ++----------------------------------------------++-- |Convert 'GenericData' to 'Doc'.+toDoc :: GenericData -> Doc+toDoc {-text (<+>) fsep punctuate comma quotes doubleQuotes brackets parens -} +    = showsP 0 +  where+    showsP j x = case x of+        Hole           -> "…"       -- !!! ragadás+        ListHole       -> "……"+        Timeout _      -> "⊥"+        Error e        -> text e+        Detail s       -> showParen_ (j > 10) $ "……" <+> showsP 0 s <+> "……"+        Constructor (Char c) []         -> quotes $ text $ showLitCharInChar c+        Constructor Nil []              -> "[]"+        Constructor (Prefix f) []       -> text f+        Constructor (Infix i f)  [a,b]  -> showParen_ (j > i) $ showsP (i+1) a <+> text f <+> showsP (i+1) b+        Constructor (Infixr i f) [a,b]  -> showParen_ (j > i) $ showsP (i+1) a <+> text f <+> showsP i b+        Constructor (Infixl i f) [a,b]  -> showParen_ (j > i) $ showsP i a <+> text f <+> showsP (i+1) b+        Constructor (Tuple _) xs        -> showParen_ True $ list $ map (showsP 0) xs+        Constructor Cons [_,_]          -> fsep $ intersperse "++" $ elems x -- showListEnd "[]" "\"" "[" s+        Constructor (Prefix f) l        -> showParen_ (j > 10) $ text f <+> fsep (map (showsP 11) l)+        _                               -> error $ "showsP: " ++ show x++    showParen_ True  = parens+    showParen_ False = id++    list = fsep . punctuate comma++    collectChars (Constructor Cons [Constructor (Char c) [],b])+        | (cs, x) <- collectChars b+        = (c: cs, x)+    collectChars x = ([], x)++    collectElems x@(Constructor Cons [Constructor (Char _) [], _]) = ([], x)+    collectElems (Constructor Cons [a,b])+        | (cs, x) <- collectElems b+        = (a: cs, x)+    collectElems (Detail b) +        | (cs, x) <- collectElems b+        = (ListHole: cs, x)+    collectElems Hole +        = ([ListHole], Constructor Nil [])+    collectElems x = ([], x)++    elems x+        | (es@(_:_), y) <- collectChars x+        = doubleQuotes (text $ concatMap showLitCharInString es): elems y+        | (es@(_:_), y) <- collectElems x+        = (brackets . list . map (showsP 0) $ es): elems y+    elems (Constructor Nil []) = []+    elems (Detail x) = ["...", showsP 0 x]+    elems x = [showsP 0 x]++
+ Data/Data/GenRep/Functions.hs view
@@ -0,0 +1,113 @@+-- |Intended for internal use: Generic representation of 'Data' vales.+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Data.GenRep.Functions+    ( mistify+    , numberErrors+    ) where++import System.IO.Parallel+import System.SimpleTimeout.Limits+import Data.Data.GenRep++import Control.Exception+import Control.DeepSeq (deepseq)+import Control.Monad.State (State, runState, get, put)+import Prelude hiding (catch)++---------------------------------------++-- | True for 'Hole', 'ListHole' and 'Detail' constructors.+-- Used in 'mistify'.+isJoker :: GenericData -> Bool+isJoker Hole        = True+isJoker ListHole    = True+isJoker (Detail _)  = True+isJoker _ = False++-- could be better+-- | Try to hide some part of the value.+--+-- This is used in the evaluation of exercises, when the result+-- is wrong. We would like to show the erroneous part but not the whole result.+mistify :: GenericData -> GenericData+mistify (Constructor _ []) = Hole+mistify (Constructor p ss) | not (any isJoker ss) = Constructor p $ map mistify ss+mistify x = x++ +-------------------------------------------------------++-- |Collect and number of '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)+ 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 ++ "…")])++    (res, (_, errs)) = runState (mapM replace l) (0, [])++    replace :: GenericData -> State (Int, [(String, String)]) GenericData+    replace (Constructor p ss) = do+        ss' <- mapM replace ss+        return $ Constructor p ss'+    replace (Error e) = do+        i <- getErrorIndex e+        return $ Error i+    replace (Timeout d) = do+        i <- getErrorIndex $ showTimeout d+        return $ Error i+    replace (Detail s) = do+        s' <- replace s+        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++    toLowerIndex c = case c of+        '0' -> '₀'+        '1' -> '₁'+        '2' -> '₂'+        '3' -> '₃'+        '4' -> '₄'+        '5' -> '₅'+        '6' -> '₆'+        '7' -> '₇'+        '8' -> '₈'+        '9' -> '₉'+        _   -> error $ "toLowerIndex: " ++ show c+
+ Data/PPrint.hs view
@@ -0,0 +1,58 @@+-- |Prettyprint and compare 'Data' values.+module Data.PPrint+    ( pprint+    , (===)+    ) where++import Data.Data.GenRep.Functions (numberErrors)+import Data.Data.GenRep.Doc (Doc, toDoc)+import Data.Data.Eval (eval)+import Data.Data.Compare++import Text.PrettyPrint.HughesPJ (fsep, nest, text, vcat, (<>), (<+>), ($+$))+import Data.Data (Data)++---------------------++-- |Prettyprint a 'Data' value.+--+-- There is a 1 second time limit and the output+-- contains at most approximately 500 characters.+--+-- The exceptions are shown as bottom signs+-- 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)+++infix 0 === ++-- |Compare two 'Data' values.+--+-- The can be yes, no or maybe.+-- The differences are highlighted.+--+-- There is a 1 second time limit and the output+-- contains at most approximately 500 characters.+--+-- The exceptions are shown as bottom signs+-- followed by explanations.+(===) :: Data a => a -> a -> IO Doc+a === b = do+    (ans, a, b) <- compareData 0.8 0.2 500 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]+         $+$ nest 2 (showBotts es)++----------------------++showBotts :: [(String, String)] -> Doc+showBotts es = vcat $ map f es+ where+    f (i, e) = text i <> text ":" <+> vcat (map text $ lines e)++
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Péter Diviánszky 2008++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 Péter Diviánszky 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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/IO/Parallel.hs view
@@ -0,0 +1,63 @@+-- |Intended for internal use: Parallel evaluation of @IO@ values+module System.IO.Parallel+    ( twoParallel+    , threeParallel+    , fourParallel+    , manyParallel+    ) where++import Control.Concurrent (forkIO, yield)+import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)+++-------------------++-- |Run an @IO@ computation in parallel. The result will appear in the @MVar@.+async :: IO a -> IO (MVar a)+async m = do+    v <- newEmptyMVar+    _ <- forkIO $ do+        x <- m+        yield+        putMVar v x+    return v++-- |Run two @IO@ computations in parallel and wait for the results.+twoParallel :: IO a -> IO b -> IO (a, b)+twoParallel a b = do+    a' <- async a+    b' <- async b+    a'' <- takeMVar a'+    b'' <- takeMVar b'+    return (a'', b'')++-- |Run three @IO@ computations in parallel and wait for the results.+threeParallel :: IO a -> IO b -> IO c -> IO (a, b, c)+threeParallel a b c = do+    a' <- async a+    b' <- async b+    c' <- async c+    a'' <- takeMVar a'+    b'' <- takeMVar b'+    c'' <- takeMVar c'+    return (a'', b'', c'')++-- |Run four @IO@ computations in parallel and wait for the results.+fourParallel :: IO a -> IO b -> IO c -> IO d -> IO (a, b, c, d)+fourParallel a b c d = do+    a' <- async a+    b' <- async b+    c' <- async c+    d' <- async d+    a'' <- takeMVar a'+    b'' <- takeMVar b'+    c'' <- takeMVar c'+    d'' <- takeMVar d'+    return (a'', b'', c'', d'')++-- |Run computations in parallel and wait for the results.+manyParallel :: [IO a] -> IO [a]+manyParallel m +    = mapM async m >>= mapM takeMVar++
+ System/SimpleTimeout.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |Intended for internal use: Simple timeout mechanism+module System.SimpleTimeout+    ( TimeoutHandle+    , timeoutHandle+    , timeout+    ) where++import Control.Exception (Exception, handle)+import Control.Concurrent (forkIO, threadDelay, throwTo, ThreadId, myThreadId)+import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar, takeMVar, putMVar, swapMVar, modifyMVar)++import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)+import Data.Typeable (Typeable)++------------------------++-- |timeout exception+--+-- The @Double@ parameter documented at 'timeout'.+data TimeOutException  +    = TimeOutException Double+        deriving (Eq, Typeable)++instance Show TimeOutException where+    show (TimeOutException d) = "<<timeout at " ++ show (round $ 100*d :: Integer) ++ "%>>"++instance Exception TimeOutException++---------------++-- |Abstract data structure used by 'TimeoutHandle' and 'timeout'.+newtype TimeoutHandle +    = TimeutHandle (MVar +        (Maybe [(ThreadId, UTCTime)]))+            -- ^ +            -- @Nothing@: the timeout happened already+            -- @Just xs@: there is time left+            --   @xs@ contains the list of threads for which a 'TimeoutException' +            --         will be thrown when the time is over.+            --   'UTCTime' is needed to compute the @Double@ parameter of the exception.++-- |Creates a 'TimeoutHandle'.+--+-- The @Double@ parameter is the time limit in second.+-- All operations behind 'timeout' will be stopped +-- at the current time plus the time limit.+timeoutHandle :: Double -> IO TimeoutHandle+timeoutHandle limit = do+    th <- newMVar $ Just []+    _ <- forkIO $ killLater th+    return $ TimeutHandle th+  where++    killLater th = do+        start <- getCurrentTime+        threadDelay $ round $ 1000000 * limit+        Just threads <- swapMVar th Nothing++        end <- getCurrentTime+        let whole = end `diffUTCTime` start++        let kill (x, time) +                = x `throwTo` +                    TimeOutException (realToFrac $ (time `diffUTCTime` start) / whole)++        mapM_ kill threads+++-- | Stop an operation at a time given by 'timeoutHandle'.+--+-- The @Double@ parameter is a percent between 0 and 1.+-- +--  * 0: 'timeout' was called right after the 'TimeoutHandle' was created.+--+--  * 1: 'timeout' was called after the time of the timeout.+--+--  * near to 1: 'timeout' was called right before the time of the timeout.+--+--  * Other values: proportional to the time spend by the operation.+timeout +    :: TimeoutHandle    -- ^ knows the time of the timeout and the creation time of itself+    -> (Double -> IO a) -- ^ timeout handling action for which will the percent will be supplied+    -> IO a             -- ^ the operation to timeout+    -> IO a+timeout (TimeutHandle th) handleTimeout operation = do+    result <- newEmptyMVar++    let handleTimeoutException (TimeOutException d) +            = handleTimeout d >>= putMVar result++    _ <- forkIO $ handle handleTimeoutException $ do+        b <- modifyMVar th $ \b -> case b of+            Nothing -> return (Nothing, False)+            Just xs -> do+                pid <- myThreadId+                time <- getCurrentTime+                return (Just $ (pid,time):xs, True)+        x <- if b +            then operation+            else handleTimeout 1+        putMVar result x++    takeMVar result+++
+ System/SimpleTimeout/Limits.hs view
@@ -0,0 +1,53 @@+-- |Time and size limits+module System.SimpleTimeout.Limits+    ( TimeLimit+    , SizeLimit+    , Budget+    , newBudget+    , checkBudget+    , decSizeBudget+    ) where++import System.SimpleTimeout (TimeoutHandle, timeoutHandle, timeout)+import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)++--------------++-- |Time limit is a 'Double' which is the allowed time in seconds.+type TimeLimit = Double++-- |Size limit is an 'Int' which meaning is given by 'checkBudget' and 'decSizeBudget'.+type SizeLimit = Int++-- |A 'Budget' contains a time and size limit.+data Budget +    = Budget TimeoutHandle (MVar SizeLimit)++-- |Create a new budget.+newBudget :: TimeLimit -> SizeLimit -> IO Budget+newBudget t s = do+    th <- timeoutHandle t+    mv <- newMVar s+    return $ Budget th mv++-- |Check budget and take another action if there is no more resource.+checkBudget +    :: Budget +    -> Int                  -- ^ decrement size budget with this value+    -> (Double -> IO a)     -- ^ what to do in case of timeout ('Double': percent when the thread was started)+    -> IO a                 -- ^ what to do in case there is no more space +    -> IO a                 -- ^ what to do in a normal case+    -> IO a+checkBudget (Budget tb sb) dec ta sa na = do+    r <- modifyMVar sb $ \a -> return $ +        if a > 0 then (a-dec, True) else (a, False)+    if r then timeout tb ta na else sa++-- |Decrement free size in a budget.+decSizeBudget +    :: Budget+    -> (SizeLimit -> (SizeLimit, a))    -- ^ funtion to modify free size and produce a value+    -> IO a+decSizeBudget (Budget _ sb) f+    = modifyMVar sb $ return . f+
+ data-pprint.cabal view
@@ -0,0 +1,70 @@+name:                data-pprint+version:             0.1+category:            Testing, Text+synopsis:            Prettyprint and compare Data values+description:+    Prettyprint and compare Data values.+    .+    *   Size limit for the output+    .+    *   Time limit for the computation+    .+    *   Escape exceptions+    .+    *   Do not escape unicode characters+    .+    *   Comparison: Highlight the first difference+    .+    *   Comparison: Yes, No or Maybe results+    .+    Probably you need only the 'pprint' and '(===)' functions from the "Data.PPrint" module.+    .+    Usage examples:+    .+    > pprint [1..]+    > pprint $ repeat [1..]+    > pprint $ iterate (*10) 1+    > pprint $ map length $ replicate 5 [1..] ++ repeat []+    > pprint [2 `div` 0, error "xxx", 18, 4 `div` 0]+    > [1..10] === reverse [10,9..1]+    > [1..10] === reverse [10..1]+    > reverse [10..] === [1..]+    > [1..] === [1..99] ++ [101..]+    > ([1..], [1..]) === ([1..], [1..100]) +    > (error "x", [1..]) === (0 `div` 0, reverse [1..])+    > error ("xx" ++ show (length [1..])) === 1+    > error ("xx" ++ error "yy") === 1+    > (error $ unlines $ replicate 300 "xxxxxxxxxxxxxxxxxxxxxxxxxxx") === 1+    > pprint ['a'..]+    > pprint $ "hello" ++ [error "x"] ++ "world!"+    .+    See also <http://pnyf.inf.elte.hu/fp/Show_en.xml>+stability:           beta+license:             BSD3+license-file:        LICENSE+author:              Péter Diviánszky+maintainer:          divip@aszt.inf.elte.hu+cabal-version:       >=1.2+build-type:          Simple++library+  ghc-options:       -Wall -fno-warn-name-shadowing -fno-warn-orphans+  exposed-modules:+    Data.PPrint,+    Data.Data.Eval,+    Data.Data.Compare,+    Data.Data.GenRep,+    Data.Data.GenRep.Functions,+    Data.Data.GenRep.Doc,+    System.SimpleTimeout,+    System.SimpleTimeout.Limits,+    System.IO.Parallel+  other-modules:+  build-depends:+    base >= 4.0 && < 4.4,+    pretty >= 1.0 && < 1.1,+    mtl >= 2.0 && < 2.1,+    deepseq >= 1.1 && < 1.2, +    time >= 1.2 && < 1.3,+    parallel >= 3.1 && < 3.2+