diff --git a/Data/Object.hs b/Data/Object.hs --- a/Data/Object.hs +++ b/Data/Object.hs @@ -1,10 +1,207 @@ --- | Imports all instances provided in this package. +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} +--------------------------------------------------------- +-- +-- 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. +-- +--------------------------------------------------------- + +-- | 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 - ( module Data.Object.Base + ( -- * Object data type + Object (..) + -- ** Convenient type synonyms + , StringObject + , TextObject + -- ** Scalar data type + , Scalar (..) + , ScalarObject + -- * Basic mapping of keys and values + , mapKeys + , mapValues + , mapKeysValues + , mapKeysValuesA + , mapKeysValuesM + -- * Extracting underlying values + , ObjectExtractError (..) + , fromScalar + , fromSequence + , fromMapping ) where -import Data.Object.Base +import Control.Arrow +import Control.Applicative +import Control.Monad (ap) -import Data.Object.String () -import Data.Object.Text () -import Data.Object.Scalar () +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) + +-- | 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) + +type StringObject = Object String String + +-- | 'Object's with keys and values of strict 'Text'. +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 + +-- 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' + +-- | 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 + +-- | Extract a scalar from the input, failing if the input is a sequence or +-- mapping. +fromScalar :: Failure ObjectExtractError m => Object k v -> m v +fromScalar (Scalar s) = return s +fromScalar _ = failure ExpectedScalar + +-- | Extract a sequence from the input, failing if the input is a scalar or +-- mapping. +fromSequence :: Failure ObjectExtractError m + => Object k v + -> m [Object k v] +fromSequence (Sequence s) = return s +fromSequence _ = failure ExpectedSequence + +-- | Extract a mapping from the input, failing if the input is a scalar or +-- sequence. +fromMapping :: Failure ObjectExtractError m + => Object k v + -> m [(k, Object k v)] +fromMapping (Mapping m) = return m +fromMapping _ = failure ExpectedMapping diff --git a/Data/Object/Base.hs b/Data/Object/Base.hs deleted file mode 100644 --- a/Data/Object/Base.hs +++ /dev/null @@ -1,375 +0,0 @@ -{-# 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 - , lookupScalar - , lookupSequence - , lookupMapping - -- * 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) - -lookupScalar :: ( MonadFailure ObjectExtractError m - , Failure (A.LookupFailure k) m - , Eq k) - => k - -> [(k, Object k v)] - -> m v -lookupScalar key = fromScalar <=< A.lookup key - -lookupSequence :: ( MonadFailure ObjectExtractError m - , Failure (A.LookupFailure k) m - , Eq k) - => k - -> [(k, Object k v)] - -> m [Object k v] -lookupSequence key = fromSequence <=< A.lookup key - -lookupMapping :: ( MonadFailure ObjectExtractError m - , Failure (A.LookupFailure k) m - , Eq k) - => k - -> [(k, Object k v)] - -> m [(k, Object k v)] -lookupMapping key = fromMapping <=< A.lookup key diff --git a/Data/Object/Scalar.hs b/Data/Object/Scalar.hs deleted file mode 100644 --- a/Data/Object/Scalar.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# 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 - -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 deleted file mode 100644 --- a/Data/Object/String.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Data/Object/Text.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# 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/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -2,10 +2,6 @@ > module Main where > import Distribution.Simple -> import System.Cmd (system) > main :: IO () -> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' }) - -> runTests' :: a -> b -> c -> d -> IO () -> runTests' _ _ _ _ = system "runhaskell Test.hs" >> return () +> main = defaultMain diff --git a/data-object.cabal b/data-object.cabal --- a/data-object.cabal +++ b/data-object.cabal @@ -1,5 +1,5 @@ name: data-object -version: 0.2.1 +version: 0.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman, Nicolas Pouillard @@ -15,46 +15,11 @@ 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 >= 0.9.1.4 && < 1, text >= 0.5 && < 0.8, 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 + failure >= 0.1.0 && < 0.2 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 deleted file mode 100644 --- a/runtests.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# 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 - ]