purescript-iso 0.0.3 → 0.0.4
raw patch · 7 files changed
+76/−74 lines, 7 filesdep ~attoparsec-uridep ~base
Dependency ranges changed: attoparsec-uri, base
Files
- purescript-iso.cabal +13/−11
- src/Data/Aeson/JSONDateTime.hs +2/−2
- src/Data/Aeson/JSONInteger.hs +17/−13
- src/Data/Aeson/JSONScientific.hs +25/−16
- src/Data/Aeson/JSONUnit.hs +0/−9
- src/Test/Serialization.hs +15/−19
- src/Test/Serialization/Types.hs +4/−4
purescript-iso.cabal view
@@ -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 <https://github.com/githubuser/purescript-iso#readme> 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
src/Data/Aeson/JSONDateTime.hs view
@@ -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
src/Data/Aeson/JSONInteger.hs view
@@ -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
src/Data/Aeson/JSONScientific.hs view
@@ -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'
src/Data/Aeson/JSONUnit.hs view
@@ -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
src/Test/Serialization.hs view
@@ -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
src/Test/Serialization/Types.hs view
@@ -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