{-# LANGUAGE Arrows #-}
module Codec.Epub.Parse.Metadata
( metadataP
)
where
import Control.Applicative
import Control.Arrow.ListArrows
import Data.List ( isPrefixOf )
import qualified Data.Map.Strict as Map
import Data.Maybe ( catMaybes )
import Data.Tree.NTree.TypeDefs ( NTree )
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.DOM.TypeDefs
import Codec.Epub.Data.Metadata
import Codec.Epub.Parse.Util
idP :: (ArrowXml a) => a (NTree XNode) Identifier
idP :: forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) Identifier
idP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"identifier") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ( forall (a :: * -> * -> *) b c. WrappedArrow a b c -> a b c
unwrapArrow forall a b. (a -> b) -> a -> b
$ Maybe String
-> Maybe String -> Maybe String -> String -> Identifier
Identifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *).
ArrowXml a =>
String -> a (NTree XNode) (Maybe String)
mbGetAttrValue String
"id")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA forall a. Maybe a
Nothing)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (Maybe String)
mbGetQAttrValue (String -> QName
opfName String
"scheme"))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text)
)
titleP :: (ArrowXml a) => a (NTree XNode) (String, Title)
titleP :: forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (String, Title)
titleP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"title") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
proc NTree XNode
x -> do
Maybe String
i <- forall (a :: * -> * -> *).
ArrowXml a =>
String -> a (NTree XNode) (Maybe String)
mbGetAttrValue String
"id" -< NTree XNode
x
Maybe String
l <- forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (Maybe String)
mbGetQAttrValue (String -> QName
xmlName String
"lang") -< NTree XNode
x
String
c <- forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text -< NTree XNode
x
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ((forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" forall a. a -> a
id Maybe String
i), Maybe String -> Maybe String -> Maybe Int -> String -> Title
Title Maybe String
l forall a. Maybe a
Nothing forall a. Maybe a
Nothing String
c)
langP :: (ArrowXml a) => a (NTree XNode) String
langP :: forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
langP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"language") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text
creatorP :: (ArrowXml a) => String -> a (NTree XNode) (String, Creator)
creatorP :: forall (a :: * -> * -> *).
ArrowXml a =>
String -> a (NTree XNode) (String, Creator)
creatorP String
tag = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
tag) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
proc NTree XNode
x -> do
Maybe String
i <- forall (a :: * -> * -> *).
ArrowXml a =>
String -> a (NTree XNode) (Maybe String)
mbGetAttrValue String
"id" -< NTree XNode
x
Maybe String
r <- forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (Maybe String)
mbGetQAttrValue (String -> QName
opfName String
"role") -< NTree XNode
x
Maybe String
f <- forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (Maybe String)
mbGetQAttrValue (String -> QName
opfName String
"file-as") -< NTree XNode
x
String
t <- forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text -< NTree XNode
x
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ((forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" forall a. a -> a
id Maybe String
i), Maybe String -> Maybe String -> Maybe Int -> String -> Creator
Creator Maybe String
r Maybe String
f forall a. Maybe a
Nothing String
t)
dateElemP :: (ArrowXml a) => a (NTree XNode) (Maybe (DateEvent, DateValue))
dateElemP :: forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (Maybe (DateEvent, DateValue))
dateElemP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"date") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
proc NTree XNode
x -> do
Maybe String
e <- forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (Maybe String)
mbGetQAttrValue (String -> QName
opfName String
"event") -< NTree XNode
x
String
c <- forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text -< NTree XNode
x
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (, String -> DateValue
DateValue String
c) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String -> Maybe DateEvent
dateEventFromString Maybe String
e
dateMetaP :: (ArrowXml a) => a (NTree XNode) (Maybe (DateEvent, DateValue))
dateMetaP :: forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (Maybe (DateEvent, DateValue))
dateMetaP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
opfName String
"meta") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
proc NTree XNode
x -> do
Maybe String
e <- forall (a :: * -> * -> *).
ArrowXml a =>
String -> a (NTree XNode) (Maybe String)
mbGetAttrValue String
"property" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< forall (a :: * -> * -> *).
ArrowXml a =>
String -> (String -> Bool) -> a (NTree XNode) (NTree XNode)
hasAttrValue String
"property" (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"dcterms:") -< NTree XNode
x
String
c <- forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text -< NTree XNode
x
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (, String -> DateValue
DateValue String
c) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String -> Maybe DateEvent
dateEventFromString Maybe String
e
sourceP :: (ArrowXml a) => a (NTree XNode) (Maybe String)
sourceP :: forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (Maybe String)
sourceP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (Maybe String)
mbQTagText forall a b. (a -> b) -> a -> b
$ String -> QName
dcName String
"source"
typeP :: (ArrowXml a) => a (NTree XNode) (Maybe String)
typeP :: forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (Maybe String)
typeP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (Maybe String)
mbQTagText forall a b. (a -> b) -> a -> b
$ String -> QName
dcName String
"type"
coverageP :: (ArrowXml a) => a (NTree XNode) String
coverageP :: forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
coverageP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"coverage") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text
descriptionP :: (ArrowXml a) => a (NTree XNode) Description
descriptionP :: forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) Description
descriptionP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"description") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
proc NTree XNode
x -> do
Maybe String
l <- forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (Maybe String)
mbGetQAttrValue (String -> QName
xmlName String
"lang") -< NTree XNode
x
String
c <- forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text -< NTree XNode
x
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Maybe String -> String -> Description
Description Maybe String
l String
c
formatP :: (ArrowXml a) => a (NTree XNode) String
formatP :: forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
formatP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"format") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text
publisherP :: (ArrowXml a) => a (NTree XNode) String
publisherP :: forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
publisherP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"publisher") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text
relationP :: (ArrowXml a) => a (NTree XNode) String
relationP :: forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
relationP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"relation") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text
rightsP :: (ArrowXml a) => a (NTree XNode) String
rightsP :: forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
rightsP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"rights") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text
subjectP :: (ArrowXml a) => a (NTree XNode) String
subjectP :: forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
subjectP = forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
dcName String
"subject") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
text
metadataP :: (ArrowXml a) => [Refinement] -> a (NTree XNode) Metadata
metadataP :: forall (a :: * -> * -> *).
ArrowXml a =>
[Refinement] -> a (NTree XNode) Metadata
metadataP [Refinement]
refinements =
forall (a :: * -> * -> *).
ArrowXml a =>
QName -> a (NTree XNode) (NTree XNode)
atQTag (String -> QName
opfName String
"metadata") forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ( forall (a :: * -> * -> *) b c. WrappedArrow a b c -> a b c
unwrapArrow forall a b. (a -> b) -> a -> b
$ [Identifier]
-> [Title]
-> [String]
-> [Creator]
-> [Creator]
-> Map DateEvent DateValue
-> Maybe String
-> Maybe String
-> [String]
-> [Description]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> Metadata
Metadata
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) Identifier
idP forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>. forall a b. (a -> b) -> [a] -> [b]
map ([Refinement] -> Identifier -> Identifier
refineIdentifier [Refinement]
refinements))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (String, Title)
titleP forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>. forall a b. (a -> b) -> [a] -> [b]
map ([Refinement] -> (String, Title) -> Title
refineTitle [Refinement]
refinements))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
langP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *).
ArrowXml a =>
String -> a (NTree XNode) (String, Creator)
creatorP String
"contributor" forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>.
forall a b. (a -> b) -> [a] -> [b]
map ([Refinement] -> (String, Creator) -> Creator
refineCreator [Refinement]
refinements))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *).
ArrowXml a =>
String -> a (NTree XNode) (String, Creator)
creatorP String
"creator" forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>.
forall a b. (a -> b) -> [a] -> [b]
map ([Refinement] -> (String, Creator) -> Creator
refineCreator [Refinement]
refinements))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA [forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (Maybe (DateEvent, DateValue))
dateElemP, forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (Maybe (DateEvent, DateValue))
dateMetaP]))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (Maybe String)
sourceP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) (Maybe String)
typeP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
coverageP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *).
ArrowXml a =>
a (NTree XNode) Description
descriptionP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
formatP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
publisherP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
relationP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
rightsP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *). ArrowXml a => a (NTree XNode) String
subjectP)
)