diff --git a/purescript-iso.cabal b/purescript-iso.cabal --- a/purescript-iso.cabal +++ b/purescript-iso.cabal @@ -1,29 +1,31 @@ --- This file has been generated from package.yaml by hpack version 0.21.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.0. -- -- see: https://github.com/sol/hpack -- --- hash: ca2f0181c9dc623b5d3b883c1e50bf817a79ecdc527e6b7c2283e063662be81f +-- hash: 2058c3363478467a6999fd7f7046f77cff04128810d3882c084170379e867bc9 name: purescript-iso -version: 0.0.3 +version: 0.0.4 synopsis: Isomorphic trivial data type definitions over JSON description: Please see the README on GitHub at category: Web +homepage: https://github.com/athanclark/purescript-iso#readme +bug-reports: https://github.com/athanclark/purescript-iso/issues author: Athan Clark maintainer: athan.clark@localcooking.com copyright: 2018 (c) Local Cooking Inc. license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 - extra-source-files: - ChangeLog.md README.md + ChangeLog.md source-repository head type: git - location: git://git.localcooking.com/tooling/purescript-iso.git + location: https://github.com/athanclark/purescript-iso library exposed-modules: @@ -51,8 +53,8 @@ , aeson-diff , async , attoparsec - , attoparsec-uri >=0.0.5.1 && <0.0.6 - , base >=4.7 && <5 + , attoparsec-uri >=0.0.6 + , base >=4.11 && <5 , bytestring , containers , deepseq @@ -86,8 +88,8 @@ , aeson-diff , async , attoparsec - , attoparsec-uri >=0.0.5.1 && <0.0.6 - , base >=4.7 && <5 + , attoparsec-uri >=0.0.6 + , base >=4.11 && <5 , bytestring , containers , deepseq diff --git a/src/Data/Aeson/JSONDateTime.hs b/src/Data/Aeson/JSONDateTime.hs --- a/src/Data/Aeson/JSONDateTime.hs +++ b/src/Data/Aeson/JSONDateTime.hs @@ -3,7 +3,7 @@ , DeriveGeneric #-} -module Data.Aeson.JSONDateTime where +module Data.Aeson.JSONDateTime (JSONDateTime, getJSONDateTime, jsonDateTime) where import Data.Time ( UTCTime, formatTime, iso8601DateFormat, defaultTimeLocale @@ -28,7 +28,7 @@ s' = s ++ "." ++ p ++ "Z" in case decode $ LBS8.fromString $ show s' of Just x -> JSONDateTime x - Nothing -> error s' + Nothing -> error $ "DateTime parsing failed: " ++ s' instance Arbitrary JSONDateTime where diff --git a/src/Data/Aeson/JSONInteger.hs b/src/Data/Aeson/JSONInteger.hs --- a/src/Data/Aeson/JSONInteger.hs +++ b/src/Data/Aeson/JSONInteger.hs @@ -38,24 +38,27 @@ instance ToJSON JSONInteger where toJSON (JSONInteger x) = toJSON $ let c = coefficient x - e = let g | c > 0 = length (show c) - 1 - | c == 0 = 0 + e | c == 0 = 0 + | otherwise = + let g | c > 0 = length (show c) - 1 | otherwise = length (show c) - 2 in base10Exponent x + g - q | c > 0 = dropZeros (show c) + cShownReducedExp | c == 0 = "0" - | otherwise = "-" ++ dropZeros (drop 1 $ show c) + | otherwise = dropZerosFromRight (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 + if read cShownReducedExp < (10 :: Integer) + then cShownReducedExp + else take 1 cShownReducedExp ++ "." ++ drop 1 cShownReducedExp + | c == 0 = "0" + | otherwise = dropZerosFromRight $ + if read cShownReducedExp > (-10 :: Integer) + then cShownReducedExp + else take 2 cShownReducedExp ++ "." ++ drop 2 cShownReducedExp in c' ++ "e" ++ (if e >= 0 then "+" else "") ++ show e + where + dropZerosFromRight :: String -> String + dropZerosFromRight = reverse . dropWhile (== '0') . reverse instance FromJSON JSONInteger where parseJSON json = case json of @@ -73,3 +76,4 @@ s <- listOf1 (elements ['0'..'9']) case readMaybe s of Just x -> pure x + Nothing -> error $ "Can't parse JSONInteger: " ++ s diff --git a/src/Data/Aeson/JSONScientific.hs b/src/Data/Aeson/JSONScientific.hs --- a/src/Data/Aeson/JSONScientific.hs +++ b/src/Data/Aeson/JSONScientific.hs @@ -23,24 +23,31 @@ instance ToJSON JSONScientific where toJSON (JSONScientific x) = toJSON $ let c = coefficient x - e = let g | c > 0 = length (show c) - 1 - | c == 0 = 0 + e | c == 0 = 0 -- if coefficient is 0, then the whole value is 0 + | otherwise = + let g :: Int -- decimal places in coefficient alone + g | c > 0 = length (show c) - 1 | otherwise = length (show c) - 2 in base10Exponent x + g - q | c > 0 = dropZeros (show c) + -- coefficient shown, but without trailing zeros (exponent) + cShownReducedExp :: String + cShownReducedExp | c == 0 = "0" - | otherwise = "-" ++ dropZeros (drop 1 $ show c) + | otherwise = dropZerosFromRight (show c) + c' :: String -- reduced coefficient 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 + if read cShownReducedExp < (10 :: Integer) + then cShownReducedExp + else take 1 cShownReducedExp ++ "." ++ drop 1 cShownReducedExp + | c == 0 = "0" + | otherwise = dropZerosFromRight $ + if read cShownReducedExp > (-10 :: Integer) + then cShownReducedExp + else take 2 cShownReducedExp ++ "." ++ drop 2 cShownReducedExp in c' ++ "e" ++ (if e >= 0 then "+" else "") ++ show e + where + dropZerosFromRight :: String -> String + dropZerosFromRight = reverse . dropWhile (== '0') . reverse instance FromJSON JSONScientific where parseJSON json = case json of @@ -52,10 +59,12 @@ fail' = typeMismatch "JSONScientific" json instance Arbitrary JSONScientific where - arbitrary = JSONScientific {-. go-} <$> {-scale (^ 10)-} arbitraryInt + arbitrary = JSONScientific <$> arbitraryFloat where - arbitraryInt = do + arbitraryFloat = do s <- listOf1 (elements ['0'..'9']) p <- listOf (elements ['0'..'9']) - case readMaybe (s ++ (if length p == 0 then "" else "." ++ p)) of + let s' = s ++ (if null p then "" else "." ++ p) + case readMaybe s' of Just x -> pure x + Nothing -> error $ "Can't parse int: " ++ s' diff --git a/src/Data/Aeson/JSONUnit.hs b/src/Data/Aeson/JSONUnit.hs --- a/src/Data/Aeson/JSONUnit.hs +++ b/src/Data/Aeson/JSONUnit.hs @@ -31,12 +31,3 @@ where fail' = typeMismatch "JSONUnit" json - -boolToUnit :: Bool -> Maybe JSONUnit -boolToUnit ok - | ok = Just JSONUnit - | otherwise = Nothing - - -unitToUnit :: () -> Maybe JSONUnit -unitToUnit () = Just JSONUnit diff --git a/src/Test/Serialization.hs b/src/Test/Serialization.hs --- a/src/Test/Serialization.hs +++ b/src/Test/Serialization.hs @@ -20,7 +20,6 @@ import Data.URI (URI (..), printURI) import Data.URI.Auth (URIAuth) -import Data.UUID (UUID) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.ByteString (ByteString) @@ -33,11 +32,9 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Aeson (eitherDecode, encode, toJSON) -import Control.Monad (forever, void, when) +import Control.Monad (forever, when) import Control.Monad.Reader (runReaderT) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Control (liftBaseWith) -import Control.Concurrent.Async (async, link, cancel) import Control.Concurrent.STM (STM, TVar, newTVar, atomically, modifyTVar, readTVar, writeTVar) import System.ZMQ4.Monadic @@ -77,7 +74,6 @@ runReaderT serverParamsTestSuite suiteState ts <- Map.keysSet <$> atomically (readTVar suiteState) when (ts == Set.empty) exitSuccess - forever $ do mIncoming <- Z.receive server @@ -213,7 +209,7 @@ fail' :: Show a => ServerState - -> Z.Socket z Router Dealer Z.Bound + -> Z.Socket z Router Dealer 'Z.Bound -> String -> Z.ZMQIdent -> TestTopic @@ -225,7 +221,7 @@ error $ prefix ++ show t ++ ", " ++ show v -send :: Z.ZMQIdent -> Z.Socket z Router Dealer Z.Bound -> ServerToClient -> ZMQ z ByteString +send :: Z.ZMQIdent -> Z.Socket z Router Dealer 'Z.Bound -> ServerToClient -> ZMQ z ByteString send addr server x = do let x' = LBS.toStrict (encode x) Z.send addr server (x' :| []) @@ -250,25 +246,25 @@ putStrLn $ "size: " ++ show size' mClientG <- atomically (readTVar clientG) putStrLn $ "clientG: " ++ show (serialize <$> mClientG) - mBS <- atomically (readTVar clientGReceived) - putStrLn $ " - received: " ++ show mBS + mCGR <- atomically (readTVar clientGReceived) + putStrLn $ " - received: " ++ show mCGR mServerS <- atomically (readTVar serverS) putStrLn $ "serverS: " ++ show mServerS - mBS <- atomically (readTVar serverSSent) - putStrLn $ " - sent: " ++ show mBS + mSSS <- atomically (readTVar serverSSent) + putStrLn $ " - sent: " ++ show mSSS mClientD <- atomically (readTVar clientD) putStrLn $ "clientD: " ++ show (serialize <$> mClientD) - mBS <- atomically (readTVar clientDReceived) - putStrLn $ " - received: " ++ show mBS + mCDR <- atomically (readTVar clientDReceived) + putStrLn $ " - received: " ++ show mCDR mServerG <- atomically (readTVar serverG) putStrLn $ "serverG: " ++ show (serialize <$> mServerG) - mBS <- atomically (readTVar serverGSent) - putStrLn $ " - sent: " ++ show mBS + mSGS <- atomically (readTVar serverGSent) + putStrLn $ " - sent: " ++ show mSGS mClientS <- atomically (readTVar clientS) putStrLn $ "clientS: " ++ show mClientS - mBS <- atomically (readTVar clientSReceived) - putStrLn $ " - received: " ++ show mBS + mCSR <- atomically (readTVar clientSReceived) + putStrLn $ " - received: " ++ show mCSR mServerD <- atomically (readTVar serverD) putStrLn $ "serverD: " ++ show (serialize <$> mServerD) - mBS <- atomically (readTVar serverDSent) - putStrLn $ " - sent: " ++ show mBS + mSDS <- atomically (readTVar serverDSent) + putStrLn $ " - sent: " ++ show mSDS diff --git a/src/Test/Serialization/Types.hs b/src/Test/Serialization/Types.hs --- a/src/Test/Serialization/Types.hs +++ b/src/Test/Serialization/Types.hs @@ -22,7 +22,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Aeson - (FromJSON (..), ToJSON (..), object, (.:), (.=), Value (..), encode, decode) + (FromJSON (..), ToJSON (..), object, (.:), (.=), Value (..), encode) import Data.Aeson.Types (typeMismatch, Parser, parseEither) import Data.Aeson.Diff (diff) import Data.Proxy (Proxy (..)) @@ -557,7 +557,7 @@ , deserialize , serialize } = do - let serverSMatch :: (Value -> IO _) -> IO (HasServerG (HasClientS (ServerSerializedMatch _))) + let serverSMatch :: (Value -> IO a) -> IO (HasServerG (HasClientS (ServerSerializedMatch a))) serverSMatch x = do mServerG <- atomically (readTVar serverG) case mServerG of @@ -574,7 +574,7 @@ putStrLn $ " clientS-serverG: " ++ show (diff clientS' serverG'') pure $ ServerSerializedMismatch serverG'' clientS' (encode serverG'') (encode clientS') else ServerSerializedMatch <$> x clientS' - serverDMatch :: IO _ -> Value -> IO (HasServerD (DesValue (ServerDeSerializedMatch _))) + serverDMatch :: IO a -> Value -> IO (HasServerD (DesValue (ServerDeSerializedMatch a))) serverDMatch x clientS' = do mServerD <- atomically (readTVar serverD) case mServerD of @@ -585,7 +585,7 @@ Right clientS'' | clientS'' /= serverD' -> pure $ DesValue $ ServerDeSerializedMismatch clientS' (toJSON serverD') (encode clientS') (encode serverD') | otherwise -> (DesValue . ServerDeSerializedMatch) <$> x - clientSMatch :: (Value -> IO _) -> IO (HasClientG (HasServerS (ClientSerializedMatch _))) + clientSMatch :: (Value -> IO a) -> IO (HasClientG (HasServerS (ClientSerializedMatch a))) clientSMatch x = do mClientG <- atomically (readTVar clientG) case mClientG of