--------------------------------------------------------------------------------
{-# 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 = Comment
    { Comment -> SpeakerNotes
cSpeakerNotes :: SpeakerNotes
    , Comment -> Either String PresentationSettings
cConfig       :: Either String PresentationSettings
    } deriving (Int -> Comment -> ShowS
[Comment] -> ShowS
Comment -> String
(Int -> Comment -> ShowS)
-> (Comment -> String) -> ([Comment] -> ShowS) -> Show Comment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Comment -> ShowS
showsPrec :: Int -> Comment -> ShowS
$cshow :: Comment -> String
show :: Comment -> String
$cshowList :: [Comment] -> ShowS
showList :: [Comment] -> ShowS
Show)


--------------------------------------------------------------------------------
instance Semigroup Comment where
    Comment
l <> :: Comment -> Comment -> Comment
<> Comment
r = Comment
        { cSpeakerNotes :: SpeakerNotes
cSpeakerNotes = (SpeakerNotes -> SpeakerNotes -> SpeakerNotes)
-> (Comment -> SpeakerNotes) -> Comment -> Comment -> SpeakerNotes
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on SpeakerNotes -> SpeakerNotes -> SpeakerNotes
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
_       ) -> String -> Either String PresentationSettings
forall a b. a -> Either a b
Left String
err
            (Right PresentationSettings
_,  Left String
err) -> String -> Either String PresentationSettings
forall a b. a -> Either a b
Left String
err
            (Right PresentationSettings
x,  Right PresentationSettings
y ) -> PresentationSettings -> Either String PresentationSettings
forall a b. b -> Either a b
Right (PresentationSettings
x PresentationSettings
-> PresentationSettings -> PresentationSettings
forall a. Semigroup a => a -> a -> a
<> PresentationSettings
y)
        }


--------------------------------------------------------------------------------
instance Monoid Comment where
    mappend :: Comment -> Comment -> Comment
mappend = Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: Comment
mempty  = SpeakerNotes -> Either String PresentationSettings -> Comment
Comment SpeakerNotes
forall a. Monoid a => a
mempty (PresentationSettings -> Either String PresentationSettings
forall a b. b -> Either a b
Right PresentationSettings
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
        Comment -> Maybe Comment
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Comment -> Maybe Comment)
-> (Either String PresentationSettings -> Comment)
-> Either String PresentationSettings
-> Maybe Comment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpeakerNotes -> Either String PresentationSettings -> Comment
Comment SpeakerNotes
forall a. Monoid a => a
mempty (Either String PresentationSettings -> Maybe Comment)
-> Either String PresentationSettings -> Maybe Comment
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either ParseException PresentationSettings
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' (Text -> ByteString
T.encodeUtf8 Text
t2) of
            Left ParseException
err  -> String -> Either String PresentationSettings
forall a b. a -> Either a b
Left (ParseException -> String
forall a. Show a => a -> String
show ParseException
err)
            Right PresentationSettings
obj -> PresentationSettings -> Either String PresentationSettings
forall a b. b -> Either a b
Right PresentationSettings
obj) Maybe Comment -> Maybe Comment -> Maybe Comment
forall a. Maybe a -> Maybe a -> Maybe a
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
        Comment -> Maybe Comment
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Comment -> Maybe Comment) -> Comment -> Maybe Comment
forall a b. (a -> b) -> a -> b
$ SpeakerNotes -> Either String PresentationSettings -> Comment
Comment ([Text] -> SpeakerNotes
SpeakerNotes [Text -> Text
T.strip Text
t2]) (PresentationSettings -> Either String PresentationSettings
forall a b. b -> Either a b
Right PresentationSettings
forall a. Monoid a => a
mempty))
parse Block
_ = Maybe Comment
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
remove :: [Pandoc.Block] -> [Pandoc.Block]
remove :: [Block] -> [Block]
remove = (Comment, [Block]) -> [Block]
forall a b. (a, b) -> b
snd ((Comment, [Block]) -> [Block])
-> ([Block] -> (Comment, [Block])) -> [Block] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> (Comment, [Block])
partition


