instant-aeson (empty) → 0.1

raw patch · 7 files changed

+423/−0 lines, 7 filesdep +aesondep +basedep +instant-aesonsetup-changed

Dependencies added: aeson, base, instant-aeson, instant-generics, tasty, tasty-quickcheck

Files

CHANGELOG.md +3/−0
LICENSE.txt +30/−0
README.md +3/−0
Setup.hs +2/−0
instant-aeson.cabal +38/−0
src/lib/Generics/Instant/Functions/Aeson.hs +204/−0
tests/Main.hs +143/−0

+ CHANGELOG.md view

@@ -0,0 +1,3 @@+# Version 0.1++* First release

+ LICENSE.txt view

@@ -0,0 +1,30 @@+Copyright (c) 2015, Renzo Carbonara++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Renzo Carbonara nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,3 @@+`instant-aeson` allows you to generically derive JSON representations (from the+`aeson` package) for your types using `instant-generics`, which in particular,+supports deriving generic representations for GADTs.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ instant-aeson.cabal view

@@ -0,0 +1,38 @@+name:                instant-aeson+version:             0.1+author:              Renzo Carbonara+maintainer:          renzo@carbonara.com.ar+copyright:           Renzo Carbonara 2015+license:             BSD3+license-file:        LICENSE.txt+category:            Web+build-type:          Simple+extra-source-files:  README.md CHANGELOG.md+cabal-version:       >=1.18+synopsis:            Generic Aeson instances through instant-generics++library+  hs-source-dirs: src/lib+  default-language: Haskell2010+  exposed-modules:+      Generics.Instant.Functions.Aeson+  build-depends:+      aeson >=0.8 && <0.10+    , base >=4.8 && <4.9+    , instant-generics >=0.4 && <0.5+  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:+      base >= 4 && < 5+    , aeson+    , tasty >= 0.10+    , tasty-quickcheck >= 0.8+    , instant-aeson+    , instant-generics

+ src/lib/Generics/Instant/Functions/Aeson.hs view

