module Data.Object
( Object
, GenObject (..)
, FromObject (..)
, ToObject (..)
, FromScalar (..)
, ToScalar (..)
, oLookup
) where
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import Data.ByteString.Class
import Control.Arrow
import Data.Time.Calendar
import Safe (readMay)
data GenObject key val =
Mapping [(key, GenObject key val)]
| Sequence [GenObject key val]
| Scalar val
deriving (Show)
type Object = GenObject B.ByteString B.ByteString
class ToObject a where
toObject :: a -> Object
class FromObject a where
fromObject :: Monad m => Object -> m a
class ToObject a => ToScalar a where
toScalar :: a -> B.ByteString
class FromObject a => FromScalar a where
fromScalar :: Monad m => B.ByteString -> m a
bsFromObject :: Monad m => Object -> m B.ByteString
bsFromObject (Scalar s) = return s
bsFromObject _ = fail "Attempt to extract a scalar from non-scalar"
instance ToScalar B.ByteString where
toScalar = id
instance FromScalar B.ByteString where
fromScalar = return
instance ToObject B.ByteString where
toObject = Scalar
instance FromObject B.ByteString where
fromObject = bsFromObject
instance ToScalar BS.ByteString where
toScalar = toLazyByteString
instance FromScalar BS.ByteString where
fromScalar = return . fromLazyByteString
instance ToObject BS.ByteString where
toObject = Scalar . toScalar
instance FromObject BS.ByteString where
fromObject o = fromObject o >>= fromScalar
instance ToScalar String where
toScalar = toLazyByteString
instance FromScalar String where
fromScalar = return . fromLazyByteString
instance ToObject String where
toObject = Scalar . toScalar
instance FromObject String where
fromObject o = fromObject o >>= fromScalar
instance ToObject o => ToObject [o] where
toObject = Sequence . map toObject
instance FromObject o => FromObject [o] where
fromObject (Sequence os) = mapM fromObject os
fromObject _ = fail "Attempt to extract a sequence from non-sequence"
instance (ToScalar bs, ToObject o) => ToObject [(bs, o)] where
toObject = Mapping . map (toScalar *** toObject)
instance (FromScalar bs, FromObject o) => FromObject [(bs, o)] where
fromObject (Mapping pairs) =
mapM (liftPair . (fromScalar *** fromObject)) pairs
fromObject _ = fail "Attempt to extract a mapping from non-mapping"
instance ToObject Object where
toObject = id
instance FromObject Object where
fromObject = return
liftPair :: Monad m => (m a, m b) -> m (a, b)
liftPair (a, b) = do
a' <- a
b' <- b
return (a', b')
oLookup :: (Monad m, Eq a, Show a, FromObject b)
=> a
-> [(a, Object)]
-> m b
oLookup key pairs =
case lookup key pairs of
Nothing -> fail $ "Key not found: " ++ show key
Just x -> fromObject x
instance ToScalar Day where
toScalar = toLazyByteString . show
instance ToObject Day where
toObject = toObject . toScalar
instance FromScalar Day where
fromScalar bs = do
let s = fromLazyByteString bs
if length s /= 10
then fail ("Invalid day: " ++ s)
else do
let x = do
y' <- readMay $ take 4 s
m' <- readMay $ take 2 $ drop 5 s
d' <- readMay $ take 2 $ drop 8 s
return (y', m', d')
case x of
Just (y, m, d) -> return $ fromGregorian y m d
Nothing -> fail $ "Invalid day: " ++ s
instance FromObject Day where
fromObject o = fromObject o >>= fromScalar
instance ToScalar Bool where
toScalar b = toScalar $ if b then "true" else "false"
instance ToObject Bool where
toObject = toObject . toScalar
instance FromScalar Bool where
fromScalar bs =
case fromLazyByteString bs of
"true" -> return True
"false" -> return False
x -> fail $ "Invalid bool value: " ++ x
instance FromObject Bool where
fromObject o = fromObject o >>= fromScalar
instance ToScalar Int where
toScalar = toScalar . show
instance ToObject Int where
toObject = toObject . toScalar
instance FromScalar Int where
fromScalar bs =
case readMay $ fromLazyByteString bs of
Nothing -> fail $ "Invalid integer: " ++ fromLazyByteString bs
Just i -> return i
instance FromObject Int where
fromObject o = fromObject o >>= fromScalar