module Text.Pandoc.Readers.Odt.Generic.XMLConverter
( ElementName
, XMLConverterState
, XMLConverter
, FallibleXMLConverter
, swapPosition
, runConverter
, runConverter''
, runConverter'
, runConverterF'
, runConverterF
, getCurrentElement
, getExtraState
, setExtraState
, modifyExtraState
, convertingExtraState
, producingExtraState
, lookupNSiri
, lookupNSprefix
, readNSattributes
, elemName
, elemNameIs
, strContent
, elContent
, currentElem
, currentElemIs
, expectElement
, elChildren
, findChildren
, filterChildren
, filterChildrenName
, findChild'
, findChild
, filterChild'
, filterChild
, filterChildName'
, filterChildName
, isSet
, isSet'
, isSetWithDefault
, hasAttrValueOf'
, failIfNotAttrValueOf
, isThatTheAttrValue
, searchAttrIn
, searchAttrWith
, searchAttr
, lookupAttr
, lookupAttr'
, lookupAttrWithDefault
, lookupDefaultingAttr
, findAttr'
, findAttr
, findAttrWithDefault
, readAttr
, readAttr'
, readAttrWithDefault
, getAttr
, executeIn
, collectEvery
, withEveryL
, withEvery
, tryAll
, tryAll'
, IdXMLConverter
, MaybeEConverter
, ElementMatchConverter
, MaybeCConverter
, ContentMatchConverter
, makeMatcherE
, makeMatcherC
, prepareMatchersE
, prepareMatchersC
, matchChildren
, matchContent''
, matchContent'
, matchContent
) where
import Control.Applicative hiding ( liftA, liftA2 )
import Control.Monad ( MonadPlus )
import Control.Arrow
import qualified Data.Map as M
import qualified Data.Foldable as F
import Data.Default
import Data.Maybe
import qualified Text.XML.Light as XML
import Text.Pandoc.Readers.Odt.Arrows.State
import Text.Pandoc.Readers.Odt.Arrows.Utils
import Text.Pandoc.Readers.Odt.Generic.Namespaces
import Text.Pandoc.Readers.Odt.Generic.Utils
import Text.Pandoc.Readers.Odt.Generic.Fallible
type ElementName = String
type AttributeName = String
type AttributeValue = String
type NameSpacePrefix = String
type NameSpacePrefixes nsID = M.Map nsID NameSpacePrefix
data XMLConverterState nsID extraState where
XMLConverterState :: NameSpaceID nsID
=> {
parentElements :: [XML.Element]
, namespacePrefixes :: NameSpacePrefixes nsID
, namespaceIRIs :: NameSpaceIRIs nsID
, moreState :: extraState
}
-> XMLConverterState nsID extraState
createStartState :: (NameSpaceID nsID)
=> XML.Element
-> extraState
-> XMLConverterState nsID extraState
createStartState element extraState =
XMLConverterState
{ parentElements = [element]
, namespacePrefixes = M.empty
, namespaceIRIs = getInitialIRImap
, moreState = extraState
}
instance Functor (XMLConverterState nsID) where
fmap f ( XMLConverterState parents prefixes iRIs extraState )
= XMLConverterState parents prefixes iRIs (f extraState)
replaceExtraState :: extraState
-> XMLConverterState nsID _x
-> XMLConverterState nsID extraState
replaceExtraState x s
= fmap (const x) s
currentElement :: XMLConverterState nsID extraState
-> XML.Element
currentElement state = head (parentElements state)
swapPosition :: (extraState -> extraState')
-> [XML.Element]
-> XMLConverterState nsID extraState
-> XMLConverterState nsID extraState'
swapPosition f stack state
= state { parentElements = stack
, moreState = f (moreState state)
}
swapStack' :: XMLConverterState nsID extraState
-> [XML.Element]
-> ( XMLConverterState nsID extraState , [XML.Element] )
swapStack' state stack
= ( state { parentElements = stack }
, parentElements state
)
pushElement :: XML.Element
-> XMLConverterState nsID extraState
-> XMLConverterState nsID extraState
pushElement e state = state { parentElements = e:(parentElements state) }
popElement :: XMLConverterState nsID extraState
-> Maybe (XMLConverterState nsID extraState)
popElement state
| _:es@(_:_) <- parentElements state = Just $ state { parentElements = es }
| otherwise = Nothing
type XMLConverter nsID extraState input output
= ArrowState (XMLConverterState nsID extraState ) input output
type FallibleXMLConverter nsID extraState input output
= XMLConverter nsID extraState input (Fallible output)
runConverter :: XMLConverter nsID extraState input output
-> XMLConverterState nsID extraState
-> input
-> output
runConverter converter state input = snd $ runArrowState converter (state,input)
runConverter'' :: (NameSpaceID nsID)
=> XMLConverter nsID extraState (Fallible ()) output
-> extraState
-> XML.Element
-> output
runConverter'' converter extraState element = runConverter (readNSattributes >>> converter) (createStartState element extraState) ()
runConverter' :: (NameSpaceID nsID)
=> FallibleXMLConverter nsID extraState () success
-> extraState
-> XML.Element
-> Fallible success
runConverter' converter extraState element = runConverter (readNSattributes >>? converter) (createStartState element extraState) ()
runConverterF' :: FallibleXMLConverter nsID extraState x y
-> XMLConverterState nsID extraState
-> Fallible x -> Fallible y
runConverterF' a s e = runConverter (returnV e >>? a) s e
runConverterF :: (NameSpaceID nsID)
=> FallibleXMLConverter nsID extraState XML.Element x
-> extraState
-> Fallible XML.Element -> Fallible x
runConverterF a s = either failWith
(\e -> runConverter a (createStartState e s) e)
getCurrentElement :: XMLConverter nsID extraState x XML.Element
getCurrentElement = extractFromState currentElement
getExtraState :: XMLConverter nsID extraState x extraState
getExtraState = extractFromState moreState
setExtraState :: XMLConverter nsID extraState extraState extraState
setExtraState = withState $ \state extra
-> (replaceExtraState extra state , extra)
modifyExtraState :: (extraState -> extraState)
-> XMLConverter nsID extraState x x
modifyExtraState = modifyState.fmap
convertingExtraState :: extraState'
-> FallibleXMLConverter nsID extraState' extraState extraState
-> FallibleXMLConverter nsID extraState x x
convertingExtraState v a = withSubStateF setVAsExtraState modifyWithA
where
setVAsExtraState = liftAsSuccess $ extractFromState id >>^ replaceExtraState v
modifyWithA = keepingTheValue (moreState ^>> a)
>>^ spreadChoice >>?% flip replaceExtraState
producingExtraState :: extraState'
-> a
-> FallibleXMLConverter nsID extraState' a extraState
-> FallibleXMLConverter nsID extraState x x
producingExtraState v x a = convertingExtraState v (returnV x >>> a)
lookupNSiri :: (NameSpaceID nsID)
=> nsID
-> XMLConverter nsID extraState x (Maybe NameSpaceIRI)
lookupNSiri nsID = extractFromState
$ \state -> getIRI nsID $ namespaceIRIs state
lookupNSprefix :: (NameSpaceID nsID)
=> nsID
-> XMLConverter nsID extraState x (Maybe NameSpacePrefix)
lookupNSprefix nsID = extractFromState
$ \state -> M.lookup nsID $ namespacePrefixes state
readNSattributes :: (NameSpaceID nsID)
=> FallibleXMLConverter nsID extraState x ()
readNSattributes = fromState $ \state -> maybe (state, failEmpty )
( , succeedWith ())
(extractNSAttrs state )
where
extractNSAttrs :: (NameSpaceID nsID)
=> XMLConverterState nsID extraState
-> Maybe (XMLConverterState nsID extraState)
extractNSAttrs startState
= foldl (\state d -> state >>= addNS d)
(Just startState)
nsAttribs
where nsAttribs = mapMaybe readNSattr (XML.elAttribs element)
element = currentElement startState
readNSattr (XML.Attr (XML.QName name _ (Just "xmlns")) iri)
= Just (name, iri)
readNSattr _ = Nothing
addNS (prefix, iri) state = fmap updateState
$ getNamespaceID iri
$ namespaceIRIs state
where updateState (iris,nsID)
= state { namespaceIRIs = iris
, namespacePrefixes = M.insert nsID prefix
$ namespacePrefixes state
}
elemName :: (NameSpaceID nsID)
=> nsID -> ElementName
-> XMLConverter nsID extraState x XML.QName
elemName nsID name = lookupNSiri nsID
&&& lookupNSprefix nsID
>>% XML.QName name
elemNameIs :: (NameSpaceID nsID)
=> nsID -> ElementName
-> XMLConverter nsID extraState XML.Element Bool
elemNameIs nsID name = keepingTheValue (lookupNSiri nsID) >>% hasThatName
where hasThatName e iri = let elName = XML.elName e
in XML.qName elName == name
&& XML.qURI elName == iri
strContent :: XMLConverter nsID extraState x String
strContent = getCurrentElement
>>^ XML.strContent
elContent :: XMLConverter nsID extraState x [XML.Content]
elContent = getCurrentElement
>>^ XML.elContent
currentElem :: XMLConverter nsID extraState x (XML.QName)
currentElem = getCurrentElement
>>^ XML.elName
currentElemIs :: (NameSpaceID nsID)
=> nsID -> ElementName
-> XMLConverter nsID extraState x Bool
currentElemIs nsID name = getCurrentElement
>>> elemNameIs nsID name
expectElement :: (NameSpaceID nsID)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState x ()
expectElement nsID name = currentElemIs nsID name
>>^ boolToChoice
elChildren :: XMLConverter nsID extraState x [XML.Element]
elChildren = getCurrentElement
>>^ XML.elChildren
findChildren :: (NameSpaceID nsID)
=> nsID -> ElementName
-> XMLConverter nsID extraState x [XML.Element]
findChildren nsID name = elemName nsID name
&&& getCurrentElement
>>% XML.findChildren
filterChildren :: (XML.Element -> Bool)
-> XMLConverter nsID extraState x [XML.Element]
filterChildren p = getCurrentElement
>>^ XML.filterChildren p
filterChildrenName :: (XML.QName -> Bool)
-> XMLConverter nsID extraState x [XML.Element]
filterChildrenName p = getCurrentElement
>>^ XML.filterChildrenName p
findChild' :: (NameSpaceID nsID)
=> nsID
-> ElementName
-> XMLConverter nsID extraState x (Maybe XML.Element)
findChild' nsID name = elemName nsID name
&&& getCurrentElement
>>% XML.findChild
findChild :: (NameSpaceID nsID)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState x XML.Element
findChild nsID name = findChild' nsID name
>>> maybeToChoice
filterChild' :: (XML.Element -> Bool)
-> XMLConverter nsID extraState x (Maybe XML.Element)
filterChild' p = getCurrentElement
>>^ XML.filterChild p
filterChild :: (XML.Element -> Bool)
-> FallibleXMLConverter nsID extraState x XML.Element
filterChild p = filterChild' p
>>> maybeToChoice
filterChildName' :: (XML.QName -> Bool)
-> XMLConverter nsID extraState x (Maybe XML.Element)
filterChildName' p = getCurrentElement
>>^ XML.filterChildName p
filterChildName :: (XML.QName -> Bool)
-> FallibleXMLConverter nsID extraState x XML.Element
filterChildName p = filterChildName' p
>>> maybeToChoice
isSet :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> (Either Failure Bool)
-> FallibleXMLConverter nsID extraState x Bool
isSet nsID attrName deflt
= findAttr' nsID attrName
>>^ maybe deflt stringToBool
isSet' :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> XMLConverter nsID extraState x (Maybe Bool)
isSet' nsID attrName = findAttr' nsID attrName
>>^ (>>= stringToBool')
isSetWithDefault :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> Bool
-> XMLConverter nsID extraState x Bool
isSetWithDefault nsID attrName def'
= isSet' nsID attrName
>>^ fromMaybe def'
hasAttrValueOf' :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> AttributeValue
-> XMLConverter nsID extraState x Bool
hasAttrValueOf' nsID attrName attrValue
= findAttr nsID attrName
>>> ( const False ^|||^ (==attrValue))
failIfNotAttrValueOf :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> AttributeValue
-> FallibleXMLConverter nsID extraState x ()
failIfNotAttrValueOf nsID attrName attrValue
= hasAttrValueOf' nsID attrName attrValue
>>^ boolToChoice
isThatTheAttrValue :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> FallibleXMLConverter nsID extraState AttributeValue Bool
isThatTheAttrValue nsID attrName
= keepingTheValue
(findAttr nsID attrName)
>>% right.(==)
searchAttrIn :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> [(AttributeValue,a)]
-> FallibleXMLConverter nsID extraState x a
searchAttrIn nsID attrName dict
= findAttr nsID attrName
>>?^? maybeToChoice.(`lookup` dict )
searchAttrWith :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> a
-> [(AttributeValue,a)]
-> FallibleXMLConverter nsID extraState x a
searchAttrWith nsID attrName defV dict
= findAttr nsID attrName
>>?^ (fromMaybe defV).(`lookup` dict )
searchAttr :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> a
-> [(AttributeValue,a)]
-> XMLConverter nsID extraState x a
searchAttr nsID attrName defV dict
= searchAttrIn nsID attrName dict
>>> const defV ^|||^ id
lookupAttr :: (NameSpaceID nsID, Lookupable a)
=> nsID -> AttributeName
-> FallibleXMLConverter nsID extraState x a
lookupAttr nsID attrName = lookupAttr' nsID attrName
>>^ maybeToChoice
lookupAttr' :: (NameSpaceID nsID, Lookupable a)
=> nsID -> AttributeName
-> XMLConverter nsID extraState x (Maybe a)
lookupAttr' nsID attrName
= findAttr' nsID attrName
>>^ (>>= readLookupable)
lookupAttrWithDefault :: (NameSpaceID nsID, Lookupable a)
=> nsID -> AttributeName
-> a
-> XMLConverter nsID extraState x a
lookupAttrWithDefault nsID attrName deflt
= lookupAttr' nsID attrName
>>^ fromMaybe deflt
lookupDefaultingAttr :: (NameSpaceID nsID, Lookupable a, Default a)
=> nsID -> AttributeName
-> XMLConverter nsID extraState x a
lookupDefaultingAttr nsID attrName
= lookupAttrWithDefault nsID attrName def
findAttr' :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> XMLConverter nsID extraState x (Maybe AttributeValue)
findAttr' nsID attrName = elemName nsID attrName
&&& getCurrentElement
>>% XML.findAttr
findAttr :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> FallibleXMLConverter nsID extraState x AttributeValue
findAttr nsID attrName = findAttr' nsID attrName
>>> maybeToChoice
findAttrWithDefault :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> AttributeValue
-> XMLConverter nsID extraState x AttributeValue
findAttrWithDefault nsID attrName deflt
= findAttr' nsID attrName
>>^ fromMaybe deflt
readAttr :: (NameSpaceID nsID, Read attrValue)
=> nsID -> AttributeName
-> FallibleXMLConverter nsID extraState x attrValue
readAttr nsID attrName = readAttr' nsID attrName
>>> maybeToChoice
readAttr' :: (NameSpaceID nsID, Read attrValue)
=> nsID -> AttributeName
-> XMLConverter nsID extraState x (Maybe attrValue)
readAttr' nsID attrName = findAttr' nsID attrName
>>^ (>>= tryToRead)
readAttrWithDefault :: (NameSpaceID nsID, Read attrValue)
=> nsID -> AttributeName
-> attrValue
-> XMLConverter nsID extraState x attrValue
readAttrWithDefault nsID attrName deflt
= findAttr' nsID attrName
>>^ (>>= tryToRead)
>>^ fromMaybe deflt
getAttr :: (NameSpaceID nsID, Read attrValue, Default attrValue)
=> nsID -> AttributeName
-> XMLConverter nsID extraState x attrValue
getAttr nsID attrName = readAttrWithDefault nsID attrName def
jumpThere :: XMLConverter nsID extraState XML.Element XML.Element
jumpThere = withState (\state element
-> ( pushElement element state , element )
)
swapStack :: XMLConverter nsID extraState [XML.Element] [XML.Element]
swapStack = withState swapStack'
jumpBack :: FallibleXMLConverter nsID extraState _x _x
jumpBack = tryModifyState (popElement >>> maybeToChoice)
switchingTheStack :: XMLConverter nsID moreState a b
-> XMLConverter nsID moreState (a, XML.Element) b
switchingTheStack a = second ( (:[]) ^>> swapStack )
>>> first a
>>> second swapStack
>>^ fst
executeThere :: FallibleXMLConverter nsID moreState a b
-> FallibleXMLConverter nsID moreState (a, XML.Element) b
executeThere a = second jumpThere
>>> fst
^>> a
>>> jumpBack
>>^ collapseEither
executeIn :: (NameSpaceID nsID)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState f s
-> FallibleXMLConverter nsID extraState f s
executeIn nsID name a = keepingTheValue
(findChild nsID name)
>>> ignoringState liftFailure
>>? switchingTheStack a
where liftFailure (_, (Left f)) = Left f
liftFailure (x, (Right e)) = Right (x, e)
prepareIteration :: (NameSpaceID nsID)
=> nsID -> ElementName
-> XMLConverter nsID extraState b [(b, XML.Element)]
prepareIteration nsID name = keepingTheValue
(findChildren nsID name)
>>% distributeValue
collectEvery :: (NameSpaceID nsID, Monoid m)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState a m
-> FallibleXMLConverter nsID extraState a m
collectEvery nsID name a = prepareIteration nsID name
>>> foldS' (switchingTheStack a)
withEveryL :: (NameSpaceID nsID)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState a b
-> FallibleXMLConverter nsID extraState a [b]
withEveryL = withEvery
withEvery :: (NameSpaceID nsID, MonadPlus m)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState a b
-> FallibleXMLConverter nsID extraState a (m b)
withEvery nsID name a = prepareIteration nsID name
>>> iterateS' (switchingTheStack a)
tryAll :: (NameSpaceID nsID)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll nsID name a = prepareIteration nsID name
>>> iterateS (switchingTheStack a)
>>^ collectRights
tryAll' :: (NameSpaceID nsID, F.Foldable c, MonadPlus c)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b (c a)
tryAll' nsID name a = prepareIteration nsID name
>>> iterateS (switchingTheStack a)
>>^ collectRightsF
type IdXMLConverter nsID moreState x
= XMLConverter nsID moreState x x
type MaybeEConverter nsID moreState x
= Maybe (IdXMLConverter nsID moreState (x, XML.Element))
type ElementMatchConverter nsID extraState x
= IdXMLConverter nsID
extraState
(MaybeEConverter nsID extraState x, XML.Element)
type MaybeCConverter nsID moreState x
= Maybe (IdXMLConverter nsID moreState (x, XML.Content))
type ContentMatchConverter nsID extraState x
= IdXMLConverter nsID
extraState
(MaybeCConverter nsID extraState x, XML.Content)
makeMatcherE :: (NameSpaceID nsID)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState a a
-> ElementMatchConverter nsID extraState a
makeMatcherE nsID name c = ( second (
elemNameIs nsID name
>>^ bool Nothing (Just tryC)
)
>>% (<|>)
) &&&^ snd
where tryC = (fst ^&&& executeThere c >>% recover) &&&^ snd
makeMatcherC :: (NameSpaceID nsID)
=> nsID -> ElementName
-> FallibleXMLConverter nsID extraState a a
-> ContentMatchConverter nsID extraState a
makeMatcherC nsID name c = ( second ( contentToElem
>>> returnV Nothing
||| ( elemNameIs nsID name
>>^ bool Nothing (Just cWithJump)
)
)
>>% (<|>)
) &&&^ snd
where cWithJump = ( fst
^&&& ( second contentToElem
>>> spreadChoice
^>>? executeThere c
)
>>% recover)
&&&^ snd
contentToElem :: FallibleXMLConverter nsID extraState XML.Content XML.Element
contentToElem = arr $ \e -> case e of
XML.Elem e' -> succeedWith e'
_ -> failEmpty
prepareMatchersE :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)]
-> ElementMatchConverter nsID extraState x
prepareMatchersE = reverseComposition . (map $ uncurry3 makeMatcherE)
prepareMatchersC :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)]
-> ContentMatchConverter nsID extraState x
prepareMatchersC = reverseComposition . (map $ uncurry3 makeMatcherC)
matchChildren :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]
-> XMLConverter nsID extraState a a
matchChildren lookups = let matcher = prepareMatchersE lookups
in keepingTheValue (
elChildren
>>> map (Nothing,)
^>> iterateSL matcher
>>^ catMaybes.map (\(m,e) -> fmap (swallowElem e) m)
>>> reverseComposition
)
>>> swap
^>> app
where
swallowElem element converter = (,element) ^>> converter >>^ fst
matchContent'' :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]
-> XMLConverter nsID extraState a a
matchContent'' lookups = let matcher = prepareMatchersC lookups
in keepingTheValue (
elContent
>>> map (Nothing,)
^>> iterateSL matcher
>>^ catMaybes.map (\(m,c) -> fmap (swallowContent c) m)
>>> reverseComposition
)
>>> swap
^>> app
where
swallowContent content converter = (,content) ^>> converter >>^ fst
matchContent' :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]
-> XMLConverter nsID extraState a a
matchContent' lookups = matchContent lookups (arr fst)
matchContent :: (NameSpaceID nsID)
=> [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)]
-> XMLConverter nsID extraState (a,XML.Content) a
-> XMLConverter nsID extraState a a
matchContent lookups fallback
= let matcher = prepareMatchersC lookups
in keepingTheValue (
elContent
>>> map (Nothing,)
^>> iterateSL matcher
>>^ map swallowOrFallback
>>> reverseComposition
)
>>> swap
^>> app
where
swallowOrFallback (Just converter,content) = (,content) ^>> converter >>^ fst
swallowOrFallback (Nothing ,content) = (,content) ^>> fallback
stringToBool :: (Monoid failure) => String -> Either failure Bool
stringToBool val
| val `elem` trueValues = succeedWith True
| val `elem` falseValues = succeedWith False
| otherwise = failEmpty
where trueValues = ["true" ,"on" ,"1"]
falseValues = ["false","off","0"]
stringToBool' :: String -> Maybe Bool
stringToBool' val | val `elem` trueValues = Just True
| val `elem` falseValues = Just False
| otherwise = Nothing
where trueValues = ["true" ,"on" ,"1"]
falseValues = ["false","off","0"]
distributeValue :: a -> [b] -> [(a,b)]
distributeValue = map.(,)