module HBooru.Parsers.FieldParsers where
import Control.Applicative
import Control.Exception.Base (Exception)
import Control.Monad
import Control.Monad.Error
import Data.Maybe
import Data.Monoid
import Data.Typeable
import Data.Vinyl
import HBooru.Types
import Prelude
import Text.Read (readMaybe)
import Text.XML.HXT.Core hiding (mkName, (<+>))
import Data.Vinyl.TyFun
newtype E = E String deriving (Show, Eq, Typeable)
instance Exception E where
type ParseArrow cat = (Functor (cat XmlTree), ArrowXml cat)
type Field cat s = cat XmlTree (Parse (R '[s]))
readAttr ∷ (ArrowXml cat, Read (App ElF s), Functor (cat XmlTree)) ⇒ String
→ sing s → Field cat s
readAttr s f = readAttrWith s f readMaybe
readAttrWith ∷ (ArrowXml cat, Functor (cat XmlTree)) ⇒ String → sing s
→ (String → Maybe (App ElF s)) → Field cat s
readAttrWith s f r = readCustom s f (\x → handler x $ r x)
where
handler inp Nothing = throwError . PF $ mconcat [s, ": '", inp, "'"]
handler _ (Just x) = return x
readCustom ∷ (ArrowXml cat, Functor (cat XmlTree)) ⇒ String
→ sing s → (String → Parse (App ElF s)) → Field cat s
readCustom s f h = fmap (f =:) . h <$> getAttrValue s
readNormalAttr ∷ (ArrowXml cat, (App ElF s) ~ String, Functor (cat XmlTree))
⇒ String → sing s → Field cat s
readNormalAttr s f = return . (f =:) <$> getAttrValue s
heightA ∷ ParseArrow cat ⇒ Field cat "height"
heightA = readAttr "height" height
scoreA ∷ ParseArrow cat ⇒ Field cat "score"
scoreA = readAttr "score" score
file_urlA ∷ ParseArrow cat ⇒ Field cat "file_url"
file_urlA = readNormalAttr "file_url" file_url
parent_idA ∷ ParseArrow cat ⇒ Field cat "parent_id"
parent_idA = readCustom "parent_id" parent_id handler
where
handler = return . readMaybe
sample_urlA ∷ ParseArrow cat ⇒ Field cat "sample_url"
sample_urlA = readNormalAttr "sample_url" sample_url
sample_widthA ∷ ParseArrow cat ⇒ Field cat "sample_width"
sample_widthA = readAttr "sample_width" sample_width
sample_heightA ∷ ParseArrow cat ⇒ Field cat "sample_height"
sample_heightA = readAttr "sample_height" sample_height
preview_urlA ∷ ParseArrow cat ⇒ Field cat "preview_url"
preview_urlA = readNormalAttr "preview_url" preview_url
ratingA ∷ ParseArrow cat ⇒ Field cat "rating"
ratingA = readAttrWith "rating" rating parseRating
tagsA ∷ ParseArrow cat ⇒ Field cat "tags"
tagsA = readCustom "tags" tags (return . parseTags)
idA ∷ ParseArrow cat ⇒ Field cat "id"
idA = readAttr "id" HBooru.Types.id
widthA ∷ ParseArrow cat ⇒ Field cat "width"
widthA = readAttr "width" width
changeA ∷ ParseArrow cat ⇒ Field cat "change"
changeA = readAttr "change" change
md5A ∷ ParseArrow cat ⇒ Field cat "md5"
md5A = readNormalAttr "md5" md5
creator_idA ∷ ParseArrow cat ⇒ Field cat "creator_id"
creator_idA = readAttr "creator_id" creator_id
has_childrenA ∷ ParseArrow cat ⇒ Field cat "has_children"
has_childrenA = readAttrWith "has_children" has_children parseBool
created_atA ∷ ParseArrow cat ⇒ Field cat "created_at"
created_atA = readNormalAttr "created_at" created_at
statusA ∷ ParseArrow cat ⇒ Field cat "status"
statusA = readNormalAttr "status" status
sourceA ∷ ParseArrow cat ⇒ Field cat "source"
sourceA = readNormalAttr "source" source
has_notesA ∷ ParseArrow cat ⇒ Field cat "has_notes"
has_notesA = readAttrWith "has_notes" has_notes (return . parseBool)
has_commentsA ∷ ParseArrow cat ⇒ Field cat "has_comments"
has_commentsA = readAttrWith "has_comments" has_comments (return . parseBool)
preview_widthA ∷ ParseArrow cat ⇒ Field cat "preview_width"
preview_widthA = readAttr "preview_width" preview_width
preview_heightA ∷ ParseArrow cat ⇒ Field cat "preview_height"
preview_heightA = readAttr "preview_height" preview_height
authorA ∷ ParseArrow cat ⇒ Field cat "author"
authorA = readNormalAttr "author" author
actual_preview_heightA ∷ ParseArrow cat ⇒ Field cat "actual_preview_height"
actual_preview_heightA = readAttr "actual_preview_height" actual_preview_height
actual_preview_widthA ∷ ParseArrow cat ⇒ Field cat "actual_preview_width"
actual_preview_widthA = readAttr "actual_preview_width" actual_preview_width
framesA ∷ ParseArrow cat ⇒ Field cat "frames"
framesA = readNormalAttr "frames" frames
frames_pendingA ∷ ParseArrow cat ⇒ Field cat "frames_pending"
frames_pendingA = readNormalAttr "frames_pending" frames_pending
frames_pending_stringA ∷ ParseArrow cat ⇒ Field cat "frames_pending_string"
frames_pending_stringA =
readNormalAttr "frames_pending_string" frames_pending_string
frames_stringA ∷ ParseArrow cat ⇒ Field cat "frames_string"
frames_stringA = readNormalAttr "frames_string" frames_string
is_heldA ∷ ParseArrow cat ⇒ Field cat "is_held"
is_heldA = readAttrWith "is_held" is_held parseBool
is_shown_in_indexA ∷ ParseArrow cat ⇒ Field cat "is_shown_in_index"
is_shown_in_indexA =
readAttrWith "is_shown_in_index" is_shown_in_index parseBool
jpeg_file_sizeA ∷ ParseArrow cat ⇒ Field cat "jpeg_file_size"
jpeg_file_sizeA = readAttr "jpeg_file_size" jpeg_file_size
jpeg_heightA ∷ ParseArrow cat ⇒ Field cat "jpeg_height"
jpeg_heightA = readAttr "jpeg_height" jpeg_height
jpeg_urlA ∷ ParseArrow cat ⇒ Field cat "jpeg_url"
jpeg_urlA = readNormalAttr "jpeg_url" jpeg_url
jpeg_widthA ∷ ParseArrow cat ⇒ Field cat "jpeg_width"
jpeg_widthA = readAttr "jpeg_width" jpeg_width
sample_file_sizeA ∷ ParseArrow cat ⇒ Field cat "sample_file_size"
sample_file_sizeA = readAttr "sample_file_size" sample_file_size
file_sizeA ∷ ParseArrow cat ⇒ Field cat "file_size"
file_sizeA = readAttr "file_size" file_size
parseRating ∷ String → Maybe Rating
parseRating "e" = Just Explicit
parseRating "s" = Just HBooru.Types.Safe
parseRating "q" = Just Questionable
parseRating _ = Nothing
parseTags ∷ String → [Tag]
parseTags = words
parseBool ∷ String → Maybe Bool
parseBool "false" = Just False
parseBool "true" = Just True
parseBool _ = Nothing
infixr 5 <:+>
(<:+>) ∷ Arrow cat ⇒ cat b (Parse (R as))
→ cat b (Parse (R bs))
→ cat b (Parse (R (as ++ bs)))
x <:+> y = arr (uncurry pnd) <<< x &&& y
where
pnd ∷ Parse (R a) → Parse (R b) → Parse (R (a ++ b))
pnd (Left x') _ = Left x'
pnd _ (Left y') = Left y'
pnd (Right x') (Right y') = Right (x' <+> y')