--------------------------------------------------------------------------------
{-# 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
    { 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
(Int -> Options -> ShowS)
-> (Options -> FilePath) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Options -> ShowS
showsPrec :: Int -> Options -> ShowS
$cshow :: Options -> FilePath
show :: Options -> FilePath
$cshowList :: [Options] -> ShowS
showList :: [Options] -> ShowS
Show)


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


--------------------------------------------------------------------------------
parserInfo :: OA.ParserInfo Options
parserInfo :: ParserInfo Options
parserInfo = Parser Options -> InfoMod Options -> ParserInfo Options
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info (Parser (Options -> Options)
forall a. Parser (a -> a)
OA.helper Parser (Options -> Options) -> Parser Options -> Parser Options
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Options
parseOptions) (InfoMod Options -> ParserInfo Options)
-> InfoMod Options -> ParserInfo Options
forall a b. (a -> b) -> a -> b
$
    InfoMod Options
forall a. InfoMod a
OA.fullDesc InfoMod Options -> InfoMod Options -> InfoMod Options
forall a. Semigroup a => a -> a -> a
<>
    FilePath -> InfoMod Options
forall a. FilePath -> InfoMod a
OA.header (FilePath
"patat v" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> FilePath
showVersion Version
Paths_patat.version) InfoMod Options -> InfoMod Options -> InfoMod Options
forall a. Semigroup a => a -> a -> a
<>
    Maybe Doc -> InfoMod Options
forall a. Maybe Doc -> InfoMod a
OA.progDescDoc (Doc -> Maybe Doc
forall a. a -> Maybe a
Just Doc
forall {ann}. Doc ann
desc)
  where
    desc :: Doc ann
desc = [Doc ann] -> Doc ann
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
    (FilePath -> Cleanup) -> [FilePath] -> Cleanup
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
    IO a
forall a. IO a
exitFailure


--------------------------------------------------------------------------------
assertAnsiFeatures :: IO ()
assertAnsiFeatures :: Cleanup
assertAnsiFeatures = do
    supports <- Handle -> IO Bool
Ansi.hSupportsANSI Handle
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
    { App -> Options
aOptions      :: Options
    , App -> Maybe Handle
aImages       :: Maybe Images.Handle
    , App -> Maybe Handle
aSpeakerNotes :: Maybe SpeakerNotes.Handle
    , App -> Chan AppCommand
aCommandChan  :: Chan AppCommand
    , App -> Presentation
aPresentation :: Presentation
    , App -> AppView
aView         :: AppView
    }


--------------------------------------------------------------------------------
data AppView
    = PresentationView
    | ErrorView String
    | TransitionView TransitionInstance


--------------------------------------------------------------------------------
data AppCommand = PresentationCommand PresentationCommand | TransitionTick TransitionId


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

    when (oVersion options) $ do
        putStrLn $ showVersion Paths_patat.version
        putStrLn $ "Using pandoc: " ++ showVersion Pandoc.pandocVersion
        exitSuccess

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

    errOrPres <- readPresentation zeroUniqueGen filePath
    pres      <- either (errorAndExit . return) return errOrPres
    let settings = Presentation -> PresentationSettings
pSettings Presentation
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) $ \Maybe Handle
images ->

        -- (Maybe) initialize speaker notes.
        (SpeakerNotesSettings -> (Handle -> Cleanup) -> Cleanup)
-> Maybe SpeakerNotesSettings
-> (Maybe Handle -> Cleanup)
-> Cleanup
forall settings handle a.
(settings -> (handle -> IO a) -> IO a)
-> Maybe settings -> (Maybe handle -> IO a) -> IO a
withMaybeHandle SpeakerNotesSettings -> (Handle -> Cleanup) -> Cleanup
forall a. SpeakerNotesSettings -> (Handle -> IO a) -> IO a
SpeakerNotes.withHandle
            (PresentationSettings -> Maybe SpeakerNotesSettings
psSpeakerNotes PresentationSettings
settings) ((Maybe Handle -> Cleanup) -> Cleanup)
-> (Maybe Handle -> Cleanup) -> Cleanup
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
speakerNotes ->

        -- Read presentation commands
        (Handle -> IO PresentationCommand)
