--------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
module Patat.Main
    ( main
    ) where


--------------------------------------------------------------------------------
import           Control.Concurrent              (forkIO, killThread,
                                                  threadDelay)
import           Control.Concurrent.Chan         (Chan)
import qualified Control.Concurrent.Chan         as Chan
import           Control.Exception               (bracket)
import           Control.Monad                   (forever, unless, when)
import qualified Data.Aeson.Extended             as A
import           Data.Functor                    (($>))
import           Data.Time                       (UTCTime)
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.Images                    as Images
import           Patat.Presentation
import qualified Patat.PrettyPrint               as PP
import qualified Paths_patat
import           Prelude
import qualified System.Console.ANSI             as Ansi
import           System.Directory                (doesFileExist,
                                                  getModificationTime)
import           System.Exit                     (exitFailure, exitSuccess)
import qualified System.IO                       as IO
import qualified Text.Pandoc                     as Pandoc


--------------------------------------------------------------------------------
data Options = Options
    { Options -> Maybe FilePath
oFilePath :: !(Maybe FilePath)
    , Options -> Bool
oForce    :: !Bool
    , Options -> Bool
oDump     :: !Bool
    , Options -> Bool
oWatch    :: !Bool
    , Options -> Bool
oVersion  :: !Bool
    } deriving (Int -> Options -> ShowS
[Options] -> ShowS
Options -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> FilePath
$cshow :: Options -> FilePath
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show)


--------------------------------------------------------------------------------
parseOptions :: OA.Parser Options
parseOptions :: Parser Options
parseOptions = Maybe FilePath -> Bool -> Bool -> Bool -> Bool -> Options
Options
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
OA.optional forall a b. (a -> b) -> a -> b
$ forall s. IsString s => Mod ArgumentFields s -> Parser s
OA.strArgument forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
OA.metavar FilePath
"FILENAME" forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. FilePath -> Mod f a
OA.help    FilePath
"Input file")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Mod FlagFields Bool -> Parser Bool
OA.switch forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
OA.long    FilePath
"force" forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. HasName f => Char -> Mod f a
OA.short   Char
'f' forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. FilePath -> Mod f a
OA.help    FilePath
"Force ANSI terminal" forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. Mod f a
OA.hidden)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Mod FlagFields Bool -> Parser Bool
OA.switch forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
OA.long    FilePath
"dump" forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. HasName f => Char -> Mod f a
OA.short   Char
'd' forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. FilePath -> Mod f a
OA.help    FilePath
"Just dump all slides and exit" forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. Mod f a
OA.hidden)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Mod FlagFields Bool -> Parser Bool
OA.switch forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
OA.long    FilePath
"watch" forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. HasName f => Char -> Mod f a
OA.short   Char
'w' forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. FilePath -> Mod f a
OA.help    FilePath
"Watch file for changes")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Mod FlagFields Bool -> Parser Bool
OA.switch forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
OA.long    FilePath
"version" forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. FilePath -> Mod f a
OA.help    FilePath
"Display version info and exit" forall a. Semigroup a => a -> a -> a
<>
            forall (f :: * -> *) a. Mod f a
OA.hidden)


--------------------------------------------------------------------------------
parserInfo :: OA.ParserInfo Options
parserInfo :: ParserInfo Options
parserInfo = forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info (forall a. Parser (a -> a)
OA.helper forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Options
parseOptions) forall a b. (a -> b) -> a -> b
$
    forall a. InfoMod a
OA.fullDesc forall a. Semigroup a => a -> a -> a
<>
    forall a. FilePath -> InfoMod a
OA.header (FilePath
"patat v" forall a. Semigroup a => a -> a -> a
<> Version -> FilePath
showVersion Version
Paths_patat.version) forall a. Semigroup a => a -> a -> a
<>
    forall a. Maybe Doc -> InfoMod a
OA.progDescDoc (forall a. a -> Maybe a
Just forall {ann}. Doc ann
desc)
  where
    desc :: Doc ann
