{-|
Module      : Test.Aeson.Internal.Utils
Description : Internal types, functions and values
Copyright   : (c) Plow Technologies, 2016
License     : BSD3
Maintainer  : mchaver@gmail.com
Stability   : Beta
-}

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes          #-}

module Test.Aeson.Internal.Utils where

import           Control.Exception

import           Data.Aeson
import           Data.Aeson.Encode.Pretty
import           Data.ByteString.Lazy (ByteString)
import           Data.Proxy
import           Data.Typeable

import           Prelude

import           Test.Hspec
import           Test.QuickCheck

-- | Option to indicate whether to create a separate comparison file or overwrite the golden file.
-- A separate file allows you to use `diff` to compare.
-- Overwriting allows you to use source control tools for comparison.
data ComparisonFile
  = FaultyFile
  -- ^ Create a new faulty file when tests fail
  | OverwriteGoldenFile
  -- ^ Overwrite the golden file when tests fail

-- | Option indicating whether to fail tests when the random seed does not produce the same values as in the golden file.
-- Default is to output a warning.
data RandomMismatchOption
  = RandomMismatchWarning
  -- ^ Only output a warning when the random seed does not produce the same values
  | RandomMismatchError
  -- ^ Fail the test when the random seed does not produce the same value

data Settings = Settings 
  { Settings -> GoldenDirectoryOption
goldenDirectoryOption :: GoldenDirectoryOption
  -- ^ use a custom directory name or use the generic "golden" directory.
  , Settings -> Bool
useModuleNameAsSubDirectory :: Bool
  -- ^ If true, use the module name in the file path, otherwise ignore it.
  , Settings -> Int
sampleSize :: Int
  -- ^ How many instances of each type you want. If you use ADT versions than it will use the sample size for each constructor.
  , Settings -> ComparisonFile
comparisonFile :: ComparisonFile
  -- ^ Whether to create a separate comparison file or ovewrite the golden file.
  , Settings -> RandomMismatchOption
randomMismatchOption :: RandomMismatchOption
  -- ^ Whether to output a warning or fail the test when the random seed produces different values than the values in the golden file.
  }

-- | A custom directory name or a preselected directory name.
data GoldenDirectoryOption = CustomDirectoryName String | GoldenDirectory

-- | The default settings for general use cases.
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = GoldenDirectoryOption
-> Bool
-> Int
-> ComparisonFile
-> RandomMismatchOption
-> Settings
Settings GoldenDirectoryOption
GoldenDirectory Bool
False 5 ComparisonFile
FaultyFile RandomMismatchOption
RandomMismatchWarning

-- | put brackets around a String.
addBrackets :: String -> String
addBrackets :: String -> String
addBrackets s :: String
s =
  if ' ' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s
    then "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
    else String
s

