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)
isJoker :: GenericData -> Bool
isJoker Hole = True
isJoker ListHole = True
isJoker (Detail _) = True
isJoker _ = False
mistify :: GenericData -> GenericData
mistify (Constructor _ []) = Hole
mistify (Constructor p ss) | not (any isJoker ss) = Constructor p $ map mistify ss
mistify x = x
numberErrors
:: TimeLimit
-> SizeLimit
-> SizeLimit
-> [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