diff --git a/Data/Object.hs b/Data/Object.hs --- a/Data/Object.hs +++ b/Data/Object.hs @@ -1,168 +1,10 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverlappingInstances #-} ---------------------------------------------------------- --- --- Module : Data.Object --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- These objects show up in different places, eg JSON, Yaml. --- By providing a representation in a separate repository, --- other libraries can share a single representation of --- these structures. --- ---------------------------------------------------------- +-- | Imports all instances provided in this package. module Data.Object - ( Object - , GenObject (..) - , FromObject (..) - , ToObject (..) - , FromScalar (..) - , ToScalar (..) - , oLookup + ( module Data.Object.Base ) 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 -- ^ key - -> [(a, Object)] - -> m b -oLookup key pairs = - case lookup key pairs of - Nothing -> fail $ "Key not found: " ++ show key - Just x -> fromObject x - --- instances - -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 +import Data.Object.Base -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 +import Data.Object.String () +import Data.Object.Text () +import Data.Object.Scalar () diff --git a/Data/Object/Base.hs b/Data/Object/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Object/Base.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} +--------------------------------------------------------- +-- +-- Module : Data.Object.Base +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- These objects show up in different places, eg JSON, Yaml. +-- By providing a representation in a separate repository, +-- other libraries can share a single representation of +-- these structures. +-- +--------------------------------------------------------- + +-- | The core of this package is the 'Object' data type, which is used for +-- handling scalars, sequences and mappings in a nested manner. This +-- is the same structure used in JSON or Yaml data. +-- +-- The 'Object' data type is polymorphic in its keys and values. Submodules +-- within this package provide more concrete datatypes, such as a 'String' +-- 'Object' and a specialized scalar type. +-- +-- Besides the 'Object' data type, there are utility functions and type classes +-- for converting objects around. Care has been taken to avoid any overloaded +-- instances for these type classes. +module Data.Object.Base + ( -- * Object data type + Object (..) + -- * Basic mapping of keys and values + , mapKeys + , mapValues + , mapKeysValues + , mapKeysValuesA + , mapKeysValuesM + -- * Convert entires objects + , convertObject + , convertObjectM + -- * Extracting underlying values + , ObjectExtractError (..) + , fromScalar + , fromSequence + , fromMapping + -- * Common object conversions + , sTO + , sFO + , lTO + , lFO + , mTO + , mFO + , olTO + , olFO + , omTO + , omFO + -- * Automatic deriving of instances + , deriveSuccessConvs + -- * Helper functions + , lookupObject + -- * Re-export + , module Data.Convertible.Text + ) 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 Data.Generics +import qualified Safe.Failure as A +import Control.Exception (Exception) +import Data.Attempt + +import Data.Convertible.Text +import Language.Haskell.TH + +-- | Can represent nested values as scalars, sequences and mappings. A +-- sequence is synonymous with a list, while a mapping is synonymous with a +-- list of pairs. +-- +-- Note that instances of standard library type classes for this data type +-- leave the key untouched while altering the value. For example, the 'Functor' +-- instance defines 'fmap' to be synonymous with 'mapValues'. +data Object key val = + Mapping [(key, Object key val)] + | Sequence [Object key val] + | Scalar val + deriving (Show, Eq, Data, Typeable) + +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 + +-- It would be nice if there were an "instance Traversable ((,) a)", but I +-- won't make an orphan instance simply for convenience. Instead: +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 + +-- | Apply some conversion to the keys of an 'Object', leaving the values +-- unchanged. +mapKeys :: (keyIn -> keyOut) -> Object keyIn val -> Object keyOut val +mapKeys = flip mapKeysValues id + +-- | Apply some conversion to the values of an 'Object', leaving the keys +-- unchanged. This is equivalent to 'fmap'. +mapValues :: (valIn -> valOut) -> Object key valIn -> Object key valOut +mapValues = mapKeysValues id + +-- | Apply a conversion to both the keys and values of an 'Object'. +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 + +-- | Apply an 'Applicative' conversion to both the keys and values of an +-- 'Object'. +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 + +-- | The same as 'mapKeysValuesA', but using a 'Monad' since some people are +-- more comfortable with 'Monad's and not all 'Monad's are 'Applicative'. +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' + +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 = + ExpectedScalar + | ExpectedSequence + | ExpectedMapping + deriving (Typeable, Show) +instance Exception ObjectExtractError + +-- | Extra a scalar from the input, failing if the input is a sequence or +-- mapping. +fromScalar :: MonadFailure ObjectExtractError m => Object k v -> m v +fromScalar (Scalar s) = return s +fromScalar _ = failure ExpectedScalar + +-- | Extra a sequence from the input, failing if the input is a scalar or +-- mapping. +fromSequence :: MonadFailure ObjectExtractError m + => Object k v + -> m [Object k v] +fromSequence (Sequence s) = return s +fromSequence _ = failure ExpectedSequence + +-- | Extra a mapping from the input, failing if the input is a scalar or +-- sequence. +fromMapping :: MonadFailure ObjectExtractError m + => Object k v + -> m [(k, Object k v)] +fromMapping (Mapping m) = return m +fromMapping _ = failure ExpectedMapping + +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 :: ConvertSuccess x (Object k v) => [x] -> Object k v +olTO = Sequence . map cs + +olFO :: ConvertAttempt (Object k v) x => Object k v -> Attempt [x] +olFO = mapM ca <=< fromSequence + +omTO :: (ConvertSuccess k' k, ConvertSuccess x (Object k v)) + => [(k', x)] + -> Object k v +omTO = Mapping . map (cs *** cs) + +omFO :: (ConvertAttempt k k', ConvertAttempt (Object k v) x) + => Object k v + -> Attempt [(k', x)] +omFO = mapM (runKleisli (Kleisli ca *** Kleisli ca)) <=< fromMapping + +deriveSuccessConvs :: Name -- ^ dest key + -> Name -- ^ dest value + -> [Name] -- ^ source keys + -> [Name] -- ^ source values + -> Q [Dec] +deriveSuccessConvs dk dv sks svs = do + sto <- [|sTO|] + sfo <- [|sFO|] + lto <- [|lTO|] + lfo <- [|lFO|] + mto <- [|mTO|] + mfo <- [|mFO|] + olto <- [|olTO|] + olfo <- [|olFO|] + omto <- [|omTO|] + omfo <- [|omFO|] + co <- [|convertObject|] + coa <- [|convertObjectM|] + let sks' = map ConT sks + svs' = map ConT svs + pairs = do + sk <- sks' + sv <- svs' + return (sk, sv) + let valOnly = concatMap (helper1 sto sfo lto lfo) svs' + both = concatMap (helper2 mto mfo olto olfo co coa omto omfo) pairs + keyOnly = concatMap (helper3 omto omfo) sks' + return $ valOnly ++ both ++ keyOnly + where + dk' = ConT dk + dv' = ConT dv + objectt k v = ConT (mkName "Object") `AppT` k `AppT` v + to' src = ConT (mkName "ConvertSuccess") `AppT` src `AppT` + objectt dk' dv' + fo' dst = ConT (mkName "ConvertAttempt") `AppT` + objectt dk' dv' `AppT` dst + cs' = mkName "convertSuccess" + ca' = mkName "convertAttempt" + to src f = + InstanceD [] (to' src) [FunD cs' [Clause [] (NormalB f) []]] + fo dst f = + InstanceD [] (fo' dst) [FunD ca' [Clause [] (NormalB f) []]] + tofo ty x y = [to ty x, fo ty y] + listt = AppT ListT + pairt k v = TupleT 2 `AppT` k `AppT` v + helper1 sto sfo lto lfo sv = concat + [ tofo sv sto sfo + , tofo (listt sv) lto lfo + ] + helper2 mto mfo olto olfo co coa omto omfo (sk, sv) = concat + [ tofo (listt $ pairt sk sv) mto mfo + , tofo (listt $ objectt sk sv) olto olfo + , if sk == dk' && sv == dv' -- avoid overlapping with identity + then [] + else tofo (objectt sk sv) co coa + , if sk == dk' && sv == dv' -- avoid overlapping with helper3 + then [] + else tofo (listt $ pairt sk $ objectt sk sv) omto omfo + ] + helper3 omto omfo sk = concat + [ tofo (listt $ pairt sk $ objectt dk' dv') omto omfo + ] + +-- | An equivalent of 'lookup' to deal specifically with maps of 'Object's. In +-- particular, it will: +-- +-- 1. Automatically convert the lookup key as necesary. For example- assuming +-- you have the appropriate 'ConvertSuccess' instances, you could lookup an 'Int' in +-- a map that has 'String' keys. +-- +-- 2. Return the result in an 'Attempt', not 'Maybe'. This is especially useful +-- when creating 'FromObject' instances. +-- +-- 3. Show a more useful error message. Since this function requires the key to +-- be 'Show'able, the fail message states what key was not found. +-- +-- 4. Calls 'fromObject' automatically, so you get out the value type that you +-- want, not just an 'Object'. +lookupObject :: ( ConvertSuccess k' k + , ConvertAttempt (Object k v) o + , Typeable k + , Typeable v + , Show k + , Eq k + ) + => k' + -> [(k, Object k v)] + -> Attempt o +lookupObject key = ca <=< A.lookup (convertSuccess key) diff --git a/Data/Object/Scalar.hs b/Data/Object/Scalar.hs new file mode 100644 --- /dev/null +++ b/Data/Object/Scalar.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +--------------------------------------------------------- +-- +-- Module : Data.Object.Scalar +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +--------------------------------------------------------- +module Data.Object.Scalar + ( Scalar (..) + , ScalarObject + , toScalarObject + , fromScalarObject + , module Data.Object.Base + ) where + +import Data.ByteString.Lazy (ByteString, empty) +import Data.Time.Clock (UTCTime) +import Data.Object.Text +import Data.Object.Base +import System.Locale (defaultTimeLocale) +import Data.Time.Format (formatTime) +import Data.Attempt +import Data.Convertible.Text + +data Scalar = Numeric Rational + | Text Text + | Binary ByteString + | Bool Bool + | Timestamp UTCTime + | Null + +type ScalarObject = Object String Scalar + +instance ConvertSuccess Scalar Text where + convertSuccess (Numeric n) = convertSuccess $ show n + convertSuccess (Text t) = t + convertSuccess (Binary b) = convertSuccess b + convertSuccess (Bool True) = convertSuccess "true" + convertSuccess (Bool False) = convertSuccess "false" + -- this is W3 format for timestamps. + convertSuccess (Timestamp t) = + convertSuccess $ formatTime defaultTimeLocale "%FT%XZ" t + convertSuccess Null = convertSuccess empty + +{- FIXME write a real conversion here +instance ConvertSuccess Text Scalar where + convertSuccess = Text +-} + +-- | 'toObject' specialized for 'ScalarObject's +toScalarObject :: ConvertSuccess a ScalarObject => a -> ScalarObject +toScalarObject = cs + +-- | 'fromObject' specialized for 'ScalarObject's +fromScalarObject :: ConvertAttempt ScalarObject a + => ScalarObject + -> Attempt a +fromScalarObject = ca diff --git a/Data/Object/String.hs b/Data/Object/String.hs new file mode 100644 --- /dev/null +++ b/Data/Object/String.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +--------------------------------------------------------- +-- +-- Module : Data.Object.String +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Objects with 'String's for keys and values. +--------------------------------------------------------- + +module Data.Object.String + ( StringObject + , toStringObject + , fromStringObject + , module Data.Object.Base + ) where + +import Data.Object.Base +import Data.Attempt + +import Data.Time.Calendar + +type StringObject = Object String String + +-- | 'toObject' specialized for 'StringObject's +toStringObject :: ConvertSuccess a StringObject => a -> StringObject +toStringObject = cs + +-- | 'fromObject' specialized for 'StringObject's +fromStringObject :: ConvertAttempt StringObject a + => StringObject + -> Attempt a +fromStringObject = ca + +$(deriveSuccessConvs ''String ''String + [''String] + [''String, ''Day, ''Int, ''Rational, ''Bool]) diff --git a/Data/Object/Text.hs b/Data/Object/Text.hs new file mode 100644 --- /dev/null +++ b/Data/Object/Text.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +--------------------------------------------------------- +-- +-- Module : Data.Object.Text +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +--------------------------------------------------------- + +-- | Keys and values are lazy 'Text's. +module Data.Object.Text + ( TextObject + , toTextObject + , fromTextObject + , Text + , module Data.Object.Base +#if TEST + , testSuite +#endif + ) where + +import Data.Object.Base +import Data.Text.Lazy (Text) +import Data.Attempt + +import Data.Time.Calendar + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as TS + +#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 ((***)) +import Data.Convertible.Text +#endif + +-- | 'Object's with keys and values of type 'Text'. +type TextObject = Object Text Text + +-- | 'convertSuccess' specialized for 'TextObject's +toTextObject :: ConvertSuccess a TextObject => a -> TextObject +toTextObject = cs + +-- | 'convertAttempt' specialized for 'TextObject's +fromTextObject :: ConvertAttempt TextObject a => TextObject -> Attempt a +fromTextObject = ca + +$(deriveSuccessConvs ''Text ''Text + [''Text, ''String, ''BS.ByteString, ''BL.ByteString, ''TS.Text] + [''String, ''Day, ''Int, ''Rational, ''Bool, ''BS.ByteString, + ''BL.ByteString, ''TS.Text, ''Text + ]) + +#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 ConvertAttempt TextObject (Object Int Int) where + convertAttempt = convertObjectM +instance ConvertSuccess (Object Int Int) TextObject where + convertSuccess = 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, + Eq a, + Show a, + ConvertSuccess a TextObject, + ConvertAttempt TextObject a, + ConvertSuccess [a] TextObject, + ConvertAttempt TextObject [a], + ConvertSuccess [(a, a)] TextObject, + ConvertAttempt TextObject [(a, a)], + ConvertSuccess [TextObject] TextObject, + ConvertAttempt TextObject [TextObject], + ConvertSuccess [(a, TextObject)] TextObject, + ConvertAttempt TextObject [(a, TextObject)]) + => a -> Assertion + test' a = do + let dummy' = map (cs *** cs) dummy `asTypeOf` [(a, a)] + dummy'' = toTextObject dummy' + dummy'' @?= expected + Just dummy' @=? fa (fromTextObject expected) + let dummyO = map (cs *** toTextObject) dummy `asTypeOf` + [(a, undefined :: TextObject)] + expected @=? toTextObject dummyO + Just dummyO @=? fa (fromTextObject expected) + test' (undefined :: String) + test' (undefined :: Text) + test' (undefined :: BS.ByteString) + test' (undefined :: BL.ByteString) +#endif diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2008, Michael Snoyman. All rights reserved. +Copyright 2009, Michael Snoyman. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/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 () diff --git a/data-object.cabal b/data-object.cabal --- a/data-object.cabal +++ b/data-object.cabal @@ -1,8 +1,8 @@ name: data-object -version: 0.0.2 +version: 0.2.0 license: BSD3 license-file: LICENSE -author: Michael Snoyman +author: Michael Snoyman, Nicolas Pouillard maintainer: Michael Snoyman synopsis: Represent hierachichal structures, called objects in JSON. description: These objects show up in different places, eg JSON, Yaml. @@ -10,16 +10,51 @@ other libraries can share a single representation of these structures. category: Data -stability: unstable +stability: Stable cabal-version: >= 1.2 build-type: Simple homepage: http://github.com/snoyberg/data-object/tree/master +flag buildtests + description: Build the executable to run unit tests + default: False + +flag nolib + description: Skip building the library. + default: False + library + if flag(nolib) + Buildable: False + else + Buildable: True build-depends: base >= 4 && < 5, - bytestring-class, bytestring >= 0.9.1.4 && < 1, - time >= 1, - safe + text >= 0.5 && < 0.6, + time >= 1.1.4 && < 1.2, + safe-failure >= 0.4 && < 0.5, + old-locale >= 1 && < 1.1, + syb, + attempt >= 0.2.0 && < 0.3, + convertible-text >= 0.2.0 && < 0.3, + template-haskell exposed-modules: Data.Object + Data.Object.Base + Data.Object.Text + Data.Object.Scalar + Data.Object.String ghc-options: -Wall + +executable runtests + if flag(buildtests) + Buildable: True + cpp-options: -DTEST + build-depends: test-framework, + test-framework-quickcheck, + test-framework-hunit, + HUnit, + QuickCheck >= 1 && < 2 + else + Buildable: False + ghc-options: -Wall + main-is: runtests.hs diff --git a/runtests.hs b/runtests.hs new file mode 100644 --- /dev/null +++ b/runtests.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +import Test.Framework (defaultMain) + +import qualified Data.Object.Text + +main :: IO () +main = defaultMain + [ Data.Object.Text.testSuite + ]