{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Readers.OPML
   Copyright   : Copyright (C) 2013-2024 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
  (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

-- 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
  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