--------------------------------------------------------------------------------
-- | Take all comments from the front of the list.  Return those and the
-- remaining blocks.
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 []                           = ([Comment] -> Comment
forall a. Monoid a => [a] -> a
mconcat ([Comment] -> [Comment]
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 Comment -> [Comment] -> [Comment]
forall a. a -> [a] -> [a]
: [Comment]
sn) [Block]
xs
    go [Comment]
sn [Block]
xs                           = ([Comment] -> Comment
forall a. Monoid a => [a] -> a
mconcat ([Comment] -> [Comment]
forall a. [a] -> [a]
reverse [Comment]
sn), [Block]
xs)


--------------------------------------------------------------------------------
-- | Partition the list into speaker notes and other blocks.
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 []                           = ([Comment] -> Comment
forall a. Monoid a => [a] -> a
mconcat ([Comment] -> [Comment]
forall a. [a] -> [a]
reverse [Comment]
sn), [Block] -> [Block]
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 Comment -> [Comment] -> [Comment]
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 Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
bs) [Block]
xs


--------------------------------------------------------------------------------
newtype SpeakerNotes = SpeakerNotes [T.Text]
    deriving (SpeakerNotes -> SpeakerNotes -> Bool
(SpeakerNotes -> SpeakerNotes -> Bool)
-> (SpeakerNotes -> SpeakerNotes -> Bool) -> Eq SpeakerNotes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpeakerNotes -> SpeakerNotes -> Bool
== :: SpeakerNotes -> SpeakerNotes -> Bool
$c/= :: SpeakerNotes -> SpeakerNotes -> Bool
/= :: SpeakerNotes -> SpeakerNotes -> Bool
Eq, Semigroup SpeakerNotes
SpeakerNotes
Semigroup SpeakerNotes =>
SpeakerNotes
-> (SpeakerNotes -> SpeakerNotes -> SpeakerNotes)
-> ([SpeakerNotes] -> SpeakerNotes)
-> Monoid SpeakerNotes
[SpeakerNotes] -> SpeakerNotes
SpeakerNotes -> SpeakerNotes -> SpeakerNotes
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: SpeakerNotes
mempty :: SpeakerNotes
$cmappend :: SpeakerNotes -> SpeakerNotes -> SpeakerNotes
mappend :: SpeakerNotes -> SpeakerNotes -> SpeakerNotes
$cmconcat :: [SpeakerNotes] -> SpeakerNotes
mconcat :: [SpeakerNotes] -> SpeakerNotes
Monoid, NonEmpty SpeakerNotes -> SpeakerNotes
SpeakerNotes -> SpeakerNotes -> SpeakerNotes
(SpeakerNotes -> SpeakerNotes -> SpeakerNotes)
-> (NonEmpty SpeakerNotes -> SpeakerNotes)
-> (forall b. Integral b => b -> SpeakerNotes -> SpeakerNotes)
-> Semigroup 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
$c<> :: SpeakerNotes -> SpeakerNotes -> SpeakerNotes
<> :: SpeakerNotes -> SpeakerNotes -> SpeakerNotes
$csconcat :: NonEmpty SpeakerNotes -> SpeakerNotes
sconcat :: NonEmpty SpeakerNotes -> SpeakerNotes
$cstimes :: forall b. Integral b => b -> SpeakerNotes -> SpeakerNotes
stimes :: forall b. Integral b => b -> SpeakerNotes -> SpeakerNotes
Semigroup, Int -> SpeakerNotes -> ShowS
[SpeakerNotes] -> ShowS
SpeakerNotes -> String
(Int -> SpeakerNotes -> ShowS)
-> (SpeakerNotes -> String)
-> ([SpeakerNotes] -> ShowS)
-> Show SpeakerNotes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpeakerNotes -> ShowS
showsPrec :: Int -> SpeakerNotes -> ShowS
$cshow :: SpeakerNotes -> String
show :: SpeakerNotes -> String
$cshowList :: [SpeakerNotes] -> ShowS
showList :: [SpeakerNotes] -> ShowS
Show)


--------------------------------------------------------------------------------
speakerNotesToText :: SpeakerNotes -> T.Text
speakerNotesToText :: SpeakerNotes -> Text
speakerNotesToText (SpeakerNotes [Text]
sn) = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
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 = IO SpeakerNotesHandle
-> (SpeakerNotesHandle -> IO ())
-> (SpeakerNotesHandle -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (SpeakerNotesSettings -> IORef SpeakerNotes -> SpeakerNotesHandle
SpeakerNotesHandle SpeakerNotesSettings
settings (IORef SpeakerNotes -> SpeakerNotesHandle)
-> IO (IORef SpeakerNotes) -> IO SpeakerNotesHandle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpeakerNotes -> IO (IORef SpeakerNotes)
forall a. a -> IO (IORef a)
IORef.newIORef SpeakerNotes
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 <- IORef SpeakerNotes
-> (SpeakerNotes -> (SpeakerNotes, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' (SpeakerNotesHandle -> IORef SpeakerNotes
snhActive SpeakerNotesHandle
h) ((SpeakerNotes -> (SpeakerNotes, Bool)) -> IO Bool)
-> (SpeakerNotes -> (SpeakerNotes, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \SpeakerNotes
old -> (SpeakerNotes
sn, SpeakerNotes
old SpeakerNotes -> SpeakerNotes -> Bool
forall a. Eq a => a -> a -> Bool
/= SpeakerNotes
sn)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
change (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile (SpeakerNotesSettings -> String
snsFile (SpeakerNotesSettings -> String) -> SpeakerNotesSettings -> String
forall a b. (a -> b) -> a -> b
$ SpeakerNotesHandle -> SpeakerNotesSettings
snhSettings SpeakerNotesHandle
h) IOMode
IO.WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
ioh ->
        Handle -> EncodingFallback -> IO () -> IO ()
forall a. Handle -> EncodingFallback -> IO a -> IO a
EncodingFallback.withHandle Handle
ioh EncodingFallback
encodingFallback (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStr Handle
ioh (Text -> IO ()) -> Text -> IO ()
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 =
    [ String -> (PresentationSettings -> Maybe Bool) -> Setting
forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"incrementalLists" PresentationSettings -> Maybe Bool
psIncrementalLists
    , String
-> (PresentationSettings -> Maybe (FlexibleNum Int)) -> Setting
forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"autoAdvanceDelay" PresentationSettings -> Maybe (FlexibleNum Int)
psAutoAdvanceDelay
    , String -> (PresentationSettings -> Maybe Int) -> Setting
forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"slideLevel"       PresentationSettings -> Maybe Int
psSlideLevel
    , String -> (PresentationSettings -> Maybe ExtensionList) -> Setting
forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"pandocExtensions" PresentationSettings -> Maybe ExtensionList
psPandocExtensions
    , String -> (PresentationSettings -> Maybe ImageSettings) -> Setting
forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"images"           PresentationSettings -> Maybe ImageSettings
psImages
    , String
-> (PresentationSettings -> Maybe EvalSettingsMap) -> Setting
forall a. String -> (PresentationSettings -> Maybe a) -> Setting
Setting String
"eval"             PresentationSettings -> Maybe EvalSettingsMap
psEval
    , String
-> (PresentationSettings -> Maybe SpeakerNotesSettings) -> Setting
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
_                        -> []
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
unsupported) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String
"the following settings are not supported in slide config blocks: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
unsupported
    PresentationSettings -> Either String PresentationSettings
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PresentationSettings
settings