content: --------------------------------------------------------------------------------
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE OverloadedStrings          #-}
  {-# LANGUAGE RecordWildCards            #-}
  module Patat.Main
      ( main
      ) where
  
  
  --------------------------------------------------------------------------------
  import           Control.Concurrent               (forkIO, threadDelay)
  import qualified Control.Concurrent.Async         as Async
  import           Control.Concurrent.Chan.Extended (Chan)
  import qualified Control.Concurrent.Chan.Extended as Chan
  import           Control.Exception                (bracket)
  import           Control.Monad                    (forever, unless, void, when)
  import qualified Data.Aeson.Extended              as A
  import           Data.Foldable                    (for_)
  import           Data.Functor                     (($>))
  import qualified Data.List.NonEmpty               as NonEmpty
  import qualified Data.Sequence.Extended           as Seq
  import           Data.Version                     (showVersion)
  import qualified Options.Applicative              as OA
  import qualified Options.Applicative.Help.Pretty  as OA.PP
  import           Patat.AutoAdvance
  import qualified Patat.EncodingFallback           as EncodingFallback
  import qualified Patat.Eval                       as Eval
  import qualified Patat.Images                     as Images
  import           Patat.Presentation
  import qualified Patat.Presentation.SpeakerNotes  as SpeakerNotes
  import qualified Patat.PrettyPrint                as PP
  import           Patat.PrettyPrint.Matrix         (hPutMatrix)
  import           Patat.Transition
  import qualified Paths_patat
  import           Prelude
  import qualified System.Console.ANSI              as Ansi
  import           System.Directory                 (doesFileExist,
                                                     getModificationTime)
  import           System.Environment               (lookupEnv)
  import           System.Exit                      (exitFailure, exitSuccess)
  import qualified System.IO                        as IO
  import qualified Text.Pandoc                      as Pandoc
  
  
  --------------------------------------------------------------------------------
  data Options = Options
      { oFilePath :: !(Maybe FilePath)
      , oForce    :: !Bool
      , oDump     :: !Bool
      , oWatch    :: !Bool
      , oVersion  :: !Bool
      } deriving (Show)
  
  
  --------------------------------------------------------------------------------
  parseOptions :: OA.Parser Options
  parseOptions = Options
      <$> (OA.optional $ OA.strArgument $
              OA.metavar "FILENAME" <>
              OA.action  "file" <>  -- For bash file completion
              OA.help    "Input file")
      <*> (OA.switch $
              OA.long    "force" <>
              OA.short   'f' <>
              OA.help    "Force ANSI terminal" <>
              OA.hidden)
      <*> (OA.switch $
              OA.long    "dump" <>
              OA.short   'd' <>
              OA.help    "Just dump all slides and exit" <>
              OA.hidden)
      <*> (OA.switch $
              OA.long    "watch" <>
              OA.short   'w' <>
              OA.help    "Watch file for changes")
      <*> (OA.switch $
              OA.long    "version" <>
              OA.help    "Display version info and exit" <>
              OA.hidden)
  
  
  --------------------------------------------------------------------------------
  parserInfo :: OA.ParserInfo Options
  parserInfo = OA.info (OA.helper <*> parseOptions) $
      OA.fullDesc <>
      OA.header ("patat v" <> showVersion Paths_patat.version) <>
      OA.progDescDoc (Just desc)
    where
      desc = OA.PP.vcat
          [ "Terminal-based presentations using Pandoc"
          , ""
          , "Controls:"
          , "- Next slide:             space, enter, l, right, pagedown"
          , "- Previous slide:         backspace, h, left, pageup"
          , "- Go forward 10 slides:   j, down"
          , "- Go backward 10 slides:  k, up"
          , "- First slide:            0"
          , "- Last slide:             G"
          , "- Jump to slide N:        N followed by enter"
          , "- Reload file:            r"
          , "- Quit:                   q"
          ]
  
  
  --------------------------------------------------------------------------------
  parserPrefs :: OA.ParserPrefs
  parserPrefs = OA.prefs OA.showHelpOnError
  
  
  --------------------------------------------------------------------------------
  errorAndExit :: [String] -> IO a
  errorAndExit msg = do
      mapM_ (IO.hPutStrLn IO.stderr) msg
      exitFailure
  
  
  --------------------------------------------------------------------------------
  assertAnsiFeatures :: IO ()
  assertAnsiFeatures = do
      supports <- Ansi.hSupportsANSI IO.stdout
      unless supports $ errorAndExit
          [ "It looks like your terminal does not support ANSI codes."
          , "If you still want to run the presentation, use `--force`."
          ]
  
  
  --------------------------------------------------------------------------------
  data App = App
      { aOptions      :: Options
      , aImages       :: Maybe Images.Handle
      , aSpeakerNotes :: Maybe SpeakerNotes.Handle
      , aCommandChan  :: Chan AppCommand
      , aPresentation :: Presentation
      , aView         :: AppView
      }
  
  
  --------------------------------------------------------------------------------
  data AppView
      = PresentationView
      | ErrorView String
      | TransitionView TransitionInstance
  
  
  --------------------------------------------------------------------------------
  data AppCommand = PresentationCommand PresentationCommand | TransitionTick TransitionId
  
  
  --------------------------------------------------------------------------------
  main :: IO ()
  main = do
      options <- OA.customExecParser parserPrefs parserInfo
  
      when (oVersion options) $ do
          putStrLn $ showVersion Paths_patat.version
          putStrLn $ "Using pandoc: " ++ showVersion Pandoc.pandocVersion
          exitSuccess
  
      filePath <- case oFilePath options of
          Just fp -> return fp
          Nothing -> OA.handleParseResult $ OA.Failure $
              OA.parserFailure parserPrefs parserInfo
              (OA.ShowHelpText Nothing) mempty
  
      errOrPres <- readPresentation zeroUniqueGen filePath
      pres      <- either (errorAndExit . return) return errOrPres
      let settings = pSettings pres
  
      unless (oForce options) assertAnsiFeatures
  
      if oDump options then
          EncodingFallback.withHandle IO.stdout (pEncodingFallback pres) $ do
          Eval.evalAllVars pres >>= dumpPresentation
      else
          -- (Maybe) initialize images backend.
          withMaybeHandle Images.withHandle (psImages settings) $ \images ->
  
          -- (Maybe) initialize speaker notes.
          withMaybeHandle SpeakerNotes.withHandle
              (psSpeakerNotes settings) $ \speakerNotes ->
  
          -- Read presentation commands
          interactively (readPresentationCommand) $ \commandChan0 ->
  
          -- If an auto delay is set, use 'autoAdvance' to create a new one.
          maybeAutoAdvance
              (A.unFlexibleNum <$> psAutoAdvanceDelay settings)
              commandChan0 $ \commandChan1 ->
  
          -- Change to AppCommand
          Chan.withMapChan PresentationCommand commandChan1 $ \commandChan ->
  
          -- Spawn a thread that adds 'Reload' commands based on the file time.
          withWatcher (oWatch options) commandChan (pFilePath pres)
              (PresentationCommand Reload) $
  
          loop App
              { aOptions      = options
              , aImages       = images
              , aSpeakerNotes = speakerNotes
              , aCommandChan  = commandChan
              , aPresentation = pres
              , aView         = PresentationView
              }
  
  
  --------------------------------------------------------------------------------
  loop :: App -> IO ()
  loop app@App {..} = do
      for_ aSpeakerNotes $ \sn -> SpeakerNotes.write sn
          (pEncodingFallback aPresentation)
          (activeSpeakerNotes aPresentation)
  
      -- Start necessary eval blocks
      presentation <- Eval.evalActiveVars
          (\v -> Chan.writeChan aCommandChan . PresentationCommand . UpdateVar v)
          aPresentation
  
      size <- getPresentationSize presentation
      Ansi.clearScreen
      Ansi.setCursorPosition 0 0
      cleanup <- case aView of
          PresentationView -> case displayPresentation size presentation of
              DisplayDoc doc    -> drawDoc doc
              DisplayImage path -> drawImg size path
          ErrorView err -> drawDoc $
                  displayPresentationError size presentation err
          TransitionView tr -> do
              drawMatrix (tiSize tr) . fst . NonEmpty.head $ tiFrames tr
              pure mempty
  
      appCmd <- Chan.readChan aCommandChan
      cleanup
      case appCmd of
          TransitionTick eid -> case aView of
              PresentationView -> loop app
              ErrorView _      -> loop app
              TransitionView tr0  -> case stepTransition eid tr0 of
                  Just tr1 -> do
                      scheduleTransitionTick tr1
                      loop app {aView = TransitionView tr1}
                  Nothing -> loop app {aView = PresentationView}
          PresentationCommand c -> do
              update <- updatePresentation c presentation
              case update of
                  ExitedPresentation       -> return ()
                  UpdatedPresentation pres
                      | Just tgen <- mbTransition c size presentation pres -> do
                          tr <- tgen
                          scheduleTransitionTick tr
                          loop app
                              {aPresentation = pres, aView = TransitionView tr}
                      | otherwise -> loop app
                          {aPresentation = pres, aView = PresentationView}
                  ErroredPresentation err  ->
                      loop app {aView = ErrorView err}
    where
      drawDoc doc = EncodingFallback.withHandle
          IO.stdout (pEncodingFallback aPresentation) $
          PP.putDoc doc $> mempty
      drawImg size path = case aImages of
          Nothing -> drawDoc $ displayPresentationError
              size aPresentation "image backend not initialized"
          Just img -> do
              putStrLn ""
              IO.hFlush IO.stdout
              Images.drawImage img path
      drawMatrix size raster = hPutMatrix IO.stdout size raster
  
      mbTransition c size old new
          | c == Forward
          , oldSlide + 1 == newSlide
          , DisplayDoc oldDoc <- displayPresentation size old
          , DisplayDoc newDoc <- displayPresentation size new
          , Just (Just tgen) <- pTransitionGens new `Seq.safeIndex` newSlide =
              Just $ newTransition tgen size oldDoc newDoc
          | otherwise = Nothing
        where
          (oldSlide, _) = pActiveFragment old
          (newSlide, _) = pActiveFragment new
  
      scheduleTransitionTick tr = void $ forkIO $ do
          threadDelayDuration . snd . NonEmpty.head $ tiFrames tr
          Chan.writeChan aCommandChan $ TransitionTick $ tiId tr
  
  
  --------------------------------------------------------------------------------
  -- | Utility for dealing with pecularities of stdin & interactive applications
  -- on the terminal.  Tries to restore the original state of the terminal as much
  -- as possible.
  interactively
      :: (IO.Handle -> IO a)
      -- ^ Reads a command from stdin (or from some other IO).  This will be
      -- interrupted by 'killThread' when the application finishes.
      -> (Chan a -> IO ())
      -- ^ Application to run.
      -> IO ()
      -- ^ Returns when application finishes.
  interactively reader app = bracket setup teardown $ \(_, _, chan) ->
      Async.withAsync
          (forever $ reader IO.stdin >>= Chan.writeChan chan)
          (\_ -> app chan)
    where
      setup = do
          chan <- Chan.newChan
          echo <- IO.hGetEcho      IO.stdin
          buff <- IO.hGetBuffering IO.stdin
          IO.hSetEcho      IO.stdin False
          IO.hSetBuffering IO.stdin IO.NoBuffering
  
          -- Suppress cursor hiding for WezTerm image compatibility
          termProgram <- lookupEnv "TERM_PROGRAM"
          unless (termProgram == Just "WezTerm") $ Ansi.hideCursor
  
          return (echo, buff, chan)
  
      teardown (echo, buff, _chan) = do
          Ansi.showCursor
          Ansi.clearScreen
          Ansi.setCursorPosition 0 0
          IO.hSetEcho      IO.stdin echo
          IO.hSetBuffering IO.stdin buff
  
  
  --------------------------------------------------------------------------------
  withWatcher
      :: Bool -> Chan.Chan cmd -> FilePath -> cmd -> IO a -> IO a
  withWatcher False _    _        _   mx = mx
  withWatcher True  chan filePath cmd mx = do
      mtime0 <- getModificationTime filePath
      Async.withAsync (watcher mtime0) (\_ -> mx)
    where
      watcher mtime0 = do
          -- The extra exists check helps because some editors temporarily make
          -- the file disappear while writing.
          exists <- doesFileExist filePath
          mtime1 <- if exists then getModificationTime filePath else return mtime0
  
          when (mtime1 > mtime0) $ Chan.writeChan chan cmd
          threadDelay (200 * 1000)
          watcher mtime1
  
  
  --------------------------------------------------------------------------------
  -- | Wrapper for optional handles.
  withMaybeHandle
      :: (settings -> (handle -> IO a) -> IO a)
      -> Maybe settings
      -> (Maybe handle -> IO a)
      -> IO a
  withMaybeHandle _    Nothing         f = f Nothing
  withMaybeHandle impl (Just settings) f = impl settings (f . Just)
  