desc = forall ann. [Doc ann] -> Doc ann
OA.PP.vcat
        [ Doc ann
"Terminal-based presentations using Pandoc"
        , Doc ann
""
        , Doc ann
"Controls:"
        , Doc ann
"- Next slide:             space, enter, l, right, pagedown"
        , Doc ann
"- Previous slide:         backspace, h, left, pageup"
        , Doc ann
"- Go forward 10 slides:   j, down"
        , Doc ann
"- Go backward 10 slides:  k, up"
        , Doc ann
"- First slide:            0"
        , Doc ann
"- Last slide:             G"
        , Doc ann
"- Jump to slide N:        N followed by enter"
        , Doc ann
"- Reload file:            r"
        , Doc ann
"- Quit:                   q"
        ]


--------------------------------------------------------------------------------
parserPrefs :: OA.ParserPrefs
parserPrefs :: ParserPrefs
parserPrefs = PrefsMod -> ParserPrefs
OA.prefs PrefsMod
OA.showHelpOnError


--------------------------------------------------------------------------------
errorAndExit :: [String] -> IO a
errorAndExit :: forall a. [FilePath] -> IO a
errorAndExit [FilePath]
msg = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> FilePath -> Cleanup
IO.hPutStrLn Handle
IO.stderr) [FilePath]
msg
    forall a. IO a
exitFailure


--------------------------------------------------------------------------------
assertAnsiFeatures :: IO ()
assertAnsiFeatures :: Cleanup
assertAnsiFeatures = do
    Bool
supports <- Handle -> IO Bool
Ansi.hSupportsANSI Handle
IO.stdout
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
supports forall a b. (a -> b) -> a -> b
$ forall a. [FilePath] -> IO a
errorAndExit
        [ FilePath
"It looks like your terminal does not support ANSI codes."
        , FilePath
"If you still want to run the presentation, use `--force`."
        ]


--------------------------------------------------------------------------------
main :: IO ()
main :: Cleanup
main = do
    Options
options <- forall a. ParserPrefs -> ParserInfo a -> IO a
OA.customExecParser ParserPrefs
parserPrefs ParserInfo Options
parserInfo

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Bool
oVersion Options
options) forall a b. (a -> b) -> a -> b
$ do
        FilePath -> Cleanup
putStrLn forall a b. (a -> b) -> a -> b
$ Version -> FilePath
showVersion Version
Paths_patat.version
        FilePath -> Cleanup
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Using pandoc: " forall a. [a] -> [a] -> [a]
++ Version -> FilePath
showVersion Version
Pandoc.pandocVersion
        forall a. IO a
exitSuccess

    FilePath
filePath <- case Options -> Maybe FilePath
oFilePath Options
options of
        Just FilePath
fp -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fp
        Maybe FilePath
Nothing -> forall a. ParserResult a -> IO a
OA.handleParseResult forall a b. (a -> b) -> a -> b
$ forall a. ParserFailure ParserHelp -> ParserResult a
OA.Failure forall a b. (a -> b) -> a -> b
$
            forall a.
ParserPrefs
-> ParserInfo a
-> ParseError
-> [Context]
-> ParserFailure ParserHelp
OA.parserFailure ParserPrefs
parserPrefs ParserInfo Options
parserInfo
            (Maybe FilePath -> ParseError
OA.ShowHelpText forall a. Maybe a
Nothing) forall a. Monoid a => a
mempty

    Either FilePath Presentation
errOrPres <- FilePath -> IO (Either FilePath Presentation)
readPresentation FilePath
filePath
    Presentation
pres      <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. [FilePath] -> IO a
errorAndExit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) forall (m :: * -> *) a. Monad m => a -> m a
return Either FilePath Presentation
errOrPres

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Options -> Bool
oForce Options
options) Cleanup
assertAnsiFeatures

    -- (Maybe) initialize images backend.
    Maybe Handle
images <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ImageSettings -> IO Handle
Images.new (PresentationSettings -> Maybe ImageSettings
psImages forall a b. (a -> b) -> a -> b
$ Presentation -> PresentationSettings
pSettings Presentation
pres)

    if Options -> Bool
oDump Options
options
        then Presentation -> Cleanup
dumpPresentation Presentation
pres
        else Options -> Maybe Handle -> Presentation -> Cleanup
interactiveLoop Options
options Maybe Handle
images Presentation
pres
  where
    interactiveLoop :: Options -> Maybe Images.Handle -> Presentation -> IO ()
    interactiveLoop :: Options -> Maybe Handle -> Presentation -> Cleanup
interactiveLoop Options
options Maybe Handle
images Presentation
pres0 =
        forall a. (Handle -> IO a) -> (Chan a -> Cleanup) -> Cleanup
interactively Handle -> IO PresentationCommand
readPresentationCommand forall a b. (a -> b) -> a -> b
$ \Chan PresentationCommand
commandChan0 -> do

        -- If an auto delay is set, use 'autoAdvance' to create a new one.
        Chan PresentationCommand
commandChan <- case PresentationSettings -> Maybe (FlexibleNum Int)
psAutoAdvanceDelay (Presentation -> PresentationSettings
pSettings Presentation
pres0) of
            Maybe (FlexibleNum Int)
Nothing                    -> forall (m :: * -> *) a. Monad m => a -> m a
return Chan PresentationCommand
commandChan0
            Just (A.FlexibleNum Int
delay) -> Int -> Chan PresentationCommand -> IO (Chan PresentationCommand)
autoAdvance Int
delay Chan PresentationCommand
commandChan0

        -- Spawn a thread that adds 'Reload' commands based on the file time.
        UTCTime
mtime0 <- FilePath -> IO UTCTime
getModificationTime (Presentation -> FilePath
pFilePath Presentation
pres0)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Bool
oWatch Options
options) forall a b. (a -> b) -> a -> b
$ do
            ThreadId
_ <- Cleanup -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. Chan PresentationCommand -> FilePath -> UTCTime -> IO a
watcher Chan PresentationCommand
commandChan (Presentation -> FilePath
pFilePath Presentation
pres0) UTCTime
mtime0
            forall (m :: * -> *) a. Monad m => a -> m a
return ()

        let loop :: Presentation -> Maybe String -> IO ()
            loop :: Presentation -> Maybe FilePath -> Cleanup
loop Presentation
pres Maybe FilePath
mbError = do
                Size
size <- Presentation -> IO Size
getDisplaySize Presentation
pres
                let display :: Display
display = case Maybe FilePath
mbError of
                        Maybe FilePath
Nothing  -> Size -> Presentation -> Display
displayPresentation Size
size Presentation
pres
                        Just FilePath
err -> Doc -> Display
DisplayDoc forall a b. (a -> b) -> a -> b
$
                            Size -> Presentation -> FilePath -> Doc
displayPresentationError Size
size Presentation
pres FilePath
err

                Cleanup
Ansi.clearScreen
                Int -> Int -> Cleanup
Ansi.setCursorPosition Int
0 Int
0
                Cleanup
cleanup <- case Display
display of
                    DisplayDoc Doc
doc -> Doc -> Cleanup
PP.putDoc Doc
doc forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Monoid a => a
mempty
                    DisplayImage FilePath
path -> case Maybe Handle
images of
                        Maybe Handle
Nothing -> do
                            Doc -> Cleanup
PP.putDoc forall a b. (a -> b) -> a -> b
$ Size -> Presentation -> FilePath -> Doc
displayPresentationError
                                 Size
size Presentation
pres FilePath
"image backend not initialized"
                            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
                        Just Handle
img -> do
                            FilePath -> Cleanup
putStrLn FilePath
""
                            Handle -> Cleanup
IO.hFlush Handle
IO.stdout
                            Handle -> FilePath -> IO Cleanup
Images.drawImage Handle
img FilePath
path

                PresentationCommand
c      <- forall a. Chan a -> IO a
Chan.readChan Chan PresentationCommand
commandChan
                UpdatedPresentation
