{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Patat.Presentation.Interactive
( PresentationCommand (..)
, readPresentationCommand
, UpdatedPresentation (..)
, updatePresentation
) where
import Data.Char (isDigit)
import Patat.Presentation.Internal
import Patat.Presentation.Read
import qualified System.IO as IO
import Text.Read (readMaybe)
data PresentationCommand
= Exit
| Forward
| Backward
| SkipForward
| SkipBackward
| First
| Last
| Reload
| Seek Int
| UnknownCommand String
deriving (Eq, Show)
readPresentationCommand :: IO.Handle -> IO PresentationCommand
readPresentationCommand h = do
k <- readKeys
case k of
"q" -> return Exit
"\n" -> return Forward
"\DEL" -> return Backward
"h" -> return Backward
"j" -> return SkipForward
"k" -> return SkipBackward
"l" -> return Forward
"\ESC[C" -> return Forward
"\ESC[D" -> return Backward
"\ESC[B" -> return SkipForward
"\ESC[A" -> return SkipBackward
"\ESC[6" -> return Forward
"\ESC[5" -> return Backward
"0" -> return First
"G" -> return Last
"r" -> return Reload
_ | Just n <- readMaybe k -> return (Seek n)
_ -> return (UnknownCommand k)
where
readKeys :: IO String
readKeys = do
c0 <- IO.hGetChar h
case c0 of
'\ESC' -> do
c1 <- IO.hGetChar h
case c1 of
'[' -> do
c2 <- IO.hGetChar h
return [c0, c1, c2]
_ -> return [c0, c1]
_ | isDigit c0 && c0 /= '0' -> (c0 :) <$> readDigits
_ -> return [c0]
readDigits :: IO String
readDigits = do
c <- IO.hGetChar h
if isDigit c then (c :) <$> readDigits else return [c]
data UpdatedPresentation
= UpdatedPresentation !Presentation
| ExitedPresentation
| ErroredPresentation String
deriving (Show)
updatePresentation
:: PresentationCommand -> Presentation -> IO UpdatedPresentation
updatePresentation cmd presentation = case cmd of
Exit -> return ExitedPresentation
Forward -> return $ goToSlide $ \(s, f) -> (s, f + 1)
Backward -> return $ goToSlide $ \(s, f) -> (s, f - 1)
SkipForward -> return $ goToSlide $ \(s, _) -> (s + 10, 0)
SkipBackward -> return $ goToSlide $ \(s, _) -> (s - 10, 0)
First -> return $ goToSlide $ \_ -> (0, 0)
Last -> return $ goToSlide $ \_ -> (numSlides presentation, 0)
Seek n -> return $ goToSlide $ \_ -> (n - 1, 0)
Reload -> reloadPresentation
UnknownCommand _ -> return (UpdatedPresentation presentation)
where
numSlides :: Presentation -> Int
numSlides pres = length (pSlides pres)
clip :: Index -> Presentation -> Index
clip (slide, fragment) pres
| slide >= numSlides pres = (numSlides pres - 1, lastFragments - 1)
| slide < 0 = (0, 0)
| fragment >= numFragments' slide =
if slide + 1 >= numSlides pres
then (slide, lastFragments - 1)
else (slide + 1, 0)
| fragment < 0 =
if slide - 1 >= 0
then (slide - 1, numFragments' (slide - 1) - 1)
else (slide, 0)
| otherwise = (slide, fragment)
where
numFragments' s = maybe 1 numFragments (getSlide s pres)
lastFragments = numFragments' (numSlides pres - 1)
goToSlide :: (Index -> Index) -> UpdatedPresentation
goToSlide f = UpdatedPresentation $ presentation
{ pActiveFragment = clip (f $ pActiveFragment presentation) presentation
}
reloadPresentation = do
errOrPres <- readPresentation (pFilePath presentation)
return $ case errOrPres of
Left err -> ErroredPresentation err
Right pres -> UpdatedPresentation $ pres
{ pActiveFragment = clip (pActiveFragment presentation) pres
}