-> (Chan PresentationCommand -> Cleanup) -> Cleanup
forall a. (Handle -> IO a) -> (Chan a -> Cleanup) -> Cleanup
interactively (Handle -> IO PresentationCommand
readPresentationCommand) ((Chan PresentationCommand -> Cleanup) -> Cleanup)
-> (Chan PresentationCommand -> Cleanup) -> Cleanup
forall a b. (a -> b) -> a -> b
$ \Chan PresentationCommand
commandChan0 ->

        -- If an auto delay is set, use 'autoAdvance' to create a new one.
        Maybe Int
-> Chan PresentationCommand
-> (Chan PresentationCommand -> Cleanup)
-> Cleanup
forall a.
Maybe Int
-> Chan PresentationCommand
-> (Chan PresentationCommand -> IO a)
-> IO a
maybeAutoAdvance
            (FlexibleNum Int -> Int
forall a. FlexibleNum a -> a
A.unFlexibleNum (FlexibleNum Int -> Int) -> Maybe (FlexibleNum Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PresentationSettings -> Maybe (FlexibleNum Int)
psAutoAdvanceDelay PresentationSettings
settings)
            Chan PresentationCommand
commandChan0 ((Chan PresentationCommand -> Cleanup) -> Cleanup)
-> (Chan PresentationCommand -> Cleanup) -> Cleanup
forall a b. (a -> b) -> a -> b
$ \Chan PresentationCommand
commandChan1 ->

        -- Change to AppCommand
        (PresentationCommand -> AppCommand)
-> Chan PresentationCommand
-> (Chan AppCommand -> Cleanup)
-> Cleanup
forall a b r. (a -> b) -> Chan a -> (Chan b -> IO r) -> IO r
Chan.withMapChan PresentationCommand -> AppCommand
PresentationCommand Chan PresentationCommand
commandChan1 ((Chan AppCommand -> Cleanup) -> Cleanup)
-> (Chan AppCommand -> Cleanup) -> Cleanup
forall a b. (a -> b) -> a -> b
$ \Chan AppCommand
commandChan ->

        -- Spawn a thread that adds 'Reload' commands based on the file time.
        Bool
-> Chan AppCommand -> FilePath -> AppCommand -> Cleanup -> Cleanup
forall cmd a. Bool -> Chan cmd -> FilePath -> cmd -> IO a -> IO a
withWatcher (Options -> Bool
oWatch Options
options) Chan AppCommand
commandChan (Presentation -> FilePath
pFilePath Presentation
pres)
            (PresentationCommand -> AppCommand
PresentationCommand PresentationCommand
Reload) (Cleanup -> Cleanup) -> Cleanup -> Cleanup
forall a b. (a -> b) -> a -> b
$

        App -> Cleanup
loop App
            { aOptions :: Options
aOptions      = Options
options
            , aImages :: Maybe Handle
aImages       = Maybe Handle
images
            , aSpeakerNotes :: Maybe Handle
aSpeakerNotes = Maybe Handle
speakerNotes
            , aCommandChan :: Chan AppCommand
aCommandChan  = Chan AppCommand
commandChan
            , aPresentation :: Presentation
aPresentation = Presentation
pres
            , aView :: AppView
aView         = AppView
PresentationView
            }


--------------------------------------------------------------------------------
loop :: App -> IO ()
loop :: App -> Cleanup
loop app :: App
app@App {Maybe Handle
Maybe Handle
Chan AppCommand
Presentation
AppView
Options
aOptions :: App -> Options
aImages :: App -> Maybe Handle
aSpeakerNotes :: App -> Maybe Handle
aCommandChan :: App -> Chan AppCommand
aPresentation :: App -> Presentation
aView :: App -> AppView
aOptions :: Options
aImages :: Maybe Handle
aSpeakerNotes :: Maybe Handle
aCommandChan :: Chan AppCommand
aPresentation :: Presentation
aView :: AppView
..} = do
    Maybe Handle -> (Handle -> Cleanup) -> Cleanup
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Handle
aSpeakerNotes ((Handle -> Cleanup) -> Cleanup) -> (Handle -> Cleanup) -> Cleanup
forall a b. (a -> b) -> a -> b
$ \Handle
sn -> Handle -> EncodingFallback -> SpeakerNotes -> Cleanup
SpeakerNotes.write Handle
sn
        (Presentation -> EncodingFallback
pEncodingFallback Presentation
aPresentation)
        (Presentation -> SpeakerNotes
activeSpeakerNotes Presentation
aPresentation)

    -- Start necessary eval blocks
    presentation <- (Var -> [Block] -> Cleanup) -> Presentation -> IO Presentation
Eval.evalActiveVars
        (\Var
v -> Chan AppCommand -> AppCommand -> Cleanup
forall a. Chan a -> a -> Cleanup
Chan.writeChan Chan AppCommand
aCommandChan (AppCommand -> Cleanup)
-> ([Block] -> AppCommand) -> [Block] -> Cleanup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PresentationCommand -> AppCommand
PresentationCommand (PresentationCommand -> AppCommand)
-> ([Block] -> PresentationCommand) -> [Block] -> AppCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> [Block] -> PresentationCommand
UpdateVar Var
v)
        Presentation
aPresentation

    size <- getPresentationSize presentation
    Ansi.clearScreen
    Ansi.setCursorPosition 0 0
    cleanup <- case aView of
        AppView
PresentationView -> case Size -> Presentation -> Display
displayPresentation Size
size Presentation
presentation of
            DisplayDoc Doc
doc    -> Doc -> IO Cleanup
forall {a}. Monoid a => Doc -> IO a
drawDoc Doc
doc
            DisplayImage FilePath
path -> Size -> FilePath -> IO Cleanup
drawImg Size
size FilePath
path
        ErrorView FilePath
err -> Doc -> IO Cleanup
forall {a}. Monoid a => Doc -> IO a
drawDoc (Doc -> IO Cleanup) -> Doc -> IO Cleanup
forall a b. (a -> b) -> a -> b
$
                Size -> Presentation -> FilePath -> Doc
displayPresentationError Size
size Presentation
presentation FilePath
err
        TransitionView TransitionInstance
tr -> do
            Size -> Matrix -> Cleanup
drawMatrix (TransitionInstance -> Size
tiSize TransitionInstance
tr) (Matrix -> Cleanup)
-> (NonEmpty (Matrix, Duration) -> Matrix)
-> NonEmpty (Matrix, Duration)
-> Cleanup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Matrix, Duration) -> Matrix
forall a b. (a, b) -> a
fst ((Matrix, Duration) -> Matrix)
-> (NonEmpty (Matrix, Duration) -> (Matrix, Duration))
-> NonEmpty (Matrix, Duration)
-> Matrix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Matrix, Duration) -> (Matrix, Duration)
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (Matrix, Duration) -> Cleanup)
-> NonEmpty (Matrix, Duration) -> Cleanup
forall a b. (a -> b) -> a -> b
$ TransitionInstance -> NonEmpty (Matrix, Duration)
tiFrames TransitionInstance
tr
            Cleanup -> IO Cleanup
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cleanup
forall a. Monoid a => a
mempty

    appCmd <- Chan.readChan aCommandChan
    cleanup
    case appCmd of
        TransitionTick TransitionId
