module HBooru.Types where
import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Exception
import Control.Monad.Error
import Data.Proxy
import GHC.TypeLits (Symbol)
import Data.Vinyl
import Data.Vinyl.TH
import Network.HTTP.Conduit (HttpException(..))
import Prelude
import Text.XML.HXT.Core hiding (mkName, (<+>))
type Tag = String
class DataFormat a where
data XML = XML deriving Show
data JSON = JSON deriving Show
instance DataFormat XML where
instance DataFormat JSON where
class Response r ⇒ CoerceResponse x r | x → r, r → x where
toResponse ∷ x → String → r
fromResponse ∷ r → x
instance CoerceResponse XML XMLResponse where
toResponse _ = XMLResponse
fromResponse _ = XML
instance CoerceResponse JSON JSONResponse where
toResponse _ = JSONResponse
fromResponse _ = JSON
class (Site s, DataFormat r) ⇒ PostParser s r where
type ImageTy s r
parseResponse ∷ CoerceResponse r r' ⇒ s → r' → [ImageTy s r]
class (Site s, DataFormat r) ⇒ Counted s r where
parseCount ∷ CoerceResponse r r' ⇒ s → r' → Integer
class (Counted s r, Postable s r) ⇒ PostablePaged s r where
postUrlPaged ∷ s → r → [Tag] → Integer → String
postUrlPaged s r ts i = postUrl s r ts ++ "&pid=" ++ show i
class PostParser s r ⇒ Postable s r where
postUrl ∷ s → r → [Tag] → String
hardLimit ∷ s → r → Limit
class Site s where
data Rating = Safe | Questionable | Explicit deriving (Show, Eq)
data Limit = NoLimit | Limit Integer deriving (Show, Eq)
data XMLResponse = XMLResponse String deriving Show
data JSONResponse = JSONResponse String deriving Show
class Response r where
getResponse ∷ r → String
instance Response XMLResponse where
getResponse (XMLResponse x) = x
instance Response JSONResponse where
getResponse (JSONResponse x) = x
instance Functor (LA XmlTree) where
fmap f (LA g) = LA $ fmap fmap fmap f g
bA ∷ ArrowApply cat ⇒ cat c' b → (b → cat c' c) → cat c' c
bA mx f = (arr (\a -> mx >>> arr (\x -> (f x, a)) >>> app) &&& arr id) >>> app
instance Applicative (LA XmlTree) where
pure x = LA . const $ return x
(<*>) = ap
instance Monad (LA XmlTree) where
return = pure
(>>=) = bA
newtype ParseFailure = PF String deriving (Show, Eq)
instance Error ParseFailure where
noMsg = PF noMsg
strMsg = PF . strMsg
type Parse = Either ParseFailure
data RealWorldExcs = Network HttpException
| IOE IOException
| SomethingElse String
deriving (Show)
instance Error RealWorldExcs where
noMsg = SomethingElse noMsg
strMsg = SomethingElse . strMsg
type ExcIO a = ErrorT RealWorldExcs IO a
makeUniverse' ''Symbol "ElF"
semantics ''ElF [ [t| "height" |] :~> [t| Integer |]
, [t| "score" |] :~> [t| Integer |]
, [t| "file_url" |] :~> [t| String |]
, [t| "parent_id" |] :~> [t| Maybe Integer |]
, [t| "sample_url" |] :~> [t| String |]
, [t| "sample_width" |] :~> [t| Integer |]
, [t| "sample_height" |] :~> [t| Integer |]
, [t| "preview_url" |] :~> [t| String |]
, [t| "rating" |] :~> [t| Rating |]
, [t| "tags" |] :~> [t| [Tag] |]
, [t| "id" |] :~> [t| Integer |]
, [t| "width" |] :~> [t| Integer |]
, [t| "change" |] :~> [t| Int |]
, [t| "md5" |] :~> [t| String |]
, [t| "creator_id" |] :~> [t| Integer |]
, [t| "has_children" |] :~> [t| Bool |]
, [t| "created_at" |] :~> [t| String |]
, [t| "status" |] :~> [t| String |]
, [t| "source" |] :~> [t| String |]
, [t| "has_notes" |] :~> [t| Maybe Bool |]
, [t| "has_comments" |] :~> [t| Maybe Bool |]
, [t| "preview_width" |] :~> [t| Integer |]
, [t| "preview_height" |] :~> [t| Integer |]
, [t| "author" |] :~> [t| String |]
, [t| "frames" |] :~> [t| String |]
, [t| "frames_pending" |] :~> [t| String |]
, [t| "frames_pending_string" |] :~> [t| String |]
, [t| "frames_string" |] :~> [t| String |]
, [t| "is_held" |] :~> [t| Bool |]
, [t| "is_shown_in_index" |] :~> [t| Bool |]
, [t| "jpeg_file_size" |] :~> [t| Integer |]
, [t| "jpeg_height" |] :~> [t| Integer |]
, [t| "jpeg_url" |] :~> [t| String |]
, [t| "jpeg_width" |] :~> [t| Integer |]
, [t| "sample_file_size" |] :~> [t| Integer |]
, [t| "actual_preview_height" |] :~> [t| Integer |]
, [t| "actual_preview_width" |] :~> [t| Integer |]
, [t| "file_size" |] :~> [t| Integer |]
]
type R a = PlainRec ElF a
type PR a = Parse (R a)
height ∷ Proxy "height"
height = Proxy
score ∷ Proxy "score"
score = Proxy
file_url ∷ Proxy "file_url"
file_url = Proxy
parent_id ∷ Proxy "parent_id"
parent_id = Proxy
sample_url ∷ Proxy "sample_url"
sample_url = Proxy
sample_width ∷ Proxy "sample_width"
sample_width = Proxy
sample_height ∷ Proxy "sample_height"
sample_height = Proxy
preview_url ∷ Proxy "preview_url"
preview_url = Proxy
rating ∷ Proxy "rating"
rating = Proxy
tags ∷ Proxy "tags"
tags = Proxy
id ∷ Proxy "id"
id = Proxy
width ∷ Proxy "width"
width = Proxy
change ∷ Proxy "change"
change = Proxy
md5 ∷ Proxy "md5"
md5 = Proxy
creator_id ∷ Proxy "creator_id"
creator_id = Proxy
has_children ∷ Proxy "has_children"
has_children = Proxy
created_at ∷ Proxy "created_at"
created_at = Proxy
status ∷ Proxy "status"
status = Proxy
source ∷ Proxy "source"
source = Proxy
has_notes ∷ Proxy "has_notes"
has_notes = Proxy
has_comments ∷ Proxy "has_comments"
has_comments = Proxy
preview_width ∷ Proxy "preview_width"
preview_width = Proxy
preview_height ∷ Proxy "preview_height"
preview_height = Proxy
author ∷ Proxy "author"
author = Proxy
frames ∷ Proxy "frames"
frames = Proxy
frames_pending ∷ Proxy "frames_pending"
frames_pending = Proxy
frames_pending_string ∷ Proxy "frames_pending_string"
frames_pending_string = Proxy
frames_string ∷ Proxy "frames_string"
frames_string = Proxy
is_held ∷ Proxy "is_held"
is_held = Proxy
is_shown_in_index ∷ Proxy "is_shown_in_index"
is_shown_in_index = Proxy
jpeg_file_size ∷ Proxy "jpeg_file_size"
jpeg_file_size = Proxy
jpeg_height ∷ Proxy "jpeg_height"
jpeg_height = Proxy
jpeg_url ∷ Proxy "jpeg_url"
jpeg_url = Proxy
jpeg_width ∷ Proxy "jpeg_width"
jpeg_width = Proxy
sample_file_size ∷ Proxy "sample_file_size"
sample_file_size = Proxy
actual_preview_height ∷ Proxy "actual_preview_height"
actual_preview_height = Proxy
actual_preview_width ∷ Proxy "actual_preview_width"
actual_preview_width = Proxy
file_size ∷ Proxy "file_size"
file_size = Proxy