OMS/tiedote.md
3
0
Fork 0
Code Issues 14 Pull Requests Projects Releases Wiki Activity

Tuo 'Text.Pandoc' omaan 'Pandoc' nimiavaruuteen

Browse Source
This commit is contained in:
Saku Laesvuori 2024-04-24 16:09:57 +03:00
parent 20775ae1d5
commit dcf00955e9
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
1 changed files with 20 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
src/TiedoteMD/Read.hs
View File

@ -22,7 +22,7 @@ import Data.Time.Format.ISO8601 (iso8601ParseM)
import System.Exit (ExitCode(..))
import System.IO (hClose)
import System.Process (createProcess, proc, waitForProcess, CreateProcess(..), StdStream(..))
import Text.Pandoc (Pandoc(..), ReaderOptions(..), WriterOptions(..), Meta(..), MetaValue(..), nullMeta, Inline, Block(Plain), runIO, lookupMeta, runPure, pandocExtensions)
import Text.Pandoc (Pandoc(..))
import Text.Pandoc.Readers (readMarkdown)
import Text.Pandoc.Writers (writePlain, writeMarkdown, writeHtml5String)
@ -30,6 +30,7 @@ import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Text.Pandoc as Pandoc
import TiedoteMD.Git
import TiedoteMD.State
@ -56,9 +57,9 @@ readMessageFile store = flip (retrieve store) Nothing >=>
where addHash text = (convert $ hashWith SHA256 $ encodeUtf8 text, text)
parseMessageFile :: ByteString -> T.Text -> IO (Either Error Message)
parseMessageFile hash text = fmap (join . first PandocError) . runIO $ do
parseMessageFile hash text = fmap (join . first PandocError) . Pandoc.runIO $ do
pandoc@(Pandoc meta _) <- flip readMarkdown text
def {readerStandalone = True, readerExtensions = pandocExtensions}
def {Pandoc.readerStandalone = True, Pandoc.readerExtensions = Pandoc.pandocExtensions}
let tiedoteMeta = do
previewTo <- lookupMeta' "tarkistaja" meta >>= metaToEmails
previewTime <- lookupMeta' "deadline" meta >>= metaToTime
@ -71,7 +72,7 @@ parseMessageFile hash text = fmap (join . first PandocError) . runIO $ do
plainTextMessage <- renderHelper writePlain plainTemplate pandoc
markdownMessage <- renderHelper writeMarkdown markdownTemplate pandoc
let htmlPandoc = let Pandoc meta' blocks' = pandoc in Pandoc
(Meta $ Map.insertWith (flip const) "pagetitle" (MetaString subject) $ unMeta meta')
(Pandoc.Meta $ Map.insertWith (flip const) "pagetitle" (Pandoc.MetaString subject) $ Pandoc.unMeta meta')
blocks'
htmlMessage <- liftIO . inlineCSS =<< renderHelper writeHtml5String htmlTemplate htmlPandoc
pure $ pure $ Message
@ -81,11 +82,11 @@ parseMessageFile hash text = fmap (join . first PandocError) . runIO $ do
, previewMailID = Nothing
, ..
}
where renderHelper writer template = writer (writerOpts {writerTemplate = Just template})
where renderHelper writer template = writer (writerOpts {Pandoc.writerTemplate = Just template})
writerOpts = def
{ writerTOCDepth = 2
, writerTableOfContents = True
, writerSectionDivs = True
{ Pandoc.writerTOCDepth = 2
, Pandoc.writerTableOfContents = True
, Pandoc.writerSectionDivs = True
}
-- TODO: Store the media somewhere
@ -100,7 +101,7 @@ inlineCSS html = do
unless (exitCode == ExitSuccess) $ throwIO $ ProcessError "douceur" exitCode
pure inlined
metaToTime :: MetaValue -> Either Error UTCTime
metaToTime :: Pandoc.MetaValue -> Either Error UTCTime
metaToTime meta = do
textMeta <- metaToTexts meta >>= headOrError
maybe (Left $ InvalidTime textMeta) pure $
@ -108,21 +109,21 @@ metaToTime meta = do
where headOrError (x:_) = pure x
headOrError _ = Left $ InvalidTime ""
metaToEmails :: MetaValue -> Either Error [Email]
metaToEmails :: Pandoc.MetaValue -> Either Error [Email]
metaToEmails meta = metaToTexts meta >>= mapM
(\text -> maybe (Left $ InvalidEmail text) pure $ email $ encodeUtf8 $ T.strip text)
metaToText :: MetaValue -> Either Error T.Text
metaToText :: Pandoc.MetaValue -> Either Error T.Text
metaToText = second T.unwords . metaToTexts
metaToTexts :: MetaValue -> Either Error [T.Text]
metaToTexts (MetaString text) = pure [text]
metaToTexts (MetaInlines inlines) = second singleton $ inlinesToText inlines
metaToTexts (MetaList metas) = second concat $ mapM metaToTexts metas
metaToTexts :: Pandoc.MetaValue -> Either Error [T.Text]
metaToTexts (Pandoc.MetaString text) = pure [text]
metaToTexts (Pandoc.MetaInlines inlines) = second singleton $ inlinesToText inlines
metaToTexts (Pandoc.MetaList metas) = second concat $ mapM metaToTexts metas
metaToTexts _ = Left InvalidData
inlinesToText :: [Inline] -> Either Error T.Text
inlinesToText = first PandocError . runPure . writeMarkdown def{writerExtensions = pandocExtensions} . Pandoc nullMeta . singleton . Plain
inlinesToText :: [Pandoc.Inline] -> Either Error T.Text
inlinesToText = first PandocError . Pandoc.runPure . writeMarkdown def{Pandoc.writerExtensions = Pandoc.pandocExtensions} . Pandoc Pandoc.nullMeta . singleton . Pandoc.Plain
lookupMeta' :: T.Text -> Meta -> Either Error MetaValue
lookupMeta' key meta = maybe (Left $ NoMeta key) Right $ lookupMeta key meta
lookupMeta' :: T.Text -> Pandoc.Meta -> Either Error Pandoc.MetaValue
lookupMeta' key meta = maybe (Left $ NoMeta key) Right $ Pandoc.lookupMeta key meta