diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,20 +1,4 @@ -# Version 0.2 - -* Depend on `singletons-2.2`, which means `KProxy` is gone. - - -# Version 0.1.0.2 - -* Relax upper bound on `aeson`, `base`, `singletons`, `constraints`. - - -# Version 0.1.0.1 - -* Relax upper bound on `singletons` dependency. - -* Relax upper bound on `aeson` dependency. - - -# Version 0.1 +# Version 0.7 -* Initial release. +* This library exports the `ToJSON` and `FromJSON` instances previously + exported from `exinst-0.6`. diff --git a/LICENSE.txt b/LICENSE.txt --- a/LICENSE.txt +++ b/LICENSE.txt @@ -1,4 +1,4 @@ -Copyright (c) 2015-2016, Renzo Carbonara +Copyright (c) 2015-2018, Renzo Carbonara All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,2 +1,6 @@ -See the README file in the @exinst@ package for more general documentation: -https://hackage.haskell.org/package/exinst#readme +# exinst-aeson + +See the [BSD3 LICENSE](https://github.com/k0001/exinst/blob/master/exinst/exinst-aeson/LICENSE.txt) +file to learn about the legal terms and conditions for this library. + + diff --git a/exinst-aeson.cabal b/exinst-aeson.cabal --- a/exinst-aeson.cabal +++ b/exinst-aeson.cabal @@ -1,28 +1,45 @@ name: exinst-aeson -version: 0.2 +version: 0.7 author: Renzo Carbonara -maintainer: renzoλcarbonara.com.ar -copyright: Renzo Carbonara 2015-2016 +maintainer: renλren!zone +copyright: Renzo Carbonara 2015-2018 license: BSD3 license-file: LICENSE.txt extra-source-files: README.md CHANGELOG.md category: Data build-type: Simple cabal-version: >=1.18 -synopsis: Derive instances for the `aeson` library for your existential types. +synopsis: Dependent pairs and their instances. homepage: https://github.com/k0001/exinst bug-reports: https://github.com/k0001/exinst/issues + library - hs-source-dirs: src/lib + hs-source-dirs: lib default-language: Haskell2010 - exposed-modules: - Exinst.Instances.Aeson + exposed-modules: Exinst.Aeson build-depends: - aeson >=0.8 && <1.1 + aeson , base >=4.9 && <5.0 - , constraints >=0.4 && <0.9 - , exinst >=0.2 && <0.3 - , singletons >=2.2 && <2.3 + , constraints + , exinst >= 0.7 + , singletons ghcjs-options: -Wall -O3 ghc-options: -Wall -O2 + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + build-depends: + aeson + , base + , bytestring + , exinst + , exinst-aeson + , QuickCheck + , tasty + , tasty-quickcheck + ghcjs-options: -Wall -O0 + ghc-options: -Wall -O0 diff --git a/lib/Exinst/Aeson.hs b/lib/Exinst/Aeson.hs new file mode 100644 --- /dev/null +++ b/lib/Exinst/Aeson.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This module exports 'Ae.FromJSON' and 'Ae.ToJSON' instances for 'Some1', +-- 'Some2', 'Some3' and 'Some4' from "Exinst", provided situable +-- 'Dict1', 'Dict2', 'Dict3' and 'Dict4' instances are available. +-- +-- See the README file in the @exinst@ package for more general documentation: +-- https://hackage.haskell.org/package/exinst#readme +module Exinst.Aeson () where + +import qualified Data.Aeson as Ae +import Data.Constraint +import Data.Kind (Type) +import Data.Singletons +import Exinst +import Prelude + +-------------------------------------------------------------------------------- + +instance forall (f :: k1 -> Type) + . ( SingKind k1 + , Ae.ToJSON (Demote k1) + , Dict1 Ae.ToJSON f + ) => Ae.ToJSON (Some1 f) + where + {-# INLINABLE toJSON #-} + toJSON = \some1x -> withSome1Sing some1x $ \sa1 (x :: f a1) -> + case dict1 sa1 :: Dict (Ae.ToJSON (f a1)) of + Dict -> Ae.toJSON (fromSing sa1, x) + +instance forall (f :: k2 -> k1 -> Type) + . ( SingKind k2 + , SingKind k1 + , Ae.ToJSON (Demote k2) + , Ae.ToJSON (Demote k1) + , Dict2 Ae.ToJSON f + ) => Ae.ToJSON (Some2 f) + where + {-# INLINABLE toJSON #-} + toJSON = \some2x -> withSome2Sing some2x $ \sa2 sa1 (x :: f a2 a1) -> + case dict2 sa2 sa1 :: Dict (Ae.ToJSON (f a2 a1)) of + Dict -> Ae.toJSON ((fromSing sa2, fromSing sa1), x) + +instance forall (f :: k3 -> k2 -> k1 -> Type) + . ( SingKind k3 + , SingKind k2 + , SingKind k1 + , Ae.ToJSON (Demote k3) + , Ae.ToJSON (Demote k2) + , Ae.ToJSON (Demote k1) + , Dict3 Ae.ToJSON f + ) => Ae.ToJSON (Some3 f) + where + {-# INLINABLE toJSON #-} + toJSON = \some3x -> withSome3Sing some3x $ \sa3 sa2 sa1 (x :: f a3 a2 a1) -> + case dict3 sa3 sa2 sa1 :: Dict (Ae.ToJSON (f a3 a2 a1)) of + Dict -> Ae.toJSON ((fromSing sa3, fromSing sa2, fromSing sa1), x) + +instance forall (f :: k4 -> k3 -> k2 -> k1 -> Type) + . ( SingKind k4 + , SingKind k3 + , SingKind k2 + , SingKind k1 + , Ae.ToJSON (Demote k4) + , Ae.ToJSON (Demote k3) + , Ae.ToJSON (Demote k2) + , Ae.ToJSON (Demote k1) + , Dict4 Ae.ToJSON f + ) => Ae.ToJSON (Some4 f) + where + {-# INLINABLE toJSON #-} + toJSON = \some4x -> withSome4Sing some4x $ \sa4 sa3 sa2 sa1 (x :: f a4 a3 a2 a1) -> + case dict4 sa4 sa3 sa2 sa1 :: Dict (Ae.ToJSON (f a4 a3 a2 a1)) of + Dict -> Ae.toJSON ((fromSing sa4, fromSing sa3, fromSing sa2, fromSing sa1), x) + +-------------------------------------------------------------------------------- + +instance forall (f :: k1 -> Type) + . ( SingKind k1 + , Ae.FromJSON (Demote k1) + , Dict1 Ae.FromJSON f + ) => Ae.FromJSON (Some1 f) + where + {-# INLINABLE parseJSON #-} + parseJSON = \v -> do + (rsa1, v') <- Ae.parseJSON v + withSomeSing rsa1 $ \(sa1 :: Sing (a1 :: k1)) -> + case dict1 sa1 :: Dict (Ae.FromJSON (f a1)) of + Dict -> do + x :: f a1 <- Ae.parseJSON v' + pure (Some1 sa1 x) + +instance forall (f :: k2 -> k1 -> Type) + . ( SingKind k2 + , SingKind k1 + , Ae.FromJSON (Demote k2) + , Ae.FromJSON (Demote k1) + , Dict2 Ae.FromJSON f + ) => Ae.FromJSON (Some2 f) + where + {-# INLINABLE parseJSON #-} + parseJSON = \v -> do + ((rsa2, rsa1), v') <- Ae.parseJSON v + withSomeSing rsa2 $ \(sa2 :: Sing (a2 :: k2)) -> + withSomeSing rsa1 $ \(sa1 :: Sing (a1 :: k1)) -> + case dict2 sa2 sa1 :: Dict (Ae.FromJSON (f a2 a1)) of + Dict -> do + x :: f a2 a1 <- Ae.parseJSON v' + pure (Some2 sa2 sa1 x) + +instance forall (f :: k3 -> k2 -> k1 -> Type) + . ( SingKind k3 + , SingKind k2 + , SingKind k1 + , Ae.FromJSON (Demote k3) + , Ae.FromJSON (Demote k2) + , Ae.FromJSON (Demote k1) + , Dict3 Ae.FromJSON f + ) => Ae.FromJSON (Some3 f) + where + {-# INLINABLE parseJSON #-} + parseJSON = \v -> do + ((rsa3, rsa2, rsa1), v') <- Ae.parseJSON v + withSomeSing rsa3 $ \(sa3 :: Sing (a3 :: k3)) -> + withSomeSing rsa2 $ \(sa2 :: Sing (a2 :: k2)) -> + withSomeSing rsa1 $ \(sa1 :: Sing (a1 :: k1)) -> + case dict3 sa3 sa2 sa1 :: Dict (Ae.FromJSON (f a3 a2 a1)) of + Dict -> do + x :: f a3 a2 a1 <- Ae.parseJSON v' + pure (Some3 sa3 sa2 sa1 x) + +instance forall (f :: k4 -> k3 -> k2 -> k1 -> Type) + . ( SingKind k4 + , SingKind k3 + , SingKind k2 + , SingKind k1 + , Ae.FromJSON (Demote k4) + , Ae.FromJSON (Demote k3) + , Ae.FromJSON (Demote k2) + , Ae.FromJSON (Demote k1) + , Dict4 Ae.FromJSON f + ) => Ae.FromJSON (Some4 f) + where + {-# INLINABLE parseJSON #-} + parseJSON = \v -> do + ((rsa4, rsa3, rsa2, rsa1), v') <- Ae.parseJSON v + withSomeSing rsa4 $ \(sa4 :: Sing (a4 :: k4)) -> + withSomeSing rsa3 $ \(sa3 :: Sing (a3 :: k3)) -> + withSomeSing rsa2 $ \(sa2 :: Sing (a2 :: k2)) -> + withSomeSing rsa1 $ \(sa1 :: Sing (a1 :: k1)) -> + case dict4 sa4 sa3 sa2 sa1 :: Dict (Ae.FromJSON (f a4 a3 a2 a1)) of + Dict -> do + x :: f a4 a3 a2 a1 <- Ae.parseJSON v' + pure (Some4 sa4 sa3 sa2 sa1 x) + +-------------------------------------------------------------------------------- + +instance (Ae.FromJSON (l a1), Ae.FromJSON (r a1)) => Ae.FromJSON (S1 l r a1) +instance (Ae.FromJSON (l a2 a1), Ae.FromJSON (r a2 a1)) => Ae.FromJSON (S2 l r a2 a1) +instance (Ae.FromJSON (l a3 a2 a1), Ae.FromJSON (r a3 a2 a1)) => Ae.FromJSON (S3 l r a3 a2 a1) +instance (Ae.FromJSON (l a4 a3 a2 a1), Ae.FromJSON (r a4 a3 a2 a1)) => Ae.FromJSON (S4 l r a4 a3 a2 a1) + +instance (Ae.ToJSON (l a1), Ae.ToJSON (r a1)) => Ae.ToJSON (S1 l r a1) +instance (Ae.ToJSON (l a2 a1), Ae.ToJSON (r a2 a1)) => Ae.ToJSON (S2 l r a2 a1) +instance (Ae.ToJSON (l a3 a2 a1), Ae.ToJSON (r a3 a2 a1)) => Ae.ToJSON (S3 l r a3 a2 a1) +instance (Ae.ToJSON (l a4 a3 a2 a1), Ae.ToJSON (r a4 a3 a2 a1)) => Ae.ToJSON (S4 l r a4 a3 a2 a1) + +-------------------------------------------------------------------------------- + +instance (Ae.FromJSON (l a1), Ae.FromJSON (r a1)) => Ae.FromJSON (P1 l r a1) +instance (Ae.FromJSON (l a2 a1), Ae.FromJSON (r a2 a1)) => Ae.FromJSON (P2 l r a2 a1) +instance (Ae.FromJSON (l a3 a2 a1), Ae.FromJSON (r a3 a2 a1)) => Ae.FromJSON (P3 l r a3 a2 a1) +instance (Ae.FromJSON (l a4 a3 a2 a1), Ae.FromJSON (r a4 a3 a2 a1)) => Ae.FromJSON (P4 l r a4 a3 a2 a1) + +instance (Ae.ToJSON (l a1), Ae.ToJSON (r a1)) => Ae.ToJSON (P1 l r a1) +instance (Ae.ToJSON (l a2 a1), Ae.ToJSON (r a2 a1)) => Ae.ToJSON (P2 l r a2 a1) +instance (Ae.ToJSON (l a3 a2 a1), Ae.ToJSON (r a3 a2 a1)) => Ae.ToJSON (P3 l r a3 a2 a1) +instance (Ae.ToJSON (l a4 a3 a2 a1), Ae.ToJSON (r a4 a3 a2 a1)) => Ae.ToJSON (P4 l r a4 a3 a2 a1) + + diff --git a/src/lib/Exinst/Instances/Aeson.hs b/src/lib/Exinst/Instances/Aeson.hs deleted file mode 100644 --- a/src/lib/Exinst/Instances/Aeson.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | This module exports 'Ae.FromJSON' and 'Ae.ToJSON' instances for 'Some1', --- 'Some2', 'Some3' and 'Some4' from "Exinst.Singletons", provided situable --- 'Dict1', 'Dict2', 'Dict3' and 'Dict4' instances are available. --- --- See the README file in the @exinst@ package for more general documentation: --- https://hackage.haskell.org/package/exinst#readme -module Exinst.Instances.Aeson () where - -import qualified Data.Aeson as Ae -import Data.Constraint -import Data.Singletons -import Exinst.Singletons -import Prelude - --------------------------------------------------------------------------------- - -instance forall (f1 :: k1 -> *) - . ( SingKind k1 - , Ae.ToJSON (DemoteRep k1) - , Dict1 Ae.ToJSON f1 - ) => Ae.ToJSON (Some1 f1) - where - {-# INLINABLE toJSON #-} - toJSON = \some1x -> withSome1Sing some1x $ \sa1 (x :: f1 a1) -> - case dict1 sa1 :: Dict (Ae.ToJSON (f1 a1)) of - Dict -> Ae.toJSON (fromSing sa1, x) - -instance forall (f2 :: k2 -> k1 -> *) - . ( SingKind k2 - , SingKind k1 - , Ae.ToJSON (DemoteRep k2) - , Ae.ToJSON (DemoteRep k1) - , Dict2 Ae.ToJSON f2 - ) => Ae.ToJSON (Some2 f2) - where - {-# INLINABLE toJSON #-} - toJSON = \some2x -> withSome2Sing some2x $ \sa2 sa1 (x :: f2 a2 a1) -> - case dict2 sa2 sa1 :: Dict (Ae.ToJSON (f2 a2 a1)) of - Dict -> Ae.toJSON ((fromSing sa2, fromSing sa1), x) - -instance forall (f3 :: k3 -> k2 -> k1 -> *) - . ( SingKind k3 - , SingKind k2 - , SingKind k1 - , Ae.ToJSON (DemoteRep k3) - , Ae.ToJSON (DemoteRep k2) - , Ae.ToJSON (DemoteRep k1) - , Dict3 Ae.ToJSON f3 - ) => Ae.ToJSON (Some3 f3) - where - {-# INLINABLE toJSON #-} - toJSON = \some3x -> withSome3Sing some3x $ \sa3 sa2 sa1 (x :: f3 a3 a2 a1) -> - case dict3 sa3 sa2 sa1 :: Dict (Ae.ToJSON (f3 a3 a2 a1)) of - Dict -> Ae.toJSON ((fromSing sa3, fromSing sa2, fromSing sa1), x) - -instance forall (f4 :: k4 -> k3 -> k2 -> k1 -> *) - . ( SingKind k4 - , SingKind k3 - , SingKind k2 - , SingKind k1 - , Ae.ToJSON (DemoteRep k4) - , Ae.ToJSON (DemoteRep k3) - , Ae.ToJSON (DemoteRep k2) - , Ae.ToJSON (DemoteRep k1) - , Dict4 Ae.ToJSON f4 - ) => Ae.ToJSON (Some4 f4) - where - {-# INLINABLE toJSON #-} - toJSON = \some4x -> withSome4Sing some4x $ \sa4 sa3 sa2 sa1 (x :: f4 a4 a3 a2 a1) -> - case dict4 sa4 sa3 sa2 sa1 :: Dict (Ae.ToJSON (f4 a4 a3 a2 a1)) of - Dict -> Ae.toJSON ((fromSing sa4, fromSing sa3, fromSing sa2, fromSing sa1), x) - --------------------------------------------------------------------------------- - -instance forall (f1 :: k1 -> *) - . ( SingKind k1 - , Ae.FromJSON (DemoteRep k1) - , Dict1 Ae.FromJSON f1 - ) => Ae.FromJSON (Some1 f1) - where - {-# INLINABLE parseJSON #-} - parseJSON = \v -> do - (rsa1, v') <- Ae.parseJSON v - withSomeSing rsa1 $ \(sa1 :: Sing (a1 :: k1)) -> withSingI sa1 $ - case dict1 sa1 :: Dict (Ae.FromJSON (f1 a1)) of - Dict -> do - x :: f1 a1 <- Ae.parseJSON v' - return (some1 x) - -instance forall (f2 :: k2 -> k1 -> *) - . ( SingKind k2 - , SingKind k1 - , Ae.FromJSON (DemoteRep k2) - , Ae.FromJSON (DemoteRep k1) - , Dict2 Ae.FromJSON f2 - ) => Ae.FromJSON (Some2 f2) - where - {-# INLINABLE parseJSON #-} - parseJSON = \v -> do - ((rsa2, rsa1), v') <- Ae.parseJSON v - withSomeSing rsa2 $ \(sa2 :: Sing (a2 :: k2)) -> withSingI sa2 $ - withSomeSing rsa1 $ \(sa1 :: Sing (a1 :: k1)) -> withSingI sa1 $ - case dict2 sa2 sa1 :: Dict (Ae.FromJSON (f2 a2 a1)) of - Dict -> do - x :: f2 a2 a1 <- Ae.parseJSON v' - return (some2 x) - -instance forall (f3 :: k3 -> k2 -> k1 -> *) - . ( SingKind k3 - , SingKind k2 - , SingKind k1 - , Ae.FromJSON (DemoteRep k3) - , Ae.FromJSON (DemoteRep k2) - , Ae.FromJSON (DemoteRep k1) - , Dict3 Ae.FromJSON f3 - ) => Ae.FromJSON (Some3 f3) - where - {-# INLINABLE parseJSON #-} - parseJSON = \v -> do - ((rsa3, rsa2, rsa1), v') <- Ae.parseJSON v - withSomeSing rsa3 $ \(sa3 :: Sing (a3 :: k3)) -> withSingI sa3 $ - withSomeSing rsa2 $ \(sa2 :: Sing (a2 :: k2)) -> withSingI sa2 $ - withSomeSing rsa1 $ \(sa1 :: Sing (a1 :: k1)) -> withSingI sa1 $ - case dict3 sa3 sa2 sa1 :: Dict (Ae.FromJSON (f3 a3 a2 a1)) of - Dict -> do - x :: f3 a3 a2 a1 <- Ae.parseJSON v' - return (some3 x) - -instance forall (f4 :: k4 -> k3 -> k2 -> k1 -> *) - . ( SingKind k4 - , SingKind k3 - , SingKind k2 - , SingKind k1 - , Ae.FromJSON (DemoteRep k4) - , Ae.FromJSON (DemoteRep k3) - , Ae.FromJSON (DemoteRep k2) - , Ae.FromJSON (DemoteRep k1) - , Dict4 Ae.FromJSON f4 - ) => Ae.FromJSON (Some4 f4) - where - {-# INLINABLE parseJSON #-} - parseJSON = \v -> do - ((rsa4, rsa3, rsa2, rsa1), v') <- Ae.parseJSON v - withSomeSing rsa4 $ \(sa4 :: Sing (a4 :: k4)) -> withSingI sa4 $ - withSomeSing rsa3 $ \(sa3 :: Sing (a3 :: k3)) -> withSingI sa3 $ - withSomeSing rsa2 $ \(sa2 :: Sing (a2 :: k2)) -> withSingI sa2 $ - withSomeSing rsa1 $ \(sa1 :: Sing (a1 :: k1)) -> withSingI sa1 $ - case dict4 sa4 sa3 sa2 sa1 :: Dict (Ae.FromJSON (f4 a4 a3 a2 a1)) of - Dict -> do - x :: f4 a4 a3 a2 a1 <- Ae.parseJSON v' - return (some4 x) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import qualified Data.Aeson as Aeson +import Data.Int (Int32) +import Data.Kind (Type) +import qualified GHC.Generics as G +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Runners as Tasty +import Test.Tasty.QuickCheck ((===)) +import qualified Test.Tasty.QuickCheck as QC + +import Exinst +import Exinst.Aeson () + +-------------------------------------------------------------------------------- + +main :: IO () +main = Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] tt + +-------------------------------------------------------------------------------- + +data family X1 :: Bool -> Type +data instance X1 'False = XF1 | XF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X1 'True = XT1 | XT2 Int32 deriving (Eq, Show, Read, G.Generic) + +data family X2 :: Bool -> Bool -> Type +data instance X2 'False 'False = XFF1 | XFF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X2 'False 'True = XFT1 | XFT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X2 'True 'False = XTF1 | XTF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X2 'True 'True = XTT1 | XTT2 Int32 deriving (Eq, Show, Read, G.Generic) + +data family X3 :: Bool -> Bool -> Bool -> Type +data instance X3 'False 'False 'False = XFFF1 | XFFF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X3 'False 'False 'True = XFFT1 | XFFT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X3 'False 'True 'False = XFTF1 | XFTF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X3 'False 'True 'True = XFTT1 | XFTT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X3 'True 'False 'False = XTFF1 | XTFF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X3 'True 'False 'True = XTFT1 | XTFT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X3 'True 'True 'False = XTTF1 | XTTF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X3 'True 'True 'True = XTTT1 | XTTT2 Int32 deriving (Eq, Show, Read, G.Generic) + +data family X4 :: Bool -> Bool -> Bool -> Bool -> Type +data instance X4 'False 'False 'False 'False = XFFFF1 | XFFFF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'False 'False 'False 'True = XFFFT1 | XFFFT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'False 'False 'True 'False = XFFTF1 | XFFTF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'False 'False 'True 'True = XFFTT1 | XFFTT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'False 'True 'False 'False = XFTFF1 | XFTFF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'False 'True 'False 'True = XFTFT1 | XFTFT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'False 'True 'True 'False = XFTTF1 | XFTTF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'False 'True 'True 'True = XFTTT1 | XFTTT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'True 'False 'False 'False = XTFFF1 | XTFFF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'True 'False 'False 'True = XTFFT1 | XTFFT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'True 'False 'True 'False = XTFTF1 | XTFTF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'True 'False 'True 'True = XTFTT1 | XTFTT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'True 'True 'False 'False = XTTFF1 | XTTFF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'True 'True 'False 'True = XTTFT1 | XTTFT2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'True 'True 'True 'False = XTTTF1 | XTTTF2 Int32 deriving (Eq, Show, Read, G.Generic) +data instance X4 'True 'True 'True 'True = XTTTT1 | XTTTT2 Int32 deriving (Eq, Show, Read, G.Generic) + +#define INSTANCETRON(c) \ + instance c (X1 'False); \ + instance c (X1 'True); \ + instance c (X2 'False 'False); \ + instance c (X2 'False 'True); \ + instance c (X2 'True 'False); \ + instance c (X2 'True 'True); \ + instance c (X3 'False 'False 'False); \ + instance c (X3 'False 'False 'True); \ + instance c (X3 'False 'True 'False); \ + instance c (X3 'False 'True 'True); \ + instance c (X3 'True 'False 'False); \ + instance c (X3 'True 'False 'True); \ + instance c (X3 'True 'True 'False); \ + instance c (X3 'True 'True 'True); \ + instance c (X4 'False 'False 'False 'False); \ + instance c (X4 'False 'False 'False 'True); \ + instance c (X4 'False 'False 'True 'False); \ + instance c (X4 'False 'False 'True 'True); \ + instance c (X4 'False 'True 'False 'False); \ + instance c (X4 'False 'True 'False 'True); \ + instance c (X4 'False 'True 'True 'False); \ + instance c (X4 'False 'True 'True 'True); \ + instance c (X4 'True 'False 'False 'False); \ + instance c (X4 'True 'False 'False 'True); \ + instance c (X4 'True 'False 'True 'False); \ + instance c (X4 'True 'False 'True 'True); \ + instance c (X4 'True 'True 'False 'False); \ + instance c (X4 'True 'True 'False 'True); \ + instance c (X4 'True 'True 'True 'False); \ + instance c (X4 'True 'True 'True 'True) + +-------------------------------------------------------------------------------- +-- Arbitrary instances + +instance QC.Arbitrary (X1 'False) where arbitrary = QC.oneof [ pure XF1, fmap XF2 QC.arbitrary ] +instance QC.Arbitrary (X1 'True) where arbitrary = QC.oneof [ pure XT1, fmap XT2 QC.arbitrary ] + +instance QC.Arbitrary (X2 'False 'False) where arbitrary = QC.oneof [ pure XFF1, fmap XFF2 QC.arbitrary ] +instance QC.Arbitrary (X2 'False 'True) where arbitrary = QC.oneof [ pure XFT1, fmap XFT2 QC.arbitrary ] +instance QC.Arbitrary (X2 'True 'False) where arbitrary = QC.oneof [ pure XTF1, fmap XTF2 QC.arbitrary ] +instance QC.Arbitrary (X2 'True 'True) where arbitrary = QC.oneof [ pure XTT1, fmap XTT2 QC.arbitrary ] + +instance QC.Arbitrary (X3 'False 'False 'False) where arbitrary = QC.oneof [ pure XFFF1, fmap XFFF2 QC.arbitrary ] +instance QC.Arbitrary (X3 'False 'False 'True) where arbitrary = QC.oneof [ pure XFFT1, fmap XFFT2 QC.arbitrary ] +instance QC.Arbitrary (X3 'False 'True 'False) where arbitrary = QC.oneof [ pure XFTF1, fmap XFTF2 QC.arbitrary ] +instance QC.Arbitrary (X3 'False 'True 'True) where arbitrary = QC.oneof [ pure XFTT1, fmap XFTT2 QC.arbitrary ] +instance QC.Arbitrary (X3 'True 'False 'False) where arbitrary = QC.oneof [ pure XTFF1, fmap XTFF2 QC.arbitrary ] +instance QC.Arbitrary (X3 'True 'False 'True) where arbitrary = QC.oneof [ pure XTFT1, fmap XTFT2 QC.arbitrary ] +instance QC.Arbitrary (X3 'True 'True 'False) where arbitrary = QC.oneof [ pure XTTF1, fmap XTTF2 QC.arbitrary ] +instance QC.Arbitrary (X3 'True 'True 'True) where arbitrary = QC.oneof [ pure XTTT1, fmap XTTT2 QC.arbitrary ] + +instance QC.Arbitrary (X4 'False 'False 'False 'False) where arbitrary = QC.oneof [ pure XFFFF1, fmap XFFFF2 QC.arbitrary ] +instance QC.Arbitrary (X4 'False 'False 'False 'True) where arbitrary = QC.oneof [ pure XFFFT1, fmap XFFFT2 QC.arbitrary ] +instance QC.Arbitrary (X4 'False 'False 'True 'False) where arbitrary = QC.oneof [ pure XFFTF1, fmap XFFTF2 QC.arbitrary ] +instance QC.Arbitrary (X4 'False 'False 'True 'True) where arbitrary = QC.oneof [ pure XFFTT1, fmap XFFTT2 QC.arbitrary ] +instance QC.Arbitrary (X4 'False 'True 'False 'False) where arbitrary = QC.oneof [ pure XFTFF1, fmap XFTFF2 QC.arbitrary ] +instance QC.Arbitrary (X4 'False 'True 'False 'True) where arbitrary = QC.oneof [ pure XFTFT1, fmap XFTFT2 QC.arbitrary ] +instance QC.Arbitrary (X4 'False 'True 'True 'False) where arbitrary = QC.oneof [ pure XFTTF1, fmap XFTTF2 QC.arbitrary ] +instance QC.Arbitrary (X4 'False 'True 'True 'True) where arbitrary = QC.oneof [ pure XFTTT1, fmap XFTTT2 QC.arbitrary ] +instance QC.Arbitrary (X4 'True 'False 'False 'False) where arbitrary = QC.oneof [ pure XTFFF1, fmap XTFFF2 QC.arbitrary ] +instance QC.Arbitrary (X4 'True 'False 'False 'True) where arbitrary = QC.oneof [ pure XTFFT1, fmap XTFFT2 QC.arbitrary ] +instance QC.Arbitrary (X4 'True 'False 'True 'False) where arbitrary = QC.oneof [ pure XTFTF1, fmap XTFTF2 QC.arbitrary ] +instance QC.Arbitrary (X4 'True 'False 'True 'True) where arbitrary = QC.oneof [ pure XTFTT1, fmap XTFTT2 QC.arbitrary ] +instance QC.Arbitrary (X4 'True 'True 'False 'False) where arbitrary = QC.oneof [ pure XTTFF1, fmap XTTFF2 QC.arbitrary ] +instance QC.Arbitrary (X4 'True 'True 'False 'True) where arbitrary = QC.oneof [ pure XTTFT1, fmap XTTFT2 QC.arbitrary ] +instance QC.Arbitrary (X4 'True 'True 'True 'False) where arbitrary = QC.oneof [ pure XTTTF1, fmap XTTTF2 QC.arbitrary ] +instance QC.Arbitrary (X4 'True 'True 'True 'True) where arbitrary = QC.oneof [ pure XTTTT1, fmap XTTTT2 QC.arbitrary ] + +-------------------------------------------------------------------------------- + +tt :: Tasty.TestTree +tt = + Tasty.testGroup "main" + [ tt_id "Identity through Aeson's ToJSON/FromJSON" id_aeson + ] + +tt_id + :: String + -> (forall a. (Aeson.FromJSON a, Aeson.ToJSON a) => a -> Maybe a) + -- ^ It's easier to put all the constraints here in the 'MegaCtx' monster. + -> Tasty.TestTree +tt_id = \title id' -> Tasty.testGroup title + [ QC.testProperty "Some1 X1" $ + QC.forAll QC.arbitrary $ \(x :: Some1 X1) -> Just x === id' x + , QC.testProperty "Some2 X2" $ + QC.forAll QC.arbitrary $ \(x :: Some2 X2) -> Just x === id' x + , QC.testProperty "Some3 X3" $ + QC.forAll QC.arbitrary $ \(x :: Some3 X3) -> Just x === id' x + , QC.testProperty "Some4 X4" $ + QC.forAll QC.arbitrary $ \(x :: Some4 X4) -> Just x === id' x + , QC.testProperty "Some1 (P1 X1 X1)" $ + QC.forAll QC.arbitrary $ \(x :: Some1 (P1 X1 X1)) -> Just x === id' x + , QC.testProperty "Some2 (P2 X2 X2)" $ + QC.forAll QC.arbitrary $ \(x :: Some2 (P2 X2 X2)) -> Just x === id' x + , QC.testProperty "Some3 (P3 X3 X3)" $ + QC.forAll QC.arbitrary $ \(x :: Some3 (P3 X3 X3)) -> Just x === id' x + , QC.testProperty "Some4 (P4 X4 X4)" $ + QC.forAll QC.arbitrary $ \(x :: Some4 (P4 X4 X4)) -> Just x === id' x + , QC.testProperty "Some1 (S1 X1 X1)" $ + QC.forAll QC.arbitrary $ \(x :: Some1 (S1 X1 X1)) -> Just x === id' x + , QC.testProperty "Some2 (S2 X2 X2)" $ + QC.forAll QC.arbitrary $ \(x :: Some2 (S2 X2 X2)) -> Just x === id' x + , QC.testProperty "Some3 (S3 X3 X3)" $ + QC.forAll QC.arbitrary $ \(x :: Some3 (S3 X3 X3)) -> Just x === id' x + , QC.testProperty "Some4 (S4 X4 X4)" $ + QC.forAll QC.arbitrary $ \(x :: Some4 (S4 X4 X4)) -> Just x === id' x + ] + +-------------------------------------------------------------------------------- + +INSTANCETRON(Aeson.ToJSON) +INSTANCETRON(Aeson.FromJSON) + +id_aeson :: (Aeson.FromJSON a, Aeson.ToJSON a) => a -> Maybe a +id_aeson = Aeson.decode . Aeson.encode