Raw terminology, mapping functions and tests.

GenObject -> Object
Object -> RawObject
To/FromObject -> To/FromRawObject

Also added MonadFail, which adds no functions, but allows specification
that a monad has a sensical fail function.

Data/Object.hs

@@ -18,13 +18,18 @@
 --
 ---------------------------------------------------------
 module Data.Object
-    ( Object
-    , GenObject (..)
-    , FromObject (..)
-    , ToObject (..)
-    , FromScalar (..)
-    , ToScalar (..)
+    ( Object (..)
+    , mapKeys
+    , mapValues
+    , mapKeysValues
+    , RawObject
+    , FromRawObject (..)
+    , ToRawObject (..)
+    , FromRaw (..)
+    , ToRaw (..)
     , oLookup
+    , MonadFail
+    , testSuite
     ) where
 
 import qualified Data.ByteString.Lazy as B
@@ -33,100 +38,155 @@ import Data.ByteString.Class
 import Control.Arrow
 import Data.Time.Calendar
 import Safe (readMay)
+import Control.Applicative
 
-data GenObject key val =
-    Mapping [(key, GenObject key val)]
-    | Sequence [GenObject key val]
+import Test.Framework (testGroup, Test)
+--import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck (testProperty)
+--import Test.HUnit hiding (Test)
+import Test.QuickCheck
+
+class (Functor m, Applicative m, Monad m) => MonadFail m where
+
+instance MonadFail IO where
+instance MonadFail Maybe where
+instance MonadFail [] where
+
+data Object key val =
+    Mapping [(key, Object key val)]
+    | Sequence [Object 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
+    deriving (Show, Eq)
+
+mapKeys :: (key1 -> key2) -> Object key1 val -> Object key2 val
+mapKeys = flip mapKeysValues id
+
+mapValues :: (val1 -> val2) -> Object key val1 -> Object key val2
+mapValues = mapKeysValues id
+
+mapKeysValues :: (key1 -> key2)
+              -> (val1 -> val2)
+              -> Object key1 val1
+              -> Object key2 val2
+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
+
+mapKeysValuesM :: MonadFail m
+               => (key1 -> m key2)
+               -> (val1 -> m val2)
+               -> Object key1 val1
+               -> m (Object key2 val2)
+mapKeysValuesM _ fv (Scalar v) = Scalar <$> fv v
+mapKeysValuesM fk fv (Sequence os)=
+    Sequence <$> mapM (mapKeysValuesM fk fv) os
+mapKeysValuesM fk fv (Mapping pairs) =
+    Mapping <$> mapM (liftPair . (fk *** mapKeysValuesM fk fv)) pairs
+    where
+        liftPair :: Monad m => (m a, m b) -> m (a, b)
+        liftPair (a, b) = do
+            a' <- a
+            b' <- b
+            return $! (a', b')
+
+propMapKeysValuesId :: Object Int Int -> Bool
+propMapKeysValuesId o = mapKeysValues id id o == o
+
+type Raw = B.ByteString
+
+type RawObject = Object Raw Raw
+
+class ToRawObject a where
+    toRawObject :: a -> RawObject
+class FromRawObject a where
+    fromRawObject :: MonadFail m => RawObject -> m a
+
+class ToRawObject a => ToRaw a where
+    toRaw :: a -> B.ByteString
+class FromRawObject a => FromRaw a where
+    fromRaw :: MonadFail m => B.ByteString -> m a
+
+rawFromRawObject :: MonadFail m => RawObject -> m Raw
+rawFromRawObject (Scalar s) = return s
+rawFromRawObject _ = fail "Attempt to extract a scalar from non-scalar"
+
+instance ToRaw Raw where
+    toRaw = id
+instance FromRaw Raw where
+    fromRaw = return
+instance ToRawObject Raw where
+    toRawObject = Scalar
+instance FromRawObject Raw where
+    fromRawObject = rawFromRawObject
+
+instance ToRaw BS.ByteString where
+    toRaw = toLazyByteString
+instance FromRaw BS.ByteString where
+    fromRaw = return . fromLazyByteString
+instance ToRawObject BS.ByteString where
+    toRawObject = Scalar . toRaw
+instance FromRawObject BS.ByteString where
+    fromRawObject o = fromRawObject o >>= fromRaw
+
+instance ToRaw String where
+    toRaw = toLazyByteString
+instance FromRaw String where
+    fromRaw = return . fromLazyByteString
+instance ToRawObject String where
+    toRawObject = Scalar . toRaw
+instance FromRawObject String where
+    fromRawObject o = fromRawObject o >>= fromRaw
+
+instance ToRawObject o => ToRawObject [o] where
+    toRawObject = Sequence . map toRawObject
+instance FromRawObject o => FromRawObject [o] where
+    fromRawObject (Sequence os) = mapM fromRawObject os
+    fromRawObject _ = fail "Attempt to extract a sequence from non-sequence"
+
+instance (ToRaw bs, ToRawObject o) => ToRawObject [(bs, o)] where
+    toRawObject = Mapping . map (toRaw *** toRawObject)
+instance (FromRaw bs, FromRawObject o) => FromRawObject [(bs, o)] where
+    fromRawObject (Mapping pairs) =
+        mapM (liftPair . (fromRaw *** fromRawObject)) pairs
+    fromRawObject _ = fail "Attempt to extract a mapping from non-mapping"
+
+instance ToRawObject RawObject where
+    toRawObject = id
+instance FromRawObject RawObject where
+    fromRawObject = return
+
+instance (ToRaw key, ToRaw value) => ToRawObject (Object key value) where
+    toRawObject = mapKeysValues toRaw toRaw
+instance (FromRaw key, FromRaw value) => FromRawObject (Object key value) where
+    fromRawObject = mapKeysValuesM fromRaw fromRaw
+
+propToFromRawObject :: Object Int Int -> Bool
+propToFromRawObject o = fromRawObject (toRawObject o) == Just o
 
 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)
+oLookup :: (MonadFail m, Eq a, Show a, FromRawObject b)
         => a -- ^ key
-        -> [(a, Object)]
+        -> [(a, RawObject)]
         -> m b
 oLookup key pairs =
     case lookup key pairs of
         Nothing -> fail $ "Key not found: " ++ show key
-        Just x -> fromObject x
+        Just x -> fromRawObject x
 
 -- instances
 
-instance ToScalar Day where
-    toScalar = toLazyByteString . show
-instance ToObject Day where
-    toObject = toObject . toScalar
-instance FromScalar Day where
-    fromScalar bs = do
+instance ToRaw Day where
+    toRaw = toLazyByteString . show
+instance ToRawObject Day where
+    toRawObject = toRawObject . toRaw
+instance FromRaw Day where
+    fromRaw bs = do
         let s = fromLazyByteString bs
         if length s /= 10
             then fail ("Invalid day: " ++ s)
@@ -139,30 +199,43 @@ instance FromScalar Day where
                 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 =
+instance FromRawObject Day where
+    fromRawObject o = fromRawObject o >>= fromRaw
+
+instance ToRaw Bool where
+    toRaw b = toRaw $ if b then "true" else "false"
+instance ToRawObject Bool where
+    toRawObject = toRawObject . toRaw
+instance FromRaw Bool where
+    fromRaw 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 =
+instance FromRawObject Bool where
+    fromRawObject o = fromRawObject o >>= fromRaw
+
+instance ToRaw Int where
+    toRaw = toRaw . show
+instance ToRawObject Int where
+    toRawObject = toRawObject . toRaw
+instance FromRaw Int where
+    fromRaw 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
+instance FromRawObject Int where
+    fromRawObject o = fromRawObject o >>= fromRaw
+
+testSuite :: Test
+testSuite = testGroup "Data.Object"
+    [ testProperty "propMapKeysValuesId" propMapKeysValuesId
+    , testProperty "propToFromRawObject" propToFromRawObject
+    ]
+
+instance Arbitrary (Object Int Int) where
+    coarbitrary = undefined
+    arbitrary = oneof [arbS, arbL, arbM] where
+        arbS = Scalar `fmap` (arbitrary :: Gen Int)
+        arbL = Sequence `fmap` vector 2
+        arbM = Mapping `fmap` vector 1

Setup.lhs

@@ -2,6 +2,10 @@
 
 > module Main where
 > import Distribution.Simple
+> import System.Cmd (system)
 
 > main :: IO ()
-> main = defaultMain
+> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' })
+
+> runTests' :: a -> b -> c -> d -> IO ()
+> runTests' _ _ _ _ = system "runhaskell Test.hs" >> return ()

Test.hs

@@ -0,0 +1,8 @@
+import Test.Framework (defaultMain)
+
+import qualified Data.Object
+
+main :: IO ()
+main = defaultMain
+    [ Data.Object.testSuite
+    ]

data-object.cabal

@@ -1,5 +1,5 @@
 name:            data-object
-version:         0.0.2
+version:         0.2.0
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>