--------------------------------------------------------------------------------
{-# 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.Images as Images
import Patat.Presentation
import qualified Patat.Presentation.Comments as Comments
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.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 Comments.SpeakerNotesHandle
, 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 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) $
dumpPresentation pres
else
-- (Maybe) initialize images backend.
withMaybeHandle Images.withHandle (psImages settings) $ \images ->
-- (Maybe) initialize speaker notes.
withMaybeHandle Comments.withSpeakerNotesHandle
(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 -> Comments.writeSpeakerNotes sn
(pEncodingFallback aPresentation)
(activeSpeakerNotes aPresentation)
size <- getPresentationSize aPresentation
Ansi.clearScreen
Ansi.setCursorPosition 0 0
cleanup <- case aView of
PresentationView -> case displayPresentation size aPresentation of
DisplayDoc doc -> drawDoc doc
DisplayImage path -> drawImg size path
ErrorView err -> drawDoc $
displayPresentationError size aPresentation 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 aPresentation
case update of
ExitedPresentation -> return ()
UpdatedPresentation pres
| Just tgen <- mbTransition c size aPresentation 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
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)