{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module      :  Pinch.Internal.Generic
-- Copyright   :  (c) Abhinav Gupta 2015
-- License     :  BSD3
--
-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>
-- Stability   :  experimental
--
-- Implements support for automatically deriving Pinchable instances for types
-- that implement @Generic@ and follow a specific pattern.
--
module Pinch.Internal.Generic
    ( Field(..)
    , getField
    , putField
    , field

    , Enumeration(..)
    , enum

    , Void(..)
    ) where

import Control.Applicative
import Control.DeepSeq     (NFData)
import Data.Proxy          (Proxy (..))
import Data.Typeable       (Typeable)
import GHC.Generics
import GHC.TypeLits

import qualified Data.HashMap.Strict as HM

import Pinch.Internal.Pinchable
import Pinch.Internal.TType
import Pinch.Internal.Value     (Value (..))


-- | Implemented by TType tags whose values know how to combine.
class Combinable t where
    combine :: Value t -> Value t -> Value t

instance Combinable TStruct where
    combine :: Value TStruct -> Value TStruct -> Value TStruct
combine (VStruct HashMap Int16 SomeValue
as) (VStruct HashMap Int16 SomeValue
bs) = HashMap Int16 SomeValue -> Value TStruct
VStruct forall a b. (a -> b) -> a -> b
$ HashMap Int16 SomeValue
as forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` HashMap Int16 SomeValue
bs


instance {-# OVERLAPPABLE #-} GPinchable a => GPinchable (M1 i c a) where
    type GTag (M1 i c a) = GTag a
    gPinch :: forall a. M1 i c a a -> Value (GTag (M1 i c a))
gPinch = forall (f :: * -> *) a. GPinchable f => f a -> Value (GTag f)
gPinch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
    gUnpinch :: forall a. Value (GTag (M1 i c a)) -> Parser (M1 i c a a)
gUnpinch = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
GPinchable f =>
Value (GTag f) -> Parser (f a)
gUnpinch


-- Adds the name of the data type to the error message.
instance (Datatype d, GPinchable a) => GPinchable (D1 d a) where
    type GTag (D1 d a) = GTag a
    gPinch :: forall a. D1 d a a -> Value (GTag (D1 d a))
gPinch = forall (f :: * -> *) a. GPinchable f => f a -> Value (GTag f)
gPinch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
    gUnpinch :: forall a. Value (GTag (D1 d a)) -> Parser (D1 d a a)
gUnpinch Value (GTag (D1 d a))
v =
        forall a b.
Parser a -> (String -> Parser b) -> (a -> Parser b) -> Parser b
parserCatch (forall (f :: * -> *) a.
GPinchable f =>
Value (GTag f) -> Parser (f a)
gUnpinch Value (GTag (D1 d a))
v)
            (\String
msg -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to read '" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"': " forall a. [a] -> [a] -> [a]
++ String
msg)
            (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1)
      where
        name :: String
name = forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName (forall a. HasCallStack => a
undefined :: D1 d a b)

instance
  ( GPinchable a
  , GPinchable b
  , GTag a ~ GTag b
  , Combinable (GTag a)
  ) => GPinchable (a :*: b) where
    type GTag (a :*: b) = GTag a
    gPinch :: forall a. (:*:) a b a -> Value (GTag (a :*: b))
gPinch (a a
a :*: b a
b) = forall (f :: * -> *) a. GPinchable f => f a -> Value (GTag f)
gPinch a a
a forall t. Combinable t => Value t -> Value t -> Value t
`combine` forall (f :: * -> *) a. GPinchable f => f a -> Value (GTag f)
gPinch b a
b
    gUnpinch :: forall a. Value (GTag (a :*: b)) -> Parser ((:*:) a b a)
gUnpinch Value (GTag (a :*: b))
m = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
GPinchable f =>
Value (GTag f) -> Parser (f a)
gUnpinch Value (GTag (a :*: b))
m forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a.
GPinchable f =>
Value (GTag f) -> Parser (f a)
gUnpinch Value (GTag (a :*: b))
m

instance
  ( GPinchable a
  , GPinchable b
  , GTag a ~ GTag b
  ) => GPinchable (a :+: b) where
    type GTag (a :+: b) = GTag a
    gPinch :: forall a. (:+:) a b a -> Value (GTag (a :+: b))
gPinch (L1 a a
a) = forall (f :: * -> *) a. GPinchable f => f a -> Value (GTag f)
gPinch a a
a
    gPinch (R1 b a
b) = forall (f :: * -> *) a. GPinchable f => f a -> Value (GTag f)
gPinch b a
b
    gUnpinch :: forall a. Value (GTag (a :+: b)) -> Parser ((:+:) a b a)
gUnpinch Value (GTag (a :+: b))
m = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
GPinchable f =>
Value (GTag f) -> Parser (f a)
gUnpinch Value (GTag (a :+: b))
m forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
GPinchable f =>
Value (GTag f) -> Parser (f a)
gUnpinch Value (GTag (a :+: b))
m

------------------------------------------------------------------------------

-- | Fields of data types that represent structs, unions, and exceptions
-- should be wrapped inside 'Field' and tagged with the field identifier.
--
-- > data Foo = Foo (Field 1 Text) (Field 2 (Maybe Int32)) deriving Generic
-- > instance Pinchable Foo
--
-- > data A = A (Field 1 Int32) | B (Field 2 Text) deriving Generic
-- > instance Pinchable Foo
--
-- Fields which hold @Maybe@ values are treated as optional. All fields values
-- must be 'Pinchable' to automatically derive a @Pinchable@ instance for the
-- new data type.
newtype Field (n :: Nat) a = Field a
  deriving
    (Field n a
forall (n :: Nat) a. Bounded a => Field n a
forall a. a -> a -> Bounded a
maxBound :: Field n a
$cmaxBound :: forall (n :: Nat) a. Bounded a => Field n a
minBound :: Field n a
$cminBound :: forall (n :: Nat) a. Bounded a => Field n a
Bounded, Field n a -> Field n a -> Bool
forall (n :: Nat) a. Eq a => Field n a -> Field n a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Field n a -> Field n a -> Bool
$c/= :: forall (n :: Nat) a. Eq a => Field n a -> Field n a -> Bool
== :: Field n a -> Field n a -> Bool
$c== :: forall (n :: Nat) a. Eq a => Field n a -> Field n a -> Bool
Eq, Int -> Field n a
Field n a -> Int
Field n a -> [Field n a]
Field n a -> Field n a
Field n a -> Field n a -> [Field n a]
Field n a -> Field n a -> Field n a -> [Field n a]
forall (n :: Nat) a. Enum a => Int -> Field n a
forall (n :: Nat) a. Enum a => Field n a -> Int
forall (n :: Nat) a. Enum a => Field n a -> [Field n a]
forall (n :: Nat) a. Enum a => Field n a -> Field n a
forall (n :: Nat) a.
Enum a =>
Field n a -> Field n a -> [Field n a]
forall (n :: Nat) a.
Enum a =>
Field n a -> Field n a -> Field n a -> [Field n a]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Field n a -> Field n a -> Field n a -> [Field n a]
$cenumFromThenTo :: forall (n :: Nat) a.
Enum a =>
Field n a -> Field n a -> Field n a -> [Field n a]
enumFromTo :: Field n a -> Field n a -> [Field n a]
$cenumFromTo :: forall (n :: Nat) a.
Enum a =>
Field n a -> Field n a -> [Field n a]
enumFromThen :: Field n a -> Field n a -> [Field n a]
$cenumFromThen :: forall (n :: Nat) a.
Enum a =>
Field n a -> Field n a -> [Field n a]
enumFrom :: Field n a -> [Field n a]
$cenumFrom :: forall (n :: Nat) a. Enum a => Field n a -> [Field n a]
fromEnum :: Field n a -> Int
$cfromEnum :: forall (n :: Nat) a. Enum a => Field n a -> Int
toEnum :: Int -> Field n a
$ctoEnum :: forall (n :: Nat) a. Enum a => Int -> Field n a
pred :: Field n a -> Field n a
$cpred :: forall (n :: Nat) a. Enum a => Field n a -> Field n a
succ :: Field n a -> Field n a
$csucc :: forall (n :: Nat) a. Enum a => Field n a -> Field n a
Enum, forall (n :: Nat) a. Eq a => a -> Field n a -> Bool
forall (n :: Nat) a. Num a => Field n a -> a
forall (n :: Nat) a. Ord a => Field n a -> a
forall (n :: Nat) m. Monoid m => Field n m -> m
forall (n :: Nat) a. Field n a -> Bool
forall (n :: Nat) a. Field n a -> Int
forall (n :: Nat) a. Field n a -> [a]
forall (n :: Nat) a. (a -> a -> a) -> Field n a -> a
forall (n :: Nat) m a. Monoid m => (a -> m) -> Field n a -> m
forall (n :: Nat) b a. (b -> a -> b) -> b -> Field n a -> b
forall (n :: Nat) a b. (a -> b -> b) -> b -> Field n a -> b
forall a. Field n a -> Bool
forall m a. Monoid m => (a -> m) -> Field n a -> m
forall a b. (a -> b -> b) -> b -> Field n a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Field n a -> a
$cproduct :: forall (n :: Nat) a. Num a => Field n a -> a
sum :: forall a. Num a => Field n a -> a
$csum :: forall (n :: Nat) a. Num a => Field n a -> a
minimum :: forall a. Ord a => Field n a -> a
$cminimum :: forall (n :: Nat) a. Ord a => Field n a -> a
maximum :: forall a. Ord a => Field n a -> a
$cmaximum :: forall (n :: Nat) a. Ord a => Field n a -> a
elem :: forall a. Eq a => a -> Field n a -> Bool
$celem :: forall (n :: Nat) a. Eq a => a -> Field n a -> Bool
length :: forall a. Field n a -> Int
$clength :: forall (n :: Nat) a. Field n a -> Int
null :: forall a. Field n a -> Bool
$cnull :: forall (n :: Nat) a. Field n a -> Bool
toList :: forall a. Field n a -> [a]
$ctoList :: forall (n :: Nat) a. Field n a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Field n a -> a
$cfoldl1 :: forall (n :: Nat) a. (a -> a -> a) -> Field n a -> a
foldr1 :: forall a. (a -> a -> a) -> Field n a -> a
$cfoldr1 :: forall (n :: Nat) a. (a -> a -> a) -> Field n a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Field n a -> b
$cfoldl' :: forall (n :: Nat) b a. (b -> a -> b) -> b -> Field n a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Field n a -> b
$cfoldl :: forall (n :: Nat) b a. (b -> a -> b) -> b -> Field n a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Field n a -> b
$cfoldr' :: forall (n :: Nat) a b. (a -> b -> b) -> b -> Field n a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Field n a -> b
$cfoldr :: forall (n :: Nat) a b. (a -> b -> b) -> b -> Field n a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Field n a -> m
$cfoldMap' :: forall (n :: Nat) m a. Monoid m => (a -> m) -> Field n a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Field n a -> m
$cfoldMap :: forall (n :: Nat) m a. Monoid m => (a -> m) -> Field n a -> m
fold :: forall m. Monoid m => Field n m -> m
$cfold :: forall (n :: Nat) m. Monoid m => Field n m -> m
Foldable, forall (n :: Nat) a b. a -> Field n b -> Field n a
forall (n :: Nat) a b. (a -> b) -> Field n a -> Field n b
forall a b. a -> Field n b -> Field n a
forall a b. (a -> b) -> Field n a -> Field n b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Field n b -> Field n a
$c<$ :: forall (n :: Nat) a b. a -> Field n b -> Field n a
fmap :: forall a b. (a -> b) -> Field n a -> Field n b
$cfmap :: forall (n :: Nat) a b. (a -> b) -> Field n a -> Field n b
Functor, forall (n :: Nat) a x. Rep (Field n a) x -> Field n a
forall (n :: Nat) a x. Field n a -> Rep (Field n a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall (n :: Nat) a x. Rep (Field n a) x -> Field n a
$cfrom :: forall (n :: Nat) a x. Field n a -> Rep (Field n a) x
Generic, NonEmpty (Field n a) -> Field n a
Field n a -> Field n a -> Field n a
forall (n :: Nat) a.
Semigroup a =>
NonEmpty (Field n a) -> Field n a
forall (n :: Nat) a.
Semigroup a =>
Field n a -> Field n a -> Field n a
forall (n :: Nat) a b.
(Semigroup a, Integral b) =>
b -> Field n a -> Field n a
forall b. Integral b => b -> Field n a -> Field n a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Field n a -> Field n a
$cstimes :: forall (n :: Nat) a b.
(Semigroup a, Integral b) =>
b -> Field n a -> Field n a
sconcat :: NonEmpty (Field n a) -> Field n a
$csconcat :: forall (n :: Nat) a.
Semigroup a =>
NonEmpty (Field n a) -> Field n a
<> :: Field n a -> Field n a -> Field n a
$c<> :: forall (n :: Nat) a.
Semigroup a =>
Field n a -> Field n a -> Field n a
Semigroup, Field n a
[Field n a] -> Field n a
Field n a -> Field n a -> Field n a
forall {n :: Nat} {a}. Monoid a => Semigroup (Field n a)
forall (n :: Nat) a. Monoid a => Field n a
forall (n :: Nat) a. Monoid a => [Field n a] -> Field n a
forall (n :: Nat) a.
Monoid a =>
Field n a -> Field n a -> Field n a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Field n a] -> Field n a
$cmconcat :: forall (n :: Nat) a. Monoid a => [Field n a] -> Field n a
mappend :: Field n a -> Field n a -> Field n a
$cmappend :: forall (n :: Nat) a.
Monoid a =>
Field n a -> Field n a -> Field n a
mempty :: Field n a
$cmempty :: forall (n :: Nat) a. Monoid a => Field n a
Monoid, Field n a -> ()
forall (n :: Nat) a. NFData a => Field n a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Field n a -> ()
$crnf :: forall (n :: Nat) a. NFData a => Field n a -> ()
NFData, Field n a -> Field n a -> Bool
Field n a -> Field n a -> Ordering
Field n a -> Field n a -> Field n a
forall {n :: Nat} {a}. Ord a => Eq (Field n a)
forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Bool
forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Ordering
forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Field n a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Field n a -> Field n a -> Field n a
$cmin :: forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Field n a
max :: Field n a -> Field n a -> Field n a
$cmax :: forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Field n a
>= :: Field n a -> Field n a -> Bool
$c>= :: forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Bool
> :: Field n a -> Field n a -> Bool
$c> :: forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Bool
<= :: Field n a -> Field n a -> Bool
$c<= :: forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Bool
< :: Field n a -> Field n a -> Bool
$c< :: forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Bool
compare :: Field n a -> Field n a -> Ordering
$ccompare :: forall (n :: Nat) a. Ord a => Field n a -> Field n a -> Ordering
Ord, Int -> Field n a -> ShowS
forall (n :: Nat) a. Show a => Int -> Field n a -> ShowS
forall (n :: Nat) a. Show a => [Field n a] -> ShowS
forall (n :: Nat) a. Show a => Field n a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Field n a] -> ShowS
$cshowList :: forall (n :: Nat) a. Show a => [Field n a] -> ShowS
show :: Field n a -> String
$cshow :: forall (n :: Nat) a. Show a => Field n a -> String
showsPrec :: Int -> Field n a -> ShowS
$cshowsPrec :: forall (n :: Nat) a. Show a => Int -> Field n a -> ShowS
Show,
     forall (n :: Nat). Functor (Field n)
forall (n :: Nat). Foldable (Field n)
forall (n :: Nat) (m :: * -> *) a.
Monad m =>
Field n (m a) -> m (Field n a)
forall (n :: Nat) (f :: * -> *) a.
Applicative f =>
Field n (f a) -> f (Field n a)
forall (n :: Nat) (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Field n a -> m (Field n b)
forall (n :: Nat) (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Field n a -> f (Field n b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Field n a -> f (Field n b)
sequence :: forall (m :: * -> *) a. Monad m => Field n (m a) -> m (Field n a)
$csequence :: forall (n :: Nat) (m :: * -> *) a.
Monad m =>
Field n (m a) -> m (Field n a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Field n a -> m (Field n b)
$cmapM :: forall (n :: Nat) (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Field n a -> m (Field n b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Field n (f a) -> f (Field n a)
$csequenceA :: forall (n :: Nat) (f :: * -> *) a.
Applicative f =>
Field n (f a) -> f (Field n a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Field n a -> f (Field n b)
$ctraverse :: forall (n :: Nat) (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Field n a -> f (Field n b)
Traversable, Typeable)

-- | Gets the current value of a field.
--
-- > let Foo a' _ = {- ... -}
-- >     a = getField a'
getField :: Field n a -> a
getField :: forall (n :: Nat) a. Field n a -> a
getField (Field a
a) = a
a

-- | Puts a value inside a field.
--
-- > Foo (putField "Hello") (putField (Just 42))
putField :: a -> Field n a
putField :: forall a (n :: Nat). a -> Field n a
putField = forall (n :: Nat) a. a -> Field n a
Field

-- | A lens on @Field@ wrappers for use with the lens library.
--
-- > person & name . field .~ "new value"
--
field :: Functor f => (a -> f b) -> Field n a -> f (Field n b)
field :: forall (f :: * -> *) a b (n :: Nat).
Functor f =>
(a -> f b) -> Field n a -> f (Field n b)
field a -> f b
f (Field a
a) = forall (n :: Nat) a. a -> Field n a
Field forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a

instance {-# OVERLAPPABLE #-} (Pinchable a, KnownNat n)
  => GPinchable (K1 i (Field n a)) where
    type GTag (K1 i (Field n a)) = TStruct
    gPinch :: forall a. K1 i (Field n a) a -> Value (GTag (K1 i (Field n a)))
gPinch (K1 (Field a
a)) = [FieldPair] -> Value TStruct
struct [Int16
n forall a. Pinchable a => Int16 -> a -> FieldPair
.= a
a]
      where
        n :: Int16
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)

    gUnpinch :: forall a.
Value (GTag (K1 i (Field n a))) -> Parser (K1 i (Field n a) a)
gUnpinch Value (GTag (K1 i (Field n a)))
m = forall k i c (p :: k). c -> K1 i c p
K1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat) a. a -> Field n a
Field forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value (GTag (K1 i (Field n a)))
m forall a. Pinchable a => Value TStruct -> Int16 -> Parser a
.: Int16
n
      where
        n :: Int16
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)

instance
  (Pinchable a, KnownNat n)
  => GPinchable (K1 i (Field n (Maybe a))) where
    type GTag (K1 i (Field n (Maybe a))) = TStruct
    gPinch :: forall a.
K1 i (Field n (Maybe a)) a
-> Value (GTag (K1 i (Field n (Maybe a))))
gPinch (K1 (Field Maybe a
a)) = [FieldPair] -> Value TStruct
struct [Int16
n forall a. Pinchable a => Int16 -> Maybe a -> FieldPair
?= Maybe a
a]
      where
        n :: Int16
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)

    gUnpinch :: forall a.
Value (GTag (K1 i (Field n (Maybe a))))
-> Parser (K1 i (Field n (Maybe a)) a)
gUnpinch Value (GTag (K1 i (Field n (Maybe a))))
m = forall k i c (p :: k). c -> K1 i c p
K1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat) a. a -> Field n a
Field forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value (GTag (K1 i (Field n (Maybe a))))
m forall a. Pinchable a => Value TStruct -> Int16 -> Parser (Maybe a)
.:? Int16
n
      where
        n :: Int16
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)

------------------------------------------------------------------------------

-- | Data types that represent Thrift enums must have one constructor for each
-- enum item accepting an 'Enumeration' object tagged with the corresponding
-- enum value.
--
-- > data Role = RoleUser (Enumeration 1) | RoleAdmin (Enumeration 2)
-- >   deriving Generic
-- > instance Pinchable Role
data Enumeration (n :: Nat) = Enumeration
  deriving
    (Enumeration n -> Enumeration n -> Bool
forall (n :: Nat). Enumeration n -> Enumeration n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Enumeration n -> Enumeration n -> Bool
$c/= :: forall (n :: Nat). Enumeration n -> Enumeration n -> Bool
== :: Enumeration n -> Enumeration n -> Bool
$c== :: forall (n :: Nat). Enumeration n -> Enumeration n -> Bool
Eq, forall (n :: Nat) x. Rep (Enumeration n) x -> Enumeration n
forall (n :: Nat) x. Enumeration n -> Rep (Enumeration n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall (n :: Nat) x. Rep (Enumeration n) x -> Enumeration n
$cfrom :: forall (n :: Nat) x. Enumeration n -> Rep (Enumeration n) x
Generic, Enumeration n -> Enumeration n -> Bool
Enumeration n -> Enumeration n -> Ordering
forall (n :: Nat). Eq (Enumeration n)
forall (n :: Nat). Enumeration n -> Enumeration n -> Bool
forall (n :: Nat). Enumeration n -> Enumeration n -> Ordering
forall (n :: Nat). Enumeration n -> Enumeration n -> Enumeration n
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Enumeration n -> Enumeration n -> Enumeration n
$cmin :: forall (n :: Nat). Enumeration n -> Enumeration n -> Enumeration n
max :: Enumeration n -> Enumeration n -> Enumeration n
$cmax :: forall (n :: Nat). Enumeration n -> Enumeration n -> Enumeration n
>= :: Enumeration n -> Enumeration n -> Bool
$c>= :: forall (n :: Nat). Enumeration n -> Enumeration n -> Bool
> :: Enumeration n -> Enumeration n -> Bool
$c> :: forall (n :: Nat). Enumeration n -> Enumeration n -> Bool
<= :: Enumeration n -> Enumeration n -> Bool
$c<= :: forall (n :: Nat). Enumeration n -> Enumeration n -> Bool
< :: Enumeration n -> Enumeration n -> Bool
$c< :: forall (n :: Nat). Enumeration n -> Enumeration n -> Bool
compare :: Enumeration n -> Enumeration n -> Ordering
$ccompare :: forall (n :: Nat). Enumeration n -> Enumeration n -> Ordering
Ord, Int -> Enumeration n -> ShowS
forall (n :: Nat). Int -> Enumeration n -> ShowS
forall (n :: Nat). [Enumeration n] -> ShowS
forall (n :: Nat). Enumeration n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Enumeration n] -> ShowS
$cshowList :: forall (n :: Nat). [Enumeration n] -> ShowS
show :: Enumeration n -> String
$cshow :: forall (n :: Nat). Enumeration n -> String
showsPrec :: Int -> Enumeration n -> ShowS
$cshowsPrec :: forall (n :: Nat). Int -> Enumeration n -> ShowS
Show, Typeable)

instance NFData (Enumeration n)

-- | Convenience function to construct 'Enumeration' objects.
--
-- > let role = RoleUser enum
enum :: Enumeration n
enum :: forall (n :: Nat). Enumeration n
enum = forall (n :: Nat). Enumeration n
Enumeration

instance KnownNat n => GPinchable (K1 i (Enumeration n)) where
    type GTag (K1 i (Enumeration n)) = TEnum
    gPinch :: forall a.
K1 i (Enumeration n) a -> Value (GTag (K1 i (Enumeration n)))
gPinch (K1 Enumeration n
Enumeration) = Int32 -> Value TEnum
VInt32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)
    gUnpinch :: forall a.
Value (GTag (K1 i (Enumeration n)))
-> Parser (K1 i (Enumeration n) a)
gUnpinch (VInt32 Int32
i)
        | Int32
i forall a. Eq a => a -> a -> Bool
== Int32
val  = forall (m :: * -> *) a. Monad m => a -> m a
return (forall k i c (p :: k). c -> K1 i c p
K1 forall (n :: Nat). Enumeration n
Enumeration)
        | Bool
otherwise = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Couldn't match enum value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
i
      where
        val :: Int32
val = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)

------------------------------------------------------------------------------

-- | Represents a @void@ result for methods.
--
-- This should be used as an element in a response union along with 'Field'
-- tags.
--
-- For a method,
--
-- > void setValue(..) throws
-- >   (1: ValueAlreadyExists alreadyExists,
-- >    2: InternalError internalError)
--
-- Something similar to the following can be used.
--
-- > data SetValueResponse
-- >   = SetValueAlreadyExists (Field 1 ValueAlreadyExists)
-- >   | SetValueInternalError (Field 2 InternalError)
-- >   | SetValueSuccess Void
-- >   deriving (Generic)
-- >
-- > instance Pinchable SetValueResponse
data Void = Void
  deriving
    (Void -> Void -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Void -> Void -> Bool
$c/= :: Void -> Void -> Bool
== :: Void -> Void -> Bool
$c== :: Void -> Void -> Bool
Eq, forall x. Rep Void x -> Void
forall x. Void -> Rep Void x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Void x -> Void
$cfrom :: forall x. Void -> Rep Void x
Generic, Eq Void
Void -> Void -> Bool
Void -> Void -> Ordering
Void -> Void -> Void
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Void -> Void -> Void
$cmin :: Void -> Void -> Void
max :: Void -> Void -> Void
$cmax :: Void -> Void -> Void
>= :: Void -> Void -> Bool
$c>= :: Void -> Void -> Bool
> :: Void -> Void -> Bool
$c> :: Void -> Void -> Bool
<= :: Void -> Void -> Bool
$c<= :: Void -> Void -> Bool
< :: Void -> Void -> Bool
$c< :: Void -> Void -> Bool
compare :: Void -> Void -> Ordering
$ccompare :: Void -> Void -> Ordering
Ord, Int -> Void -> ShowS
[Void] -> ShowS
Void -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Void] -> ShowS
$cshowList :: [Void] -> ShowS
show :: Void -> String
$cshow :: Void -> String
showsPrec :: Int -> Void -> ShowS
$cshowsPrec :: Int -> Void -> ShowS
Show, Typeable)

instance GPinchable (K1 i Void) where
    type GTag (K1 i Void) = TStruct

    gPinch :: forall a. K1 i Void a -> Value (GTag (K1 i Void))
gPinch (K1 Void
Void) = [FieldPair] -> Value TStruct
struct []

    -- If the map isn't empty, there's probably an exception in there.
    gUnpinch :: forall a. Value (GTag (K1 i Void)) -> Parser (K1 i Void a)
gUnpinch (VStruct HashMap Int16 SomeValue
m) | forall k v. HashMap k v -> Bool
HM.null HashMap Int16 SomeValue
m = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k i c (p :: k). c -> K1 i c p
K1 Void
Void
    gUnpinch Value (GTag (K1 i Void))
x = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
        String
"Failed to read response. Expected void, got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value (GTag (K1 i Void))
x