module Main (main) where

import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar)
import Control.Monad (fail, forever, guard, void, when)
import Control.Monad.STM (atomically)
import Control.Monad.Trans (liftIO)
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Version (showVersion)
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText
import GHC.Generics (Generic)
import System.Exit (exitSuccess)
import System.IO (BufferMode (..))
import qualified System.Process.ListLike as Process
import qualified System.Process.Text as Text

import System.FSNotify (eventTime, withManager)
import qualified System.FSNotify as FSNotify

import Options.Generic
       (ParseRecord (..), type (<?>) (..), getWithHelp, lispCaseModifiers,
        parseRecordWithModifiers, shortNameModifier)

import Brick
import Brick.BChan
import Graphics.Vty

import qualified Paths_trackit as Trackit
import ParseANSI

type LText = LText.Text

data CmdOptions = CmdOptions
  { _watchDir      :: Maybe FilePath <?> "Directory to watch for changes in (not sub-directories). Cannot be used together with '--watch-tree'."
  , _watchTree     :: Maybe FilePath <?> "Directory tree to watch for changes in (including sub-directories). Cannot be used together with '--watch-dir'."
  , _command       :: Maybe String   <?> "Command to run"
  , _maxLines      :: Maybe Int      <?> "Maximum number of lines to show (default: 400)"
  , _followTail    :: Bool           <?> "Follow the tail of the generated output."
  , _showRunning   :: Bool           <?> "Display a message while the command is running."
  , _incremental   :: Bool           <?> "Allow output to be updated incrementally. Redraws the buffer for every output line, so should only be used for \
                                         \slow outputs. Implies '--show-running'."
  , _stabilization :: Maybe Int      <?> "Minimal time (milliseconds) between any file event and the next command update (default: 200)"
  , _version       :: Bool           <?> "Print the version number"
  , _help          :: Bool
  , _debug         :: Bool           <?> "Show debug information in the lower right corner"
  } deriving (Show, Generic)

-- `--show-running` is not on by default because it causes a quick flickering
-- for fast commands.

shortName :: String -> Maybe Char
shortName "_watchDir" = Just 'd'
shortName "_watchTree" = Just 't'
shortName "_showRunning" = Just 'r'
shortName "_debug" = Just 'g'
shortName (_:c:_) = Just c
shortName _ = Nothing

instance ParseRecord CmdOptions where
  parseRecord =
    parseRecordWithModifiers
      lispCaseModifiers {shortNameModifier = shortName}

data WatchDepth
  = Single
  | Recursive
  deriving (Eq, Show)

data Options = Options
  { watchDir      :: Maybe (FilePath, WatchDepth)
  , command       :: Maybe String
  , maxLines      :: Int
  , followTail    :: Bool
  , showRunning   :: Bool
  , incremental   :: Bool
  , stabilization :: NominalDiffTime
  , debug         :: Bool
  } deriving (Show, Generic)

watchDirError =
  "The flags '--watch-dir' and '--watch-tree' cannot be used together."

getOptions :: IO Options
getOptions = do
  (CmdOptions {..}, showHelp) <- getWithHelp "trackit"
  if | _help -> showHelp >> exitSuccess
     | unHelpful _version ->
       do putStrLn $ showVersion Trackit.version
          exitSuccess
     | otherwise ->
       do watchDir <- case (unHelpful _watchDir, unHelpful _watchTree) of
            (Nothing, Nothing) -> return Nothing
            (Just d, Nothing) -> return $ Just (d, Single)
            (Nothing, Just t) -> return $ Just (t, Recursive)
            _ -> fail watchDirError
          let command       = unHelpful _command
              maxLines      = fromMaybe 400 $ unHelpful _maxLines
              followTail    = unHelpful _followTail
              showRunning   = unHelpful _showRunning
              incremental   = unHelpful _incremental
              stabPerMs     = fromMaybe 200 $ unHelpful _stabilization
              stabilization = fromIntegral stabPerMs / 1000
              debug         = unHelpful _debug
          return $ Options {..}

