diff --git a/Data/Data/Compare.hs b/Data/Data/Compare.hs new file mode 100644 --- /dev/null +++ b/Data/Data/Compare.hs @@ -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) + diff --git a/Data/Data/Eval.hs b/Data/Data/Eval.hs new file mode 100644 --- /dev/null +++ b/Data/Data/Eval.hs @@ -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 + + + diff --git a/Data/Data/GenRep.hs b/Data/Data/GenRep.hs new file mode 100644 --- /dev/null +++ b/Data/Data/GenRep.hs @@ -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 + + diff --git a/Data/Data/GenRep/Doc.hs b/Data/Data/GenRep/Doc.hs new file mode 100644 --- /dev/null +++ b/Data/Data/GenRep/Doc.hs @@ -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] + + diff --git a/Data/Data/GenRep/Functions.hs b/Data/Data/GenRep/Functions.hs new file mode 100644 --- /dev/null +++ b/Data/Data/GenRep/Functions.hs @@ -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 + diff --git a/Data/PPrint.hs b/Data/PPrint.hs new file mode 100644 --- /dev/null +++ b/Data/PPrint.hs @@ -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) + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + 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/System/IO/Parallel.hs b/System/IO/Parallel.hs new file mode 100644 --- /dev/null +++ b/System/IO/Parallel.hs @@ -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 + + diff --git a/System/SimpleTimeout.hs b/System/SimpleTimeout.hs new file mode 100644 --- /dev/null +++ b/System/SimpleTimeout.hs @@ -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) = "<>" + +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 + + + diff --git a/System/SimpleTimeout/Limits.hs b/System/SimpleTimeout/Limits.hs new file mode 100644 --- /dev/null +++ b/System/SimpleTimeout/Limits.hs @@ -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 + diff --git a/data-pprint.cabal b/data-pprint.cabal new file mode 100644 --- /dev/null +++ b/data-pprint.cabal @@ -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 +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 +