module Text.OPML.Import where
import Text.OPML.Syntax
import Text.XML.Light as XML
import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)
import Data.Char (isSpace )
import Control.Monad (guard)
pNodes :: String -> [XML.Element] -> [XML.Element]
pNodes x es = filter ((opmlName x ==) . elName) es
pNode :: String -> [XML.Element] -> Maybe XML.Element
pNode x es = listToMaybe (pNodes x es)
pLeaf :: String -> [XML.Element] -> Maybe String
pLeaf x es = strContent `fmap` pNode x es
pAttr :: String -> XML.Element -> Maybe String
pAttr x e = lookup (opmlName x) [ (k,v) | Attr k v <- elAttribs e ]
pMany :: String -> (XML.Element -> Maybe a) -> [XML.Element] -> [a]
pMany p f es = mapMaybe f (pNodes p es)
children :: XML.Element -> [XML.Element]
children e = onlyElems (elContent e)
opmlName :: String -> QName
opmlName x = QName{qName=x,qURI=Nothing,qPrefix=Nothing}
elementToOPML :: XML.Element -> Maybe OPML
elementToOPML e =
do guard (elName e == opmlName "opml")
let es = children e
v <- pAttr "version" e
h <- pNode "head" es >>= elementToHead
b <- pNode "body" es >>= elementToBody
let consumed = map opmlName ["head","body"]
return OPML
{ opmlVersion = v
, opmlAttrs = elAttribs e
, opmlHead = h
, opmlBody = b
, opmlOther = filter (\ e1 -> not (elName e1 `elem` consumed)) es
}
elementToHead :: XML.Element -> Maybe OPMLHead
elementToHead e = do
guard (elName e == opmlName "head")
let es = children e
as = elAttribs e
knowns = map opmlName
[ "title"
, "dateCreated"
, "dateModified"
, "ownerName"
, "ownerEmail"
, "ownerId"
, "docs"
, "expansionState"
, "vertScrollState"
, "windowTop"
, "windowLeft"
, "windowBottom"
, "windowRight"
]
return OPMLHead
{ opmlTitle = fromMaybe "" (pLeaf "title" es)
, opmlHeadAttrs = as
, opmlCreated = pLeaf "dateCreated" es
, opmlModified = pLeaf "dateModified" es
, opmlOwner = Just OPMLOwner
{ opmlOwnerId = pLeaf "ownerId" es
, opmlOwnerEmail = pLeaf "ownerEmail" es
, opmlOwnerName = pLeaf "ownerName" es
}
, opmlDocs = pLeaf "docs" es
, opmlExpansionState = readInts $ pLeaf "expansionState" es
, opmlVertScrollState= readInt $ pLeaf "vertScrollState" es
, opmlWindowTop = readInt $ pLeaf "windowTop" es
, opmlWindowLeft = readInt $ pLeaf "windowLeft" es
, opmlWindowBottom = readInt $ pLeaf "windowBottom" es
, opmlWindowRight = readInt $ pLeaf "windowRight" es
, opmlHeadOther = filter (\ e1 -> not (elName e1 `elem` knowns)) es
}
where
readInts Nothing = Nothing
readInts (Just xs) =
case reads xs of
((x,_):_) -> Just (x::[Int])
_ -> Nothing
readInt Nothing = Nothing
readInt (Just xs) =
case reads xs of
((x,_):_) -> Just (x::Int)
_ -> Nothing
elementToBody :: XML.Element -> Maybe [Outline]
elementToBody e = do
guard (elName e == opmlName "body")
let es = children e
return (pMany "outline" elementToOutline es)
elementToOutline :: XML.Element -> Maybe Outline
elementToOutline e = do
guard (elName e == opmlName "outline")
let es = children e
let as = elAttribs e
let knowns = ["text", "type", "category", "isComment", "isBreakpoint"]
return Outline
{ opmlText = fromMaybe "" (pAttr "text" e)
, opmlType = pAttr "type" e
, opmlCategories = readCats $ pAttr "category" e
, opmlIsComment = readBool $ pAttr "isComment" e
, opmlIsBreakpoint = readBool $ pAttr "isBreakpoint" e
, opmlOutlineAttrs = filter (\ a -> not (qName (attrKey a) `elem` knowns)) as
, opmlOutlineChildren = pMany "outline" elementToOutline es
, opmlOutlineOther = filter (\ e1 -> elName e1 /= opmlName "outline") es
}
where
readCats Nothing = Nothing
readCats (Just xs) =
case reads xs of
((x,_):_) -> Just (x::[String])
_ -> Nothing
readBool Nothing = Nothing
readBool (Just xs) =
case dropWhile isSpace xs of
't':'r':'u':'e':_ -> Just True
'f':'a':'l':'s':'e':_ -> Just False
_ -> Nothing