Random.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}

module Test.Random(main) where

import Development.Shake
import Numeric.Extra
import Test.Type
import Control.Exception.Extra
import Control.Monad
import Data.List
import Data.Maybe
import General.GetOpt
import System.Environment
import System.Exit
import System.Random
import General.Extra
import qualified System.IO.Extra as IO
import System.Time.Extra


inputRange = [1..10]

data Value = Single Int | Multiple [[Value]]
    deriving (Read,Show,Eq)

data Source = Input Int | Output Int | Bang
    deriving (Read,Show)

data Logic = Logic Int [[Source]]
           | Want [Int]
    deriving (Read,Show)

arg = [Option "" ["arg"] (ReqArg Right "") ""]

main = testBuildArgs test arg $ \args -> do
    let toFile (Input i) = "input-" ++ show i ++ ".txt"
        toFile (Output i) = "output-" ++ show i ++ ".txt"
        toFile Bang = error "BANG"

    let randomSleep = liftIO $ do
            i <- randomRIO (0, 25)
            sleep $ intToDouble i / 100

    forM_ (map read $ filter (isNothing . asDuration) args) $ \case
        Want xs -> want $ map (toFile . Output) xs
        Logic out srcs -> toFile (Output out) %> \out -> do
            res <- fmap (show . Multiple) $ forM srcs $ \src -> do
                randomSleep
                need $ map toFile src
                mapM (liftIO . fmap read . IO.readFile' . toFile) src
            randomSleep
            writeFileChanged out res


asDuration :: String -> Maybe Double
asDuration x
    | "s" `isSuffixOf` x, [(i,"")] <- reads $ init x = Just i
    | "m" `isSuffixOf` x, [(i,"")] <- reads $ init x = Just $ i * 60
    | otherwise = Nothing


test build = do
    limit <- do
        args <- getArgs
        let bound = listToMaybe $ reverse $ mapMaybe asDuration args
        time <- offsetTime
        pure $ when (isJust bound) $ do
            now <- time
            when (now > fromJust bound) exitSuccess

    forM_ [1..] $ \count -> do
        limit
        putStrLn $ "* PERFORMING RANDOM TEST " ++ show count
        build ["clean"]
        build [] -- to create the directory
        forM_ inputRange $ \i ->
            writeFile ("input-" ++ show i ++ ".txt") $ show $ Single i
        logic <- randomLogic
        runLogic [] logic
        chng <- filterM (const randomIO) inputRange
        forM_ chng $ \i ->
            writeFile ("input-" ++ show i ++ ".txt") $ show $ Single $ negate i
        runLogic chng logic
        forM_ inputRange $ \i ->
            writeFile ("input-" ++ show i ++ ".txt") $ show $ Single i
        logicBang <- addBang =<< addBang logic
        j <- randomRIO (1::Int,8)
        res <- try_ $ build $ "--exception" : ("-j" ++ show j) : map ((++) "--arg=" . show) (logicBang ++ [Want [i | Logic i _ <- logicBang]])
        case res of
            Left err
                | "BANG" `isInfixOf` show err -> pure () -- error I expected
                | otherwise -> error $ "UNEXPECTED ERROR: " ++ show err
            _ -> pure () -- occasionally we only put BANG in places with no dependenies that don't get rebuilt
        runLogic [] $ logic ++ [Want [i | Logic i _ <- logic]]
        where
            runLogic :: [Int] -> [Logic] -> IO ()
            runLogic negated xs = do
                let poss = [i | Logic i _ <- xs]
                i <- randomRIO (0, 7)
                wants <- replicateM i $ do
                    i <- randomRIO (0, 5)
                    replicateM i $ randomElem poss
                sleepFileTime
                j <- randomRIO (1::Int,8)
                build $ ("-j" ++ show j) : map ((++) "--arg=" . show) (xs ++ map Want wants)

                let value i =
                        let ys = headErr [ys | Logic j ys <- xs, j == i]
                        in Multiple $ flip map ys $ map $ \case
                            Input i -> Single $ if i `elem` negated then negate i else i
                            Output i -> value i
                            Bang -> error "BANG"
                forM_ (concat wants) $ \i -> do
                    let wanted = value i
                    got <- fmap read $ IO.readFile' $ "output-" ++ show i ++ ".txt"
                    when (wanted /= got) $
                        error $ "INCORRECT VALUE for " ++ show i


addBang :: [Logic] -> IO [Logic]
addBang xs = do
    i <- randomRIO (0, length xs - 1)
    let (before,now:after) = splitAt i xs
    now <- f now
    pure $ before ++ now : after
    where
        f (Logic log xs) = do
            i <- randomRIO (0, length xs)
            let (before,after) = splitAt i xs
            pure $ Logic log $ before ++ [Bang] : after
        f x = pure x


randomLogic :: IO [Logic] -- only Logic constructors
randomLogic = do
    rules <- randomRIO (1,100)
    f rules $ map Input inputRange
    where
        f 0 _ = pure []
        f i avail = do
            needs <- randomRIO (0,3)
            xs <- replicateM needs $ do
                ns <- randomRIO (0,3)
                replicateM ns $ randomElem avail
            let r = Logic i xs
            (r:) <$> f (i-1) (Output i:avail)