purescript-iso 0.0.1.4 → 0.0.1.5
raw patch · 8 files changed
+206/−14 lines, 8 filesdep +aeson-attoparsecdep +attoparsecdep +scientific
Dependencies added: aeson-attoparsec, attoparsec, scientific
Files
- purescript-iso.cabal +11/−2
- src/Data/Aeson/JSONEmailAddress.hs +8/−4
- src/Data/Aeson/JSONInt.hs +18/−0
- src/Data/Aeson/JSONInteger.hs +65/−0
- src/Data/Aeson/JSONScientific.hs +66/−0
- src/Test/Serialization.hs +28/−6
- src/Test/Serialization/Types.hs +3/−2
- test/Spec.hs +7/−0
purescript-iso.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 288de828bb3fd2e14f409f4bd84bc2117c0794f83f469214bc6c0108da1ff70f+-- hash: fcbf6153f422f16a84a384b5bcc7532b82e4cca20717465e0b064bc795a44b67 name: purescript-iso-version: 0.0.1.4+version: 0.0.1.5 synopsis: Isomorphic trivial data type definitions over JSON description: Please see the README on GitHub at <https://github.com/githubuser/purescript-iso#readme> category: Web@@ -30,6 +30,9 @@ Data.Aeson.JSONDateTime Data.Aeson.JSONEither Data.Aeson.JSONEmailAddress+ Data.Aeson.JSONInt+ Data.Aeson.JSONInteger+ Data.Aeson.JSONScientific Data.Aeson.JSONString Data.Aeson.JSONTuple Data.Aeson.JSONUnit@@ -43,7 +46,9 @@ build-depends: QuickCheck , aeson+ , aeson-attoparsec , async+ , attoparsec , attoparsec-uri >=0.0.5.1 && <0.0.6 , base >=4.7 && <5 , bytestring@@ -52,6 +57,7 @@ , monad-control , mtl , quickcheck-instances+ , scientific , stm , strict , text@@ -73,7 +79,9 @@ build-depends: QuickCheck , aeson+ , aeson-attoparsec , async+ , attoparsec , attoparsec-uri >=0.0.5.1 && <0.0.6 , base >=4.7 && <5 , bytestring@@ -83,6 +91,7 @@ , mtl , purescript-iso , quickcheck-instances+ , scientific , stm , strict , tasty
src/Data/Aeson/JSONEmailAddress.hs view
@@ -8,10 +8,12 @@ import Text.EmailAddress (EmailAddress, emailAddressFromString) import Data.Aeson (ToJSON, FromJSON) import qualified Data.Char as Char+import Control.Monad (replicateM) import Test.QuickCheck (Arbitrary (..))-import Test.QuickCheck.Gen (listOf1, elements, scale)+import Test.QuickCheck.Gen (elements, scale, choose) import GHC.Generics (Generic) +-- FIXME restrict to 64 x 63 chars newtype JSONEmailAddress = JSONEmailAddress { getJSONEmailAddress :: EmailAddress@@ -19,11 +21,13 @@ instance Arbitrary JSONEmailAddress where arbitrary = do- name <- arbitraryNonEmptyAscii -- listOf1 (arbitrary `suchThat` Char.isAlphaNum)- domain <- arbitraryNonEmptyAscii -- listOf1 (arbitrary `suchThat` Char.isAlphaNum)+ name <- arbitraryNonEmptyAscii 64+ domain <- arbitraryNonEmptyAscii 63 let x = name ++ "@" ++ domain ++ ".com" case emailAddressFromString x of Just e -> pure (JSONEmailAddress e) Nothing -> error x where- arbitraryNonEmptyAscii = scale (`div` 2) $ listOf1 (elements ['a' .. 'z'])+ arbitraryNonEmptyAscii s = do+ l <- choose (1,s)+ replicateM l (elements ['a' .. 'z'])
+ src/Data/Aeson/JSONInt.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE+ DeriveGeneric+ , GeneralizedNewtypeDeriving+ #-}++module Data.Aeson.JSONInt where++import Data.Aeson (ToJSON, FromJSON)+import Data.Int (Int32)+import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary (..))+import Test.QuickCheck.Gen (scale)+import System.IO.Unsafe (unsafePerformIO)+++newtype JSONInt = JSONInt+ { getJSONInt :: Int32+ } deriving (Eq, Ord, Enum, Show, Read, Generic, Num, Real, Integral, ToJSON, FromJSON, Arbitrary)
+ src/Data/Aeson/JSONInteger.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE+ DeriveGeneric+ , GeneralizedNewtypeDeriving+ #-}++module Data.Aeson.JSONInteger where++import Data.Aeson (ToJSON (..), FromJSON (..), Value (String))+import Data.Aeson.Types (typeMismatch)+import Data.Aeson.Attoparsec (attoAeson)+import Data.Attoparsec.Text (decimal, signed)+import Data.Scientific (Scientific, coefficient, base10Exponent)+import qualified Data.Text as T+import Text.Read (readMaybe)+import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary (..))+import Test.QuickCheck.Gen (scale, elements, listOf1)+import System.IO.Unsafe (unsafePerformIO)+++newtype JSONInteger = JSONInteger+ { getJSONInt :: Scientific+ } deriving (Eq, Ord{-, Enum-}, Show, Read, Generic, Num, Real{-, Integral-})++instance ToJSON JSONInteger where+ toJSON (JSONInteger x) = toJSON $+ let c = coefficient x+ e = let g | c > 0 = length (show c) - 1+ | c == 0 = 0+ | otherwise = length (show c) - 2+ in base10Exponent x + g+ q | c > 0 = dropZeros (show c)+ | c == 0 = "0"+ | otherwise = "-" ++ dropZeros (drop 1 $ show c)+ c' | c > 0 =+ if read q < 10+ then q+ else take 1 q ++ "." ++ drop 1 q+ | c == 0 = show c+ | otherwise = dropZeros $+ if read q > -10+ then q+ else take 2 q ++ "." ++ drop 2 q+ dropZeros = reverse . dropWhile (== '0') . reverse+ in c' ++ "e" ++ (if e >= 0 then "+" else "") ++ show e++instance FromJSON JSONInteger where+ parseJSON json = case json of+ String s -> case readMaybe (T.unpack s) of+ Just x -> pure (JSONInteger x)+ _ -> fail'+ _ -> fail'+ where+ fail' = typeMismatch "JSONInteger" json++instance Arbitrary JSONInteger where+ arbitrary = JSONInteger {-. go-} <$> {-scale (^ 10)-} arbitraryInt+ where+ arbitraryInt = do+ s <- listOf1 (elements ['0'..'9'])+ case readMaybe s of+ Just x -> pure x+ go x = unsafePerformIO $ do+ print x+ pure x
+ src/Data/Aeson/JSONScientific.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE+ DeriveGeneric+ , GeneralizedNewtypeDeriving+ #-}++module Data.Aeson.JSONScientific where++import Data.Aeson (ToJSON (..), FromJSON (..), Value (String))+import Data.Aeson.Types (typeMismatch)+import Data.Aeson.Attoparsec (attoAeson)+import Data.Attoparsec.Text (decimal, signed)+import Data.Scientific (Scientific, coefficient, base10Exponent)+import qualified Data.Text as T+import Text.Read (readMaybe)+import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary (..))+import Test.QuickCheck.Gen (scale, elements, listOf1, listOf)+import System.IO.Unsafe (unsafePerformIO)+++newtype JSONScientific = JSONScientific+ { getJSONInt :: Scientific+ } deriving (Eq, Ord{-, Enum-}, Show, Read, Generic, Num, Real{-, Integral-})++instance ToJSON JSONScientific where+ toJSON (JSONScientific x) = toJSON $+ let c = coefficient x+ e = let g | c > 0 = length (show c) - 1+ | c == 0 = 0+ | otherwise = length (show c) - 2+ in base10Exponent x + g+ q | c > 0 = dropZeros (show c)+ | c == 0 = "0"+ | otherwise = "-" ++ dropZeros (drop 1 $ show c)+ c' | c > 0 =+ if read q < 10+ then q+ else take 1 q ++ "." ++ drop 1 q+ | c == 0 = show c+ | otherwise = dropZeros $+ if read q > -10+ then q+ else take 2 q ++ "." ++ drop 2 q+ dropZeros = reverse . dropWhile (== '0') . reverse+ in c' ++ "e" ++ (if e >= 0 then "+" else "") ++ show e++instance FromJSON JSONScientific where+ parseJSON json = case json of+ String s -> case readMaybe (T.unpack s) of+ Just x -> pure (JSONScientific x)+ _ -> fail'+ _ -> fail'+ where+ fail' = typeMismatch "JSONScientific" json++instance Arbitrary JSONScientific where+ arbitrary = JSONScientific {-. go-} <$> {-scale (^ 10)-} arbitraryInt+ where+ arbitraryInt = do+ s <- listOf1 (elements ['0'..'9'])+ p <- listOf (elements ['0'..'9'])+ case readMaybe (s ++ (if length p == 0 then "" else "." ++ p)) of+ Just x -> pure x+ go x = unsafePerformIO $ do+ print x+ pure x
src/Test/Serialization.hs view
@@ -49,6 +49,7 @@ data ServerParams = ServerParams { serverParamsControlHost :: URIAuth , serverParamsTestSuite :: TestSuiteM ()+ , serverParamsMaxSize :: Int } @@ -139,12 +140,12 @@ mOk <- liftIO $ gotClientDeSerialize state y if isOkay mOk then do- mOutgoing <- liftIO $ generateValue state t+ mOutgoing <- liftIO $ generateValue state t serverParamsMaxSize case mOutgoing of GenValue outgoing -> do o' <- send addr server outgoing liftIO $ atomically $ writeTVar (serverGSent state) (Just o')- DoneGenerating -> pure ()+ DoneGenerating -> error "Server finished before client" -- FIXME should never occur - client dictates -- number of quickchecks else fail' serverStateRef server "Bad got deserialize: " addr t mOk@@ -161,14 +162,33 @@ -- verify mOk' <- liftIO $ verify state if isOkay mOk'- then () <$ send addr server (Continue t)+ then do+ liftIO $ clearState state+ () <$ send addr server (Continue t) else fail' serverStateRef server "Bad verify: " addr t mOk' _ -> fail' serverStateRef server "Bad deserialize value: " addr t mOutgoing else fail' serverStateRef server "Bad got serialize: " addr t mOk +clearState :: TestTopicState+ -> IO ()+clearState TestTopicState{..} = atomically $ do+ writeTVar clientG Nothing+ writeTVar clientGReceived Nothing+ writeTVar clientS Nothing+ writeTVar clientSReceived Nothing+ writeTVar clientD Nothing+ writeTVar clientDReceived Nothing+ writeTVar serverG Nothing+ writeTVar serverGSent Nothing+ writeTVar serverS Nothing+ writeTVar serverSSent Nothing+ writeTVar serverD Nothing+ writeTVar serverDSent Nothing ++ getTestSuiteState :: ServerState -> Z.ZMQIdent -> STM (Maybe TestSuiteState) getTestSuiteState serverState clientKey = fmap fst . Map.lookup clientKey <$> readTVar serverState@@ -226,6 +246,8 @@ case mState of NoTopic -> error $ "No topic in test suite! " ++ show t HasTopic (TestTopicState {..}) -> do+ size' <- atomically $ readTVar size+ putStrLn $ "size: " ++ show size' mClientG <- atomically (readTVar clientG) putStrLn $ "clientG: " ++ show (serialize <$> mClientG) mBS <- atomically (readTVar clientGReceived)@@ -233,7 +255,7 @@ mServerS <- atomically (readTVar serverS) putStrLn $ "serverS: " ++ show mServerS mBS <- atomically (readTVar serverSSent)- putStrLn $ " - sent: " ++ show mBS+ putStrLn $ " - sent: " ++ show mBS mClientD <- atomically (readTVar clientD) putStrLn $ "clientD: " ++ show (serialize <$> mClientD) mBS <- atomically (readTVar clientDReceived)@@ -241,7 +263,7 @@ mServerG <- atomically (readTVar serverG) putStrLn $ "serverG: " ++ show (serialize <$> mServerG) mBS <- atomically (readTVar serverGSent)- putStrLn $ " - sent: " ++ show mBS+ putStrLn $ " - sent: " ++ show mBS mClientS <- atomically (readTVar clientS) putStrLn $ "clientS: " ++ show mClientS mBS <- atomically (readTVar clientSReceived)@@ -249,4 +271,4 @@ mServerD <- atomically (readTVar serverD) putStrLn $ "serverD: " ++ show (serialize <$> mServerD) mBS <- atomically (readTVar serverDSent)- putStrLn $ " - sent: " ++ show mBS+ putStrLn $ " - sent: " ++ show mBS
src/Test/Serialization/Types.hs view
@@ -438,10 +438,11 @@ generateValue :: TestTopicState -> TestTopic+ -> Int -> IO (GenValue ServerToClient)-generateValue TestTopicState{size,generate,serialize,serverG} topic = do+generateValue TestTopicState{size,generate,serialize,serverG} topic maxSize = do s <- atomically (readTVar size)- if s >= 100+ if s >= maxSize then pure DoneGenerating else do g <- newQCGen
test/Spec.hs view
@@ -8,6 +8,9 @@ import Data.Aeson.JSONDateTime (JSONDateTime) import Data.Aeson.JSONString (JSONString) import Data.Aeson.JSONEmailAddress (JSONEmailAddress)+import Data.Aeson.JSONInt (JSONInt)+import Data.Aeson.JSONInteger (JSONInteger)+import Data.Aeson.JSONScientific (JSONScientific) import Data.Time (UTCTime) import Data.Time.Calendar (Day) @@ -40,6 +43,7 @@ ServerParams { serverParamsControlHost = URIAuth Strict.Nothing Glob (Strict.Just 5561) , serverParamsTestSuite = tests+ , serverParamsMaxSize = 200 } @@ -56,6 +60,9 @@ registerTopic "JSONDateTime" (Proxy :: Proxy JSONDateTime) registerTopic "JSONString" (Proxy :: Proxy JSONString) registerTopic "JSONEmailAddress" (Proxy :: Proxy JSONEmailAddress)+ registerTopic "JSONInt" (Proxy :: Proxy JSONInt)+ registerTopic "JSONInteger" (Proxy :: Proxy JSONInteger)+ registerTopic "JSONScientific" (Proxy :: Proxy JSONScientific) jsonIso :: ToJSON a => FromJSON a => Eq a => a -> Result