Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

Change return type of OPML reader

Browse source
This commit is contained in:
Matthew Pickering 2015-02-18 13:05:05 +00:00
parent ef2a8107e2
commit db6baab217
1 changed files with 28 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
src/Text/Pandoc/Readers/OPML.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
module Text.Pandoc.Readers.OPML ( readOPML ) where module Text.Pandoc.Readers.OPML ( readOPML ) where
import Data.Char (toUpper) import Data.Char (toUpper)
import Text.Pandoc.Options import Text.Pandoc.Options
@ -11,8 +12,11 @@ import Data.Generics
import Data.Monoid import Data.Monoid
import Control.Monad.State import Control.Monad.State
import Control.Applicative ((<$>), (<$)) import Control.Applicative ((<$>), (<$))
import Data.Default
import Text.Pandoc.Compat.Except
import Text.Pandoc.Error
type OPML = State OPMLState type OPML = ExceptT PandocError (State OPMLState)
data OPMLState = OPMLState{ data OPMLState = OPMLState{
opmlSectionLevel :: Int opmlSectionLevel :: Int
@ -21,17 +25,19 @@ data OPMLState = OPMLState{
, opmlDocDate :: Inlines , opmlDocDate :: Inlines
} deriving Show } deriving Show
readOPML :: ReaderOptions -> String -> Pandoc instance Default OPMLState where
def = OPMLState{ opmlSectionLevel = 0
, opmlDocTitle = mempty
, opmlDocAuthors = []
, opmlDocDate = mempty
}
readOPML :: ReaderOptions -> String -> Either PandocError Pandoc
readOPML _ inp = setTitle (opmlDocTitle st') readOPML _ inp = setTitle (opmlDocTitle st')
$ setAuthors (opmlDocAuthors st') . setAuthors (opmlDocAuthors st')
$ setDate (opmlDocDate st') . setDate (opmlDocDate st')
$ doc $ mconcat bs . doc . mconcat <$> bs
where (bs, st') = runState (mapM parseBlock $ normalizeTree $ parseXML inp) where (bs, st') = flip runState def . runExceptT $ (mapM parseBlock $ normalizeTree $ parseXML inp)
OPMLState{ opmlSectionLevel = 0
, opmlDocTitle = mempty
, opmlDocAuthors = []
, opmlDocDate = mempty
}
-- normalize input, consolidating adjacent Text and CRef elements -- normalize input, consolidating adjacent Text and CRef elements
normalizeTree :: [Content] -> [Content] normalizeTree :: [Content] -> [Content]
@ -58,14 +64,16 @@ attrValue attr elt =
Just z -> z Just z -> z
Nothing -> "" Nothing -> ""
asHtml :: String -> Inlines exceptT :: Either PandocError a -> OPML a
asHtml s = case readHtml def s of exceptT = either throwError return
Pandoc _ [Plain ils] -> fromList ils
_ -> mempty
asMarkdown :: String -> Blocks asHtml :: String -> OPML Inlines
asMarkdown s = fromList bs asHtml s = (\(Pandoc _ bs) -> case bs of
where Pandoc _ bs = readMarkdown def s [Plain ils] -> fromList ils
_ -> mempty) <$> exceptT (readHtml def s)
asMarkdown :: String -> OPML Blocks
asMarkdown s = (\(Pandoc _ bs) -> fromList bs) <$> exceptT (readMarkdown def s)
getBlocks :: Element -> OPML Blocks getBlocks :: Element -> OPML Blocks
getBlocks e = mconcat <$> (mapM parseBlock $ elContent e) getBlocks e = mconcat <$> (mapM parseBlock $ elContent e)
@ -82,8 +90,8 @@ parseBlock (Elem e) =
"outline" -> gets opmlSectionLevel >>= sect . (+1) "outline" -> gets opmlSectionLevel >>= sect . (+1)
"?xml" -> return mempty "?xml" -> return mempty
_ -> getBlocks e _ -> getBlocks e
where sect n = do let headerText = asHtml $ attrValue "text" e where sect n = do headerText <- asHtml $ attrValue "text" e
let noteBlocks = asMarkdown $ attrValue "_note" e noteBlocks <- asMarkdown $ attrValue "_note" e
modify $ \st -> st{ opmlSectionLevel = n } modify $ \st -> st{ opmlSectionLevel = n }
bs <- getBlocks e bs <- getBlocks e
modify $ \st -> st{ opmlSectionLevel = n - 1 } modify $ \st -> st{ opmlSectionLevel = n - 1 }