{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Readers.OPML ( readOPML ) where
import Control.Monad.State.Strict
import Data.Default
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Text.Pandoc.Builder
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Options
import Text.Pandoc.Error (PandocError(..))
import Text.Pandoc.Readers.HTML (readHtml)
import Text.Pandoc.Readers.Markdown (readMarkdown)
import Text.Pandoc.Shared (blocksToInlines')
import Text.Pandoc.Sources (ToSources(..), sourcesToText)
import Text.Pandoc.XML.Light
import Control.Monad.Except (throwError)
type OPML m = StateT OPMLState m
data OPMLState = OPMLState{
OPMLState -> Int
opmlSectionLevel :: Int
, OPMLState -> Inlines
opmlDocTitle :: Inlines
, OPMLState -> [Inlines]
opmlDocAuthors :: [Inlines]
, OPMLState -> Inlines
opmlDocDate :: Inlines
, OPMLState -> ReaderOptions
opmlOptions :: ReaderOptions
} deriving Int -> OPMLState -> ShowS
[OPMLState] -> ShowS
OPMLState -> String
(Int -> OPMLState -> ShowS)
-> (OPMLState -> String)
-> ([OPMLState] -> ShowS)
-> Show OPMLState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OPMLState -> ShowS
showsPrec :: Int -> OPMLState -> ShowS
$cshow :: OPMLState -> String
show :: OPMLState -> String
$cshowList :: [OPMLState] -> ShowS
showList :: [OPMLState] -> ShowS
Show
instance Default OPMLState where
def :: OPMLState
def = OPMLState{ opmlSectionLevel :: Int
opmlSectionLevel = Int
0
, opmlDocTitle :: Inlines
opmlDocTitle = Inlines
forall a. Monoid a => a
mempty
, opmlDocAuthors :: [Inlines]
opmlDocAuthors = []
, opmlDocDate :: Inlines
opmlDocDate = Inlines
forall a. Monoid a => a
mempty
, opmlOptions :: ReaderOptions
opmlOptions = ReaderOptions
forall a. Default a => a
def
}
readOPML :: (PandocMonad m, ToSources a)
=> ReaderOptions
-> a
-> m Pandoc
readOPML :: forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readOPML ReaderOptions
opts a
inp = do
let sources :: Sources
sources = a -> Sources
forall a. ToSources a => a -> Sources
toSources a
inp
(bs, st') <-
StateT OPMLState m [Blocks] -> OPMLState -> m ([Blocks], OPMLState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (case Text -> Either Text [Content]
parseXMLContents (Text -> Text
TL.fromStrict (Text -> Text) -> (Sources -> Text) -> Sources -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sources -> Text
sourcesToText (Sources -> Text) -> Sources -> Text
forall a b. (a -> b) -> a -> b
$ Sources
sources) of
Left Text
msg -> PandocError -> StateT OPMLState m [Blocks]
forall a. PandocError -> StateT OPMLState m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> StateT OPMLState m [Blocks])
-> PandocError -> StateT OPMLState m [Blocks]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PandocError
PandocXMLError Text
"" Text
msg
Right [Content]
ns -> (Content -> StateT OPMLState m Blocks)
-> [Content] -> StateT OPMLState m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Content -> StateT OPMLState m Blocks
forall (m :: * -> *). PandocMonad m => Content -> OPML m Blocks
parseBlock [Content]
ns)
OPMLState
forall a. Default a => a
def{ opmlOptions = opts }
return $
setTitle (opmlDocTitle st') $
setAuthors (opmlDocAuthors st') $
setDate (opmlDocDate st') $
doc $ mconcat bs
attrValue :: Text -> Element -> Text
attrValue :: Text -> Element -> Text
attrValue Text
attr Element
elt =
Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" ((QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy (\QName
x -> QName -> Text
qName QName
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
attr) (Element -> [Attr]
elAttribs Element
elt))
asHtml :: PandocMonad m => Text -> OPML m Inlines
asHtml :: forall (m :: * -> *). PandocMonad m => Text -> OPML m Inlines
asHtml Text
s = do
opts <- (OPMLState -> ReaderOptions) -> StateT OPMLState m ReaderOptions
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets OPMLState -> ReaderOptions
opmlOptions
Pandoc _ bs <- readHtml def{ readerExtensions = readerExtensions opts } s
return $ blocksToInlines' bs
asMarkdown :: PandocMonad m => Text -> OPML m Blocks
asMarkdown :: forall (m :: * -> *). PandocMonad m => Text -> OPML m Blocks
asMarkdown Text
s = do
opts <- (OPMLState -> ReaderOptions) -> StateT OPMLState m ReaderOptions
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets OPMLState -> ReaderOptions
opmlOptions
Pandoc _ bs <- readMarkdown def{ readerExtensions = readerExtensions opts } s
return $ fromList bs
getBlocks :: PandocMonad m => Element -> OPML m Blocks
getBlocks :: forall (m :: * -> *). PandocMonad m => Element -> OPML m Blocks
getBlocks Element
e = [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat ([Blocks] -> Blocks)
-> StateT OPMLState m [Blocks] -> StateT OPMLState m Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Content -> StateT OPMLState m Blocks)
-> [Content] -> StateT OPMLState m [Blocks]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Content -> StateT OPMLState m Blocks
forall (m :: * -> *). PandocMonad m => Content -> OPML m Blocks
parseBlock (Element -> [Content]
elContent Element
e)
parseBlock :: PandocMonad m => Content -> OPML m Blocks
parseBlock :: forall (m :: * -> *). PandocMonad m => Content -> OPML m Blocks
parseBlock (Elem Element
e) =
case QName -> Text
qName (Element -> QName
elName Element
e) of
Text
"ownerName" -> Blocks
forall a. Monoid a => a
mempty Blocks -> StateT OPMLState m () -> OPML m Blocks
forall a b. a -> StateT OPMLState m b -> StateT OPMLState m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (OPMLState -> OPMLState) -> StateT OPMLState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\OPMLState
st ->
OPMLState
st{opmlDocAuthors = [text $ strContent e]})
Text
"dateModified" -> Blocks
forall a. Monoid a => a
mempty Blocks -> StateT OPMLState m () -> OPML m Blocks
forall a b. a -> StateT OPMLState m b -> StateT OPMLState m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (OPMLState -> OPMLState) -> StateT OPMLState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\OPMLState
st ->
OPMLState
st{opmlDocDate = text $ strContent e})
Text
"title" -> Blocks
forall a. Monoid a => a
mempty Blocks -> StateT OPMLState m () -> OPML m Blocks
forall a b. a -> StateT OPMLState m b -> StateT OPMLState m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (OPMLState -> OPMLState) -> StateT OPMLState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\OPMLState
st ->
OPMLState
st{opmlDocTitle = text $ strContent e})
Text
"outline" -> (OPMLState -> Int) -> StateT OPMLState m Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets OPMLState -> Int
opmlSectionLevel StateT OPMLState m Int -> (Int -> OPML m Blocks) -> OPML m Blocks
forall a b.
StateT OPMLState m a
-> (a -> StateT OPMLState m b) -> StateT OPMLState m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> OPML m Blocks
forall {m :: * -> *}.
PandocMonad m =>
Int -> StateT OPMLState m Blocks
sect (Int -> OPML m Blocks) -> (Int -> Int) -> Int -> OPML m Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
Text
"?xml" -> Blocks -> OPML m Blocks
forall a. a -> StateT OPMLState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocks
forall a. Monoid a => a
mempty
Text
_ -> Element -> OPML m Blocks
forall (m :: * -> *). PandocMonad m => Element -> OPML m Blocks
getBlocks Element
e
where sect :: Int -> StateT OPMLState m Blocks
sect Int
n = do headerText <- Text -> OPML m Inlines
forall (m :: * -> *). PandocMonad m => Text -> OPML m Inlines
asHtml (Text -> OPML m Inlines) -> Text -> OPML m Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Element -> Text
attrValue Text
"text" Element
e
noteBlocks <- asMarkdown $ attrValue "_note" e
modify $ \OPMLState
st -> OPMLState
st{ opmlSectionLevel = n }
bs <- getBlocks e
modify $ \OPMLState
st -> OPMLState
st{ opmlSectionLevel = n - 1 }
let headerText' = case Text -> Text
T.toUpper (Text -> Element -> Text
attrValue Text
"type" Element
e) of
Text
"LINK" -> Text -> Text -> Inlines -> Inlines
link
(Text -> Element -> Text
attrValue Text
"url" Element
e) Text
"" Inlines
headerText
Text
_ -> Inlines
headerText
return $ header n headerText' <> noteBlocks <> bs
parseBlock Content
_ = Blocks -> OPML m Blocks
forall a. a -> StateT OPMLState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocks
forall a. Monoid a => a
mempty