diff --git a/hedn.cabal b/hedn.cabal --- a/hedn.cabal +++ b/hedn.cabal @@ -1,8 +1,5 @@ --- Initial hedn.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/ - name: hedn -version: 0.1.6.0 +version: 0.1.7.0 synopsis: EDN parsing and encoding homepage: https://bitbucket.org/dpwiz/hedn license: BSD3 @@ -20,29 +17,50 @@ extra-source-files: tests/Main.hs + tests/Data/EDN/Test/*.hs + tests/Data/EDN/Test/QuickCheck/TH.hs flag developer description: operate in developer mode default: False library - exposed-modules: Data.EDN, Data.EDN.Types, Data.EDN.Parser, Data.EDN.Encode, Data.EDN.Types.Class - other-modules: Data.Parser - hs-source-dirs: src/ - build-depends: base ==4.*, attoparsec, text, bytestring, containers, vector, stringsearch, mtl, deepseq + exposed-modules: + Data.EDN, + Data.EDN.Types, + Data.EDN.Types.Class, + Data.EDN.Parser, + Data.EDN.Encode - if flag(developer) - ghc-options: -Werror - ghc-prof-options: -auto-all + other-modules: + Data.Parser - ghc-options: -O2 -Wall -fno-warn-unused-do-bind + hs-source-dirs: src/ + build-depends: + base ==4.*, + attoparsec, + text, + bytestring >=0.10, + containers, + vector, + stringsearch, + mtl, + deepseq, + old-locale, + time +-- if flag(developer) +-- ghc-options: -Werror -fhpc +-- ghc-prof-options: -auto-all + ghc-options: -O2 -Wall -fno-warn-unused-do-bind + Test-Suite tests type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: tests/ - build-depends: base, hedn, HUnit, bytestring, text, containers, vector + build-depends: base, hedn, bytestring, text, containers, vector, template-haskell, time, + QuickCheck >= 2.5.1, hspec == 1.5.*, HUnit >= 1.2.5 ghc-options: -Wall source-repository head diff --git a/src/Data/EDN/Parser.hs b/src/Data/EDN/Parser.hs --- a/src/Data/EDN/Parser.hs +++ b/src/Data/EDN/Parser.hs @@ -10,20 +10,22 @@ parseValue, parseTagged ) where -import Prelude hiding (String, takeWhile) -import Data.Attoparsec.Char8 as A -import qualified Data.Attoparsec.Lazy as AL -import Data.Attoparsec.Combinator() -import Control.Applicative (pure, (<|>), (*>)) -import qualified Data.ByteString.Char8 as BS +import Control.Applicative (pure, (*>), (<|>)) +import Data.Attoparsec.Char8 as A +import Data.Attoparsec.Combinator () +import qualified Data.Attoparsec.Lazy as AL +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import Data.ByteString.Search (replace) +import Data.ByteString.Search (replace) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Prelude hiding (String, takeWhile) -import Data.EDN.Types (Value(..), Tagged(..), TaggedValue, makeVec, makeMap, makeSet) +import Data.EDN.Types (Tagged (..), TaggedValue, + Value (..), makeMap, makeSet, + makeVec) isSpaceOrComma :: Char -> Bool isSpaceOrComma ' ' = True @@ -64,7 +66,14 @@ char '"' if '\\' `BS.elem` x - then return $! String . TE.decodeUtf8 . rep "\\\"" "\"". rep "\\\\" "\\" . rep "\\n" "\n" . rep "\\r" "\r" . rep "\\t" "\t" $ x + then return $! String + . TE.decodeUtf8 + . rep "\\\"" "\"" + . rep "\\\\" "\\" + . rep "\\n" "\n" + . rep "\\r" "\r" + . rep "\\t" "\t" + $ x else return $! String . TE.decodeUtf8 $ x where rep f t s = BS.concat . BSL.toChunks $! replace (BS.pack f) (BS.pack t) s @@ -119,7 +128,9 @@ parseList = do skipSoC char '(' + A.skipSpace vs <- parseTagged `sepBy` spaceOrComma + A.skipSpace char ')' return $! List vs @@ -127,7 +138,9 @@ parseVector = do skipSoC char '[' + A.skipSpace vs <- parseTagged `sepBy` spaceOrComma + A.skipSpace char ']' return $! makeVec vs @@ -135,7 +148,9 @@ parseMap = do skipSoC char '{' + A.skipSpace pairs <- parseAssoc `sepBy` spaceOrComma + A.skipSpace char '}' return $! makeMap pairs where @@ -149,7 +164,9 @@ skipSoC char '#' char '{' + A.skipSpace vs <- parseTagged `sepBy` spaceOrComma + A.skipSpace char '}' return $! makeSet vs diff --git a/src/Data/EDN/Types.hs b/src/Data/EDN/Types.hs --- a/src/Data/EDN/Types.hs +++ b/src/Data/EDN/Types.hs @@ -25,6 +25,7 @@ ) where import Data.String (IsString(..)) +import Control.DeepSeq (NFData(..)) import Data.Text (Text) import qualified Data.Text as T import Data.ByteString.Char8 (ByteString) @@ -42,6 +43,10 @@ fmap f (NoTag v) = NoTag (f v) fmap f (Tagged v ns t) = Tagged (f v) ns t +instance NFData a => NFData (Tagged a) where + rnf (NoTag v) = rnf v + rnf (Tagged v ns t) = rnf v `seq` rnf ns `seq` rnf t + type TaggedValue = Tagged Value type EDNList = [TaggedValue] -- ^ An EDN list (head:tail container). @@ -74,6 +79,20 @@ instance IsString (Tagged Value) where fromString = string . T.pack {-# INLINE fromString #-} + +instance NFData Value where + rnf (Map m) = rnf m + rnf (Set s) = rnf s + rnf (Vec v) = V.foldl' (\x y -> rnf y `seq` x) () v + rnf (List l) = rnf l + rnf (Floating f) = rnf f + rnf (Integer i) = rnf i + rnf (Symbol ns s) = rnf ns `seq` rnf s + rnf (Keyword kw) = rnf kw + rnf (String t) = rnf t + rnf (Character c) = rnf c + rnf (Boolean b) = rnf b + rnf Nil = () -- | Basic EDN nil. nil :: TaggedValue diff --git a/src/Data/EDN/Types/Class.hs b/src/Data/EDN/Types/Class.hs --- a/src/Data/EDN/Types/Class.hs +++ b/src/Data/EDN/Types/Class.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, IncoherentInstances #-} - +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Data.EDN.Types.Class ( -- * Type conversion ToEDN(..), FromEDN(..), fromEDN, fromEDNv, @@ -11,23 +12,27 @@ (.=), (.:), (.:?), (.!=), typeMismatch ) where -import Control.Applicative (pure, (<$>)) -import Control.Monad (liftM, liftM2) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy.Encoding as TLE -import qualified Data.ByteString.Char8 as BS +import Control.Applicative (pure, (<$>), (<*>)) +import Control.Monad (liftM, liftM2) +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Vector as V -import qualified Data.Set as S -import qualified Data.Map as M +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Monoid (First (..), mconcat) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Data.Time.Clock (UTCTime) +import Data.Time.Format (formatTime, parseTime) +import qualified Data.Vector as V -import Data.Parser (Parser, Result) -import qualified Data.Parser as DP -import qualified Data.EDN.Parser as P -import qualified Data.EDN.Types as E +import qualified Data.EDN.Parser as P +import qualified Data.EDN.Types as E +import Data.Parser (Parser, Result) +import qualified Data.Parser as DP +import System.Locale (defaultTimeLocale) -- | A type that can be converted to JSON. class ToEDN a where @@ -59,8 +64,8 @@ {-# INLINE toEDN #-} instance (FromEDN a) => (FromEDN (Maybe a)) where - parseEDNv E.Nil = pure Nothing - parseEDNv a = Just <$> parseEDNv a + parseEDN (E.NoTag E.Nil) = pure Nothing + parseEDN a = Just <$> parseEDN a {-# INLINE parseEDNv #-} instance (ToEDN a, ToEDN b) => ToEDN (Either a b) where @@ -178,6 +183,46 @@ parseEDNv v = typeMismatch "Integer" v {-# INLINE parseEDNv #-} +instance ToEDN Int where + toEDNv = E.Integer . fromIntegral + {-# INLINE toEDNv #-} + +instance FromEDN Int where + parseEDNv (E.Integer i) = return (fromIntegral i) + parseEDNv v = typeMismatch "Int" v + + +showRFC3339 :: UTCTime -> String +showRFC3339 time = + concat [fm "%FT%T." time + , take 3 $ fm "%-q" time + , "+00:00"] + where + fm s = formatTime defaultTimeLocale s + +instance ToEDN UTCTime where + toEDN time = E.Tagged (E.String . T.pack $ showRFC3339 time) + "" + "inst" + {-# INLINE toEDN #-} + +instance FromEDN UTCTime where + parseEDN val@(E.Tagged (E.String ts) "" "inst") = do + let result = getFirst . mconcat $ map (First . parseTime') validRFC3339 + case result of + Just time -> return time + Nothing -> typeMismatch "UTCTime" $ E.stripTag val + where + tsStr = T.unpack ts + parseTime' fmt = parseTime defaultTimeLocale fmt tsStr + validRFC3339 = [ "%FT%T%Q%z" + , "%FT%T%QZ" + , "%FT%T%z" + , "%FT%TZ" ] + parseEDN v = typeMismatch "UTCTime" $ E.stripTag v + {-# INLINE parseEDN #-} + + instance ToEDN a => ToEDN [a] where toEDNv = E.List . map toEDN {-# INLINE toEDNv #-} @@ -214,6 +259,146 @@ parseEDNv v = typeMismatch "Map" v {-# INLINE parseEDNv #-} +instance (ToEDN a, ToEDN b) => ToEDN (a, b) where + toEDNv (a, b) = E.Vec $! V.fromList [toEDN a, toEDN b] + {-# INLINE toEDNv #-} + +instance (FromEDN a, FromEDN b) => FromEDN (a, b) where + parseEDNv v@(E.Vec vec) + | (V.length vec == 2) = (,) <$> (parseEDN (vec V.! 0)) + <*> (parseEDN (vec V.! 1)) + | otherwise = typeMismatch "(a, b)" v + parseEDNv v = typeMismatch "(a, b)" v + {-# INLINE parseEDNv #-} + +instance (ToEDN a, ToEDN b, ToEDN c) => ToEDN (a, b, c) where + toEDNv (a, b, c) = E.Vec $! V.fromList [toEDN a, toEDN b, toEDN c] + {-# INLINE toEDNv #-} + +instance (FromEDN a, FromEDN b, FromEDN c) => FromEDN (a, b, c) where + parseEDNv v@(E.Vec vec) + | V.length vec == 3 = (,,) <$> (parseEDN (vec V.! 0)) + <*> (parseEDN (vec V.! 1)) + <*> (parseEDN (vec V.! 2)) + | otherwise = typeMismatch "(a, b, c)" v + parseEDNv v = typeMismatch "(a, b, c)" v + {-# INLINE parseEDNv #-} + +instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d) => ToEDN (a, b, c, d) where + toEDNv (a, b, c, d) = E.Vec $! V.fromList [toEDN a, toEDN b, toEDN c, toEDN d] + {-# INLINE toEDNv #-} + +instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d) => FromEDN (a, b, c, d) where + parseEDNv v@(E.Vec vec) + | V.length vec == 4 = (,,,) <$> (parseEDN (vec V.! 0)) + <*> (parseEDN (vec V.! 1)) + <*> (parseEDN (vec V.! 2)) + <*> (parseEDN (vec V.! 3)) + | otherwise = typeMismatch "(a, b, c, d)" v + parseEDNv v = typeMismatch "(a, b, c, d)" v + {-# INLINE parseEDNv #-} + +instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d, ToEDN e) => ToEDN (a, b, c, d, e) where + toEDNv (a, b, c, d, e) = E.Vec $! V.fromList [ + toEDN a + , toEDN b + , toEDN c + , toEDN d + , toEDN e ] + {-# INLINE toEDNv #-} + +instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d, FromEDN e) + => FromEDN (a, b, c, d, e) where + parseEDNv v@(E.Vec vec) + | V.length vec == 5 = (,,,,) <$> (parseEDN (vec V.! 0)) + <*> (parseEDN (vec V.! 1)) + <*> (parseEDN (vec V.! 2)) + <*> (parseEDN (vec V.! 3)) + <*> (parseEDN (vec V.! 4)) + | otherwise = typeMismatch "(a, b, c, d, e)" v + parseEDNv v = typeMismatch "(a, b, c, d, e)" v + {-# INLINE parseEDNv #-} + +instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d, ToEDN e, ToEDN f) + => ToEDN (a, b, c, d, e, f) where + toEDNv (a, b, c, d, e, f) = E.Vec $! V.fromList [ + toEDN a + , toEDN b + , toEDN c + , toEDN d + , toEDN e + , toEDN f] + {-# INLINE toEDNv #-} + +instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d, FromEDN e, FromEDN f) + => FromEDN (a, b, c, d, e, f) where + parseEDNv v@(E.Vec vec) + | V.length vec == 6 = (,,,,,) <$> (parseEDN (vec V.! 0)) + <*> (parseEDN (vec V.! 1)) + <*> (parseEDN (vec V.! 2)) + <*> (parseEDN (vec V.! 3)) + <*> (parseEDN (vec V.! 4)) + <*> (parseEDN (vec V.! 5)) + | otherwise = typeMismatch "(a, b, c, d, e, f)" v + parseEDNv v = typeMismatch "(a, b, c, d, e, f)" v + {-# INLINE parseEDNv #-} + +instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d, ToEDN e, ToEDN f, ToEDN g) + => ToEDN (a, b, c, d, e, f, g) where + toEDNv (a, b, c, d, e, f, g) = E.Vec $! V.fromList [ + toEDN a + , toEDN b + , toEDN c + , toEDN d + , toEDN e + , toEDN f + , toEDN g] + {-# INLINE toEDNv #-} + +instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d, FromEDN e, FromEDN f, FromEDN g) + => FromEDN (a, b, c, d, e, f, g) where + parseEDNv v@(E.Vec vec) + | V.length vec == 7 = (,,,,,,) <$> (parseEDN (vec V.! 0)) + <*> (parseEDN (vec V.! 1)) + <*> (parseEDN (vec V.! 2)) + <*> (parseEDN (vec V.! 3)) + <*> (parseEDN (vec V.! 4)) + <*> (parseEDN (vec V.! 5)) + <*> (parseEDN (vec V.! 6)) + | otherwise = typeMismatch "(a, b, c, d, e, f, g)" v + parseEDNv v = typeMismatch "(a, b, c, d, e, f, g)" v + {-# INLINE parseEDNv #-} + +instance (ToEDN a, ToEDN b, ToEDN c, ToEDN d, ToEDN e, ToEDN f, ToEDN g, ToEDN h) + => ToEDN (a, b, c, d, e, f, g, h) where + toEDNv (a, b, c, d, e, f, g, h) = E.Vec $! V.fromList [ + toEDN a + , toEDN b + , toEDN c + , toEDN d + , toEDN e + , toEDN f + , toEDN g + , toEDN h] + {-# INLINE toEDNv #-} + +instance (FromEDN a, FromEDN b, FromEDN c, FromEDN d, + FromEDN e, FromEDN f, FromEDN g, FromEDN h) + => FromEDN (a, b, c, d, e, f, g, h) where + parseEDNv v@(E.Vec vec) + | V.length vec == 8 = (,,,,,,,) <$> (parseEDN (vec V.! 0)) + <*> (parseEDN (vec V.! 1)) + <*> (parseEDN (vec V.! 2)) + <*> (parseEDN (vec V.! 3)) + <*> (parseEDN (vec V.! 4)) + <*> (parseEDN (vec V.! 5)) + <*> (parseEDN (vec V.! 6)) + <*> (parseEDN (vec V.! 7)) + | otherwise = typeMismatch "(a, b, c, d, e, f, g, h)" v + parseEDNv v = typeMismatch "(a, b, c, d, e, f, g, h)" v + {-# INLINE parseEDNv #-} + + instance ToEDN E.Value where toEDNv = id @@ -281,7 +466,7 @@ -- from an object without affecting its validity and we know a default -- value to assign in that case. If the key and value are mandatory, -- use '(.:)' instead. --- +-- -- Example usage: -- -- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\" @@ -314,10 +499,17 @@ E.Map _ -> "Map" E.Set _ -> "Set" -mapMset :: (Monad m, Ord b) => (a -> m b) -> S.Set a -> m (S.Set b) +mapMset :: (Monad m, Ord b) + => (a -> m b) + -> S.Set a + -> m (S.Set b) mapMset f s = mapM f (S.toList s) >>= return . S.fromList {-# INLINE mapMset #-} -mapMmap :: (Ord a2, Monad m) => (a1 -> m a2) -> (b1 -> m b2) -> M.Map a1 b1 -> m (M.Map a2 b2) +mapMmap :: (Ord a2, Monad m) + => (a1 -> m a2) + -> (b1 -> m b2) + -> M.Map a1 b1 + -> m (M.Map a2 b2) mapMmap kf vf = liftM M.fromList . mapM (\(k, v) -> liftM2 (,) (kf k) (vf v)) . M.assocs {-# INLINE mapMmap #-} diff --git a/tests/Data/EDN/Test/QuickCheck.hs b/tests/Data/EDN/Test/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/tests/Data/EDN/Test/QuickCheck.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.EDN.Test.QuickCheck where + +import Data.EDN.Test.QuickCheck.TH +import Data.Time (UTCTime) + +import qualified Data.Time.Calendar as Calendar +import Data.Time.Clock (UTCTime (..), UniversalTime (..), + secondsToDiffTime) +import Data.Time.LocalTime (localTimeToUT1, localTimeToUTC, + ut1ToLocalTime, utc, + utcToLocalTime) + +import qualified Test.QuickCheck as QC + +-- * UTCTime Arbitrary instance ------------------------------------------------ + +fromGregorian :: Integer -> Int -> Int -> Int -> Int -> Int -> UTCTime +fromGregorian year month day hours minutes seconds = + UTCTime day' (secondsToDiffTime . fromIntegral $ seconds') + where + day' = Calendar.fromGregorian year month day + seconds' = 3600 * hours + 60 * minutes + seconds + +fromUniversalTime :: UniversalTime -> UTCTime +fromUniversalTime = localTimeToUTC utc . ut1ToLocalTime 0 + +toUniversalTime :: UTCTime -> UniversalTime +toUniversalTime = localTimeToUT1 0 . utcToLocalTime utc + +fromGregorian' :: Integer -> Int -> Int -> UTCTime +fromGregorian' y m d = fromGregorian y m d 0 0 0 + +startOfTime :: UTCTime +startOfTime = fromGregorian' 1970 1 1 + +fromMJD :: Rational -> UTCTime +fromMJD = fromUniversalTime . ModJulianDate + +fromMJD' :: Float -> UTCTime +fromMJD' = fromMJD . realToFrac + +startOfTimeMJD :: Rational +startOfTimeMJD = toMJD startOfTime + +toMJD :: UTCTime -> Rational +toMJD = getModJulianDate . toUniversalTime + +instance QC.Arbitrary UTCTime where + -- coarbitrary = undefined + arbitrary = do + offset <- QC.choose (0, 20000) :: QC.Gen Float + return . fromMJD' $ offset + fromRational startOfTimeMJD + +-------------------------------------------------------------------------------- + +type MUTCTime = Maybe UTCTime +type Tuple = (Int, Int) +type Triple = (Int, String, UTCTime) +type Tuple4 = (Int, String, [Maybe UTCTime], [Maybe Bool]) +type Tuple5 = (Int, [String], [Maybe UTCTime], [Maybe Bool], (Bool, Bool)) + +$(mkSerializeSpecs [ + -- ''Char -- encode/decode are not isomorphic with Char + -- ''Double -- encode/decode are not isomorphic with Double + -- ''String + ''UTCTime + , ''MUTCTime + -- , ''Tuple + -- , ''Triple + -- , ''Tuple4 + -- , ''Tuple5 + ]) diff --git a/tests/Data/EDN/Test/QuickCheck/TH.hs b/tests/Data/EDN/Test/QuickCheck/TH.hs new file mode 100644 --- /dev/null +++ b/tests/Data/EDN/Test/QuickCheck/TH.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.EDN.Test.QuickCheck.TH where + +import Control.Applicative ((<$>), (<*>)) +import Language.Haskell.TH +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) + + + +import qualified Data.EDN as E +import qualified Test.QuickCheck as QC + +-------------------------------------------------------------------------------- + +serializeProperty :: (QC.Arbitrary a, Eq a, E.ToEDN a, E.FromEDN a) => a -> Bool +serializeProperty object = do + case decoded of + Just result -> result == object + Nothing -> False + where + encoded = E.encode object + decoded = E.decode encoded + +getTestPropertyName :: Name -> Name +getTestPropertyName qualTypeName = + mkName $ "test" ++ (nameBase qualTypeName) ++ "Serialization" + +mkEDNSerializeSpecGroup :: [Name] -> Q [Dec] +mkEDNSerializeSpecGroup names = do + let fnName = mkName "ednSerializationProperties" + specType <- [t| Spec |] + describeFn <- [| describe |] + return $ [ SigD fnName specType + , ValD (VarP fnName) + (NormalB (AppE (AppE describeFn + (LitE (StringL "EDN.Serialization"))) + (DoE (map (NoBindS . VarE . getTestPropertyName) + names)))) []] + +mkSerializeSpec :: Name -> Q [Dec] +mkSerializeSpec qualTypeName = do + let typeName = nameBase qualTypeName + fnName = getTestPropertyName qualTypeName + propFn <- [| prop |] + serializePropertyFn <- [| serializeProperty |] + boolType <- [t| Bool |] + specType <- [t| Spec |] + return [ SigD fnName specType + , ValD (VarP fnName) + (NormalB (AppE + (AppE propFn + (LitE (StringL $ typeName ++ " serialization/deserialization"))) + (SigE serializePropertyFn + (AppT (AppT ArrowT (ConT qualTypeName)) + boolType)))) []] + +mkSerializeSpecs :: [Name] -> Q [Dec] +mkSerializeSpecs types = + (++) <$> (concat `fmap` mapM mkSerializeSpec types) + <*> (mkEDNSerializeSpecGroup types) diff --git a/tests/Data/EDN/Test/Unit.hs b/tests/Data/EDN/Test/Unit.hs new file mode 100644 --- /dev/null +++ b/tests/Data/EDN/Test/Unit.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +module Data.EDN.Test.Unit (tests) where + +import Test.HUnit + +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.ByteString.Char8 as BS +import qualified Data.Text.Lazy as TL +import qualified Data.Text as T + +import qualified Data.Vector as V +import qualified Data.Set as S +import qualified Data.Map as M + +import Data.EDN (encode, decode, ToEDN, toEDN, FromEDN, fromEDN) +import Data.EDN.Types as E +import Data.EDN.Types.Class (Result(..), (.=)) +import Data.EDN.Parser (parseMaybe) + +tests :: Test +tests = TestList [ TestLabel "BSL -> TV parser" $ TestList $ map makeParserCase parserCases + , TestLabel "TV -> BSL encoder" $ TestList $ map makeEncodeCase encodeCases + , TestLabel "ToEDN conversion" $ TestList $ map makeToEDNcase toEDNcases + , TestLabel "FromEDN converter/decoder" $ TestList $ map makeFromEDNcase fromEDNcases + , TestLabel "decoder fail" (TestCase (assertEqual "bad unicode" Nothing (parseMaybe "№"))) + , TestLabel "'Tagged a' conversion" $ TestList taggedConversion + ] + +makeParserCase :: (BSL.ByteString, E.TaggedValue) -> Test +makeParserCase (i, o) = TestCase (assertEqual (BSL.unpack i) (Just o) (parseMaybe i)) + +makeEncodeCase :: (E.TaggedValue, BSL.ByteString) -> Test +makeEncodeCase (i, o) = TestCase (assertEqual (BSL.unpack o) o (encode i)) + +parserCases :: [(BSL.ByteString, E.TaggedValue)] +parserCases = [ ("nil", E.nil) + + , ("true", E.true) + , ("false", E.false) + + , ("\"a nice string\"", "a nice string") + , ("\"split\\second \\t\\rai\\n\"", "split\\second \t\rai\n") + , ("\"test \\\"sausage\\\" shmest\"", "test \"sausage\" shmest") + , ("\"\"", "") + + , ("\\c", E.char 'c') + , ("\\\\", E.char '\\') + , ("\\newline", E.char '\n') + , ("\\space", E.char ' ') + , ("\\tab", E.char '\t') + + , ("justasymbol", E.symbol "justasymbol") + , ("with#stuff:inside", E.symbol "with#stuff:inside") + , ("my-namespace/foo", E.symbolNS "my-namespace" "foo") + , ("/", E.symbol "/") + + , (":fred", E.keyword "fred") + , (":my/fred", E.keyword "my/fred") + + , ("42", E.integer 42) + , ("-1", E.integer (-1)) + + , ("100.50", E.floating 100.5) + , ("-3.14", E.floating (-3.14)) + -- ...and many other strange stuff... + + , ("(a b 42)", sampleList) + , ("()", E.notag $ E.makeList []) + + , ("[a b 42]", sampleVec) + , ("[]", E.notag $ E.makeVec []) + + , ("{:a 1, \"foo\" :bar, [1 2 3] four}", sampleMap) + , ("{}", E.notag $ E.makeMap []) + + , ("#{a b [1 2 3]}", sampleSet) + , ("#{}", E.notag $ E.makeSet []) + + , ("[a b #_foo 42]", sampleDiscard) + , ("(1 2 ;more to go!\n 3 4)", sampleComment) + + , ("#myapp/Person {:first \"Fred\" :last \"Mertz\"}", E.tag "myapp" "Person" sampleTaggedMap) + , ("{:first \"Fred\" :last \"Mertz\"}", E.notag sampleTaggedMap) + ] + +encodeCases :: [(E.TaggedValue, BSL.ByteString)] +encodeCases = [ (E.nil, "nil") + + , (E.true, "true") + , (E.false, "false") + + , (E.string "a nice string", "\"a nice string\"") + , ("overloaded", "\"overloaded\"") + , ("escape \rou\te \\ \"\north\"", "\"escape \\rou\\te \\\\ \\\"\\north\\\"\"") + + , (E.char 'c', "\\c") + , (E.char '\\', "\\\\") + , (E.char '\n', "\\newline") + , (E.char '\r', "\\return") + , (E.char '\t', "\\tab") + , (E.char ' ', "\\space") + + , (E.symbol "justasymbol", "justasymbol") + , (E.symbol "with#stuff:inside", "with#stuff:inside") + , (E.symbolNS "whatever" "whenever", "whatever/whenever") + , (E.symbol "/", "/") + + , (E.keyword "fred", ":fred") + , (E.keyword "my/fred", ":my/fred") + , (E.notag ":overloaded", ":overloaded") -- IsString kw transform only for untagged values + + , (E.integer 42, "42") + , (E.integer (-1), "-1") + + , (E.floating 100.50, "100.5") + , (E.floating (-3.14), "-3.14") + + , (sampleList, "(a b 42)") + , (E.notag $ E.makeList [], "()") + + , (sampleVec, "[a b 42]") + , (E.notag $ E.makeVec [], "[]") + + , (sampleMap, "{\"foo\" :bar :a 1 [1 2 3] four}") -- Order not guaranteed + , (E.notag $ E.makeMap [], "{}") + + , (E.tag "myapp" "Person" sampleTaggedMap, "#myapp/Person {:first \"Fred\" :last \"Mertz\"}") + ] + +sampleList :: E.TaggedValue +sampleList = E.notag $ E.makeList [E.symbol "a", E.symbol "b", E.integer 42] + +sampleVec :: E.TaggedValue +sampleVec = E.notag $ E.makeVec [E.symbol "a", E.symbol "b", E.integer 42] + +sampleMap :: E.TaggedValue +sampleMap = E.notag $ E.makeMap [ (":a", E.integer 1) + , ("foo", E.keyword "bar") + , (E.makeVec [E.integer 1, E.integer 2, E.integer 3], E.symbol "four") + ] + +sampleSet :: E.TaggedValue +sampleSet = E.notag $ E.makeSet [ E.symbol "a" + , E.symbol "b" + , E.notag $ E.makeVec [E.integer 1, E.integer 2, E.integer 3] + ] + +sampleDiscard :: E.TaggedValue +sampleDiscard = E.notag $ E.makeVec [E.symbol "a", E.symbol "b", E.integer 42] + +sampleComment :: E.TaggedValue +sampleComment = E.notag $ E.makeList [E.integer 1, E.integer 2, E.integer 3, E.integer 4] + +sampleTaggedMap :: E.Value +sampleTaggedMap = E.makeMap [ "first" .= E.string "Fred", "last" .= E.string "Mertz" ] + +data ToEDNCase = forall a. ToEDN a => ToEDNCase !a !E.TaggedValue + +makeToEDNcase :: ToEDNCase -> Test +makeToEDNcase (ToEDNCase i o) = TestCase (assertEqual (show o) o (toEDN i)) + +toEDNcases :: [ToEDNCase] +toEDNcases = [ ToEDNCase (Nothing :: Maybe Bool) E.nil + + , ToEDNCase (Left "hi" :: Either String ()) $ E.tag "either" "left" "hi" + , ToEDNCase (Right "z" :: Either () String) $ E.tag "either" "right" "z" + , ToEDNCase (Just '!') (E.char '!') + + , ToEDNCase True E.true + , ToEDNCase False E.false + + , ToEDNCase ("test" :: String) (E.string "test") + , ToEDNCase ("test" :: BSL.ByteString) "test" + , ToEDNCase ("test" :: BS.ByteString) "test" + , ToEDNCase ("test" :: TL.Text) "test" + , ToEDNCase ("test" :: T.Text) "test" + + , ToEDNCase 'c' $ E.char 'c' + , ToEDNCase '\n' $ E.char '\n' + , ToEDNCase '\\' $ E.char '\\' + + , ToEDNCase (3.14 :: Double) $ E.floating 3.14 + , ToEDNCase (42 :: Integer) $ E.integer 42 + + , ToEDNCase () (E.notag $ E.makeList []) + , ToEDNCase ([] :: [()]) (E.notag $ E.makeList []) + , ToEDNCase (["yo", "wassup"] :: [String]) (E.notag $ E.makeList ["yo", "wassup"]) + , ToEDNCase [E.string "i", "am", E.symbolNS "boxed" "container"] (E.notag $ E.makeList [E.string "i", "am", E.symbolNS "boxed" "container"]) + + , ToEDNCase (V.fromList ['o', 'm', 'g']) (E.notag $ E.makeVec [E.char 'o', E.char 'm', E.char 'g']) + + , ToEDNCase (S.fromList ['o', 'm', 'g']) (E.notag $ E.makeSet [E.char 'o', E.char 'm', E.char 'g']) + + , ToEDNCase (M.fromList [("test", "shmest"), ("foo", "bar")] :: M.Map String String) (E.notag $ E.makeMap [("test", "shmest"), ("foo", "bar")]) + , ToEDNCase (M.fromList [(":test", "shmest"), (":foo", "bar")] :: EDNMap) (E.notag $ E.makeMap ["test" .= E.string "shmest", "foo" .= E.string "bar"]) + ] + +data FromEDNCase = forall a. (FromEDN a, Show a, Eq a) => FromEDNCase !BSL.ByteString !a + +makeFromEDNcase :: FromEDNCase -> Test +makeFromEDNcase (FromEDNCase i o) = TestCase $ assertEqual (BSL.unpack i) (Just o) (decode i) + +fromEDNcases :: [FromEDNCase] +fromEDNcases = [ FromEDNCase "nil" (Nothing :: Maybe Bool) + + , FromEDNCase "false" False + , FromEDNCase "true" True + + , FromEDNCase "#either/left hi" (Left "hi" :: Either String ()) + , FromEDNCase "#either/right z" (Right "z" :: Either () String) + , FromEDNCase "\"ok fine\"" (Just "ok fine" :: Maybe T.Text) + , FromEDNCase "nil" (Nothing :: Maybe BSL.ByteString) + + , FromEDNCase "\\newline" '\n' + , FromEDNCase "\\z" 'z' + + , FromEDNCase "42" (42 :: Integer) + , FromEDNCase "-3.14" (-3.14 :: Double) + + , FromEDNCase "(hello world)" (["hello", "world"] :: [String]) + , FromEDNCase "[3 2 1 \"Kaboom!\"]" $ E.makeVec [E.integer 3, E.integer 2, E.integer 1, "Kaboom!"] + , FromEDNCase "#{a/bag :of \"bugs\"}" $ E.makeSet [E.symbolNS "a" "bag", E.keyword "of", E.string "bugs"] + , FromEDNCase "{json: \"like\", but/not: \"really\"}" $ (M.fromList [("json:", "like"), ("but/not:", "really")] :: M.Map String String) + , FromEDNCase "{ json: \"like\", but/not: \"really\" }" $ (M.fromList [("json:", "like"), ("but/not:", "really")] :: M.Map String String) + ] + +taggedConversion :: [Test] +taggedConversion = [ TestCase (assertEqual "toEDN tagged" (E.tag "wo" "ot" (E.Boolean False)) (toEDN $ E.tag "wo" "ot" False)) + , TestCase (assertEqual "toEDN notag" E.false (toEDN $ E.notag False)) + , TestCase (assertEqual "fromEDN tagged" (Success $ E.tag "wo" "ot" False) (fromEDN $ E.tag "wo" "ot" (E.Boolean False))) + , TestCase (assertEqual "fromEDN notag" (Success $ E.notag False) (fromEDN $ E.false)) + ] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,239 +1,11 @@ -{-# LANGUAGE OverloadedStrings, ExistentialQuantification #-} - module Main where - -import Test.HUnit -import Control.Monad (when) -import System.Exit (exitFailure) - -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.ByteString.Char8 as BS -import qualified Data.Text.Lazy as TL -import qualified Data.Text as T - -import qualified Data.Vector as V -import qualified Data.Set as S -import qualified Data.Map as M +import Test.Hspec.HUnit (fromHUnitTest) +import Test.Hspec.Runner (hspec) -import Data.EDN (encode, decode, ToEDN, toEDN, FromEDN, fromEDN) -import Data.EDN.Types as E -import Data.EDN.Types.Class (Result(..), (.=)) -import Data.EDN.Parser (parseMaybe) +import Data.EDN.Test.QuickCheck (ednSerializationProperties) +import Data.EDN.Test.Unit (tests) main :: IO () -main = do - (Counts _ _ e f) <- runTestTT tests - when (e > 0 || f > 0) $ exitFailure - -tests :: Test -tests = TestList [ TestLabel "BSL -> TV parser" $ TestList $ map makeParserCase parserCases - , TestLabel "TV -> BSL encoder" $ TestList $ map makeEncodeCase encodeCases - , TestLabel "ToEDN conversion" $ TestList $ map makeToEDNcase toEDNcases - , TestLabel "FromEDN converter/decoder" $ TestList $ map makeFromEDNcase fromEDNcases - , TestLabel "decoder fail" (TestCase (assertEqual "bad unicode" Nothing (parseMaybe "№"))) - , TestLabel "'Tagged a' conversion" $ TestList taggedConversion - ] - -makeParserCase :: (BSL.ByteString, E.TaggedValue) -> Test -makeParserCase (i, o) = TestCase (assertEqual (BSL.unpack i) (Just o) (parseMaybe i)) - -makeEncodeCase :: (E.TaggedValue, BSL.ByteString) -> Test -makeEncodeCase (i, o) = TestCase (assertEqual (BSL.unpack o) o (encode i)) - -parserCases :: [(BSL.ByteString, E.TaggedValue)] -parserCases = [ ("nil", E.nil) - - , ("true", E.true) - , ("false", E.false) - - , ("\"a nice string\"", "a nice string") - , ("\"split\\second \\t\\rai\\n\"", "split\\second \t\rai\n") - , ("\"test \\\"sausage\\\" shmest\"", "test \"sausage\" shmest") - , ("\"\"", "") - - , ("\\c", E.char 'c') - , ("\\\\", E.char '\\') - , ("\\newline", E.char '\n') - , ("\\space", E.char ' ') - , ("\\tab", E.char '\t') - - , ("justasymbol", E.symbol "justasymbol") - , ("with#stuff:inside", E.symbol "with#stuff:inside") - , ("my-namespace/foo", E.symbolNS "my-namespace" "foo") - , ("/", E.symbol "/") - - , (":fred", E.keyword "fred") - , (":my/fred", E.keyword "my/fred") - - , ("42", E.integer 42) - , ("-1", E.integer (-1)) - - , ("100.50", E.floating 100.5) - , ("-3.14", E.floating (-3.14)) - -- ...and many other strange stuff... - - , ("(a b 42)", sampleList) - , ("()", E.notag $ E.makeList []) - - , ("[a b 42]", sampleVec) - , ("[]", E.notag $ E.makeVec []) - - , ("{:a 1, \"foo\" :bar, [1 2 3] four}", sampleMap) - , ("{}", E.notag $ E.makeMap []) - - , ("#{a b [1 2 3]}", sampleSet) - , ("#{}", E.notag $ E.makeSet []) - - , ("[a b #_foo 42]", sampleDiscard) - , ("(1 2 ;more to go!\n 3 4)", sampleComment) - - , ("#myapp/Person {:first \"Fred\" :last \"Mertz\"}", E.tag "myapp" "Person" sampleTaggedMap) - , ("{:first \"Fred\" :last \"Mertz\"}", E.notag sampleTaggedMap) - ] - -encodeCases :: [(E.TaggedValue, BSL.ByteString)] -encodeCases = [ (E.nil, "nil") - - , (E.true, "true") - , (E.false, "false") - - , (E.string "a nice string", "\"a nice string\"") - , ("overloaded", "\"overloaded\"") - , ("escape \rou\te \\ \"\north\"", "\"escape \\rou\\te \\\\ \\\"\\north\\\"\"") - - , (E.char 'c', "\\c") - , (E.char '\\', "\\\\") - , (E.char '\n', "\\newline") - , (E.char '\r', "\\return") - , (E.char '\t', "\\tab") - , (E.char ' ', "\\space") - - , (E.symbol "justasymbol", "justasymbol") - , (E.symbol "with#stuff:inside", "with#stuff:inside") - , (E.symbolNS "whatever" "whenever", "whatever/whenever") - , (E.symbol "/", "/") - - , (E.keyword "fred", ":fred") - , (E.keyword "my/fred", ":my/fred") - , (E.notag ":overloaded", ":overloaded") -- IsString kw transform only for untagged values - - , (E.integer 42, "42") - , (E.integer (-1), "-1") - - , (E.floating 100.50, "100.5") - , (E.floating (-3.14), "-3.14") - - , (sampleList, "(a b 42)") - , (E.notag $ E.makeList [], "()") - - , (sampleVec, "[a b 42]") - , (E.notag $ E.makeVec [], "[]") - - , (sampleMap, "{\"foo\" :bar :a 1 [1 2 3] four}") -- Order not guaranteed - , (E.notag $ E.makeMap [], "{}") - - , (E.tag "myapp" "Person" sampleTaggedMap, "#myapp/Person {:first \"Fred\" :last \"Mertz\"}") - ] - -sampleList :: E.TaggedValue -sampleList = E.notag $ E.makeList [E.symbol "a", E.symbol "b", E.integer 42] - -sampleVec :: E.TaggedValue -sampleVec = E.notag $ E.makeVec [E.symbol "a", E.symbol "b", E.integer 42] - -sampleMap :: E.TaggedValue -sampleMap = E.notag $ E.makeMap [ (":a", E.integer 1) - , ("foo", E.keyword "bar") - , (E.makeVec [E.integer 1, E.integer 2, E.integer 3], E.symbol "four") - ] - -sampleSet :: E.TaggedValue -sampleSet = E.notag $ E.makeSet [ E.symbol "a" - , E.symbol "b" - , E.notag $ E.makeVec [E.integer 1, E.integer 2, E.integer 3] - ] - -sampleDiscard :: E.TaggedValue -sampleDiscard = E.notag $ E.makeVec [E.symbol "a", E.symbol "b", E.integer 42] - -sampleComment :: E.TaggedValue -sampleComment = E.notag $ E.makeList [E.integer 1, E.integer 2, E.integer 3, E.integer 4] - -sampleTaggedMap :: E.Value -sampleTaggedMap = E.makeMap [ "first" .= E.string "Fred", "last" .= E.string "Mertz" ] - -data ToEDNCase = forall a. ToEDN a => ToEDNCase !a !E.TaggedValue - -makeToEDNcase :: ToEDNCase -> Test -makeToEDNcase (ToEDNCase i o) = TestCase (assertEqual (show o) o (toEDN i)) - -toEDNcases :: [ToEDNCase] -toEDNcases = [ ToEDNCase (Nothing :: Maybe Bool) E.nil - - , ToEDNCase (Left "hi" :: Either String ()) $ E.tag "either" "left" "hi" - , ToEDNCase (Right "z" :: Either () String) $ E.tag "either" "right" "z" - , ToEDNCase (Just '!') (E.char '!') - - , ToEDNCase True E.true - , ToEDNCase False E.false - - , ToEDNCase ("test" :: String) (E.string "test") - , ToEDNCase ("test" :: BSL.ByteString) "test" - , ToEDNCase ("test" :: BS.ByteString) "test" - , ToEDNCase ("test" :: TL.Text) "test" - , ToEDNCase ("test" :: T.Text) "test" - - , ToEDNCase 'c' $ E.char 'c' - , ToEDNCase '\n' $ E.char '\n' - , ToEDNCase '\\' $ E.char '\\' - - , ToEDNCase (3.14 :: Double) $ E.floating 3.14 - , ToEDNCase (42 :: Integer) $ E.integer 42 - - , ToEDNCase () (E.notag $ E.makeList []) - , ToEDNCase ([] :: [()]) (E.notag $ E.makeList []) - , ToEDNCase (["yo", "wassup"] :: [String]) (E.notag $ E.makeList ["yo", "wassup"]) - , ToEDNCase [E.string "i", "am", E.symbolNS "boxed" "container"] (E.notag $ E.makeList [E.string "i", "am", E.symbolNS "boxed" "container"]) - - , ToEDNCase (V.fromList ['o', 'm', 'g']) (E.notag $ E.makeVec [E.char 'o', E.char 'm', E.char 'g']) - - , ToEDNCase (S.fromList ['o', 'm', 'g']) (E.notag $ E.makeSet [E.char 'o', E.char 'm', E.char 'g']) - - , ToEDNCase (M.fromList [("test", "shmest"), ("foo", "bar")] :: M.Map String String) (E.notag $ E.makeMap [("test", "shmest"), ("foo", "bar")]) - , ToEDNCase (M.fromList [(":test", "shmest"), (":foo", "bar")] :: EDNMap) (E.notag $ E.makeMap ["test" .= E.string "shmest", "foo" .= E.string "bar"]) - ] - -data FromEDNCase = forall a. (FromEDN a, Show a, Eq a) => FromEDNCase !BSL.ByteString !a - -makeFromEDNcase :: FromEDNCase -> Test -makeFromEDNcase (FromEDNCase i o) = TestCase $ assertEqual (BSL.unpack i) (Just o) (decode i) - -fromEDNcases :: [FromEDNCase] -fromEDNcases = [ FromEDNCase "nil" (Nothing :: Maybe Bool) - - , FromEDNCase "false" False - , FromEDNCase "true" True - - , FromEDNCase "#either/left hi" (Left "hi" :: Either String ()) - , FromEDNCase "#either/right z" (Right "z" :: Either () String) - , FromEDNCase "\"ok fine\"" (Just "ok fine" :: Maybe T.Text) - , FromEDNCase "nil" (Nothing :: Maybe BSL.ByteString) - - , FromEDNCase "\\newline" '\n' - , FromEDNCase "\\z" 'z' - - , FromEDNCase "42" (42 :: Integer) - , FromEDNCase "-3.14" (-3.14 :: Double) - - , FromEDNCase "(hello world)" (["hello", "world"] :: [String]) - , FromEDNCase "[3 2 1 \"Kaboom!\"]" $ E.makeVec [E.integer 3, E.integer 2, E.integer 1, "Kaboom!"] - , FromEDNCase "#{a/bag :of \"bugs\"}" $ E.makeSet [E.symbolNS "a" "bag", E.keyword "of", E.string "bugs"] - , FromEDNCase "{json: \"like\", but/not: \"really\"}" $ (M.fromList [("json:", "like"), ("but/not:", "really")] :: M.Map String String) - ] - -taggedConversion :: [Test] -taggedConversion = [ TestCase (assertEqual "toEDN tagged" (E.tag "wo" "ot" (E.Boolean False)) (toEDN $ E.tag "wo" "ot" False)) - , TestCase (assertEqual "toEDN notag" E.false (toEDN $ E.notag False)) - , TestCase (assertEqual "fromEDN tagged" (Success $ E.tag "wo" "ot" False) (fromEDN $ E.tag "wo" "ot" (E.Boolean False))) - , TestCase (assertEqual "fromEDN notag" (Success $ E.notag False) (fromEDN $ E.false)) - ] +main = hspec $ do + fromHUnitTest tests + ednSerializationProperties