eid -> case AppView
aView of
            AppView
PresentationView -> App -> Cleanup
loop App
app
            ErrorView FilePath
_      -> App -> Cleanup
loop App
app
            TransitionView TransitionInstance
tr0  -> case TransitionId -> TransitionInstance -> Maybe TransitionInstance
stepTransition TransitionId
eid TransitionInstance
tr0 of
                Just TransitionInstance
tr1 -> do
                    TransitionInstance -> Cleanup
scheduleTransitionTick TransitionInstance
tr1
                    App -> Cleanup
loop App
app {aView = TransitionView tr1}
                Maybe TransitionInstance
Nothing -> App -> Cleanup
loop App
app {aView = PresentationView}
        PresentationCommand PresentationCommand
c -> do
            update <- PresentationCommand -> Presentation -> IO UpdatedPresentation
updatePresentation PresentationCommand
c Presentation
presentation
            case update of
                UpdatedPresentation
ExitedPresentation       -> () -> Cleanup
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                UpdatedPresentation Presentation
pres
                    | Just IO TransitionInstance
tgen <- PresentationCommand
-> Size
-> Presentation
-> Presentation
-> Maybe (IO TransitionInstance)
mbTransition PresentationCommand
c Size
size Presentation
presentation Presentation
pres -> do
                        tr <- IO TransitionInstance
tgen
                        scheduleTransitionTick tr
                        loop app
                            {aPresentation = pres, aView = TransitionView tr}
                    | Bool
otherwise -> App -> Cleanup
loop App
app
                        {aPresentation = pres, aView = PresentationView}
                ErroredPresentation FilePath
err  ->
                    App -> Cleanup
loop App
app {aView = ErrorView err}
  where
    drawDoc :: Doc -> IO a
