module Data.Object
( Object (..)
, FromObject (..)
, ToObject (..)
, FromScalar (..)
, ToScalar (..)
, oLookup
) where
import qualified Data.ByteString as B
import Data.ByteString.Class
import Control.Arrow
import Data.Time.Calendar
data Object =
Mapping [(B.ByteString, Object)]
| Sequence [Object]
| Scalar B.ByteString
deriving (Show)
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 String where
toScalar = toStrictByteString
instance FromScalar String where
fromScalar = return . fromStrictByteString
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
readM :: (Read r, Monad m) => String -> m r
readM s = case reads s of
((x, _):_) -> return x
_ -> fail $ "Unable to read: " ++ s
instance ToScalar Day where
toScalar = toStrictByteString . show
instance ToObject Day where
toObject = toObject . toScalar
instance FromScalar Day where
fromScalar bs = do
let s = fromStrictByteString bs
if length s /= 10
then fail ("Invalid day: " ++ s)
else do
y <- readM $ take 4 s
m <- readM $ take 2 $ drop 5 s
d <- readM $ take 2 $ drop 8 s
return $ fromGregorian y m d
instance FromObject Day where
fromObject o = fromObject o >>= fromScalar