content: {-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns #-}
  
  module Development.Bake.Test.Simulate(
      simulate
      ) where
  
  import Development.Bake.Core.Message
  import Development.Bake.Core.Type
  import Development.Bake.Server.Brain
  import Development.Bake.Server.Memory
  import Development.Bake.Server.Store
  import Control.Monad.Extra
  import Data.List.Extra
  import Data.Tuple.Extra
  import Data.Monoid
  import Data.Maybe
  import Numeric.Extra
  import General.Extra
  import System.Random
  import System.IO.Extra
  import System.Time.Extra
  import qualified Data.Set as Set
  import qualified Data.Map as Map
  import Control.Applicative
  import Prelude
  
  
  simulate :: IO ()
  simulate = withBuffering stdout NoBuffering $ do
      performance 200
      basic
      bisect
      newTest
      quickPlausible
      replicateM_ 20 randomSimple
  
  ---------------------------------------------------------------------
  -- GENERIC SIMULATION ENGINE
  
  
  -- Properties!
  -- * By the time you finish, every patch must be propertly rejected or accepted
  -- * Clients must not be executing too much at one time
  
  data S s = S
      {user :: s
      ,memory :: Memory
      ,wait :: Int
      ,asked :: Set.Set Question
      ,patch :: [(Patch, Bool, Maybe Test -> Bool)]
      }
  
  unstate :: State -> [Patch]
  unstate = map toPatch . words . fromState
  
  restate :: [Patch] -> State
  restate = toState . unwords . map fromPatch
  
  data Step = Submit Patch Bool (Maybe Test -> Bool) -- are you OK for it to pass, are you OK for it to fail
            | Reply Question Bool [Test]
            | Request Client
            | Paused Bool
  
  simulation
      :: (Test -> TestInfo Test)                  -- ^ Static test information
      -> [(Client, Int)]                          -- ^ Clients, plus their maximum thread count
      -> s                                        -- ^ initial seed
      -> ([Question] -> s -> IO (s, Bool, Step))  -- ^ step function
      -> IO s
  simulation testInfo workers u step = withTempDir $ \dir -> do
      t <- getCurrentTime
      s <- newStore True dir
      let oven = defaultOven
              {ovenUpdate = \s ps -> return $ restate $ unstate s ++ ps
              ,ovenTestInfo = testInfo
              ,ovenSupersede = \_ _ -> False
              ,ovenInit = undefined
              ,ovenPrepare = undefined
              ,ovenPatchExtra = undefined
              }
      mem <- newMemory oven (Prettys fromState fromPatch fromTest) s (restate [], Answer mempty (Just 0) [] True)
      mem <- return mem
          {active = (restate [], [])
          ,simulated = True}
      let s = S u mem 20 Set.empty []
  
      let count s c = sum [qThreads | (_, Question{..}) <- running $ memory s, qClient == c]
      s@S{..} <- flip loopM s $ \s -> do
          -- print $ clients $ memory s
          -- print $ storePoint (store $ memory s) (active $ memory s)
          putChar '.'
          (u, cont, res) <- step (map snd $ running $ memory s) (user s)
          s <- return s{user = u}
          (msg,s) <- return $ case res of
              Submit p pass fail -> (AddPatch "" p, s{patch = (p,pass,fail) : patch s})
              Reply q good tests ->
                  let ans = Answer mempty (Just 0) (if good && isNothing (qTest q) then tests else []) good
                  in (Finished q ans, s)
              Request c ->
                  let Just mx = lookup c workers
                  in (Pinged $ Ping c (fromClient c) [] mx $ mx - count s c, s)
              Paused b ->
                  (if b then Pause else Unpause, s)
          (mem, q) <- prod (memory s) msg
          q <- return $ either error id <$> q
          -- print q
          when (fatal mem /= []) $ error $ "Fatal error, " ++ unlines (fatal mem)
          s <- return s{memory = mem}
          s <- return $ case q of
              Just q | q `Set.member` asked s -> error "asking a duplicate question"
                     | otherwise -> s{asked = Set.insert q $ asked s}
              Nothing | not cont -> s{wait = wait s - 1}
              _ -> s
          return $ if wait s == 0 then Right s else Left s
  
      putStrLn ""
      let S{memory=Memory{..},..} = s
  
  --    putStrLn $ unlines $ map show $ Map.toList $ storePoints store
  
      unless (null running) $ error "Running should have been empty"
      unless (null $ snd active) $ error "Active should have been empty"
      unless (Set.null $ storeAlive store) $ error "Alive should have been empty"
      forM_ workers $ \(c,_) -> do
          (_, q) <- prod Memory{..} $ Pinged $ Ping c (fromClient c) [] maxBound maxBound
          when (isJust q) $ error "Brains should have returned sleep"
  
      forM_ patch $ \(p, pass, fail) ->
          case () of
              _ | pass -> unless (p `elem` unstate (fst active)) $ error $ show ("expected pass but not",p)
                | PatchInfo{paReject=Just (_,t)} <- storePatch store p -> unless (all fail $ Map.keys t) $ error "incorrect test failure"
                | otherwise -> error "missing patch"
      return user
  
  
  ---------------------------------------------------------------------
  -- SPECIFIC SIMULATIONS
  
  randomSimple :: IO ()
  randomSimple = do
      let info t = mempty{testDepend = [toTest "1" | t /= toTest "1"]}
  
      i <- randomRIO (0::Int,10)
      patches <- forM [0..i] $ \i -> do
          j <- randomRIO (0::Int,9)
          return $ toPatch $ show i ++ show j
      let failure t p = maybe "0" fromTest t `isSuffixOf` fromPatch p
  
      let client = toClient "c"
      simulation info [(client,2)] patches $ \active patches -> do
          i <- randomRIO (0::Int, 20)
          let cont = not $ null active && null patches
          case i of
              0 | p:patches <- patches -> do
                  let pass = last (fromPatch p) > '3'
                  return (patches, cont, Submit p pass (`failure` p))
  
              i | i <= 2, not $ null active -> do
                  i <- randomRIO (0, length active - 1)
                  let q = active !! i
                  let good = not $ any (failure $ qTest q) $ unstate (fst $ qCandidate q) ++ snd (qCandidate q)
                  return (patches, cont, Reply q good $ map toTest ["1","2","3"])
  
              _ -> return (patches, cont, Request client)
      putStrLn "Success at randomSimple"
  
  
  quickPlausible :: IO ()
  quickPlausible = do
      let info t = mempty{testPriority = if t == toTest "3" then 1 else if t == toTest "1" then -1 else 0}
      let client = toClient "c"
      let tests = map toTest ["1","2","3","4","5"]
      -- start, process 2 tests, add a patch, then process the rest
      -- expect to see 1, X, 1, rest, X
  
      let todo = [Paused True
                 ,Submit (toPatch "0") True (const False)
                 ,Submit (toPatch "1") False (== Just (toTest "3"))
                 ,Submit (toPatch "2") True (const False)
                 ,Paused False
                 ,Submit (toPatch "3") True (const False)]
  
      simulation info [(client,1)] todo $ \active todo -> return $ case () of
          _ | t:odo <- todo -> (odo, True, t)
            | q@Question{..}:_ <- active ->
                if snd qCandidate == [toPatch "0",toPatch "2"] && qTest `notElem` [Nothing, Just $ toTest "3"] then error "bad quickPlausible"
                else (todo, True, Reply q (not $ qTest == Just (toTest "3") && toPatch "1" `elem` unstate (fst qCandidate) ++ snd qCandidate) tests)
            | otherwise -> (todo, False, Request client)
      putStrLn $ "Success at quickPlausible"
  
  
  bisect :: IO ()
  bisect = do
      let info t = mempty
      let tests = map (toTest . show) [1 .. 3 :: Int]
      let client = toClient "c"
      (done,_) <- simulation info [(client,1)] (0, map (toPatch . show) [1 .. 1024 :: Int]) $ \active (done,patches) -> return $ case () of
          _ | p:patches <- patches -> ((done,patches), True, Submit p (p /= toPatch "26") (\t -> p == toPatch "26" && t == Just (toTest "2")))
            | q:_ <- active -> ((done+1,[]), True, Reply q (qTest q /= Just (toTest "2") || toPatch "26" `notElem` (unstate (fst $ qCandidate q) ++ snd (qCandidate q))) tests)
            | otherwise -> ((done,[]), False, Request client)
      when (done > 50) $ error "Did too many tests to bisect"
      putStrLn "Success at bisect"
  
  
  basic :: IO ()
  basic = do
      -- have test x, fails in patch 4 of 5
      let info t = mempty
      let client = toClient "c"
      simulation info [(client,1)] (map (toPatch . show) [1..5 :: Int]) $ \active patches -> return $ case () of
          _ | p:patches <- patches -> (patches, True, Submit p (p /= toPatch "4") (\t -> p == toPatch "4" && t == Just (toTest "x")))
            | q:_ <- active, let isX = qTest q == Just (toTest "x"), let has12 = toPatch "4" `elem` snd (qCandidate q) ->
                  ([], True, Reply q (not $ isX && has12) (map toTest ["x"]))
            | otherwise -> ([], False, Request client)
      putStrLn "Success at basic"
  
  
  newTest :: IO ()
  newTest = do
      -- had test x,y all along. Introduce z/q at newPatch, and z either always fails or always passes
      let info t = mempty
      let client = toClient "c"
      let tests = map toTest ["x","y"]
      let patches = map (toPatch . show) [1..20 :: Int]
      let newTest = toTest "z"
      let newPatch = toPatch "12"
  
      forM_ [False,True] $ \pass -> do
          simulation info [(client,1)] patches $ \active patches -> return $ case () of
              _ | p:patches <- patches -> (patches, True, Submit p (p /= newPatch || pass) (\t -> not pass && p == newPatch && t == Just newTest))
                | q:_ <- active, let isTest = qTest q == Just newTest, let isPatch = newPatch `elem` snd (qCandidate q) ->
                      if isTest && not isPatch then error $ "Running a test that doesn't exist, " ++ show q
                      else ([], True, Reply q (not isTest || pass) (tests ++ [newTest | isPatch] ++ [toTest "q" | isPatch]))
                | otherwise -> ([], False, Request client)
          putStrLn "Success at newtest"
  
  performance :: Int -> IO ()
  performance nTests = timed $ do
      -- TODO: ping the website regularly
      -- 1000 tests, 50 submissions, 7 failing, spawn about every 200 tests
      let nPatches = 50
      let f x = min (nTests-1) $ max 0 $ round $ intToDouble nTests * x 
      let fails = [(3,f 0.2),(4,f 0),(10,f 0.1),(22,f 0.6),(40,f 0.6),(48,f 0.9),(49,f 0.9)]
  
      let pri = toTest $ show $ f 0.1
      let npri = length $ fromTest pri
      let info t = mempty{testPriority = case compare (length $ fromTest t) npri of
                                              LT -> 1; GT -> 0; EQ -> if t < pri then 1 else 0}
      let client = toClient "c"
      let tests = map (toTest . show) [0 :: Int .. nTests - 1]
      simulation info [(client,3)] (0::Int, 0::Int) $ \active (patch,tick) -> return $ case () of
          _ | tick >= f 0.2, patch < nPatches ->
                  let pass = patch `notElem` map fst fails
                      fail t = (patch,maybe (-1) (read . fromTest) t) `elem` fails
                  in  ((patch+1, 0), True, Submit (toPatch $ show patch) pass fail)
            | q:_ <- active ->
                  let pass = and [ (read $ fromPatch p, maybe (-1) (read . fromTest) $ qTest q) `notElem` fails
                                 | p <- unstate (fst $ qCandidate q) ++ snd (qCandidate q)]
                  in ((patch, tick+1), True, Reply q pass tests)
            | otherwise -> ((patch, tick), patch /= nPatches, Request client)
      putStrLn $ "Success at performance"
      where
          timed act = do
              (t, _) <- duration act
              putStrLn $ "Performance test took " ++ showDuration t
  