drawDoc Doc
doc = Handle -> EncodingFallback -> IO a -> IO a
forall a. Handle -> EncodingFallback -> IO a -> IO a
EncodingFallback.withHandle
        Handle
IO.stdout (Presentation -> EncodingFallback
pEncodingFallback Presentation
aPresentation) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
        Doc -> Cleanup
PP.putDoc Doc
doc Cleanup -> a -> IO a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
forall a. Monoid a => a
mempty
    drawImg :: Size -> FilePath -> IO Cleanup
drawImg Size
size FilePath
path = case Maybe Handle
aImages of
        Maybe Handle
Nothing -> Doc -> IO Cleanup
forall {a}. Monoid a => Doc -> IO a
drawDoc (Doc -> IO Cleanup) -> Doc -> IO Cleanup
forall a b. (a -> b) -> a -> b
$ Size -> Presentation -> FilePath -> Doc
displayPresentationError
            Size
size Presentation
aPresentation FilePath
"image backend not initialized"
        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
    drawMatrix :: Size -> Matrix -> Cleanup
drawMatrix Size
size Matrix
raster = Handle -> Size -> Matrix -> Cleanup
hPutMatrix Handle
IO.stdout Size
size Matrix
raster

    mbTransition :: PresentationCommand
-> Size
-> Presentation
-> Presentation
-> Maybe (IO TransitionInstance)
mbTransition PresentationCommand
c Size
size Presentation
old Presentation
new
        | PresentationCommand
c PresentationCommand -> PresentationCommand -> Bool
forall a. Eq a => a -> a -> Bool
== PresentationCommand
Forward
        , Int
oldSlide Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
newSlide
        , DisplayDoc Doc
oldDoc <- Size -> Presentation -> Display
displayPresentation Size
size Presentation
old
        , DisplayDoc Doc
newDoc <- Size -> Presentation -> Display
displayPresentation Size
size Presentation
new
        , Just (Just TransitionGen
tgen) <- Presentation -> Seq (Maybe TransitionGen)
pTransitionGens Presentation
new Seq (Maybe TransitionGen) -> Int -> Maybe (Maybe TransitionGen)
forall a. Seq a -> Int -> Maybe a
`Seq.safeIndex` Int
newSlide =
            IO TransitionInstance -> Maybe (IO TransitionInstance)
forall a. a -> Maybe a
Just (IO TransitionInstance -> Maybe (IO TransitionInstance))
-> IO TransitionInstance -> Maybe (IO TransitionInstance)
forall a b. (a -> b) -> a -> b
$ TransitionGen -> Size -> Doc -> Doc -> IO TransitionInstance
newTransition TransitionGen
tgen Size
size Doc
oldDoc Doc
newDoc
        | Bool
otherwise = Maybe (IO TransitionInstance)
forall a. Maybe a
Nothing
      where
        (Int
oldSlide, Int
_) = Presentation -> (Int, Int)
pActiveFragment Presentation
old
        (Int
newSlide, Int
_) = Presentation -> (Int, Int)
pActiveFragment Presentation
new

    scheduleTransitionTick :: TransitionInstance -> Cleanup
scheduleTransitionTick TransitionInstance
tr = IO ThreadId -> Cleanup
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> Cleanup) -> IO ThreadId -> Cleanup
forall a b. (a -> b) -> a -> b
$ Cleanup -> IO ThreadId
forkIO (Cleanup -> IO ThreadId) -> Cleanup -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        Duration -> Cleanup
threadDelayDuration (Duration -> Cleanup)
-> (NonEmpty (Matrix, Duration) -> Duration)
-> NonEmpty (Matrix, Duration)
-> Cleanup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Matrix, Duration) -> Duration
forall a b. (a, b) -> b
snd ((Matrix, Duration) -> Duration)
-> (NonEmpty (Matrix, Duration) -> (Matrix, Duration))
-> NonEmpty (Matrix, Duration)
-> Duration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Matrix, Duration) -> (Matrix, Duration)
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (Matrix, Duration) -> Cleanup)
-> NonEmpty (Matrix, Duration) -> Cleanup
forall a b. (a -> b) -> a -> b
$ TransitionInstance -> NonEmpty (Matrix, Duration)
tiFrames TransitionInstance
tr
        Chan AppCommand -> AppCommand -> Cleanup
