Permalink
Browse files

Convenience converters and better testing

  • Loading branch information...
1 parent 4de09dc commit ba50957dffe7bd81bcde0ef664b8f989bf87c484 @snoyberg committed Dec 15, 2009
Showing with 169 additions and 80 deletions.
  1. +67 −0 Data/Object/Base.hs
  2. +3 −15 Data/Object/Scalar.hs
  3. +96 −24 Data/Object/Text.hs
  4. +3 −41 runtests.hs
View
@@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverlappingInstances #-}
---------------------------------------------------------
--
-- Module : Data.Object.Base
@@ -40,6 +41,9 @@ module Data.Object.Base
, mapKeysValues
, mapKeysValuesA
, mapKeysValuesM
+ -- * Convert entires objects
+ , convertObject
+ , convertObjectM
-- * Extracting underlying values
, ObjectExtractError (..)
, fromScalar
@@ -51,6 +55,17 @@ module Data.Object.Base
-- ** Wrapping 'FromObject'
, FromObjectException (..)
, fromObjectWrap
+ -- * Common object conversions
+ , sTO
+ , sFO
+ , lTO
+ , lFO
+ , mTO
+ , mFO
+ , olTO
+ , olFO
+ , omTO
+ , omFO
-- * Helper functions
, lookupObject
) where
@@ -162,6 +177,16 @@ mapKeysValuesM fk fv =
fv' = WrapMonad . fv
in unwrapMonad . mapKeysValuesA fk' fv'
+convertObject :: (ConvertSuccess k k', ConvertSuccess v v')
+ => Object k v
+ -> Object k' v'
+convertObject = mapKeysValues cs cs
+
+convertObjectM :: (ConvertAttempt k k', ConvertAttempt v v')
+ => Object k v
+ -> Attempt (Object k' v')
+convertObjectM = mapKeysValuesM ca ca
+
-- | An error value returned when an unexpected node is encountered, eg you
-- were expecting a 'Scalar' and found a 'Mapping'.
data ObjectExtractError =
@@ -333,6 +358,48 @@ fromObjectWrap :: (FromObject x k y, MonadFailure FromObjectException m)
-> m x
fromObjectWrap = attempt (failure . FromObjectException) return . fromObject
+sTO :: ConvertSuccess v v' => v -> Object k v'
+sTO = Scalar . cs
+
+sFO :: ConvertAttempt v' v => Object k v' -> Attempt v
+sFO = ca <=< fromScalar
+
+lTO :: ConvertSuccess v v' => [v] -> Object k v'
+lTO = Sequence . map (Scalar . cs)
+
+lFO :: ConvertAttempt v' v => Object k v' -> Attempt [v]
+lFO = mapM (ca <=< fromScalar) <=< fromSequence
+
+mTO :: (ConvertSuccess k k', ConvertSuccess v v')
+ => [(k, v)]
+ -> Object k' v'
+mTO = Mapping . map (cs *** Scalar . cs)
+
+mFO :: (ConvertAttempt k' k, ConvertAttempt v' v)
+ => Object k' v'
+ -> Attempt [(k, v)]
+mFO =
+ mapM (runKleisli (Kleisli ca *** Kleisli sFO))
+ <=< fromMapping
+
+olTO :: ToObject x k v => [x] -> Object k v
+olTO = Sequence . map toObject
+
+olFO :: FromObject x k v => Object k v -> Attempt [x]
+olFO = mapM fromObject <=< fromSequence
+
+omTO :: (ConvertSuccess k' k, ToObject x k v)
+ => [(k', x)]
+ -> Object k v
+omTO = Mapping . map (cs *** toObject)
+
+omFO :: (ConvertAttempt k k', FromObject x k v)
+ => Object k v
+ -> Attempt [(k', x)]
+omFO =
+ mapM (runKleisli (Kleisli ca *** Kleisli fromObject))
+ <=< fromMapping
+
-- | An equivalent of 'lookup' to deal specifically with maps of 'Object's. In
-- particular, it will:
--
View
@@ -38,8 +38,6 @@ data Scalar = Numeric Rational
type ScalarObject = Object String Scalar
-instance ConvertAttempt Scalar Text where
- convertAttempt = return . convertSuccess
instance ConvertSuccess Scalar Text where
convertSuccess (Numeric n) = convertSuccess $ show n
convertSuccess (Text t) = t
@@ -51,20 +49,10 @@ instance ConvertSuccess Scalar Text where
convertSuccess $ formatTime defaultTimeLocale "%FT%XZ" t
convertSuccess Null = convertSuccess empty
-instance ConvertAttempt Text Scalar where
- convertAttempt = return . convertSuccess
+{- FIXME write a real conversion here
instance ConvertSuccess Text Scalar where
- convertSuccess = Text -- FIXME this should be more intelligent
-
-instance ToObject (Object String Scalar) Text Text where
- toObject = mapKeysValues convertSuccess convertSuccess
-instance FromObject (Object String Scalar) Text Text where
- fromObject = return . toObject
-
-instance ToObject (Object Text Text) String Scalar where
- toObject = mapKeysValues convertSuccess convertSuccess
-instance FromObject (Object Text Text) String Scalar where
- fromObject = return . toObject
+ convertSuccess = Text
+-}
-- | 'toObject' specialized for 'ScalarObject's
toScalarObject :: ToObject a String Scalar => a -> ScalarObject
View
@@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
---------------------------------------------------------
--
@@ -22,6 +23,9 @@ module Data.Object.Text
, fromTextObject
, Text
, module Data.Object.Base
+#if TEST
+ , testSuite
+#endif
) where
import Data.Object.Base
@@ -31,19 +35,22 @@ import Data.Attempt
import Data.Convertible.Text
import Data.Time.Calendar
-import Data.Ratio (Ratio)
-
-import Control.Monad ((<=<))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
+#if TEST
+import Test.Framework (testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck (testProperty)
+import Test.HUnit hiding (Test)
+import Test.QuickCheck
+
+import Control.Arrow ((***))
+#endif
+
-- | 'Object's with keys and values of type 'Text'.
type TextObject = Object Text Text
-instance ToObject Text Text Text where
- toObject = Scalar
-instance FromObject Text Text Text where
- fromObject = fromScalar
-- | 'toObject' specialized for 'TextObject's
toTextObject :: ToObject a Text Text => a -> TextObject
@@ -54,36 +61,101 @@ fromTextObject :: FromObject a Text Text => TextObject -> Attempt a
fromTextObject = fromObject
instance ToObject (Object String String) Text Text where
- toObject = mapKeysValues convertSuccess convertSuccess
+ toObject = convertObject
instance ToObject String Text Text where
- toObject = Scalar . cs
+ toObject = sTO
instance ToObject Day Text Text where
- toObject = Scalar . convertSuccess
+ toObject = sTO
instance ToObject Int Text Text where
- toObject = Scalar . convertSuccess
-instance ToObject (Ratio Integer) Text Text where
- toObject = Scalar . convertSuccess
+ toObject = sTO
+instance ToObject Rational Text Text where
+ toObject = sTO
instance ToObject Bool Text Text where
- toObject = Scalar . convertSuccess
+ toObject = sTO
instance FromObject String Text Text where
- fromObject = convertAttempt <=< fromScalar
+ fromObject = sFO
instance FromObject Day Text Text where
- fromObject = convertAttempt <=< fromScalar
+ fromObject = sFO
instance FromObject Int Text Text where
- fromObject = convertAttempt <=< fromScalar
-instance FromObject (Ratio Integer) Text Text where
- fromObject = convertAttempt <=< fromScalar
+ fromObject = sFO
+instance FromObject Rational Text Text where
+ fromObject = sFO
instance FromObject Bool Text Text where
- fromObject = convertAttempt <=< fromScalar
+ fromObject = sFO
instance ToObject BL.ByteString Text Text where
- toObject = Scalar . convertSuccess
+ toObject = sTO
instance FromObject BL.ByteString Text Text where
- fromObject = fmap convertSuccess . fromScalar
+ fromObject = sFO
instance ToObject BS.ByteString Text Text where
- toObject = Scalar . convertSuccess
+ toObject = sTO
instance FromObject BS.ByteString Text Text where
- fromObject = fmap convertSuccess . fromScalar
+ fromObject = sFO
+
+#if TEST
+testSuite :: Test
+testSuite = testGroup "Data.Object.Text"
+ [ testProperty "propMapKeysValuesId" propMapKeysValuesId
+ , testProperty "propToFromTextObject" propToFromTextObject
+ , testProperty "propStrings" propStrings
+ , testCase "autoScalar" autoScalar
+ , testCase "autoMapping" autoMapping
+ ]
+
+propMapKeysValuesId :: Object Int Int -> Bool
+propMapKeysValuesId o = mapKeysValues id id o == o
+
+-- FIXME consider making something automatic, though unlikely
+instance FromObject (Object Int Int) Text Text where
+ fromObject = convertObjectM
+instance ToObject (Object Int Int) Text Text where
+ toObject = convertObject
+
+propToFromTextObject :: Object Int Int -> Bool
+propToFromTextObject o = fa (fromTextObject (toTextObject o)) == Just o
+
+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
+
+instance Arbitrary Char where
+ coarbitrary = undefined
+ arbitrary = elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']
+
+propStrings :: String -> Bool
+propStrings s = fa (sFO $ (sTO s :: TextObject)) == Just s
+
+autoScalar :: Assertion
+autoScalar = do
+ let t :: Text
+ t = cs "This is some text"
+ Scalar t @=? toTextObject t
+
+autoMapping :: Assertion
+autoMapping = do
+ let dummy = [("foo", "FOO"), ("bar", "BAR"), ("five", "5")]
+ expected :: TextObject
+ expected = Mapping $ map (cs *** Scalar . cs) dummy
+ let test' :: (ConvertSuccess String a,
+ ConvertSuccess a Text,
+ ConvertSuccess Text a,
+ FromObject a Text Text,
+ Eq a,
+ Show a)
+ => a -> Assertion
+ test' a = do
+ let dummy' = map (cs *** cs) dummy `asTypeOf` [(a, a)]
+ dummy'' = mTO dummy' :: TextObject
+ dummy'' @?= expected
+ Just dummy' @=? fa (omFO expected)
+ test' (undefined :: String)
+ test' (undefined :: Text)
+ test' (undefined :: BS.ByteString)
+ test' (undefined :: BL.ByteString)
+#endif
View
@@ -2,49 +2,11 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-import Data.Object.Text
-import Data.Attempt
-import Data.Convertible.Text
+import Test.Framework (defaultMain)
-import Test.Framework (defaultMain, testGroup, Test)
---import Test.Framework.Providers.HUnit
-import Test.Framework.Providers.QuickCheck (testProperty)
---import Test.HUnit hiding (Test)
-import Test.QuickCheck
+import qualified Data.Object.Text
main :: IO ()
main = defaultMain
- [ testSuite
+ [ Data.Object.Text.testSuite
]
-
-testSuite :: Test
-testSuite = testGroup "Data.Object"
- [ testProperty "propMapKeysValuesId" propMapKeysValuesId
- , testProperty "propToFromTextObject" propToFromTextObject
- , testProperty "propStrings" propStrings
- ]
-
-propMapKeysValuesId :: Object Int Int -> Bool
-propMapKeysValuesId o = mapKeysValues id id o == o
-
-instance FromObject (Object Int Int) Text Text where
- fromObject = mapKeysValuesM convertAttempt convertAttempt
-instance ToObject (Object Int Int) Text Text where
- toObject = mapKeysValues convertSuccess convertSuccess
-
-propToFromTextObject :: Object Int Int -> Bool
-propToFromTextObject o = fa (fromTextObject (toTextObject o)) == Just o
-
-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
-
-instance Arbitrary Char where
- coarbitrary = undefined
- arbitrary = elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']
-
-propStrings :: String -> Bool
-propStrings s = fa (fromTextObject $ toTextObject s) == Just s

0 comments on commit ba50957

Please sign in to comment.