@@ -0,0 +1,204 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}++module Generics.Instant.Functions.Aeson+  ( -- $defaults+    gtoJSON+  , gparseJSON+    -- * Internals+  , GToJSON+  , GFromJSON+    -- ** Even more internal+  , GSumFromJSON+  , GSumToJSON+  , GSumSize+  ) where++import qualified Data.Aeson as Ae+import qualified Data.Aeson.Types as Ae+import           Data.Bits+import           Generics.Instant++--------------------------------------------------------------------------------+-- $defaults+--+-- You can use 'gtoJSON' and 'gparseJSON' as your generic 'Ae.toJSON' and+-- 'Ae.parseJSON' implementations for any 'Representable' type as follows:+--+-- @+-- instance 'Ae.ToJSON' MyType where toJSON = 'gtoJSON'+-- instance 'Ae.FromJSON' MyType where parseJSON = 'gparseJSON'+-- @++gtoJSON :: (Representable a, GToJSON (Rep a)) => a -> Ae.Value+gtoJSON = \a -> gtoJSON' (from a)+{-# INLINABLE gtoJSON #-}++gparseJSON :: (Representable a, GFromJSON (Rep a)) => Ae.Value -> Ae.Parser a+gparseJSON = \v -> fmap to (gparseJSON' v)+{-# INLINABLE gparseJSON #-}++--------------------------------------------------------------------------------++class GFromJSON a where+  gparseJSON' :: Ae.Value -> Ae.Parser a++instance GFromJSON Z where+  gparseJSON' _ = fail+    "Generics.Instant.Functions.Aeson.GFromJSON Z gparseJSON' - impossible"++instance GFromJSON U where+  gparseJSON' v = U <$ (Ae.parseJSON v :: Ae.Parser ())+  {-# INLINABLE gparseJSON' #-}++instance GFromJSON a => GFromJSON (CEq c p p a) where+  gparseJSON' v = gparseJSON' v >>= \a -> return (C a)+  {-# INLINABLE gparseJSON' #-}++instance {-# OVERLAPPABLE #-} GFromJSON (CEq c p q a) where+  gparseJSON' _ = fail+    "Generics.Instant.Functions.Aeson.GFtomJSON (CEq c p q a) gparseJSON' - impossible"++instance Ae.FromJSON a => GFromJSON (Var a) where+  gparseJSON' v = Ae.parseJSON v >>= \a -> return (Var a)+  {-# INLINABLE gparseJSON' #-}++instance Ae.FromJSON a => GFromJSON (Rec a) where+  gparseJSON' v = Ae.parseJSON v >>= \a -> return (Rec a)+  {-# INLINABLE gparseJSON' #-}++instance (GFromJSON a, GFromJSON b) => GFromJSON (a :*: b) where+  gparseJSON' v = Ae.parseJSON v >>= \(va, vb) ->+                  gparseJSON' va >>= \a ->+                  gparseJSON' vb >>= \b ->+                  return (a :*: b)+  {-# INLINABLE gparseJSON' #-}++-- Borrowed from the "binary" package, which borrowed this from "cereal".+instance+  ( GSumFromJSON a, GSumFromJSON b, GSumSize a, GSumSize b+  , GFromJSON a, GFromJSON b+  ) => GFromJSON (a :+: b)+  where+    gparseJSON' v = Ae.parseJSON v >>= \(code, v') ->+      let size = unTagged (sumSize :: Tagged (a :+: b) Integer)+      in if code < size+         then gsumParseJSON code size v'+         else fail "Generics.Instant.Functions.Aeson.GFromJSON (a :+: b) - \+                   \Unknown constructor"+    {-# INLINABLE gparseJSON' #-}++--------------------------------------------------------------------------------++class GToJSON a where+  gtoJSON' :: a -> Ae.Value++instance GToJSON Z where+  gtoJSON' _ = error+    "Generics.Instant.Functions.Aeson.GToJSON Z gtoJSON' - impossible"++instance GToJSON U where+  gtoJSON' U = Ae.toJSON ()+  {-# INLINABLE gtoJSON' #-}++instance GToJSON a => GToJSON (CEq c p p a) where+  gtoJSON' (C a) = gtoJSON' a+  {-# INLINABLE gtoJSON' #-}++instance {-# OVERLAPPABLE #-} GToJSON a => GToJSON (CEq c p q a) where+  gtoJSON' (C a) = gtoJSON' a+  {-# INLINABLE gtoJSON' #-}++instance Ae.ToJSON a => GToJSON (Var a) where+  gtoJSON' (Var a) = Ae.toJSON a+  {-# INLINABLE gtoJSON' #-}++instance Ae.ToJSON a => GToJSON (Rec a) where+  gtoJSON' (Rec a) = Ae.toJSON a+  {-# INLINABLE gtoJSON' #-}++instance (GToJSON a, GToJSON b) => GToJSON (a :*: b) where+  gtoJSON' (a :*: b) = Ae.toJSON (gtoJSON' a, gtoJSON' b)+  {-# INLINABLE gtoJSON' #-}++-- Borrowed from the "binary" package, which borrowed this from "cereal".+instance+  ( GSumToJSON a, GSumToJSON b, GSumSize a, GSumSize b+  , GToJSON a, GToJSON b+  ) => GToJSON (a :+: b)+  where+    gtoJSON' x =+      let size = unTagged (sumSize :: Tagged (a :+: b) Integer)+      in gsumToJSON 0 size x+    {-# INLINABLE gtoJSON' #-}++--------------------------------------------------------------------------------++class GSumFromJSON a where+  gsumParseJSON :: Integer -> Integer -> Ae.Value -> Ae.Parser a++instance+  ( GSumFromJSON a, GSumFromJSON b, GFromJSON a, GFromJSON b+  ) => GSumFromJSON (a :+: b)+  where+    {-# INLINABLE gsumParseJSON #-}+    gsumParseJSON !code !size v+      | code < sizeL = L <$> gsumParseJSON code           sizeL v+      | otherwise    = R <$> gsumParseJSON (code - sizeL) sizeR v+      where+        sizeL = size `shiftR` 1+        sizeR = size - sizeL++instance GFromJSON a => GSumFromJSON (CEq c p p a) where+  gsumParseJSON _ _ v = gparseJSON' v+  {-# INLINABLE gsumParseJSON #-}++instance {-# OVERLAPPABLE #-} GSumFromJSON (CEq c p q a) where+  gsumParseJSON _ _ _ = fail+    "Generics.Instant.Functions.Aeson.GSumFromJSON (CEq c p q a) - impossible"++--------------------------------------------------------------------------------++class GSumToJSON a where+  gsumToJSON :: Integer -> Integer -> a -> Ae.Value++instance+  ( GSumToJSON a, GSumToJSON b, GToJSON a, GToJSON b+  ) => GSumToJSON (a :+: b)+  where+    {-# INLINABLE gsumToJSON #-}+    gsumToJSON !code !size x =+      let sizeL = size `shiftR` 1+          sizeR = size - sizeL+      in case x of+           L l -> gsumToJSON code           sizeL l+           R r -> gsumToJSON (code + sizeL) sizeR r++instance GToJSON a => GSumToJSON (CEq c p p a) where+  gsumToJSON !code _ ca = Ae.toJSON (code, gtoJSON' ca)+  {-# INLINABLE gsumToJSON #-}++instance {-# OVERLAPPABLE #-} GToJSON a => GSumToJSON (CEq c p q a) where+  gsumToJSON !code _ ca = Ae.toJSON (code, gtoJSON' ca)+  {-# INLINABLE gsumToJSON #-}++--------------------------------------------------------------------------------++class GSumSize a where+  sumSize :: Tagged a Integer++newtype Tagged s b = Tagged { unTagged :: b }++instance (GSumSize a, GSumSize b) => GSumSize (a :+: b) where+  {-# INLINABLE sumSize #-}+  sumSize = Tagged (unTagged (sumSize :: Tagged a Integer) ++                    unTagged (sumSize :: Tagged b Integer))++instance GSumSize (CEq c p q a) where+  {-# INLINABLE sumSize #-}+  sumSize = Tagged 1

+ tests/Main.hs view

@@ -0,0 +1,143 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Test.Tasty+import Test.Tasty.QuickCheck as QC++import qualified Data.Aeson+import qualified Data.Aeson as Ae+import qualified Data.Aeson.Types as Ae+import Data.Proxy++import qualified Generics.Instant as GI+import qualified Generics.Instant.TH as GI+import Generics.Instant.Functions.Aeson (GFromJSON, gparseJSON, GToJSON, gtoJSON)++--------------------------------------------------------------------------------+-- orphans++data Unit_Unit_+instance GI.Constructor Unit_Unit_ where conName _ = "()"+instance GI.Representable () where+  type Rep () = GI.U+  from () = GI.U+  to GI.U = ()++GI.deriveAll ''Either++instance Arbitrary (Proxy a) where arbitrary = return Proxy+instance Ae.ToJSON (Proxy a) where toJSON _ = Ae.toJSON ()+instance Ae.FromJSON (Proxy a) where parseJSON v = Ae.parseJSON v >>= \() -> return Proxy++--------------------------------------------------------------------------------+-- many constructors, recursive++data ZZ = ZZ1 Int | ZZ2 Char | ZZ3 ZZ deriving (Show, Eq)+GI.deriveAll ''ZZ+instance Arbitrary ZZ where+  arbitrary = QC.oneof [ ZZ1 <$> QC.arbitrary+                       , ZZ2 <$> QC.arbitrary+                       , ZZ3 <$> QC.arbitrary ]++instance Ae.ToJSON ZZ where toJSON = gtoJSON+instance Ae.FromJSON ZZ where parseJSON = gparseJSON++--------------------------------------------------------------------------------+-- GADT++data Foo1 (a :: *) :: * where+  Foo1_1 :: Bool -> Foo1 Bool+  Foo1_2 :: a -> Foo1 a+GI.deriveAll ''Foo1+deriving instance Eq a => Eq (Foo1 a)+deriving instance Show a => Show (Foo1 a)+instance QC.Arbitrary (Foo1 Bool) where+  arbitrary = Foo1_1 <$> QC.arbitrary+instance {-# OVERLAPPABLE #-} (QC.Arbitrary a, GI.Representable a) => QC.Arbitrary (Foo1 a) where+  arbitrary = Foo1_2 <$> QC.arbitrary+++data Foo2 (a :: *) (b :: *) :: * where+  Foo2_1 :: a -> Char -> Foo2 a Int+  Foo2_2 :: a -> b -> Foo2 a b+GI.deriveAll ''Foo2+deriving instance (Eq a, Eq b) => Eq (Foo2 a b)+deriving instance (Show a, Show b) => Show (Foo2 a b)+instance (QC.Arbitrary a, GI.Representable a) => QC.Arbitrary (Foo2 a Int) where+  arbitrary = Foo2_1 <$> QC.arbitrary <*> QC.arbitrary+instance {-# OVERLAPPABLE #-} (QC.Arbitrary a, GI.Representable a, QC.Arbitrary b, GI.Representable b) => QC.Arbitrary (Foo2 a b) where+  arbitrary = Foo2_2 <$> QC.arbitrary <*> QC.arbitrary+++data Bar1 (a :: Bool) :: * where+  Bar1_1 :: Char -> Bar1 'True+  Bar1_2 :: Int -> Bar1 'False+GI.deriveAll ''Bar1+deriving instance Eq (Bar1 a)+deriving instance Show (Bar1 a)+instance QC.Arbitrary (Bar1 'True) where+  arbitrary = Bar1_1 <$> QC.arbitrary+instance QC.Arbitrary (Bar1 'False) where+  arbitrary = Bar1_2 <$> QC.arbitrary++data Bar2 (a :: k1) (b :: Bool) :: * where+  Bar2_1 :: Int -> Proxy a -> Bar2 a 'True+  Bar2_2 :: String -> Proxy a -> Bar2 a 'False+GI.deriveAll ''Bar2+deriving instance Eq (Bar2 a b)+deriving instance Show (Bar2 a b)+instance (QC.Arbitrary a) => QC.Arbitrary (Bar2 a 'True) where+  arbitrary = Bar2_1 <$> QC.arbitrary <*> QC.arbitrary+instance (QC.Arbitrary a) => QC.Arbitrary (Bar2 a 'False) where+  arbitrary = Bar2_2 <$> QC.arbitrary <*> QC.arbitrary+++--------------------------------------------------------------------------------++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "QuickCheck - prop_IdJSON"+  [ -- QC.testProperty "()" (prop_IdJSON :: () -> Bool)+--   , QC.testProperty "Bool" (prop_IdJSON :: Bool -> Bool)+--   , QC.testProperty "Char" (prop_IdJSON :: Char -> Bool)+--   , QC.testProperty "Float" (prop_IdJSON :: Float -> Bool)+--   , QC.testProperty "Int" (prop_IdJSON :: Int -> Bool)+    QC.testProperty "Maybe ()" (prop_IdJSON :: Maybe () -> Bool)+  , QC.testProperty "Maybe Bool" (prop_IdJSON :: Maybe Bool -> Bool)+  , QC.testProperty "Maybe Char" (prop_IdJSON :: Maybe Char -> Bool)+  , QC.testProperty "Maybe Float" (prop_IdJSON :: Maybe Float -> Bool)+  , QC.testProperty "Maybe Int" (prop_IdJSON :: Maybe Int -> Bool)+  , QC.testProperty "Maybe ZZ" (prop_IdJSON :: Maybe ZZ -> Bool)+  , QC.testProperty "[()]" (prop_IdJSON :: [()] -> Bool)+  , QC.testProperty "[Bool]" (prop_IdJSON :: [Bool] -> Bool)+  , QC.testProperty "[Char]" (prop_IdJSON :: [Char] -> Bool)+  , QC.testProperty "[Float]" (prop_IdJSON :: [Float] -> Bool)+  , QC.testProperty "[Int]" (prop_IdJSON :: [Int] -> Bool)+  , QC.testProperty "[ZZ]" (prop_IdJSON :: [ZZ] -> Bool)+  , QC.testProperty "Foo1 Int" (prop_IdJSON :: Foo1 Int -> Bool)+  , QC.testProperty "Foo1 Char" (prop_IdJSON :: Foo1 Char -> Bool)+  , QC.testProperty "Foo2 Float Int" (prop_IdJSON :: Foo2 Float Int -> Bool)+  , QC.testProperty "Foo2 Bool Char" (prop_IdJSON :: Foo2 Bool Char -> Bool)+  , QC.testProperty "Bar1 'True" (prop_IdJSON :: Bar1 'True -> Bool)+  , QC.testProperty "Bar1 'False" (prop_IdJSON :: Bar1 'False -> Bool)+  , QC.testProperty "Bar2 Int 'True" (prop_IdJSON :: Bar2 Int 'True -> Bool)+  , QC.testProperty "Bar2 Float 'False" (prop_IdJSON :: Bar2 Float 'False -> Bool)+  ]++prop_IdJSON+  :: (Eq a, GI.Representable a, GToJSON (GI.Rep a), GFromJSON (GI.Rep a), Show a)+  => a -> Bool+prop_IdJSON a = maybe False (== a) $ Ae.parseMaybe gparseJSON (gtoJSON a)