{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Readers.OPML
   Copyright   : Copyright (C) 2013-2023 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Conversion of OPML to 'Pandoc' document.
-}

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
  ([Blocks]
bs, OPMLState
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 :: ReaderOptions
opmlOptions = ReaderOptions
opts }
  Pandoc -> m Pandoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc -> m Pandoc) -> Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$
    Inlines -> Pandoc -> Pandoc
setTitle (OPMLState -> Inlines
opmlDocTitle OPMLState
st') (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall a b. (a -> b) -> a -> b
$
    [Inlines] -> Pandoc -> Pandoc
setAuthors (OPMLState -> [Inlines]
opmlDocAuthors OPMLState
st') (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall a b. (a -> b) -> a -> b
$
    Inlines -> Pandoc -> Pandoc
setDate (OPMLState -> Inlines
opmlDocDate OPMLState
st') (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall a b. (a -> b) -> a -> b
$
    Blocks -> Pandoc
doc (Blocks -> Pandoc) -> Blocks -> Pandoc
forall a b. (a -> b) -> a -> b
$ [Blocks] -> Blocks
forall a. Monoid a => [a] -> a
mconcat [Blocks]
bs

-- convenience function to get an attribute value, defaulting to ""
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))

-- exceptT :: PandocMonad m => Either PandocError a -> OPML m a
-- exceptT = either throwError return

asHtml :: PandocMonad m => Text -> OPML m Inlines
asHtml :: forall (m :: * -> *). PandocMonad m => Text -> OPML m Inlines
asHtml Text
s = do
  ReaderOptions
opts <- (OPMLState -> ReaderOptions) -> StateT OPMLState m ReaderOptions
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets OPMLState -> ReaderOptions
opmlOptions
  Pandoc Meta
_ [Block]
bs <- ReaderOptions -> Text -> StateT OPMLState m Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readHtml ReaderOptions
forall a. Default a => a
def{ readerExtensions :: Extensions
readerExtensions = ReaderOptions -> Extensions
readerExtensions ReaderOptions
opts } Text
s
  Inlines -> OPML m Inlines
forall a. a -> StateT OPMLState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> OPML m Inlines) -> Inlines -> OPML m Inlines
forall a b. (a -> b) -> a -> b
$ [Block] -> Inlines
blocksToInlines' [Block]
bs

asMarkdown :: PandocMonad m => Text -> OPML m Blocks
asMarkdown :: forall (m :: * -> *). PandocMonad m => Text -> OPML m Blocks
asMarkdown Text
s = do
  ReaderOptions
opts <- (OPMLState -> ReaderOptions) -> StateT OPMLState m ReaderOptions
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets OPMLState -> ReaderOptions
opmlOptions
  Pandoc Meta
_ [Block]
bs <- ReaderOptions -> Text -> StateT OPMLState m Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown ReaderOptions
forall a. Default a => a
def{ readerExtensions :: Extensions
readerExtensions = ReaderOptions -> Extensions
readerExtensions ReaderOptions
opts } Text
s
  Blocks -> OPML m Blocks
forall a. a -> StateT OPMLState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocks -> OPML m Blocks) -> Blocks -> OPML m Blocks
forall a b. (a -> b) -> a -> b
$ [Block] -> Blocks
forall a. [a] -> Many a
fromList [Block]
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 :: [Inlines]
opmlDocAuthors = [Text -> Inlines
text (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Element -> Text
strContent Element
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 :: Inlines
opmlDocDate = Text -> Inlines
text (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Element -> Text
strContent Element
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 :: Inlines
opmlDocTitle = Text -> Inlines
text (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Element -> Text
strContent Element
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 Inlines
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
                     Blocks
noteBlocks <- Text -> StateT OPMLState m Blocks
forall (m :: * -> *). PandocMonad m => Text -> OPML m Blocks
asMarkdown (Text -> StateT OPMLState m Blocks)
-> Text -> StateT OPMLState m Blocks
forall a b. (a -> b) -> a -> b
$ Text -> Element -> Text
attrValue Text
"_note" Element
e
                     (OPMLState -> OPMLState) -> StateT OPMLState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((OPMLState -> OPMLState) -> StateT OPMLState m ())
-> (OPMLState -> OPMLState) -> StateT OPMLState m ()
forall a b. (a -> b) -> a -> b
$ \OPMLState
st -> OPMLState
st{ opmlSectionLevel :: Int
opmlSectionLevel = Int
n }
                     Blocks
bs <- Element -> StateT OPMLState m Blocks
forall (m :: * -> *). PandocMonad m => Element -> OPML m Blocks
getBlocks Element
e
                     (OPMLState -> OPMLState) -> StateT OPMLState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((OPMLState -> OPMLState) -> StateT OPMLState m ())
-> (OPMLState -> OPMLState) -> StateT OPMLState m ()
forall a b. (a -> b) -> a -> b
$ \OPMLState
st -> OPMLState
st{ opmlSectionLevel :: Int
opmlSectionLevel = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 }
                     let headerText' :: Inlines
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
                     Blocks -> StateT OPMLState m Blocks
forall a. a -> StateT OPMLState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocks -> StateT OPMLState m Blocks)
-> Blocks -> StateT OPMLState m Blocks
forall a b. (a -> b) -> a -> b
$ Int -> Inlines -> Blocks
header Int
n Inlines
headerText' Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Blocks
noteBlocks Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Blocks
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