    {-# LANGUAGE OverloadedStrings #-}
    {- |
       Module      : Text.Pandoc.Readers.OPML
       Copyright   : Copyright (C) 2013-2020 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.Char (toUpper)
    import Data.Default
    import Data.Generics
    import Data.Maybe (fromMaybe)
    import Data.Text (Text)
    import qualified Data.Text as T
    import Text.HTML.TagSoup.Entity (lookupEntity)
    import Text.Pandoc.Builder
    import Text.Pandoc.Class.PandocMonad (PandocMonad)
    import Text.Pandoc.Options
    import Text.Pandoc.Readers.HTML (readHtml)
    import Text.Pandoc.Readers.Markdown (readMarkdown)
    import Text.Pandoc.Shared (crFilter, blocksToInlines')
    import Text.XML.Light

    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
    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 :: Int
    -> Inlines -> [Inlines] -> Inlines -> ReaderOptions -> OPMLState
    OPMLState{ opmlSectionLevel :: Int
    opmlSectionLevel = 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 => ReaderOptions -> Text -> m Pandoc
    readOPML :: ReaderOptions -> Text -> m Pandoc
    readOPML opts :: ReaderOptions
    opts inp :: Text
    inp  = do
      (bs :: [Blocks]
    bs, st' :: OPMLState
    st') <- StateT OPMLState m [Blocks] -> OPMLState -> m ([Blocks], OPMLState)
    forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
    runStateT
                     ((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)
    mapM Content -> StateT OPMLState m Blocks
    forall (m :: * -> *). PandocMonad m => Content -> OPML m Blocks
    parseBlock ([Content] -> StateT OPMLState m [Blocks])
    -> [Content] -> StateT OPMLState m [Blocks]
    forall a b. (a -> b) -> a -> b
    $ [Content] -> [Content]
    normalizeTree ([Content] -> [Content]) -> [Content] -> [Content]
    forall a b. (a -> b) -> a -> b
    $
                        String -> [Content]
    forall s. XmlSource s => s -> [Content]
    parseXML (Text -> String
    T.unpack (Text -> Text
    crFilter Text
    inp))) OPMLState
    forall a. Default a => a
    def{ opmlOptions :: ReaderOptions
    opmlOptions = ReaderOptions
    opts }
      Pandoc -> m Pandoc
    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

    -- normalize input, consolidating adjacent Text and CRef elements
    normalizeTree :: [Content] -> [Content]
    normalizeTree :: [Content] -> [Content]
    normalizeTree = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
    everywhere (([Content] -> [Content]) -> a -> a
    forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
    mkT [Content] -> [Content]
    go)
      where go :: [Content] -> [Content]
            go :: [Content] -> [Content]
    go (Text (CData CDataRaw _ _):xs :: [Content]
    xs) = [Content]
    xs
            go (Text (CData CDataText s1 :: String
    s1 z :: Maybe Line
    z):Text (CData CDataText s2 :: String
    s2 _):xs :: [Content]
    xs) =
               CData -> Content
    Text (CDataKind -> String -> Maybe Line -> CData
    CData CDataKind
    CDataText (String
    s1 String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    s2) Maybe Line
    z)Content -> [Content] -> [Content]
    forall a. a -> [a] -> [a]
    :[Content]
    xs
            go (Text (CData CDataText s1 :: String
    s1 z :: Maybe Line
    z):CRef r :: String
    r:xs :: [Content]
    xs) =
               CData -> Content
    Text (CDataKind -> String -> Maybe Line -> CData
    CData CDataKind
    CDataText (String
    s1 String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ShowS
    convertEntity String
    r) Maybe Line
    z)Content -> [Content] -> [Content]
    forall a. a -> [a] -> [a]
    :[Content]
    xs
            go (CRef r :: String
    r:Text (CData CDataText s1 :: String
    s1 z :: Maybe Line
    z):xs :: [Content]
    xs) =
                 CData -> Content
    Text (CDataKind -> String -> Maybe Line -> CData
    CData CDataKind
    CDataText (ShowS
    convertEntity String
    r String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    s1) Maybe Line
    z)Content -> [Content] -> [Content]
    forall a. a -> [a] -> [a]
    :[Content]
    xs
            go (CRef r1 :: String
    r1:CRef r2 :: String
    r2:xs :: [Content]
    xs) =
                 CData -> Content
    Text (CDataKind -> String -> Maybe Line -> CData
    CData CDataKind
    CDataText (ShowS
    convertEntity String
    r1 String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ShowS
    convertEntity String
    r2) Maybe Line
    forall a. Maybe a
    Nothing)Content -> [Content] -> [Content]
    forall a. a -> [a] -> [a]
    :[Content]
    xs
            go xs :: [Content]
    xs = [Content]
    xs

    convertEntity :: String -> String
    convertEntity :: ShowS
    convertEntity e :: String
    e = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    Data.Maybe.fromMaybe ((Char -> Char) -> ShowS
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toUpper String
    e) (String -> Maybe String
    lookupEntity String
    e)

    -- convenience function to get an attribute value, defaulting to ""
    attrValue :: String -> Element -> Text
    attrValue :: String -> Element -> Text
    attrValue attr :: String
    attr elt :: Element
    elt =
      Text -> (String -> Text) -> Maybe String -> Text
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe "" String -> Text
    T.pack ((QName -> Bool) -> [Attr] -> Maybe String
    lookupAttrBy (\x :: QName
    x -> QName -> String
    qName QName
    x String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    attr) (Element -> [Attr]
    elAttribs Element
    elt))

    textContent :: Element -> Text
    textContent :: Element -> Text
    textContent = String -> Text
    T.pack (String -> Text) -> (Element -> String) -> Element -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Element -> String
    strContent

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

    asHtml :: PandocMonad m => Text -> OPML m Inlines
    asHtml :: Text -> OPML m Inlines
    asHtml s :: 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 _ bs :: [Block]
    bs <- ReaderOptions -> Text -> StateT OPMLState m Pandoc
    forall (m :: * -> *).
    PandocMonad m =>
    ReaderOptions -> Text -> 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 (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 :: Text -> OPML m Blocks
    asMarkdown s :: 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 _ bs :: [Block]
    bs <- ReaderOptions -> Text -> StateT OPMLState m Pandoc
    forall (m :: * -> *).
    PandocMonad m =>
    ReaderOptions -> Text -> 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 (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 :: Element -> OPML m Blocks
    getBlocks e :: Element
    e =  [Blocks] -> Blocks
    forall a. Monoid a => [a] -> a
    mconcat ([Blocks] -> Blocks)
    -> StateT OPMLState m [Blocks] -> OPML m Blocks
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Content -> OPML m Blocks)
    -> [Content] -> StateT OPMLState m [Blocks]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM Content -> OPML m Blocks
    forall (m :: * -> *). PandocMonad m => Content -> OPML m Blocks
    parseBlock (Element -> [Content]
    elContent Element
    e)

    parseBlock :: PandocMonad m => Content -> OPML m Blocks
    parseBlock :: Content -> OPML m Blocks
    parseBlock (Elem e :: Element
    e) =
      case QName -> String
    qName (Element -> QName
    elName Element
    e) of
            "ownerName"    -> Blocks
    forall a. Monoid a => a
    mempty Blocks -> StateT OPMLState m () -> OPML m Blocks
    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 (\st :: OPMLState
    st ->
                                  OPMLState
    st{opmlDocAuthors :: [Inlines]
    opmlDocAuthors = [Text -> Inlines
    text (Text -> Inlines) -> Text -> Inlines
    forall a b. (a -> b) -> a -> b
    $ Element -> Text
    textContent Element
    e]})
            "dateModified" -> Blocks
    forall a. Monoid a => a
    mempty Blocks -> StateT OPMLState m () -> OPML m Blocks
    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 (\st :: OPMLState
    st ->
                                  OPMLState
    st{opmlDocDate :: Inlines
    opmlDocDate = Text -> Inlines
    text (Text -> Inlines) -> Text -> Inlines
    forall a b. (a -> b) -> a -> b
    $ Element -> Text
    textContent Element
    e})
            "title"        -> Blocks
    forall a. Monoid a => a
    mempty Blocks -> StateT OPMLState m () -> OPML m Blocks
    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 (\st :: OPMLState
    st ->
                                  OPMLState
    st{opmlDocTitle :: Inlines
    opmlDocTitle = Text -> Inlines
    text (Text -> Inlines) -> Text -> Inlines
    forall a b. (a -> b) -> a -> b
    $ Element -> Text
    textContent Element
    e})
            "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 (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
    +1)
            "?xml"  -> Blocks -> OPML m Blocks
    forall (m :: * -> *) a. Monad m => a -> m a
    return Blocks
    forall a. Monoid a => a
    mempty
            _       -> Element -> OPML m Blocks
    forall (m :: * -> *). PandocMonad m => Element -> OPML m Blocks
    getBlocks Element
    e
       where sect :: Int -> StateT OPMLState m Blocks
    sect n :: 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
    $ String -> Element -> Text
    attrValue "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
    $ String -> Element -> Text
    attrValue "_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
    $ \st :: 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
    $ \st :: OPMLState
    st -> OPMLState
    st{ opmlSectionLevel :: Int
    opmlSectionLevel = Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - 1 }
                         let headerText' :: Inlines
    headerText' = case Text -> Text
    T.toUpper (String -> Element -> Text
    attrValue "type" Element
    e) of
                                                 "LINK"  -> Text -> Text -> Inlines -> Inlines
    link
                                                   (String -> Element -> Text
    attrValue "url" Element
    e) "" Inlines
    headerText
                                                 _ -> Inlines
    headerText
                         Blocks -> StateT OPMLState m Blocks
    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 _ = Blocks -> OPML m Blocks
    forall (m :: * -> *) a. Monad m => a -> m a
    return Blocks
    forall a. Monoid a => a
    mempty