forall a. Chan a -> a -> Cleanup
Chan.writeChan Chan AppCommand
aCommandChan (AppCommand -> Cleanup) -> AppCommand -> Cleanup
forall a b. (a -> b) -> a -> b
$ TransitionId -> AppCommand
TransitionTick (TransitionId -> AppCommand) -> TransitionId -> AppCommand
forall a b. (a -> b) -> a -> b
$ TransitionInstance -> TransitionId
tiId TransitionInstance
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 :: forall a. (Handle -> IO a) -> (Chan a -> Cleanup) -> Cleanup
interactively Handle -> IO a
reader Chan a -> Cleanup
app = IO (Bool, BufferMode, Chan a)
-> ((Bool, BufferMode, Chan a) -> Cleanup)
-> ((Bool, BufferMode, Chan a) -> Cleanup)
-> Cleanup
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Bool, BufferMode, Chan a)
forall {a}. IO (Bool, BufferMode, Chan a)
setup (Bool, BufferMode, Chan a) -> Cleanup
forall {c}. (Bool, BufferMode, c) -> Cleanup
teardown (((Bool, BufferMode, Chan a) -> Cleanup) -> Cleanup)
-> ((Bool, BufferMode, Chan a) -> Cleanup) -> Cleanup
forall a b. (a -> b) -> a -> b
$ \(Bool
_, BufferMode
_, Chan a
chan) ->
    IO (ZonkAny 1) -> (Async (ZonkAny 1) -> Cleanup) -> Cleanup
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync
        (Cleanup -> IO (ZonkAny 1)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Cleanup -> IO (ZonkAny 1)) -> Cleanup -> IO (ZonkAny 1)
forall a b. (a -> b) -> a -> b
$ Handle -> IO a
reader Handle
IO.stdin IO a -> (a -> Cleanup) -> Cleanup
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Chan a -> a -> Cleanup
forall a. Chan a -> a -> Cleanup
Chan.writeChan Chan a
chan)
        (\Async (ZonkAny 1)
_ -> Chan a -> Cleanup
app Chan a
chan)
  where
    setup :: IO (Bool, BufferMode, Chan a)
setup = do
        chan <- IO (Chan a)
forall a. IO (Chan a)
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 :: (Bool, BufferMode, c) -> Cleanup
teardown (Bool
echo, BufferMode
buff, c
_chan) = do
        Cleanup
Ansi.showCursor
        Cleanup
Ansi.clearScreen
        Int -> Int -> Cleanup
Ansi.setCursorPosition Int
0 Int
0
        Handle -> Bool -> Cleanup
IO.hSetEcho      Handle
IO.stdin Bool
echo
        Handle -> BufferMode -> Cleanup
IO.hSetBuffering Handle
IO.stdin BufferMode
buff


--------------------------------------------------------------------------------
withWatcher
    :: Bool -> Chan.Chan cmd -> FilePath -> cmd -> IO a -> IO a
withWatcher :: forall cmd a. Bool -> Chan cmd -> FilePath -> cmd -> IO a -> IO a
withWatcher Bool
False Chan cmd
_    FilePath
_        cmd
_   IO a
mx = IO a
mx
withWatcher Bool
True  Chan cmd
chan FilePath
filePath cmd
cmd IO a
mx = do
    mtime0 <- FilePath -> IO UTCTime
getModificationTime FilePath
filePath
    Async.withAsync (watcher mtime0) (\Async (ZonkAny 0)
_ -> IO a
mx)
  where
    watcher :: UTCTime -> IO b
watcher UTCTime
mtime0 = do
        -- The extra exists check helps because some editors temporarily make
        -- the file disappear while writing.
        exists <- FilePath -> IO Bool
doesFileExist FilePath
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 :: forall settings handle a.
(settings -> (handle -> IO a) -> IO a)
-> Maybe settings -> (Maybe handle -> IO a) -> IO a
withMaybeHandle settings -> (handle -> IO a) -> IO a
_    Maybe settings
Nothing         Maybe handle -> IO a
f = Maybe handle -> IO a
f Maybe handle
forall a. Maybe a
Nothing
withMaybeHandle settings -> (handle -> IO a) -> IO a
impl (Just settings
settings) Maybe handle -> IO a
f = settings -> (handle -> IO a) -> IO a
impl settings
settings (Maybe handle -> IO a
f (Maybe handle -> IO a)
-> (handle -> Maybe handle) -> handle -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. handle -> Maybe handle
forall a. a -> Maybe a
Just)