{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Patat.Presentation.Comments
( Comment (..)
, parse
, remove
, split
, partition
, SpeakerNotes
, speakerNotesToText
, SpeakerNotesHandle
, withSpeakerNotesHandle
, writeSpeakerNotes
, parseSlideSettings
) where
import Control.Applicative ((<|>))
import Control.Exception (bracket)
import Control.Monad (unless, when)
import Data.Function (on)
import qualified Data.IORef as IORef
import Data.List (intercalate, intersperse)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Yaml as Yaml
import Patat.EncodingFallback (EncodingFallback)
import qualified Patat.EncodingFallback as EncodingFallback
import Patat.Presentation.Settings
import System.Directory (removeFile)
import qualified System.IO as IO
import qualified Text.Pandoc as Pandoc
data =
{ Comment -> SpeakerNotes
cSpeakerNotes :: SpeakerNotes
, Comment -> Either String PresentationSettings
cConfig :: Either String PresentationSettings
} deriving (Int -> Comment -> ShowS
[Comment] -> ShowS
Comment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Comment] -> ShowS
$cshowList :: [Comment] -> ShowS
show :: Comment -> String
$cshow :: Comment -> String
showsPrec :: Int -> Comment -> ShowS
$cshowsPrec :: Int -> Comment -> ShowS
Show)
instance Semigroup Comment where
Comment
l <> :: Comment -> Comment -> Comment
<> Comment
r = Comment
{ cSpeakerNotes :: SpeakerNotes
cSpeakerNotes = forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Semigroup a => a -> a -> a
(<>) Comment -> SpeakerNotes
cSpeakerNotes Comment
l Comment
r
, cConfig :: Either String PresentationSettings
cConfig = case (Comment -> Either String PresentationSettings
cConfig Comment
l, Comment -> Either String PresentationSettings
cConfig Comment
r) of
(Left String
err, Either String PresentationSettings
_ ) -> forall a b. a -> Either a b
Left String
err
(Right PresentationSettings
_, Left String
err) -> forall a b. a -> Either a b
Left String
err
(Right PresentationSettings
x, Right PresentationSettings
y ) -> forall a b. b -> Either a b
Right (PresentationSettings
x forall a. Semigroup a => a -> a -> a
<> PresentationSettings
y)
}
instance Monoid Comment where
mappend :: Comment -> Comment -> Comment
mappend = forall a. Semigroup a => a -> a -> a
(<>)
mempty :: Comment
mempty = SpeakerNotes -> Either String PresentationSettings -> Comment
Comment forall a. Monoid a => a
mempty (forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty)
parse :: Pandoc.Block -> Maybe Comment
parse :: Block -> Maybe Comment
parse (Pandoc.RawBlock Format
"html" Text
t0) =
(do
Text
t1 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"<!--config:" Text
t0
Text
t2 <- Text -> Text -> Maybe Text
T.stripSuffix Text
"-->" Text
t1
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpeakerNotes -> Either String PresentationSettings -> Comment
Comment forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ case forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' (Text -> ByteString
T.encodeUtf8 Text
t2) of
Left ParseException
err -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show ParseException
err)
Right PresentationSettings
obj -> forall a b. b -> Either a b
Right PresentationSettings
obj) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(do
Text
t1 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"<!--" Text
t0
Text
t2 <- Text -> Text -> Maybe Text
T.stripSuffix Text
"-->" Text
t1
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SpeakerNotes -> Either String PresentationSettings -> Comment
Comment ([Text] -> SpeakerNotes
SpeakerNotes [Text -> Text
T.strip Text
t2]) (forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty))
parse Block
_ = forall a. Maybe a
Nothing
remove :: [Pandoc.Block] -> [Pandoc.Block]
remove :: [Block] -> [Block]
remove = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> (Comment, [Block])
partition
split :: [Pandoc.Block] -> (Comment, [Pandoc.Block])
split :: [Block] -> (Comment, [Block])
split = [Comment] -> [Block] -> (Comment, [Block])
go []
where
go :: [Comment] -> [Block] -> (Comment, [Block])
go [Comment]
sn [] = (forall a. Monoid a => [a] -> a
mconcat (forall a. [a] -> [a]
reverse [Comment]
sn), [])
go [Comment]
sn (Block
x : [Block]
xs) | Just Comment
s <- Block -> Maybe Comment
parse Block
x = [Comment] -> [Block] -> (Comment, [Block])
go (Comment
s forall a. a -> [a] -> [a]
: [Comment]
sn) [Block]
xs
go [Comment]
sn [Block]
xs = (forall a. Monoid a => [a] -> a
mconcat (forall a. [a] -> [a]
reverse [Comment]
sn), [Block]
xs)
partition :: [Pandoc.Block] -> (Comment, [Pandoc.Block])
partition :: [Block] -> (Comment, [Block])
partition = [Comment] -> [Block] -> [Block] -> (Comment, [Block])
go [] []
where
go :: [Comment] -> [Block] -> [Block] -> (Comment, [Block])
go [Comment]
sn [Block]
bs [] = (forall a. Monoid a => [a] -> a
mconcat (forall a. [a] -> [a]
reverse [Comment]
sn), forall a. [a] -> [a]
reverse [Block]
bs)
go [Comment]
sn [Block]
bs (Block
x : [Block]
xs) | Just Comment
s <- Block -> Maybe Comment
parse Block
x = [Comment] -> [Block] -> [Block] -> (Comment, [Block])
go (Comment
s forall a. a -> [a] -> [a]
: [Comment]
sn) [Block]
bs [Block]
xs
go [Comment]
sn [Block]
bs (Block
x : [Block]
xs) = [Comment] -> [Block] -> [Block] -> (Comment, [Block])
go [Comment]
sn (Block
x forall a. a -> [a] -> [a]
: [Block]
bs) [Block]
xs
newtype SpeakerNotes = SpeakerNotes [T.Text]
deriving (SpeakerNotes -> SpeakerNotes -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpeakerNotes -> SpeakerNotes -> Bool
$c/= :: SpeakerNotes -> SpeakerNotes -> Bool
== :: SpeakerNotes -> SpeakerNotes -> Bool
$c== :: SpeakerNotes -> SpeakerNotes -> Bool
Eq, Semigroup SpeakerNotes
SpeakerNotes
[SpeakerNotes] -> SpeakerNotes
SpeakerNotes -> SpeakerNotes -> SpeakerNotes
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [SpeakerNotes] -> SpeakerNotes
$cmconcat :: [SpeakerNotes] -> SpeakerNotes
mappend :: SpeakerNotes -> SpeakerNotes -> SpeakerNotes
$cmappend :: SpeakerNotes -> SpeakerNotes -> SpeakerNotes
mempty :: SpeakerNotes
$cmempty :: SpeakerNotes
Monoid, NonEmpty SpeakerNotes -> SpeakerNotes
SpeakerNotes -> SpeakerNotes -> SpeakerNotes
forall b. Integral b => b -> SpeakerNotes -> SpeakerNotes
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> SpeakerNotes -> SpeakerNotes
$cstimes :: forall b. Integral b => b -> SpeakerNotes -> SpeakerNotes
sconcat :: NonEmpty SpeakerNotes -> SpeakerNotes
$csconcat :: NonEmpty SpeakerNotes -> SpeakerNotes
<> :: SpeakerNotes -> SpeakerNotes -> SpeakerNotes
$c<> :: SpeakerNotes -> SpeakerNotes -> SpeakerNotes
Semigroup, Int -> SpeakerNotes -> ShowS
[SpeakerNotes] -> ShowS
SpeakerNotes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpeakerNotes] -> ShowS
$cshowList :: [SpeakerNotes] -> ShowS
show :: SpeakerNotes -> String
$cshow :: SpeakerNotes -> String
showsPrec :: Int -> SpeakerNotes -> ShowS
$cshowsPrec :: Int -> SpeakerNotes -> ShowS
Show)
speakerNotesToText :: SpeakerNotes -> T.Text
speakerNotesToText :: SpeakerNotes -> Text
speakerNotesToText (SpeakerNotes [Text]
sn) = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse forall a. Monoid a => a
mempty [Text]
sn
data SpeakerNotesHandle = SpeakerNotesHandle
{ SpeakerNotesHandle -> SpeakerNotesSettings
snhSettings :: !SpeakerNotesSettings
, SpeakerNotesHandle -> IORef SpeakerNotes
snhActive :: !(IORef.IORef SpeakerNotes)
}
withSpeakerNotesHandle
:: SpeakerNotesSettings -> (SpeakerNotesHandle -> IO a) -> IO a
withSpeakerNotesHandle :: forall a.
SpeakerNotesSettings -> (SpeakerNotesHandle -> IO a) -> IO a
withSpeakerNotesHandle SpeakerNotesSettings
settings = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
(SpeakerNotesSettings -> IORef SpeakerNotes -> SpeakerNotesHandle
SpeakerNotesHandle SpeakerNotesSettings
settings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
IORef.newIORef forall a. Monoid a => a
mempty)
(\SpeakerNotesHandle
_ -> String -> IO ()
removeFile (SpeakerNotesSettings -> String
snsFile SpeakerNotesSettings
settings))
writeSpeakerNotes
:: SpeakerNotesHandle -> EncodingFallback -> SpeakerNotes -> IO ()
writeSpeakerNotes :: SpeakerNotesHandle -> EncodingFallback -> SpeakerNotes -> IO ()
writeSpeakerNotes SpeakerNotesHandle
h EncodingFallback
encodingFallback SpeakerNotes
sn = do
Bool
change <- forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' (SpeakerNotesHandle -> IORef SpeakerNotes
snhActive SpeakerNotesHandle
h) forall a b. (a -> b) -> a -> b
$ \SpeakerNotes
old -> (SpeakerNotes
sn, SpeakerNotes
old forall a. Eq a => a -> a -> Bool
/= SpeakerNotes
sn)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
change forall a b. (a -> b) -> a -> b
$ forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile (SpeakerNotesSettings -> String
snsFile forall a b. (a -> b) -> a -> b
$ SpeakerNotesHandle -> SpeakerNotesSettings
snhSettings SpeakerNotesHandle
h) IOMode
IO.WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
ioh ->
forall a. Handle -> EncodingFallback -> IO a -> IO a
EncodingFallback.withHandle Handle
ioh EncodingFallback
encodingFallback forall a b. (a -> b) -> a -> b
$
Handle -> Text -> IO ()
T.hPutStr Handle
ioh forall a b. (a -> b) -> a -> b
$ SpeakerNotes -> Text
speakerNotesToText SpeakerNotes
sn
data Setting where
Setting :: String -> (PresentationSettings -> Maybe a) -> Setting
unsupportedSlideSettings :: [Setting]
unsupportedSlideSettings :: [Setting]
unsupportedSlideSettings =
[ forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"incrementalLists" PresentationSettings -> Maybe Bool
psIncrementalLists
, forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"autoAdvanceDelay" PresentationSettings -> Maybe (FlexibleNum Int)
psAutoAdvanceDelay
, forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"slideLevel" PresentationSettings -> Maybe Int
psSlideLevel
, forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"pandocExtensions" PresentationSettings -> Maybe ExtensionList
psPandocExtensions
, forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"images" PresentationSettings -> Maybe ImageSettings
psImages
, forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"eval" PresentationSettings -> Maybe EvalSettingsMap
psEval
, forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"speakerNotes" PresentationSettings -> Maybe SpeakerNotesSettings
psSpeakerNotes
]
parseSlideSettings :: Comment -> Either String PresentationSettings
parseSlideSettings :: Comment -> Either String PresentationSettings
parseSlideSettings Comment
c = do
PresentationSettings
settings <- Comment -> Either String PresentationSettings
cConfig Comment
c
let unsupported :: [String]
unsupported = do
Setting
setting <- [Setting]
unsupportedSlideSettings
case Setting
setting of
Setting String
name PresentationSettings -> Maybe a
f | Just a
_ <- PresentationSettings -> Maybe a
f PresentationSettings
settings -> [String
name]
Setting String
_ PresentationSettings -> Maybe a
_ -> []
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
unsupported) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
String
"the following settings are not supported in slide config blocks: " forall a. [a] -> [a] -> [a]
++
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
unsupported
forall (f :: * -> *) a. Applicative f => a -> f a
pure PresentationSettings
settings