{-# LANGUAGE Arrows #-}

-- | Parsing for the metadata section of the OPF Package XML Document
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"))  -- An attr in epub2
   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


{- Since creators and contributors have the same exact XML structure,
   this arrow is used to get either of them
-}
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)
      )