module Data.Object
(
Object (..)
, StringObject
, TextObject
, Scalar (..)
, ScalarObject
, mapKeys
, mapValues
, mapKeysValues
, mapKeysValuesA
, mapKeysValuesM
, ObjectExtractError (..)
, fromScalar
, fromSequence
, fromMapping
, lookupObject
, lookupScalar
, lookupSequence
, lookupMapping
) where
import Control.Arrow
import Control.Applicative
import Control.Monad (ap, (<=<))
import Prelude hiding (mapM, sequence)
import Data.Foldable hiding (concatMap, concat)
import Data.Traversable
import Data.Monoid
import Control.Exception (Exception)
import Data.Data (Data, Typeable)
import Control.Failure
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.ByteString (ByteString)
data Object key val =
Mapping [(key, Object key val)]
| Sequence [Object key val]
| Scalar val
deriving (Show, Eq, Data, Typeable)
type StringObject = Object String String
type TextObject = Object Text Text
data Scalar = Numeric Rational
| Text Text
| Binary ByteString
| Bool Bool
| Timestamp UTCTime
| Null
type ScalarObject = Object String Scalar
instance Functor (Object key) where
fmap = mapValues
instance Foldable (Object key) where
foldMap f (Scalar v) = f v
foldMap f (Sequence vs) = mconcat $ map (foldMap f) vs
foldMap f (Mapping pairs) = mconcat $ map (foldMap f . snd) pairs
instance Traversable (Object key) where
traverse f (Scalar v) = Scalar <$> f v
traverse f (Sequence vs) = Sequence <$> traverse (traverse f) vs
traverse f (Mapping pairs) =
Mapping <$> traverse (traverse' (traverse f)) pairs
traverse' :: Applicative f => (a -> f b) -> (x, a) -> f (x, b)
traverse' f (x, a) = (,) x <$> f a
joinObj :: Object key (Object key scalar) -> Object key scalar
joinObj (Scalar x) = x
joinObj (Sequence xs) = Sequence (map joinObj xs)
joinObj (Mapping xs) = Mapping (map (second joinObj) xs)
instance Monad (Object key) where
return = Scalar
x >>= f = joinObj . fmap f $ x
instance Applicative (Object key) where
pure = Scalar
(<*>) = ap
mapKeys :: (keyIn -> keyOut) -> Object keyIn val -> Object keyOut val
mapKeys = flip mapKeysValues id
mapValues :: (valIn -> valOut) -> Object key valIn -> Object key valOut
mapValues = mapKeysValues id
mapKeysValues :: (keyIn -> keyOut)
-> (valIn -> valOut)
-> Object keyIn valIn
-> Object keyOut valOut
mapKeysValues _ fv (Scalar v) = Scalar $ fv v
mapKeysValues fk fv (Sequence os)= Sequence $ map (mapKeysValues fk fv) os
mapKeysValues fk fv (Mapping pairs) =
Mapping $ map (fk *** mapKeysValues fk fv) pairs
mapKeysValuesA :: Applicative f
=> (keyIn -> f keyOut)
-> (valIn -> f valOut)
-> Object keyIn valIn
-> f (Object keyOut valOut)
mapKeysValuesA _ fv (Scalar v) = Scalar <$> fv v
mapKeysValuesA fk fv (Sequence os) =
Sequence <$> traverse (mapKeysValuesA fk fv) os
mapKeysValuesA fk fv (Mapping pairs) = Mapping <$>
traverse (uncurry (liftA2 (,)) . (fk *** mapKeysValuesA fk fv)) pairs
mapKeysValuesM :: Monad m
=> (keyIn -> m keyOut)
-> (valIn -> m valOut)
-> Object keyIn valIn
-> m (Object keyOut valOut)
mapKeysValuesM fk fv =
let fk' = WrapMonad . fk
fv' = WrapMonad . fv
in unwrapMonad . mapKeysValuesA fk' fv'
data ObjectExtractError =
ExpectedScalar
| ExpectedSequence
| ExpectedMapping
| MissingKey String
deriving (Typeable, Show)
instance Exception ObjectExtractError
fromScalar :: Failure ObjectExtractError m => Object k v -> m v
fromScalar (Scalar s) = return s
fromScalar _ = failure ExpectedScalar
fromSequence :: Failure ObjectExtractError m
=> Object k v
-> m [Object k v]
fromSequence (Sequence s) = return s
fromSequence _ = failure ExpectedSequence
fromMapping :: Failure ObjectExtractError m
=> Object k v
-> m [(k, Object k v)]
fromMapping (Mapping m) = return m
fromMapping _ = failure ExpectedMapping
lookupObject :: (Show k, Eq k, Failure ObjectExtractError m)
=> k
-> [(k, Object k v)]
-> m (Object k v)
lookupObject k pairs =
case lookup k pairs of
Nothing -> failure $ MissingKey $ show k
Just v -> return v
lookupScalar :: (Show k, Eq k, Failure ObjectExtractError m)
=> k
-> [(k, Object k v)]
-> m v
lookupScalar k = fromScalar <=< lookupObject k
lookupSequence :: (Show k, Eq k, Failure ObjectExtractError m)
=> k
-> [(k, Object k v)]
-> m [Object k v]
lookupSequence k = fromSequence <=< lookupObject k
lookupMapping :: (Show k, Eq k, Failure ObjectExtractError m)
=> k
-> [(k, Object k v)]
-> m [(k, Object k v)]
lookupMapping k = fromMapping <=< lookupObject k