data-pprint-0.2.3/0000755000000000000000000000000012230513021012112 5ustar0000000000000000data-pprint-0.2.3/LICENSE0000644000000000000000000000277712230513021013134 0ustar0000000000000000Copyright Péter Diviánszky 2008-2011 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. data-pprint-0.2.3/Setup.hs0000644000000000000000000000005612230513021013547 0ustar0000000000000000import Distribution.Simple main = defaultMain data-pprint-0.2.3/data-pprint.cabal0000644000000000000000000000435012230513021015323 0ustar0000000000000000name: data-pprint version: 0.2.3 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..] > pprintTo 10000 $ 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 . Changes since 0.1: Refactoring, proper handling of nested errors stability: beta license: BSD3 license-file: LICENSE author: Péter Diviánszky maintainer: divipp@gmail.com cabal-version: >=1.6 build-type: Simple source-repository head type: git location: https://github.com/divipp/ActiveHs-misc 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, Control.Exception.Pure, System.SimpleTimeout, System.SimpleTimeout.Limits, System.IO.Parallel other-modules: build-depends: base >= 4.0 && < 4.7, pretty >= 1.0 && < 1.2, mtl >= 2.0 && < 2.2, deepseq >= 1.1 && < 1.4, time >= 1.2 && < 1.5, parallel >= 3.1 && < 3.3 data-pprint-0.2.3/Control/0000755000000000000000000000000012230513021013532 5ustar0000000000000000data-pprint-0.2.3/Control/Exception/0000755000000000000000000000000012230513021015470 5ustar0000000000000000data-pprint-0.2.3/Control/Exception/Pure.hs0000644000000000000000000000270212230513021016740 0ustar0000000000000000-- |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) data-pprint-0.2.3/System/0000755000000000000000000000000012230513021013376 5ustar0000000000000000data-pprint-0.2.3/System/SimpleTimeout.hs0000644000000000000000000000653612230513021016544 0ustar0000000000000000{-# 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 seconds. -- 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 data-pprint-0.2.3/System/IO/0000755000000000000000000000000012230513021013705 5ustar0000000000000000data-pprint-0.2.3/System/IO/Parallel.hs0000644000000000000000000000305612230513021016001 0ustar0000000000000000-- |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 data-pprint-0.2.3/System/SimpleTimeout/0000755000000000000000000000000012230513021016176 5ustar0000000000000000data-pprint-0.2.3/System/SimpleTimeout/Limits.hs0000644000000000000000000000334212230513021017775 0ustar0000000000000000-- |Time and size limits module System.SimpleTimeout.Limits ( TimeLimit , SizeLimit , Budget , newBudget , checkBudget , decSizeBudget , showTimeout ) 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 showTimeout :: Double -> String showTimeout d = "timeout at " ++ show (round $ 100 * d :: Int) ++ "%" data-pprint-0.2.3/Data/0000755000000000000000000000000012230513021012763 5ustar0000000000000000data-pprint-0.2.3/Data/PPrint.hs0000644000000000000000000000324412230513021014536 0ustar0000000000000000-- |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 = pprintTo 700 -- |Prettyprint a 'Data' value, showing up to approximately -- the specified number of characters. Use this to show -- more than the default pprint allows. pprintTo :: Data a => Int -> a -> IO Doc pprintTo max x = do x <- eval 1 max x let ([x'], es) = numberErrors [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 700 a b let x = showAnswer ans let ([a', b'], es) = numberErrors [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) data-pprint-0.2.3/Data/Data/0000755000000000000000000000000012230513021013634 5ustar0000000000000000data-pprint-0.2.3/Data/Data/GenRep.hs0000644000000000000000000001142712230513021015355 0ustar0000000000000000-- |Intended for internal use: Generic representation of 'Data' vales. {-# LANGUAGE DeriveDataTypeable #-} module Data.Data.GenRep ( ConstructorName (..) , GenericData (..) , constructor , arity ) where import System.SimpleTimeout.Limits import System.IO.Parallel (manyParallel) import Control.Exception.Pure (catchPureErrors) 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 -- ^ 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 -- -- * 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 NestedError e -> rnf e Detail s -> rnf s Timeout d -> rnf d _ -> () -- |Convert a 'Data' value to 'GenericData' given the -- '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 . Left . Timeout) (return $ Left Hole) $ fmap Right $ catchPureErrors x case y of 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 evalWithBudget :: Data a => Budget -> a -> IO GenericData evalWithBudget b x = constructor b x $ manyParallel $ gmapQ (evalWithBudget b) x data-pprint-0.2.3/Data/Data/Compare.hs0000644000000000000000000001050512230513021015557 0ustar0000000000000000-- |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 (NestedError _) = Error "undefined error" 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-pprint-0.2.3/Data/Data/Eval.hs0000644000000000000000000000127112230513021015060 0ustar0000000000000000-- |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-pprint-0.2.3/Data/Data/GenRep/0000755000000000000000000000000012230513021015014 5ustar0000000000000000data-pprint-0.2.3/Data/Data/GenRep/Functions.hs0000644000000000000000000000506512230513021017326 0ustar0000000000000000-- |Intended for internal use: Generic representation of 'Data' vales. {-# LANGUAGE ScopedTypeVariables #-} module Data.Data.GenRep.Functions ( mistify , numberErrors , getErrorIndex ) where import Data.Data.GenRep.Doc (toDoc) import Data.Data.GenRep import System.SimpleTimeout.Limits (showTimeout) import Control.Monad.State (State, runState, get, put) --------------------------------------- -- | 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 'Error' values and replace them -- by an indexed bottom sign. -- Repeated errors will get the same number. numberErrors :: [GenericData] -> ([GenericData], [(String, String)]) numberErrors l = (res, reverse $ map swap errs) where swap (a,b) = (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 (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 replace (Detail s) = do s' <- replace s return $ Detail s' replace x = 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' -> '₁' '2' -> '₂' '3' -> '₃' '4' -> '₄' '5' -> '₅' '6' -> '₆' '7' -> '₇' '8' -> '₈' '9' -> '₉' _ -> error $ "toLowerIndex: " ++ show c data-pprint-0.2.3/Data/Data/GenRep/Doc.hs0000644000000000000000000000631112230513021016056 0ustar0000000000000000-- |Conversion from 'GenericData' to 'Doc' {-# LANGUAGE OverloadedStrings, PatternGuards #-} module Data.Data.GenRep.Doc ( Doc , showLitCharInChar , showLitCharInString , toDoc ) where import Data.Data.GenRep import Data.Char (ord, showLitChar) 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 -> text "…" -- !!! ragadás ListHole -> text "……" Timeout _ -> text "⊥" NestedError e -> text "⊥(" <+> toDoc e <+> text ")" Error e -> text e Detail s -> showParen_ (j > 10) $ text "……" <+> showsP 0 s <+> text "……" Constructor (Char c) [] -> quotes $ text $ showLitCharInChar c Constructor Nil [] -> text "[]" 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 (text "++") $ 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) = [text "...", showsP 0 x] elems x = [showsP 0 x]