update <- PresentationCommand -> Presentation -> IO UpdatedPresentation
updatePresentation PresentationCommand
c Presentation
pres
                Cleanup
cleanup
                case UpdatedPresentation
update of
                    UpdatedPresentation
ExitedPresentation        -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    UpdatedPresentation Presentation
pres' -> Presentation -> Maybe FilePath -> Cleanup
loop Presentation
pres' forall a. Maybe a
Nothing
                    ErroredPresentation FilePath
err   -> Presentation -> Maybe FilePath -> Cleanup
loop Presentation
pres (forall a. a -> Maybe a
Just FilePath
err)

        Presentation -> Maybe FilePath -> Cleanup
loop Presentation
pres0 forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
-- | 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 :: forall a. (Handle -> IO a) -> (Chan a -> Cleanup) -> Cleanup
interactively Handle -> IO a
reader Chan a -> Cleanup
app = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Bool, BufferMode, ThreadId, Chan a)
setup forall {d}. (Bool, BufferMode, ThreadId, d) -> Cleanup
teardown forall a b. (a -> b) -> a -> b
$ \(Bool
_, BufferMode
_, ThreadId
_, Chan a
chan) -> Chan a -> Cleanup
app Chan a
chan
  where
    setup :: IO (Bool, BufferMode, ThreadId, Chan a)
setup = do
        Chan a
chan <- forall a. IO (Chan a)
Chan.newChan
        Bool
echo <- Handle -> IO Bool
IO.hGetEcho      Handle
IO.stdin
        BufferMode
buff <- Handle -> IO BufferMode
IO.hGetBuffering Handle
IO.stdin
        Handle -> Bool -> Cleanup
IO.hSetEcho      Handle
IO.stdin Bool
False
        Handle -> BufferMode -> Cleanup
IO.hSetBuffering Handle
IO.stdin BufferMode
IO.NoBuffering
        Cleanup
Ansi.hideCursor
        ThreadId
readerThreadId <- Cleanup -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
            Handle -> IO a
reader Handle
IO.stdin forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Chan a -> a -> Cleanup
Chan.writeChan Chan a
chan
        forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
echo, BufferMode
buff, ThreadId
readerThreadId, Chan a
chan)

    teardown :: (Bool, BufferMode, ThreadId, d) -> Cleanup
teardown (Bool
echo, BufferMode
buff, ThreadId
readerThreadId, d
_chan) = do
        Cleanup
Ansi.showCursor
        Cleanup
Ansi.clearScreen
        Int -> Int -> Cleanup
Ansi.setCursorPosition Int
0 Int
0
        ThreadId -> Cleanup
killThread ThreadId
readerThreadId
        Handle -> Bool -> Cleanup
IO.hSetEcho      Handle
IO.stdin Bool
echo
        Handle -> BufferMode -> Cleanup
IO.hSetBuffering Handle
IO.stdin BufferMode
buff


--------------------------------------------------------------------------------
watcher :: Chan.Chan PresentationCommand -> FilePath -> UTCTime -> IO a
watcher :: forall a. Chan PresentationCommand -> FilePath -> UTCTime -> IO a
watcher Chan PresentationCommand
chan FilePath
filePath UTCTime
mtime0 = do
    -- The extra exists check helps because some editors temporarily make the
    -- file disappear while writing.
    Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
filePath
    UTCTime
mtime1 <- if Bool
exists then FilePath -> IO UTCTime
getModificationTime FilePath
filePath else forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
mtime0

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
mtime1 forall a. Ord a => a -> a -> Bool
> UTCTime
mtime0) forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> a -> Cleanup
Chan.writeChan Chan PresentationCommand
chan PresentationCommand
Reload
    Int -> Cleanup
threadDelay (Int
200 forall a. Num a => a -> a -> a
* Int
1000)
    forall a. Chan PresentationCommand -> FilePath -> UTCTime -> IO a
watcher Chan PresentationCommand
chan FilePath
filePath UTCTime
mtime1