-- | [hspec](http://hspec.github.io/) style combinator to easily write tests
-- that check the a given operation returns the same value it was given, e.g.
-- roundtrip tests.
shouldBeIdentity :: (Eq a, Show a, Arbitrary a) =>
  Proxy a -> (a -> IO a) -> Property
shouldBeIdentity :: Proxy a -> (a -> IO a) -> Property
shouldBeIdentity Proxy func :: a -> IO a
func =
  (a -> Expectation) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> Expectation) -> Property) -> (a -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \ (a
a :: a) -> a -> IO a
func a
a IO a -> a -> Expectation
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` a
a

-- | This function will compare one JSON encoding to a subsequent JSON encoding, thus eliminating the need for an Eq instance
checkAesonEncodingEquality :: forall a . (ToJSON a, FromJSON a) => JsonShow a -> Bool
checkAesonEncodingEquality :: JsonShow a -> Bool
checkAesonEncodingEquality (JsonShow a :: a
a) =  
  let byteStrA :: ByteString
byteStrA = a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
a
      decodedVal :: Either String a
decodedVal =  (ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
byteStrA) :: Either String a
      eitherByteStrB :: Either String ByteString
eitherByteStrB = a -> ByteString
forall a. ToJSON a => a -> ByteString
encode (a -> ByteString) -> Either String a -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String a
decodedVal  
  in (ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
byteStrA) Either String ByteString -> Either String ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Either String ByteString
eitherByteStrB

-- | run decode in IO, if it returns Left then throw an error.
aesonDecodeIO :: FromJSON a => ByteString -> IO a
aesonDecodeIO :: ByteString -> IO a
aesonDecodeIO bs :: ByteString
bs = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs of
  Right a :: a
a -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  Left msg :: String
msg -> AesonDecodeError -> IO a
forall e a. Exception e => e -> IO a
throwIO (AesonDecodeError -> IO a) -> AesonDecodeError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> AesonDecodeError
AesonDecodeError String
msg

data AesonDecodeError = AesonDecodeError String
  deriving (Int -> AesonDecodeError -> String -> String
[AesonDecodeError] -> String -> String
AesonDecodeError -> String
(Int -> AesonDecodeError -> String -> String)
-> (AesonDecodeError -> String)
-> ([AesonDecodeError] -> String -> String)
-> Show AesonDecodeError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AesonDecodeError] -> String -> String
$cshowList :: [AesonDecodeError] -> String -> String
show :: AesonDecodeError -> String
$cshow :: AesonDecodeError -> String
showsPrec :: Int -> AesonDecodeError -> String -> String
$cshowsPrec :: Int -> AesonDecodeError -> String -> String
Show, AesonDecodeError -> AesonDecodeError -> Bool
(AesonDecodeError -> AesonDecodeError -> Bool)
-> (AesonDecodeError -> AesonDecodeError -> Bool)
-> Eq AesonDecodeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AesonDecodeError -> AesonDecodeError -> Bool
$c/= :: AesonDecodeError -> AesonDecodeError -> Bool
== :: AesonDecodeError -> AesonDecodeError -> Bool
$c== :: AesonDecodeError -> AesonDecodeError -> Bool
Eq)

instance Exception AesonDecodeError

-- | Used to eliminate the need for an Eq instance
newtype JsonShow a = JsonShow a 

instance ToJSON a => Show (JsonShow a) where 
    show :: JsonShow a -> String
show (JsonShow v :: a
v) = ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> (a -> ByteString) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a
v 

instance ToJSON a => ToJSON (JsonShow a) where
    toJSON :: JsonShow a -> Value
toJSON (JsonShow a :: a
a) = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a

instance FromJSON a => FromJSON (JsonShow a) where
     parseJSON :: Value -> Parser (JsonShow a)
parseJSON v :: Value
v = a -> JsonShow a
forall a. a -> JsonShow a
JsonShow (a -> JsonShow a) -> Parser a -> Parser (JsonShow a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)

instance Arbitrary a => Arbitrary (JsonShow a) where
    arbitrary :: Gen (JsonShow a)
arbitrary = a -> JsonShow a
forall a. a -> JsonShow a
JsonShow (a -> JsonShow a) -> Gen a -> Gen (JsonShow a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary 

--------------------------------------------------
-- Handle creating names
--------------------------------------------------

newtype TopDir =
  TopDir
    { TopDir -> String
unTopDir :: FilePath
    } deriving (TopDir -> TopDir -> Bool
(TopDir -> TopDir -> Bool)
-> (TopDir -> TopDir -> Bool) -> Eq TopDir
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TopDir -> TopDir -> Bool
$c/= :: TopDir -> TopDir -> Bool
== :: TopDir -> TopDir -> Bool
$c== :: TopDir -> TopDir -> Bool
Eq,ReadPrec [TopDir]
ReadPrec TopDir
Int -> ReadS TopDir
ReadS [TopDir]
(Int -> ReadS TopDir)
-> ReadS [TopDir]
-> ReadPrec TopDir
-> ReadPrec [TopDir]
-> Read TopDir
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TopDir]
$creadListPrec :: ReadPrec [TopDir]
readPrec :: ReadPrec TopDir
$creadPrec :: ReadPrec TopDir
readList :: ReadS [TopDir]
$creadList :: ReadS [TopDir]
readsPrec :: Int -> ReadS TopDir
$creadsPrec :: Int -> ReadS TopDir
Read,Int -> TopDir -> String -> String
[TopDir] -> String -> String
TopDir -> String
(Int -> TopDir -> String -> String)
-> (TopDir -> String)
-> ([TopDir] -> String -> String)
-> Show TopDir
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TopDir] -> String -> String
$cshowList :: [TopDir] -> String -> String
show :: TopDir -> String
$cshow :: TopDir -> String
showsPrec :: Int -> TopDir -> String -> String
$cshowsPrec :: Int -> TopDir -> String -> String
Show)

newtype ModuleName =
  ModuleName
    { ModuleName -> String
unModuleName :: FilePath
    } deriving (ModuleName -> ModuleName -> Bool
(ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> Bool) -> Eq ModuleName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleName -> ModuleName -> Bool
$c/= :: ModuleName -> ModuleName -> Bool
== :: ModuleName -> ModuleName -> Bool
$c== :: ModuleName -> ModuleName -> Bool
Eq,ReadPrec [ModuleName]
ReadPrec ModuleName
Int -> ReadS ModuleName
ReadS [ModuleName]
(Int -> ReadS ModuleName)
-> ReadS [ModuleName]
-> ReadPrec ModuleName
-> ReadPrec [ModuleName]
-> Read ModuleName
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ModuleName]
$creadListPrec :: ReadPrec [ModuleName]
readPrec :: ReadPrec ModuleName
$creadPrec :: ReadPrec ModuleName
readList :: ReadS [ModuleName]
$creadList :: ReadS [ModuleName]
readsPrec :: Int -> ReadS ModuleName
$creadsPrec :: Int -> ReadS ModuleName
Read,Int -> ModuleName -> String -> String
[ModuleName] -> String -> String
ModuleName -> String
(Int -> ModuleName -> String -> String)
-> (ModuleName -> String)
-> ([ModuleName] -> String -> String)
-> Show ModuleName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ModuleName] -> String -> String
$cshowList :: [ModuleName] -> String -> String
show :: ModuleName -> String
$cshow :: ModuleName -> String
showsPrec :: Int -> ModuleName -> String -> String
$cshowsPrec :: Int -> ModuleName -> String -> String
Show)

newtype TypeName =
  TypeName
    { TypeName -> String
unTypeName :: FilePath
    } deriving (TypeName -> TypeName -> Bool
(TypeName -> TypeName -> Bool)
-> (TypeName -> TypeName -> Bool) -> Eq TypeName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeName -> TypeName -> Bool
$c/= :: TypeName -> TypeName -> Bool
== :: TypeName -> TypeName -> Bool
$c== :: TypeName -> TypeName -> Bool
Eq,ReadPrec [TypeName]
ReadPrec TypeName
Int -> ReadS TypeName
ReadS [TypeName]
(Int -> ReadS TypeName)
-> ReadS [TypeName]
-> ReadPrec TypeName
-> ReadPrec [TypeName]
-> Read TypeName
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TypeName]
$creadListPrec :: ReadPrec [TypeName]
readPrec :: ReadPrec TypeName
$creadPrec :: ReadPrec TypeName
readList :: ReadS [TypeName]
$creadList :: ReadS [TypeName]
readsPrec :: Int -> ReadS TypeName
$creadsPrec :: Int -> ReadS TypeName
Read,Int -> TypeName -> String -> String
[TypeName] -> String -> String
TypeName -> String
(Int -> TypeName -> String -> String)
-> (TypeName -> String)
-> ([TypeName] -> String -> String)
-> Show TypeName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TypeName] -> String -> String
$cshowList :: [TypeName] -> String -> String
show :: TypeName -> String
$cshow :: TypeName -> String
showsPrec :: Int -> TypeName -> String -> String
$cshowsPrec :: Int -> TypeName -> String -> String
Show)

data TypeNameInfo a =
  TypeNameInfo
    { TypeNameInfo a -> TopDir
typeNameTopDir :: TopDir
    , TypeNameInfo a -> Maybe ModuleName
typeNameModuleName :: Maybe ModuleName
    , TypeNameInfo a -> TypeName
typeNameTypeName   :: TypeName
    } deriving (TypeNameInfo a -> TypeNameInfo a -> Bool
(TypeNameInfo a -> TypeNameInfo a -> Bool)
-> (TypeNameInfo a -> TypeNameInfo a -> Bool)
-> Eq (TypeNameInfo a)
forall a. TypeNameInfo a -> TypeNameInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeNameInfo a -> TypeNameInfo a -> Bool
$c/= :: forall a. TypeNameInfo a -> TypeNameInfo a -> Bool
== :: TypeNameInfo a -> TypeNameInfo a -> Bool
$c== :: forall a. TypeNameInfo a -> TypeNameInfo a -> Bool
Eq,ReadPrec [TypeNameInfo a]
ReadPrec (TypeNameInfo a)
Int -> ReadS (TypeNameInfo a)
ReadS [TypeNameInfo a]
(Int -> ReadS (TypeNameInfo a))
-> ReadS [TypeNameInfo a]
-> ReadPrec (TypeNameInfo a)
-> ReadPrec [TypeNameInfo a]
-> Read (TypeNameInfo a)
forall a. ReadPrec [TypeNameInfo a]
forall a. ReadPrec (TypeNameInfo a)
forall a. Int -> ReadS (TypeNameInfo a)
forall a. ReadS [TypeNameInfo a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TypeNameInfo a]
$creadListPrec :: forall a. ReadPrec [TypeNameInfo a]
readPrec :: ReadPrec (TypeNameInfo a)
$creadPrec :: forall a. ReadPrec (TypeNameInfo a)
readList :: ReadS [TypeNameInfo a]
$creadList :: forall a. ReadS [TypeNameInfo a]
readsPrec :: Int -> ReadS (TypeNameInfo a)
$creadsPrec :: forall a. Int -> ReadS (TypeNameInfo a)
Read,Int -> TypeNameInfo a -> String -> String
[TypeNameInfo a] -> String -> String
TypeNameInfo a -> String
(Int -> TypeNameInfo a -> String -> String)
-> (TypeNameInfo a -> String)
-> ([TypeNameInfo a] -> String -> String)
-> Show (TypeNameInfo a)
forall a. Int -> TypeNameInfo a -> String -> String
forall a. [TypeNameInfo a] -> String -> String
forall a. TypeNameInfo a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TypeNameInfo a] -> String -> String
$cshowList :: forall a. [TypeNameInfo a] -> String -> String
show :: TypeNameInfo a -> String
$cshow :: forall a. TypeNameInfo a -> String
showsPrec :: Int -> TypeNameInfo a -> String -> String
$cshowsPrec :: forall a. Int -> TypeNameInfo a -> String -> String
Show)

mkTypeNameInfo :: forall a . Arbitrary a => Typeable a => Settings -> Proxy a -> IO (TypeNameInfo a)
mkTypeNameInfo :: Settings -> Proxy a -> IO (TypeNameInfo a)
mkTypeNameInfo (Settings { Bool
useModuleNameAsSubDirectory :: Bool
useModuleNameAsSubDirectory :: Settings -> Bool
useModuleNameAsSubDirectory
                       , GoldenDirectoryOption
goldenDirectoryOption :: GoldenDirectoryOption
goldenDirectoryOption :: Settings -> GoldenDirectoryOption
goldenDirectoryOption}) proxy :: Proxy a
proxy = do
  Maybe String
maybeModuleName <- IO (Maybe String)
maybeModuleNameIO
  TypeNameInfo a -> IO (TypeNameInfo a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeNameInfo a -> IO (TypeNameInfo a))
-> TypeNameInfo a -> IO (TypeNameInfo a)
forall a b. (a -> b) -> a -> b
$ TopDir -> Maybe ModuleName -> TypeName -> TypeNameInfo a
forall a. TopDir -> Maybe ModuleName -> TypeName -> TypeNameInfo a
TypeNameInfo (String -> TopDir
TopDir         String
topDir )
                        (String -> ModuleName
ModuleName (String -> ModuleName) -> Maybe String -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
maybeModuleName )
                        (String -> TypeName
TypeName String
typeName)
  where
   typeName :: String
typeName = TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy a
proxy)
   maybeModuleNameIO :: IO (Maybe String)
maybeModuleNameIO =
     if Bool
useModuleNameAsSubDirectory
     then do
       a
arbA <- Gen a -> IO a
forall a. Gen a -> IO a
generate (Gen a
forall a. Arbitrary a => Gen a
arbitrary :: Gen a)
       Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConModule (TyCon -> String) -> (a -> TyCon) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> (a -> TypeRep) -> a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a
arbA
     else Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

   topDir :: String
topDir =
     case GoldenDirectoryOption
goldenDirectoryOption of
       GoldenDirectory -> "golden"
       CustomDirectoryName d :: String
d -> String
d

encodePrettySortedKeys :: ToJSON a => a -> ByteString
encodePrettySortedKeys :: a -> ByteString
encodePrettySortedKeys = Config -> a -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
defConfig { confCompare :: Text -> Text -> Ordering
confCompare = Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare }