module Test.WebDriver.Common.Profile
( Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..)
, getPref, addPref, deletePref, addExtension, deleteExtension
, ProfileParseError(..) ) where
import Data.Aeson
import Data.Aeson.Types
import Data.Attoparsec.Number (Number(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import Data.Text (Text, pack)
import Data.ByteString (ByteString)
import Data.Fixed
import Data.Ratio
import Data.Int
import Data.Word
import Data.Typeable
import Control.Exception
data Profile b = Profile
{
profileDir :: FilePath
, profileExts :: HS.HashSet FilePath
, profilePrefs :: HM.HashMap Text ProfilePref
}
deriving (Eq, Show)
newtype PreparedProfile b = PreparedProfile ByteString
deriving (Eq, Show, ToJSON, FromJSON)
data ProfilePref = PrefInteger !Integer
| PrefDouble !Double
| PrefString !Text
| PrefBool !Bool
deriving (Eq, Show)
instance ToJSON ProfilePref where
toJSON v = case v of
PrefInteger i -> toJSON i
PrefDouble d -> toJSON d
PrefString s -> toJSON s
PrefBool b -> toJSON b
instance FromJSON ProfilePref where
parseJSON (String s) = return $ PrefString s
parseJSON (Bool b) = return $ PrefBool b
parseJSON (Number (I i)) = return $ PrefInteger i
parseJSON (Number (D d)) = return $ PrefDouble d
parseJSON other = typeMismatch "ProfilePref" other
instance Exception ProfileParseError
newtype ProfileParseError = ProfileParseError String
deriving (Eq, Show, Read, Typeable)
class ToPref a where
toPref :: a -> ProfilePref
instance ToPref Text where
toPref = PrefString
instance ToPref String where
toPref = toPref . pack
instance ToPref Bool where
toPref = PrefBool
instance ToPref Integer where
toPref = PrefInteger
#define I(t) instance ToPref t where toPref = PrefInteger . toInteger
I(Int)
I(Int8)
I(Int16)
I(Int32)
I(Int64)
I(Word)
I(Word8)
I(Word16)
I(Word32)
I(Word64)
instance ToPref Double where
toPref = PrefDouble
instance ToPref Float where
toPref = PrefDouble . realToFrac
instance (Integral a) => ToPref (Ratio a) where
toPref = PrefDouble . realToFrac
instance (HasResolution r) => ToPref (Fixed r) where
toPref = PrefDouble . realToFrac
getPref :: Text -> Profile b -> Maybe ProfilePref
getPref k (Profile _ _ m) = HM.lookup k m
addPref :: ToPref a => Text -> a -> Profile b -> Profile b
addPref k v p = asMap p $ HM.insert k (toPref v)
deletePref :: Text -> Profile b -> Profile b
deletePref k p = asMap p $ HM.delete k
addExtension :: FilePath -> Profile b -> Profile b
addExtension path p = asSet p $ HS.insert path
deleteExtension :: FilePath -> Profile b -> Profile b
deleteExtension path p = asSet p $ HS.delete path
asMap :: Profile b
-> (HM.HashMap Text ProfilePref -> HM.HashMap Text ProfilePref)
-> Profile b
asMap (Profile p hs hm) f = Profile p hs (f hm)
asSet :: Profile b
-> (HS.HashSet FilePath -> HS.HashSet FilePath)
-> Profile b
asSet (Profile p hs hm) f = Profile p (f hs) hm