ansiImage :: Text -> Image
ansiImage = foldMap mkLine . map parseANSI . Text.lines
  where
    mkLine ss =
      foldr (<|>) mempty [text' a s | Segment a s <- ss]

-- | Make a 'Context'-aware 'Widget' with 'Fixed' size
withContext :: (Context -> Widget n) -> Widget n
withContext k = Widget Fixed Fixed $ do
  cxt <- getContext
  render (k cxt)

-- | Create a bold line looking like this:
--
-- > ---------------- <info> ----------------
infoLine :: Text -> Text
infoLine info = Text.concat
  [ "\ESC[1m"
  , line1
  , " "
  , info
  , " "
  , line2
  , "\ESC[m"
  ]
  where
    l = 38 - Text.length info
    line1 = Text.replicate (l     `div` 2) "-"
    line2 = Text.replicate ((l+1) `div` 2) "-"


-- | Limit the text to @n@ lines (because large buffers make the app slow)
limit :: Int -> [Text] -> [Text]
limit n ls = ls' ++ case rest of
  [] -> [eof]
  _ -> [pruningNotification]
  where
    (ls', rest) = splitAt n ls
    eof = infoLine "End of output"
    pruningNotification =
      infoLine $ Text.unwords ["Lines beyond", Text.pack (show n), "pruned"]

helpText :: [Text]
helpText =
  [ "No command provided. Run 'trackit --help' for help.\n\n"
  , "Press 'q' to exit this window."
  ]

concatChunks :: [Process.Chunk LText] -> LText
concatChunks cs = LText.concat [c | Process.Stdout c <- cs]
  -- I initially thought that there would be one chunk per line given the
  -- `LineBuffering` setting, but this doesn't seem to be the case. Hence
  -- `Text.lines` is needed on the result.
  --
  -- There is an instance of `readCreateProcessLazy` that can return
  -- `(ExitCode, LText, LText)` directly without any chunks. However, that
  -- instance doesn't seem to have the desired laziness.

-- | Run the command provided by the user, or print a helpful text if no command
-- was given
runCMD :: Options -> IO [Text]
runCMD Options {..} = case command of
  Nothing -> return helpText
  Just cmd -> do
    (_, o, _) <- Text.readCreateProcessWithExitCode (Process.shell cmd) ""
    return $ limit maxLines $ Text.lines o

-- | Run the command provided by the user, or print a helpful text if no command
-- was given
--
-- The output is returned as a lazy list of lines.
runLazyCMD :: Options -> IO [Text]
runLazyCMD Options {..} = case command of
  Nothing -> return helpText
  Just cmd ->
    limit maxLines . map LText.toStrict . LText.lines . concatChunks <$>
    Process.readCreateProcessLazy
      (Process.shell cmd, LineBuffering, LineBuffering)
      ""

-- | Case-insensitive key-press recognizer
keyPressed :: Char -> BrickEvent n e -> Bool
keyPressed c (VtyEvent (EvKey (KChar c') [])) = toLower c == toLower c'
keyPressed _ _ = False

data AppState = AppState
  { commandOutput :: [Text] -- ^ Lines in reverse
  , commandRunning :: Bool
  , updateCount :: Integer
  } deriving (Eq, Show)

-- | Explicit request to run the command and update output
data UpdateRequest = UpdateRequest
  deriving (Eq, Show)

data TrackitEvent
  = Running             -- ^ An incremental command started running
  | Done                -- ^ An incremental command is done
  | AddLine Text        -- ^ An incremental command produced a line
  | UpdateBuffer [Text] -- ^ A non-incremental command finished with the given output
  deriving (Eq, Show)

initState :: AppState
initState = AppState
  { commandOutput = []
  , commandRunning = False
  , updateCount = 0
  }

data View = TheView
  deriving (Eq, Ord, Show)

theView :: ViewportScroll View
theView = viewportScroll TheView

drawApp :: Options -> AppState -> [Widget View]
drawApp Options {..} AppState {..} = concat
  [ guard debug >> pure debugWidget
  , pure $
    viewport TheView Both $
    raw $ ansiImage $ Text.unlines $ reverse (runningInfo ++ commandOutput)
  ]
  where
    attr = defAttr `withForeColor` black `withBackColor` white

    runningInfo = if commandRunning then [infoLine "Command is running"] else []

    debugText = "Update count: " <> Text.pack (show updateCount)
    debugWidget =
      withContext $ \cxt ->
        translateBy
          (Location
             (availWidth cxt - Text.length debugText, availHeight cxt - 1)) $
        raw $ text' attr debugText

withSize :: ((Int, Int) -> EventM View ()) -> EventM View ()
withSize k = mapM_ k . fmap extentSize =<< lookupExtent TheView

stepApp ::
     Options
  -> TVar (Maybe UpdateRequest)
  -> AppState
  -> BrickEvent View TrackitEvent
  -> EventM View (Next AppState)
stepApp _ _ s (keyPressed 'q' -> True)        = halt s
stepApp _ _ s (VtyEvent (EvKey KDown []))     = theView `vScrollBy` 1 >> continue s
stepApp _ _ s (VtyEvent (EvKey KUp []))       = theView `vScrollBy` (-1) >> continue s
stepApp _ _ s (VtyEvent (EvKey KLeft []))     = withSize (\(w, _) -> theView `hScrollBy` (negate $ div w 2)) >> continue s
stepApp _ _ s (VtyEvent (EvKey KRight []))    = withSize (\(w, _) -> theView `hScrollBy` (div w 2)) >> continue s
stepApp _ _ s (VtyEvent (EvKey KHome _))      = vScrollToBeginning theView >> continue s
stepApp _ _ s (VtyEvent (EvKey KEnd _))       = vScrollToEnd theView >> continue s
stepApp _ _ s (VtyEvent (EvKey KPageUp []))   = withSize (\(_, h) -> theView `vScrollBy` (negate h)) >> continue s
stepApp _ _ s (VtyEvent (EvKey KPageDown [])) = withSize (\(_, h) -> theView `vScrollBy` h) >> continue s
stepApp _ updReq s (VtyEvent (EvKey (KChar ' ') _)) = do
  liftIO $ atomically $ writeTVar updReq (Just UpdateRequest)
  continue s
stepApp _ _ s (AppEvent Running) =
  continue s
    { commandOutput = []
    , commandRunning = True
    }
stepApp opts _ s (AppEvent Done) = do
  when (followTail opts) $ vScrollToEnd theView
  continue s
    { commandRunning = False
    , updateCount = updateCount s + 1
    }
stepApp opts _ s (AppEvent (AddLine line)) = do
  when (followTail opts) $ vScrollToEnd theView
  continue s
    { commandOutput = line : commandOutput s
    }
stepApp opts _ s (AppEvent (UpdateBuffer buf)) = do
  when (followTail opts) $ vScrollToEnd theView
  continue s
    { commandOutput = buf
    , commandRunning = False
    , updateCount = updateCount s + 1
    }
stepApp _ _ s _ = continue s

myApp :: Options -> TVar (Maybe UpdateRequest) -> App AppState TrackitEvent View
myApp opts updReq =
  App
  { appDraw = drawApp opts
  , appHandleEvent = stepApp opts updReq
  , appStartEvent = return
  , appAttrMap = const $ attrMap defAttr []
  , appChooseCursor = neverShowCursor
  }

appMain ::
     Options -> TVar (Maybe UpdateRequest) -> BChan TrackitEvent -> IO AppState
appMain opts updReq updEv =
  customMain (mkVty defaultConfig) (Just updEv) (myApp opts updReq) initState

-- | A loop that continuously looks for events in the two variables and runs the
-- given action in response. The variables are emptied whenever the action runs.
--
-- Events in the second variable immediately trigger the action. For events in
-- the second variable, the action only happens if the event occurred more than
-- 'stabilization' seconds ago. If the event occurred less time ago, it will
-- remain in the variable and processed in a later iteration (unless emptied by
-- another event in the meantime).
worker ::
     Options
  -> TVar (Maybe FSNotify.Event)
       -- ^ Variable holding the last file event that has not yet been processed
  -> TVar (Maybe UpdateRequest)
       -- ^ Variable holding a potential update request
  -> IO () -- ^ Action to perform when the file event has stabilized
  -> IO ()
worker Options {..} lastFSEv updReq action =
  forever $ do
    threadDelay loopPeriod
    t <- getCurrentTime
    act <-
      atomically $ do
        mupd <- readTVar updReq
        case mupd of
          Just UpdateRequest -> resetEvents >> return True
          Nothing -> do
            mfsEv <- readTVar lastFSEv
            case mfsEv of
              Nothing -> return False
              Just fsEv -> do
                let stable = diffUTCTime t (eventTime fsEv) >= stabilization
                when stable resetEvents
                return stable
    when act action
  where
    resetEvents = do
      writeTVar lastFSEv Nothing
      writeTVar updReq Nothing
    loopPeriod = max 10000 $ round (stabilization * 1e6 / 5)
      -- Cap at 10 ms to avoid making the loop too busy when the stabilization
      -- period is small.

-- | Run the command and feed the output lines to the GUI
updater :: Options -> BChan TrackitEvent -> IO ()
updater opts@Options {..} updEv
  | incremental = do
      writeBChan updEv Running
      ls <- runLazyCMD opts
      mapM_ (writeBChan updEv . AddLine) ls
      writeBChan updEv Done
  | otherwise = do
      when showRunning $ writeBChan updEv Running
      ls <- runCMD opts
      writeBChan updEv $ UpdateBuffer $ reverse ls

main = do
  opts@Options {..} <- getOptions
  -- Channel holding the last file event
  lastFSEv <- newTVarIO Nothing
  -- Channel holding user update requests (set to request an initial update)
  updReq   <- newTVarIO (Just UpdateRequest)
  -- Channel for GUI update events
  updEv    <- newBChan 1
  let setFsEvent ev = atomically $ writeTVar lastFSEv $ Just ev
  tid <- forkIO $ worker opts lastFSEv updReq (updater opts updEv)
  void $ case watchDir of
    Nothing -> appMain opts updReq updEv
    Just (path, depth) ->
      withManager $ \m -> do
        void $ case depth of
          Single -> FSNotify.watchDir m path (const True) setFsEvent
          Recursive -> FSNotify.watchTree m path (const True) setFsEvent
        appMain opts updReq updEv
  killThread tid

-- Note: The "debouncing" option of fsnotify makes it so that only the *first*
-- in a tight series of events is reported. However, this is problematic since
-- it means that the GUI may miss file events. This can happen if a Git command
-- performs multiple file system operations (which is usually the case) and the
-- command take more time than updating the GUI (e.g. due to the repository
-- being large). It can of course also happen if a Git command is issued just
-- after another one.
--
-- In contrast, the approach taken here is to react to the *last* in a tight
-- sequence of events. A tight sequence is defined as a sequence in which each
-- consecutive pair of events has a time distance of less than `stabilization`
-- seconds. And since `worker` runs continuously, there's never a risk that an
-- event will be missed.