content: {-# LANGUAGE ImplicitParams    #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TemplateHaskell   #-}
  
  -- |
  -- Module      : AOC.Interactive
  -- Copyright   : (c) Justin Le 2018
  -- License     : BSD3
  --
  -- Maintainer  : justin@jle.im
  -- Stability   : experimental
  -- Portability : non-portable
  --
  -- Run actions regarding challenges, solutions, tests, submissions, viewing
  -- prompts, etc.
  --
  -- Essentially implements the functionality of the main app.
  --
  
  module AOC.Run (
    -- * Options
      TestSpec(..)
    -- * Runners
    -- ** Run solutions, tests, benchmarks
    , MainRunOpts(..), HasMainRunOpts(..), mainRun, defaultMRO
    -- ** View prompts
    , MainViewOpts(..), HasMainViewOpts(..), mainView, defaultMVO
    -- ** Submit answers
    , MainSubmitOpts(..), HasMainSubmitOpts(..), mainSubmit, defaultMSO
    -- * Util
    , withColor
    ) where
  
  import           AOC.Challenge
  import           AOC.Run.Config
  import           AOC.Run.Load
  import           AOC.Solver
  import           AOC.Util
  import           Advent
  import           Control.Applicative
  import           Control.Concurrent
  import           Control.DeepSeq
  import           Control.Exception
  import           Control.Lens
  import           Control.Monad
  import           Control.Monad.Except
  import           Criterion
  import           Data.Bifunctor
  import           Data.Char
  import           Data.Map                 (Map)
  import           Data.Maybe
  import           Data.Text                (Text)
  import           Data.Time hiding         (Day)
  import           Text.Printf
  import qualified Data.Map                 as M
  import qualified Data.Set                 as S
  import qualified Data.Text                as T
  import qualified Data.Text.IO             as T
  import qualified System.Console.ANSI      as ANSI
  import qualified System.Console.Haskeline as H
  
  -- | Specification of parts to test and run
  data TestSpec = TSAll
                | TSDayAll  { _tsDay  :: Day           }
                | TSDayPart { _tsSpec :: ChallengeSpec }
    deriving Show
  
  -- | Options for 'mainRun'.
  data MainRunOpts = MRO { _mroSpec   :: !TestSpec
                         , _mroActual :: !Bool     -- ^ Run input?  (Defualt: True
                         , _mroTest   :: !Bool     -- ^ Run tests?  (Default: False)
                         , _mroBench  :: !Bool     -- ^ Benchmark?  (Default: False)
                         , _mroLock   :: !Bool     -- ^ Lock in answer as correct?  (Default: False)
                         , _mroInput  :: !(Day -> Part -> IO (Maybe String))   -- ^ Manually supply input (Default: always return Nothing)
                         }
  
  makeClassy ''MainRunOpts
  
  -- | Options for 'mainView'.
  data MainViewOpts = MVO { _mvoSpec :: !TestSpec
                          , _mvoWait :: !Bool
                          }
    deriving Show
  
  makeClassy ''MainViewOpts
  
  -- | Options for 'mainSubmit'
  data MainSubmitOpts = MSO { _msoSpec  :: !ChallengeSpec
                            , _msoTest  :: !Bool    -- ^ Run tests before submitting?  (Default: True)
                            , _msoForce :: !Bool    -- ^ Force submission even if bad?  (Default: False)
                            , _msoLock  :: !Bool    -- ^ Lock answer if submission succeeded?  (Default: True)
                            , _msoRetry :: !Bool    -- ^ If a wait is received after submission, try again automatically (Default: False)
                            }
    deriving Show
  
  makeClassy ''MainSubmitOpts
  
  -- | Default options for 'mainRun'.
  defaultMRO :: TestSpec -> MainRunOpts
  defaultMRO ts = MRO { _mroSpec   = ts
                      , _mroActual = True
                      , _mroTest   = False
                      , _mroBench  = False
                      , _mroLock   = False
                      , _mroInput  = \_ _ -> pure Nothing
                      }
  
  -- | Default options for 'mainView'.
  defaultMVO :: TestSpec -> MainViewOpts
  defaultMVO ts = MVO { _mvoSpec = ts
                      , _mvoWait = False
                      }
  
  -- | Default options for 'mainSubmit'.
  defaultMSO :: ChallengeSpec -> MainSubmitOpts
  defaultMSO cs = MSO { _msoSpec  = cs
                      , _msoTest  = True
                      , _msoForce = False
                      , _msoLock  = True
                      , _msoRetry = False
                      }
  
  filterChallengeMap :: TestSpec -> Either String ChallengeMap
  filterChallengeMap = \case
      TSAll      -> pure challengeMap
      TSDayAll d -> maybeToEither (printf "Day not yet avaiable: %d" (dayInt d)) $
                       M.singleton d <$> M.lookup d challengeMap
      TSDayPart (CS d p) -> do
        ps <- maybeToEither (printf "Day not yet available: %d" (dayInt d)) $
                M.lookup d challengeMap
        c  <- maybeToEither (printf "Part not found: %c" (partChar p)) $
                M.lookup p ps
        pure $ M.singleton d (M.singleton p c)
  
  -- | Run, test, bench.
  mainRun
      :: (MonadIO m, MonadError [String] m)
      => Config
      -> MainRunOpts
      -> m (Map Day (Map Part (Maybe Bool, Either [String] String)))  -- whether or not passed tests, and result
  mainRun Cfg{..} MRO{..} =  do
      toRun <- liftEither . first (:[]) . filterChallengeMap $ _mroSpec
      liftIO . runAll _cfgSession _cfgYear _mroLock _mroInput toRun $ \c inp0 cd@CD{..} -> do
        testRes <- fmap join . forM (guard _mroTest) $ \_ ->
          runTestSuite c cd
  
        let inp1 = strip <$> maybe _cdInput  Right           inp0
            ans1 = strip <$> maybe _cdAnswer (const Nothing) inp0
        case inp1 of
          Right inp
            | _mroBench -> do
                _ <- evaluate (force inp)
                let res    = (testRes, Left ["Ran benchmark, so no result"])
                res <$ case c of
                  MkSomeSolWH _         ->
                        benchmark (nf (runSomeSolution c) inp)
                  MkSomeSolNF MkSol{..}
                    | Just x <- sParse inp -> do
                        _ <- evaluate (force x)
                        benchmark (nf (let ?dyno = mempty in sSolve) x)
                        putStrLn "* parsing and formatting times excluded"
                        putStrLn ""
                    | otherwise            ->
                        putStrLn "(No parse)"
            | _mroActual -> (second . first) ((:[]) . show) <$> testCase False c inp (TM ans1 M.empty)
            | otherwise   -> pure (testRes, Left ["Actual input skipped"])
          Left e
            | _mroTest  -> pure (testRes, Left ["Ran tests, so no result"])
            | otherwise -> (testRes, Left e) <$ putStrLn "[INPUT ERROR]" <* mapM_ putStrLn e
  
  -- | View prompt
  mainView
      :: (MonadIO m, MonadError [String] m)
      => Config
      -> MainViewOpts
      -> m (Map Day (Map Part Text))
  mainView Cfg{..} MVO{..} = do
      let toRun = maybe S.empty (M.keysSet . pullMap)
                . eitherToMaybe
                . filterChallengeMap
                $ _mvoSpec
          allRun = foldMap S.singleton singleTest <> toRun
      fmap pushMap . sequenceA . flip M.fromSet allRun $ \(d,p) -> do
        pmpt   <- waitFunc d $ do
          CD{..} <- liftIO $ challengeData _cfgSession _cfgYear (CS d p)
          liftEither . first ("[PROMPT ERROR]":) $ _cdPrompt
        liftIO $ do
          withColor ANSI.Dull ANSI.Blue $
            printf ">> Day %02d%c\n" (dayInt d) (partChar p)
          T.putStrLn pmpt
          putStrLn ""
        pure pmpt
    where
      waitFunc d
        | _mvoWait  = countdownConsole _cfgYear d . (liftIO (threadDelay 500000) *>)
        | otherwise = id
      singleTest = case _mvoSpec of
        TSAll        -> Nothing
        TSDayAll d   -> Just (d, Part1)
        TSDayPart cs -> Just (_csDay cs, _csPart cs)
  
  -- | Submit and analyze result
  mainSubmit
      :: (MonadIO m, MonadError [String] m)
      => Config
      -> MainSubmitOpts
      -> m (Text, SubmitRes)
  mainSubmit Cfg{..} MSO{..} = do
      cd@CD{..} <- liftIO $ challengeData _cfgSession _cfgYear _msoSpec
      dMap      <- maybeToEither [printf "Day not yet available: %d" d'] $
                     M.lookup _csDay challengeMap
      c         <- maybeToEither [printf "Part not found: %c" (partChar _csPart)] $
                     M.lookup _csPart dMap
      inp       <- liftEither . first ("[PROMPT ERROR]":) $ _cdInput
      opts      <- defaultAoCOpts _cfgYear <$>
                      maybeToEither ["ERROR: Session Key Required to Submit"]
                        _cfgSession
  
      when _msoTest $ do
        testRes <- liftIO $ runTestSuite c cd
        unless (and testRes) $
          if _msoForce
            then liftIO $ putStrLn "Proceeding with submission despite test failures (--force)"
            else do
              conf <- liftIO . H.runInputT H.defaultSettings $
                H.getInputChar "Some tests failed. Are you sure you wish to proceed? y/(n) "
              case toLower <$> conf of
                Just 'y' -> pure ()
                _        -> throwError ["Submission aborted."]
  
      resEither <- liftIO . evaluate . force . runSomeSolution c $ inp
      res       <- liftEither . first (("[SOLUTION ERROR]":) . (:[]) . show) $ resEither
      liftIO $ printf "Submitting solution: %s\n" res
  
      let submitter
            | _msoRetry = submitRetry opts _csDay _csPart res
            | otherwise = liftIO $ runAoC opts (AoCSubmit _csDay _csPart res)
      output@(resp, status) <- liftEither . first showAoCError =<< submitter
      let resp' = formatResp
                . either (map T.pack) T.lines
                . htmlToMarkdown False
                $ resp
          (color, lock, out) = displayStatus status
      liftIO $ do
        withColor ANSI.Vivid color $
          putStrLn out
        putStrLn resp'
        when lock $
          if _msoLock
            then putStrLn "Locking correct answer." >> writeFile _cpAnswer res
            else putStrLn "Not locking correct answer (--no-lock)"
        zt <- getZonedTime
        appendFile _cpLog $ printf logFmt (show zt) res (showSubmitRes status) resp resp'
      pure output
    where
      CS{..} = _msoSpec
      CP{..} = challengePaths _cfgYear _msoSpec
      d' = dayInt _csDay
      formatResp = T.unpack . T.intercalate "\n" . map ("> " <>)
      logFmt = unlines [ "[%s]"
                       , "Submission: %s"
                       , "Status: %s"
                       , "Raw: %s"
                       , "%s"
                       ]
  
  submitRetry
      :: MonadIO m
      => AoCOpts
      -> Day
      -> Part
      -> String
      -> m (Either AoCError (Text, SubmitRes))
  submitRetry opts d p ans = runExceptT go
    where
      go = do
        out@(_, status) <- ExceptT . liftIO $ runAoC opts (AoCSubmit d p ans)
        case status of
          SubWait i -> do
            liftIO . withColor ANSI.Vivid ANSI.Yellow $
                printf "Automatically waiting %d seconds to re-submit...\n" i
            -- 0.1 to account for latency
            resubTime <- addUTCTime (secondsToNominalDiffTime (fromIntegral i - 0.1)) <$> liftIO getCurrentTime
            countdownWithPrint
              ((resubTime `diffUTCTime`) <$> liftIO getCurrentTime)
              100000
              "Re-submit"
              go
          _ -> pure out
  
  displayStatus :: SubmitRes -> (ANSI.Color, Bool, String)
  displayStatus = \case
      SubCorrect r     -> ( ANSI.Green  , True , correctMsg r     )
      SubIncorrect t h -> ( ANSI.Red    , False, incorrectMsg t h )
      SubWait t        -> let (m, s) = t `divMod` 60
                              resp   = printf "Answer re-submitted too soon.  Please wait %dmin %dsec" m s
                          in  ( ANSI.Yellow, False, resp )
      SubInvalid{}     -> ( ANSI.Blue   , False
                          , "Submission was rejected.  Maybe not unlocked yet, or already answered?"
                          )
      SubUnknown{}     -> ( ANSI.Magenta, False
                          , "Response from server was not recognized."
                          )
    where
      correctMsg Nothing  = "Answer was correct!"
      correctMsg (Just r) =
          printf "Answer was correct, and you made the global leaderboard at rank %d !!"
            r
      incorrectMsg t h =
          printf "Answer was incorrect!%s  Please wait %d before submitting again"
            hintStr
            (t `div` 60)
        where
          hintStr :: String
          hintStr = case h of
            Nothing -> ""
            Just s  -> printf "  Hint: Answer was %s." s
  
  runAll
      :: Maybe String                         -- ^ session key
      -> Integer                              -- ^ year
      -> Bool                                 -- ^ run and lock answer
      -> (Day -> Part -> IO (Maybe String))   -- ^ replacements
      -> ChallengeMap
      -> (SomeSolution -> Maybe String -> ChallengeData -> IO a)  -- ^ callback. given solution, "replacement" input, and data
      -> IO (Map Day (Map Part a))
  runAll sess yr lock rep cm f = flip M.traverseWithKey cm $ \d ->
                                 M.traverseWithKey $ \p c -> do
      let CP{..} = challengePaths yr (CS d p)
      inp0 <- rep d p
      withColor ANSI.Dull ANSI.Blue $
        printf ">> Day %02d%c\n" (dayInt d) (partChar p)
      when lock $ do
        CD{..} <- challengeData sess yr (CS d p)
        forM_ (inp0 <|> eitherToMaybe _cdInput) $ \inp ->
          mapM_ (writeFile _cpAnswer) =<< evaluate (force (runSomeSolution c inp))
      f c inp0 =<< challengeData sess yr (CS d p)
  
  runTestSuite :: SomeSolution -> ChallengeData -> IO (Maybe Bool)
  runTestSuite c CD{..} = do
      testRes <- mapMaybe fst <$> mapM (uncurry (testCase True c)) _cdTests
      unless (null testRes) $ do
        let (mark, color)
                | and testRes = ('✓', ANSI.Green)
                | otherwise   = ('✗', ANSI.Red  )
        withColor ANSI.Vivid color $
          printf "[%c] Passed %d out of %d test(s)\n"
              mark
              (length (filter id testRes))
              (length testRes)
      pure $ and testRes <$ guard (not (null testRes))
  
  
  -- | Run a single test case
  testCase
      :: Bool             -- ^ is just an example
      -> SomeSolution
      -> String
      -> TestMeta
      -> IO (Maybe Bool, Either SolutionError String)
  testCase emph c inp TM{..} = do
      withColor ANSI.Dull color $
        printf "[%c]" mark
      if emph
        then printf " (%s)\n" resStr
        else printf " %s\n"   resStr
      forM_ showAns $ \a ->
        withColor ANSI.Vivid ANSI.Red $
          printf "(Expected: %s)\n" a
      return (status, res)
    where
      res = runSomeSolutionWith _tmData c inp
      resStr = case res of
        Right r -> r
        Left SEParse -> "ERROR: No parse"
        Left SESolve -> "ERROR: No solution"
      (mark, showAns, status) = case _tmAnswer of
        Just ex    -> case res of
          Right (strip->r)
            | r == ex   -> ('✓', Nothing, Just True )
            | otherwise -> ('✗', Just ex, Just False)
          Left _        -> ('✗', Just ex, Just False)
        Nothing         -> ('?', Nothing, Nothing   )
      color = case status of
        Just True  -> ANSI.Green
        Just False -> ANSI.Red
        Nothing    -> ANSI.Blue
  
  -- | Do the action with a given ANSI foreground color and intensity.
  withColor
      :: ANSI.ColorIntensity
      -> ANSI.Color
      -> IO ()
      -> IO ()
  withColor ci c act = do
      ANSI.setSGR [ ANSI.SetColor ANSI.Foreground ci c ]
      act
      ANSI.setSGR [ ANSI.Reset ]
  
  pullMap
      :: Map a (Map b c)
      -> Map (a, b) c
  pullMap = M.fromDistinctAscList
          . concatMap (uncurry go . second M.toAscList)
          . M.toAscList
    where
      go x = (map . first) (x,)
  
  pushMap
      :: Eq a
      => Map (a, b) c
      -> Map a (Map b c)
  pushMap = fmap M.fromDistinctAscList
          . M.fromAscListWith (flip (++))
          . map (uncurry go)
          . M.toAscList
    where
      go (x, y) z = (x, [(y, z)])
  