{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Readers.OPML
   Copyright   : Copyright (C) 2013-2022 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OPMLState] -> ShowS
$cshowList :: [OPMLState] -> ShowS
show :: OPMLState -> String
$cshow :: OPMLState -> String
showsPrec :: Int -> OPMLState -> ShowS
$cshowsPrec :: Int -> OPMLState -> ShowS
Show

instance Default OPMLState where
  def :: OPMLState
def = OPMLState{ opmlSectionLevel :: Int
opmlSectionLevel = Int
0
                 , opmlDocTitle :: Inlines
opmlDocTitle = forall a. Monoid a => a
mempty
                 , opmlDocAuthors :: [Inlines]
opmlDocAuthors = []
                 , opmlDocDate :: Inlines
opmlDocDate = forall a. Monoid a => a
mempty
                 , opmlOptions :: ReaderOptions
opmlOptions = 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 = forall a. ToSources a => a -> Sources
toSources a
inp
  ([Blocks]
bs, OPMLState
st') <-
    forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (case Text -> Either Text [Content]
parseXMLContents (Text -> Text
TL.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sources -> Text
sourcesToText forall a b. (a -> b) -> a -> b
$ Sources
sources) of
                     Left Text
msg -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Text -> PandocError
PandocXMLError Text
"" Text
msg
                     Right [Content]
ns -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). PandocMonad m => Content -> OPML m Blocks
parseBlock [Content]
ns)
                 forall a. Default a => a
def{ opmlOptions :: ReaderOptions
opmlOptions = ReaderOptions
opts }
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    Inlines -> Pandoc -> Pandoc
setTitle (OPMLState -> Inlines
opmlDocTitle OPMLState
st') forall a b. (a -> b) -> a -> b
$
    [Inlines] -> Pandoc -> Pandoc
setAuthors (OPMLState -> [Inlines]
opmlDocAuthors OPMLState
st') forall a b. (a -> b) -> a -> b
$
    Inlines -> Pandoc -> Pandoc
setDate (OPMLState -> Inlines
opmlDocDate OPMLState
st') forall a b. (a -> b) -> a -> b
$
    Blocks -> Pandoc
doc forall a b. (a -> b) -> a -> b
$ 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 =
  forall a. a -> Maybe a -> a
fromMaybe Text
"" ((QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy (\QName
x -> QName -> Text
qName QName
x 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets OPMLState -> ReaderOptions
opmlOptions
  Pandoc Meta
_ [Block]
bs <- forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readHtml forall a. Default a => a
def{ readerExtensions :: Extensions
readerExtensions = ReaderOptions -> Extensions
readerExtensions ReaderOptions
opts } Text
s
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets OPMLState -> ReaderOptions
opmlOptions
  Pandoc Meta
_ [Block]
bs <- forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown forall a. Default a => a
def{ readerExtensions :: Extensions
readerExtensions = ReaderOptions -> Extensions
readerExtensions ReaderOptions
opts } Text
s
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 =  forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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"    -> forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\OPMLState
st ->
                              OPMLState
st{opmlDocAuthors :: [Inlines]
opmlDocAuthors = [Text -> Inlines
text forall a b. (a -> b) -> a -> b
$ Element -> Text
strContent Element
e]})
        Text
"dateModified" -> forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\OPMLState
st ->
                              OPMLState
st{opmlDocDate :: Inlines
opmlDocDate = Text -> Inlines
text forall a b. (a -> b) -> a -> b
$ Element -> Text
strContent Element
e})
        Text
"title"        -> forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\OPMLState
st ->
                              OPMLState
st{opmlDocTitle :: Inlines
opmlDocTitle = Text -> Inlines
text forall a b. (a -> b) -> a -> b
$ Element -> Text
strContent Element
e})
        Text
"outline" -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets OPMLState -> Int
opmlSectionLevel forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}.
PandocMonad m =>
Int -> StateT OPMLState m Blocks
sect forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Int
1)
        Text
"?xml"  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        Text
_       -> forall (m :: * -> *). PandocMonad m => Element -> OPML m Blocks
getBlocks Element
e
   where sect :: Int -> StateT OPMLState m Blocks
sect Int
n = do Inlines
headerText <- forall (m :: * -> *). PandocMonad m => Text -> OPML m Inlines
asHtml forall a b. (a -> b) -> a -> b
$ Text -> Element -> Text
attrValue Text
"text" Element
e
                     Blocks
noteBlocks <- forall (m :: * -> *). PandocMonad m => Text -> OPML m Blocks
asMarkdown forall a b. (a -> b) -> a -> b
$ Text -> Element -> Text
attrValue Text
"_note" Element
e
                     forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \OPMLState
st -> OPMLState
st{ opmlSectionLevel :: Int
opmlSectionLevel = Int
n }
                     Blocks
bs <- forall (m :: * -> *). PandocMonad m => Element -> OPML m Blocks
getBlocks Element
e
                     forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \OPMLState
st -> OPMLState
st{ opmlSectionLevel :: Int
opmlSectionLevel = Int
n 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
                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Inlines -> Blocks
header Int
n Inlines
headerText' forall a. Semigroup a => a -> a -> a
<> Blocks
noteBlocks forall a. Semigroup a => a -> a -> a
<> Blocks
bs
parseBlock Content
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty