{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE DefaultSignatures    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module      :  Pinch.Internal.Pinchable
-- Copyright   :  (c) Abhinav Gupta 2015
-- License     :  BSD3
--
-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>
-- Stability   :  experimental
--
-- Provides the core @Pinchable@ typeclass and the @GPinchable@ typeclass used
-- to derive instances automatically.
--
module Pinch.Internal.Pinchable
    ( Pinchable(..)

    , (.=)
    , (?=)
    , struct
    , union
    , FieldPair

    , (.:)
    , (.:?)

    , GPinchable(..)
    , genericPinch
    , genericUnpinch

    , Parser
    , runParser
    , parserCatch
    ) where

import Data.ByteString (ByteString)
import Data.Hashable   (Hashable)
import Data.Int        (Int16, Int32, Int64, Int8)
import Data.Kind       (Type)
import Data.List       (foldl')
import Data.Text       (Text)
import Data.Typeable   ((:~:) (..))
import Data.Vector     (Vector)
import GHC.Generics    (Generic, Rep)

import qualified Data.ByteString.Lazy    as BL
import qualified Data.HashMap.Strict     as HM
import qualified Data.HashSet            as HS
import qualified Data.Map.Strict         as M
import qualified Data.Set                as S
import qualified Data.Text.Encoding      as TE
import qualified Data.Text.Lazy          as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Vector             as V
import qualified GHC.Generics            as G

import Pinch.Internal.Pinchable.Parser
import Pinch.Internal.TType
import Pinch.Internal.Value

import qualified Pinch.Internal.FoldList as FL

-- | Implementation of 'pinch' based on 'GPinchable'.
genericPinch
    :: (Generic a, GPinchable (Rep a)) => a -> Value (GTag (Rep a))
genericPinch :: a -> Value (GTag (Rep a))
genericPinch = Rep a Any -> Value (GTag (Rep a))
forall (f :: * -> *) a. GPinchable f => f a -> Value (GTag f)
gPinch (Rep a Any -> Value (GTag (Rep a)))
-> (a -> Rep a Any) -> a -> Value (GTag (Rep a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
G.from

-- | Implementation of 'unpinch' based on 'GPinchable'.
genericUnpinch
    :: (Generic a, GPinchable (Rep a)) => Value (GTag (Rep a)) -> Parser a
genericUnpinch :: Value (GTag (Rep a)) -> Parser a
genericUnpinch = (Rep a Any -> a) -> Parser (Rep a Any) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
G.to (Parser (Rep a Any) -> Parser a)
-> (Value (GTag (Rep a)) -> Parser (Rep a Any))
-> Value (GTag (Rep a))
-> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value (GTag (Rep a)) -> Parser (Rep a Any)
forall (f :: * -> *) a.
GPinchable f =>
Value (GTag f) -> Parser (f a)
gUnpinch


-- | GPinchable is used to impelment support for automatically deriving
-- instances of Pinchable via generics.
class IsTType (GTag f) => GPinchable (f :: Type -> Type) where
    -- | 'TType' tag to use for objects of this type.
    type GTag f

    -- | Converts a generic representation of a value into a 'Value'.
    gPinch :: f a -> Value (GTag f)

    -- | Converts a 'Value' back into the generic representation of the
    -- object.
    gUnpinch :: Value (GTag f) -> Parser (f a)


-- | The Pinchable type class is implemented by types that can be sent or
-- received over the wire as Thrift payloads.
class IsTType (Tag a) => Pinchable a where
    -- | 'TType' tag for this type.
    --
    -- For most custom types, this will be 'TStruct', 'TUnion', or
    -- 'TException'. For enums, it will be 'TEnum'. If the instance
    -- automatically derived with use of @Generic@, this is not required
    -- because it is automatically determined by use of @Field@ or
    -- @Enumeration@.
    type Tag a
    type Tag a = GTag (Rep a)

    -- | Convert an @a@ into a 'Value'.
    --
    -- For structs, 'struct', '.=', and '?=' may be used to construct
    -- 'Value' objects tagged with 'TStruct'.
    pinch :: a -> Value (Tag a)

    -- | Read a 'Value' back into an @a@.
    --
    -- For structs, '.:' and '.:?' may be used to retrieve field values.
    unpinch :: Value (Tag a) -> Parser a

    default pinch
        :: (Generic a, Tag a ~ GTag (Rep a), GPinchable (Rep a))
        => a -> Value (Tag a)
    pinch = a -> Value (Tag a)
forall a.
(Generic a, GPinchable (Rep a)) =>
a -> Value (GTag (Rep a))
genericPinch

    default unpinch
        :: (Generic a, Tag a ~ GTag (Rep a), GPinchable (Rep a))
        => Value (Tag a) -> Parser a
    unpinch = Value (Tag a) -> Parser a
forall a.
(Generic a, GPinchable (Rep a)) =>
Value (GTag (Rep a)) -> Parser a
genericUnpinch


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

-- | A pair of field identifier and maybe a value stored in the field. If the
-- value is absent, the field will be ignored.
type FieldPair = (Int16, Maybe SomeValue)

-- | Construct a 'FieldPair' from a field identifier and a 'Pinchable' value.
(.=) :: Pinchable a => Int16 -> a -> FieldPair
Int16
fid .= :: Int16 -> a -> FieldPair
.= a
value = (Int16
fid, SomeValue -> Maybe SomeValue
forall a. a -> Maybe a
Just (SomeValue -> Maybe SomeValue) -> SomeValue -> Maybe SomeValue
forall a b. (a -> b) -> a -> b
$ Value (Tag a) -> SomeValue
forall a. IsTType a => Value a -> SomeValue
SomeValue (a -> Value (Tag a)
forall a. Pinchable a => a -> Value (Tag a)
pinch a
value))

-- | Construct a 'FieldPair' from a field identifier and an optional
-- 'Pinchable' value.
(?=) :: Pinchable a => Int16 -> Maybe a -> FieldPair
Int16
fid ?= :: Int16 -> Maybe a -> FieldPair
?= Maybe a
value = (Int16
fid, Value (Tag a) -> SomeValue
forall a. IsTType a => Value a -> SomeValue
SomeValue (Value (Tag a) -> SomeValue)
-> (a -> Value (Tag a)) -> a -> SomeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value (Tag a)
forall a. Pinchable a => a -> Value (Tag a)
pinch (a -> SomeValue) -> Maybe a -> Maybe SomeValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
value)

-- | Construct a 'Value' tagged with a 'TStruct' from the given key-value
-- pairs. Optional fields whose values were omitted will be ignored.
--
-- > struct [1 .= ("Hello" :: Text), 2 .= (42 :: Int16)]
struct :: [FieldPair] -> Value TStruct
struct :: [FieldPair] -> Value TStruct
struct = HashMap Int16 SomeValue -> Value TStruct
VStruct (HashMap Int16 SomeValue -> Value TStruct)
-> ([FieldPair] -> HashMap Int16 SomeValue)
-> [FieldPair]
-> Value TStruct
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap Int16 SomeValue -> FieldPair -> HashMap Int16 SomeValue)
-> HashMap Int16 SomeValue
-> [FieldPair]
-> HashMap Int16 SomeValue
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HashMap Int16 SomeValue -> FieldPair -> HashMap Int16 SomeValue
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> (k, Maybe v) -> HashMap k v
go HashMap Int16 SomeValue
forall k v. HashMap k v
HM.empty
  where
    go :: HashMap k v -> (k, Maybe v) -> HashMap k v
go HashMap k v
m (k
_, Maybe v
Nothing) = HashMap k v
m
    go HashMap k v
m (k
k,  Just v
v) = k -> v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert k
k v
v HashMap k v
m

-- | Constructs a 'Value' tagged with 'TUnion'.
--
-- > union 1 ("foo" :: ByteString)
--
union :: Pinchable a => Int16 -> a -> Value TUnion
union :: Int16 -> a -> Value TStruct
union Int16
k a
v = HashMap Int16 SomeValue -> Value TStruct
VStruct (Int16 -> SomeValue -> HashMap Int16 SomeValue
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton Int16
k (Value (Tag a) -> SomeValue
forall a. IsTType a => Value a -> SomeValue
SomeValue (Value (Tag a) -> SomeValue) -> Value (Tag a) -> SomeValue
forall a b. (a -> b) -> a -> b
$ a -> Value (Tag a)
forall a. Pinchable a => a -> Value (Tag a)
pinch a
v))

-- | Given a field ID and a @Value TStruct@, get the value stored in the
-- struct under that field ID. The lookup fails if the field is absent or if
-- it's not the same type as expected by this call's context.
(.:) :: forall a. Pinchable a => Value TStruct -> Int16 -> Parser a
(VStruct HashMap Int16 SomeValue
items) .: :: Value TStruct -> Int16 -> Parser a
.: Int16
fieldId = do
    SomeValue Value a
someValue <- String -> Maybe SomeValue -> Parser SomeValue
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
note (String
"Field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int16 -> String
forall a. Show a => a -> String
show Int16
fieldId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is absent.")
               (Maybe SomeValue -> Parser SomeValue)
-> Maybe SomeValue -> Parser SomeValue
forall a b. (a -> b) -> a -> b
$ Int16
fieldId Int16 -> HashMap Int16 SomeValue -> Maybe SomeValue
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HM.lookup` HashMap Int16 SomeValue
items
    (value :: Value (Tag a)) <-
        String -> Maybe (Value (Tag a)) -> Parser (Value (Tag a))
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
note (String
"Field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int16 -> String
forall a. Show a => a -> String
show Int16
fieldId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has the incorrect type. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"Expected '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TType (Tag a) -> String
forall a. Show a => a -> String
show (TType (Tag a)
forall a. IsTType a => TType a
ttype :: TType (Tag a)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' but " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"got '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TType a -> String
forall a. Show a => a -> String
show (Value a -> TType a
forall a. IsTType a => Value a -> TType a
valueTType Value a
someValue) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
          (Maybe (Value (Tag a)) -> Parser (Value (Tag a)))
-> Maybe (Value (Tag a)) -> Parser (Value (Tag a))
forall a b. (a -> b) -> a -> b
$ Value a -> Maybe (Value (Tag a))
forall a b. (IsTType a, IsTType b) => Value a -> Maybe (Value b)
castValue Value a
someValue
    Value (Tag a) -> Parser a
forall a. Pinchable a => Value (Tag a) -> Parser a
unpinch Value (Tag a)
value
  where
    note :: String -> Maybe a -> m a
note String
msg Maybe a
m = case Maybe a
m of
        Maybe a
Nothing -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
        Just a
v -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | Given a field ID and a @Value TStruct@, get the optional value stored in
-- the struct under the given field ID. The value returned is @Nothing@ if it
-- was absent or the wrong type. The lookup fails only if the value retrieved
-- fails to 'unpinch'.
(.:?) :: forall a. Pinchable a
      => Value TStruct -> Int16 -> Parser (Maybe a)
(VStruct HashMap Int16 SomeValue
items) .:? :: Value TStruct -> Int16 -> Parser (Maybe a)
.:? Int16
fieldId =
    case Maybe (Value (Tag a))
value of
        Maybe (Value (Tag a))
Nothing -> Maybe a -> Parser (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Just Value (Tag a)
v  -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value (Tag a) -> Parser a
forall a. Pinchable a => Value (Tag a) -> Parser a
unpinch Value (Tag a)
v
  where
    value :: Maybe (Value (Tag a))
    value :: Maybe (Value (Tag a))
value = Int16
fieldId Int16 -> HashMap Int16 SomeValue -> Maybe SomeValue
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HM.lookup` HashMap Int16 SomeValue
items Maybe SomeValue
-> (SomeValue -> Maybe (Value (Tag a))) -> Maybe (Value (Tag a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(SomeValue Value a
v) -> Value a -> Maybe (Value (Tag a))
forall a b. (IsTType a, IsTType b) => Value a -> Maybe (Value b)
castValue Value a
v

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

-- | Helper to 'unpinch' values by matching TTypes.
checkedUnpinch
    :: forall a b. (Pinchable a, IsTType b)
    => Value b -> Parser a
checkedUnpinch :: Value b -> Parser a
checkedUnpinch = case Maybe (Tag a :~: b)
forall a b. (IsTType a, IsTType b) => Maybe (a :~: b)
ttypeEqT of
    Maybe (Tag a :~: b)
Nothing -> Parser a -> Value b -> Parser a
forall a b. a -> b -> a
const (Parser a -> Value b -> Parser a)
-> (String -> Parser a) -> String -> Value b -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Value b -> Parser a) -> String -> Value b -> Parser a
forall a b. (a -> b) -> a -> b
$
        String
"Type mismatch. Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TType (Tag a) -> String
forall a. Show a => a -> String
show TType (Tag a)
ttypeA String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TType b -> String
forall a. Show a => a -> String
show TType b
ttypeB
    Just (Refl :: Tag a :~: b) -> Value b -> Parser a
forall a. Pinchable a => Value (Tag a) -> Parser a
unpinch
  where
    ttypeA :: TType (Tag a)
ttypeA = TType (Tag a)
forall a. IsTType a => TType a
ttype :: TType (Tag a)
    ttypeB :: TType b
ttypeB = TType b
forall a. IsTType a => TType a
ttype :: TType b

-- | Helper to 'pinch' maps.
pinchMap
    :: (Pinchable k, Pinchable v)
    => (forall r. (r -> k -> v -> r) -> r -> m k v -> r)
          -- ^ @foldlWithKey@
    -> m k v
    -> Value TMap
pinchMap :: (forall r. (r -> k -> v -> r) -> r -> m k v -> r)
-> m k v -> Value TMap
pinchMap forall r. (r -> k -> v -> r) -> r -> m k v -> r
foldlWithKey = FoldList (MapItem (Tag k) (Tag v)) -> Value TMap
forall k a.
(IsTType k, IsTType a) =>
FoldList (MapItem k a) -> Value TMap
VMap (FoldList (MapItem (Tag k) (Tag v)) -> Value TMap)
-> (m k v -> FoldList (MapItem (Tag k) (Tag v)))
-> m k v
-> Value TMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> MapItem (Tag k) (Tag v))
-> FoldList (k, v) -> FoldList (MapItem (Tag k) (Tag v))
forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map (k, v) -> MapItem (Tag k) (Tag v)
forall a a.
(Pinchable a, Pinchable a) =>
(a, a) -> MapItem (Tag a) (Tag a)
go (FoldList (k, v) -> FoldList (MapItem (Tag k) (Tag v)))
-> (m k v -> FoldList (k, v))
-> m k v
-> FoldList (MapItem (Tag k) (Tag v))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r. (r -> k -> v -> r) -> r -> m k v -> r)
-> m k v -> FoldList (k, v)
forall k v (m :: * -> * -> *).
(forall r. (r -> k -> v -> r) -> r -> m k v -> r)
-> m k v -> FoldList (k, v)
FL.fromMap forall r. (r -> k -> v -> r) -> r -> m k v -> r
foldlWithKey
  where
    go :: (a, a) -> MapItem (Tag a) (Tag a)
go (!a
k, !a
v) = Value (Tag a) -> Value (Tag a) -> MapItem (Tag a) (Tag a)
forall k v. Value k -> Value v -> MapItem k v
MapItem (a -> Value (Tag a)
forall a. Pinchable a => a -> Value (Tag a)
pinch a
k) (a -> Value (Tag a)
forall a. Pinchable a => a -> Value (Tag a)
pinch a
v)

unpinchMap
    :: (Pinchable k, Pinchable v)
    => (k -> v -> m -> m) -> m -> Value a -> Parser m
unpinchMap :: (k -> v -> m -> m) -> m -> Value a -> Parser m
unpinchMap k -> v -> m -> m
mapInsert m
mapEmpty (VMap FoldList (MapItem k v)
xs) =
    (m -> (k, v) -> m) -> m -> FoldList (k, v) -> m
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
FL.foldl' (\m
m (!k
k, !v
v) -> k -> v -> m -> m
mapInsert k
k v
v m
m) m
mapEmpty (FoldList (k, v) -> m) -> Parser (FoldList (k, v)) -> Parser m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MapItem k v -> Parser (k, v))
-> FoldList (MapItem k v) -> Parser (FoldList (k, v))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM MapItem k v -> Parser (k, v)
forall a a b b.
(Pinchable a, Pinchable a, IsTType b, IsTType b) =>
MapItem b b -> Parser (a, a)
go FoldList (MapItem k v)
xs
  where
    go :: MapItem b b -> Parser (a, a)
go (MapItem Value b
k Value b
v) = (,) (a -> a -> (a, a)) -> Parser a -> Parser (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value b -> Parser a
forall a b. (Pinchable a, IsTType b) => Value b -> Parser a
checkedUnpinch Value b
k Parser (a -> (a, a)) -> Parser a -> Parser (a, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value b -> Parser a
forall a b. (Pinchable a, IsTType b) => Value b -> Parser a
checkedUnpinch Value b
v
unpinchMap k -> v -> m -> m
_ m
mapEmpty Value a
VNullMap = m -> Parser m
forall (m :: * -> *) a. Monad m => a -> m a
return m
mapEmpty
unpinchMap k -> v -> m -> m
_ m
_ Value a
x = String -> Parser m
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser m) -> String -> Parser m
forall a b. (a -> b) -> a -> b
$ String
"Failed to read map. Got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value a -> String
forall a. Show a => a -> String
show Value a
x

instance IsTType a => Pinchable (Value a) where
    type Tag (Value a) = a
    pinch :: Value a -> Value (Tag (Value a))
pinch = Value a -> Value (Tag (Value a))
forall a. a -> a
id
    unpinch :: Value (Tag (Value a)) -> Parser (Value a)
unpinch = Value (Tag (Value a)) -> Parser (Value a)
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Pinchable ByteString where
    type Tag ByteString = TBinary
    pinch :: ByteString -> Value (Tag ByteString)
pinch = ByteString -> Value TBinary
ByteString -> Value (Tag ByteString)
VBinary
    unpinch :: Value (Tag ByteString) -> Parser ByteString
unpinch (VBinary ByteString
b) = ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b

instance Pinchable BL.ByteString where
    type Tag BL.ByteString = TBinary
    pinch :: ByteString -> Value (Tag ByteString)
pinch = ByteString -> Value TBinary
VBinary (ByteString -> Value TBinary)
-> (ByteString -> ByteString) -> ByteString -> Value TBinary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict
    unpinch :: Value (Tag ByteString) -> Parser ByteString
unpinch (VBinary ByteString
b) = ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
BL.fromStrict ByteString
b)

instance Pinchable Text where
    type Tag Text = TBinary
    pinch :: Text -> Value (Tag Text)
pinch = ByteString -> Value TBinary
VBinary (ByteString -> Value TBinary)
-> (Text -> ByteString) -> Text -> Value TBinary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8
    unpinch :: Value (Tag Text) -> Parser Text
unpinch (VBinary ByteString
b) = Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text)
-> (ByteString -> Text) -> ByteString -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Parser Text) -> ByteString -> Parser Text
forall a b. (a -> b) -> a -> b
$ ByteString
b

instance Pinchable TL.Text where
    type Tag TL.Text = TBinary
    pinch :: Text -> Value (Tag Text)
pinch = ByteString -> Value TBinary
VBinary (ByteString -> Value TBinary)
-> (Text -> ByteString) -> Text -> Value TBinary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TLE.encodeUtf8
    unpinch :: Value (Tag Text) -> Parser Text
unpinch (VBinary ByteString
b) = Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text)
-> (ByteString -> Text) -> ByteString -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Parser Text) -> ByteString -> Parser Text
forall a b. (a -> b) -> a -> b
$ ByteString
b

instance Pinchable Bool where
    type Tag Bool = TBool
    pinch :: Bool -> Value (Tag Bool)
pinch = Bool -> Value TBool
Bool -> Value (Tag Bool)
VBool
    unpinch :: Value (Tag Bool) -> Parser Bool
unpinch (VBool Bool
x) = Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
x

instance Pinchable Int8 where
    type Tag Int8 = TByte
    pinch :: Int8 -> Value (Tag Int8)
pinch = Int8 -> Value TByte
Int8 -> Value (Tag Int8)
VByte
    unpinch :: Value (Tag Int8) -> Parser Int8
unpinch (VByte Int8
x) = Int8 -> Parser Int8
forall (m :: * -> *) a. Monad m => a -> m a
return Int8
x

instance Pinchable Double where
    type Tag Double = TDouble
    pinch :: Double -> Value (Tag Double)
pinch = Double -> Value TDouble
Double -> Value (Tag Double)
VDouble
    unpinch :: Value (Tag Double) -> Parser Double
unpinch (VDouble Double
x) = Double -> Parser Double
forall (m :: * -> *) a. Monad m => a -> m a
return Double
x

instance Pinchable Int16 where
    type Tag Int16 = TInt16
    pinch :: Int16 -> Value (Tag Int16)
pinch = Int16 -> Value TInt16
Int16 -> Value (Tag Int16)
VInt16
    unpinch :: Value (Tag Int16) -> Parser Int16
unpinch (VInt16 Int16
x) = Int16 -> Parser Int16
forall (m :: * -> *) a. Monad m => a -> m a
return Int16
x

instance Pinchable Int32 where
    type Tag Int32 = TInt32
    pinch :: Int32 -> Value (Tag Int32)
pinch = Int32 -> Value TInt32
Int32 -> Value (Tag Int32)
VInt32
    unpinch :: Value (Tag Int32) -> Parser Int32
unpinch (VInt32 Int32
x) = Int32 -> Parser Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
x

instance Pinchable Int64 where
    type Tag Int64 = TInt64
    pinch :: Int64 -> Value (Tag Int64)
pinch = Int64 -> Value TInt64
Int64 -> Value (Tag Int64)
VInt64
    unpinch :: Value (Tag Int64) -> Parser Int64
unpinch (VInt64 Int64
x) = Int64 -> Parser Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
x

instance Pinchable a => Pinchable (Vector a) where
    type Tag (Vector a) = TList

    pinch :: Vector a -> Value (Tag (Vector a))
pinch = FoldList (Value (Tag a)) -> Value TList
forall a. IsTType a => FoldList (Value a) -> Value TList
VList (FoldList (Value (Tag a)) -> Value TList)
-> (Vector a -> FoldList (Value (Tag a)))
-> Vector a
-> Value TList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value (Tag a)) -> FoldList a -> FoldList (Value (Tag a))
forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map a -> Value (Tag a)
forall a. Pinchable a => a -> Value (Tag a)
pinch (FoldList a -> FoldList (Value (Tag a)))
-> (Vector a -> FoldList a) -> Vector a -> FoldList (Value (Tag a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> FoldList a
forall (f :: * -> *) a. Foldable f => f a -> FoldList a
FL.fromFoldable

    unpinch :: Value (Tag (Vector a)) -> Parser (Vector a)
unpinch (VList FoldList (Value a)
xs) =
        [a] -> Vector a
forall a. [a] -> Vector a
V.fromList ([a] -> Vector a) -> (FoldList a -> [a]) -> FoldList a -> Vector a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FoldList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
FL.toList (FoldList a -> Vector a)
-> Parser (FoldList a) -> Parser (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value a -> Parser a) -> FoldList (Value a) -> Parser (FoldList a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM Value a -> Parser a
forall a b. (Pinchable a, IsTType b) => Value b -> Parser a
checkedUnpinch FoldList (Value a)
xs

instance Pinchable a => Pinchable [a] where
    type Tag [a] = TList

    pinch :: [a] -> Value (Tag [a])
pinch = FoldList (Value (Tag a)) -> Value TList
forall a. IsTType a => FoldList (Value a) -> Value TList
VList (FoldList (Value (Tag a)) -> Value TList)
-> ([a] -> FoldList (Value (Tag a))) -> [a] -> Value TList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value (Tag a)) -> FoldList a -> FoldList (Value (Tag a))
forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map a -> Value (Tag a)
forall a. Pinchable a => a -> Value (Tag a)
pinch (FoldList a -> FoldList (Value (Tag a)))
-> ([a] -> FoldList a) -> [a] -> FoldList (Value (Tag a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> FoldList a
forall (f :: * -> *) a. Foldable f => f a -> FoldList a
FL.fromFoldable

    unpinch :: Value (Tag [a]) -> Parser [a]
unpinch (VList FoldList (Value a)
xs) = FoldList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
FL.toList (FoldList a -> [a]) -> Parser (FoldList a) -> Parser [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value a -> Parser a) -> FoldList (Value a) -> Parser (FoldList a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM Value a -> Parser a
forall a b. (Pinchable a, IsTType b) => Value b -> Parser a
checkedUnpinch FoldList (Value a)
xs

instance
  ( Eq k
  , Hashable k
  , Pinchable k
  , Pinchable v
  ) => Pinchable (HM.HashMap k v) where
    type Tag (HM.HashMap k v) = TMap
    pinch :: HashMap k v -> Value (Tag (HashMap k v))
pinch = (forall r. (r -> k -> v -> r) -> r -> HashMap k v -> r)
-> HashMap k v -> Value TMap
forall k v (m :: * -> * -> *).
(Pinchable k, Pinchable v) =>
(forall r. (r -> k -> v -> r) -> r -> m k v -> r)
-> m k v -> Value TMap
pinchMap forall r. (r -> k -> v -> r) -> r -> HashMap k v -> r
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
HM.foldlWithKey'
    unpinch :: Value (Tag (HashMap k v)) -> Parser (HashMap k v)
unpinch = (k -> v -> HashMap k v -> HashMap k v)
-> HashMap k v -> Value TMap -> Parser (HashMap k v)
forall k v m a.
(Pinchable k, Pinchable v) =>
(k -> v -> m -> m) -> m -> Value a -> Parser m
unpinchMap k -> v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert HashMap k v
forall k v. HashMap k v
HM.empty

instance (Ord k, Pinchable k, Pinchable v) => Pinchable (M.Map k v) where
    type Tag (M.Map k v) = TMap
    pinch :: Map k v -> Value (Tag (Map k v))
pinch = (forall r. (r -> k -> v -> r) -> r -> Map k v -> r)
-> Map k v -> Value TMap
forall k v (m :: * -> * -> *).
(Pinchable k, Pinchable v) =>
(forall r. (r -> k -> v -> r) -> r -> m k v -> r)
-> m k v -> Value TMap
pinchMap forall r. (r -> k -> v -> r) -> r -> Map k v -> r
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey'
    unpinch :: Value (Tag (Map k v)) -> Parser (Map k v)
unpinch = (k -> v -> Map k v -> Map k v)
-> Map k v -> Value TMap -> Parser (Map k v)
forall k v m a.
(Pinchable k, Pinchable v) =>
(k -> v -> m -> m) -> m -> Value a -> Parser m
unpinchMap k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Map k v
forall k a. Map k a
M.empty

instance (Eq a, Hashable a, Pinchable a) => Pinchable (HS.HashSet a) where
    type Tag (HS.HashSet a) = TSet
    pinch :: HashSet a -> Value (Tag (HashSet a))
pinch = FoldList (Value (Tag a)) -> Value TSet
forall a. IsTType a => FoldList (Value a) -> Value TSet
VSet (FoldList (Value (Tag a)) -> Value TSet)
-> (HashSet a -> FoldList (Value (Tag a)))
-> HashSet a
-> Value TSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value (Tag a)) -> FoldList a -> FoldList (Value (Tag a))
forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map a -> Value (Tag a)
forall a. Pinchable a => a -> Value (Tag a)
pinch (FoldList a -> FoldList (Value (Tag a)))
-> (HashSet a -> FoldList a)
-> HashSet a
-> FoldList (Value (Tag a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet a -> FoldList a
forall (f :: * -> *) a. Foldable f => f a -> FoldList a
FL.fromFoldable

    unpinch :: Value (Tag (HashSet a)) -> Parser (HashSet a)
unpinch (VSet FoldList (Value a)
xs) =
        (HashSet a -> a -> HashSet a)
-> HashSet a -> FoldList a -> HashSet a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
FL.foldl' (\HashSet a
s !a
a -> a -> HashSet a -> HashSet a
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert a
a HashSet a
s) HashSet a
forall a. HashSet a
HS.empty
        (FoldList a -> HashSet a)
-> Parser (FoldList a) -> Parser (HashSet a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value a -> Parser a) -> FoldList (Value a) -> Parser (FoldList a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM Value a -> Parser a
forall a b. (Pinchable a, IsTType b) => Value b -> Parser a
checkedUnpinch FoldList (Value a)
xs

instance (Ord a, Pinchable a) => Pinchable (S.Set a) where
    type Tag (S.Set a) = TSet
    pinch :: Set a -> Value (Tag (Set a))
pinch = FoldList (Value (Tag a)) -> Value TSet
forall a. IsTType a => FoldList (Value a) -> Value TSet
VSet (FoldList (Value (Tag a)) -> Value TSet)
-> (Set a -> FoldList (Value (Tag a))) -> Set a -> Value TSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value (Tag a)) -> FoldList a -> FoldList (Value (Tag a))
forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map a -> Value (Tag a)
forall a. Pinchable a => a -> Value (Tag a)
pinch (FoldList a -> FoldList (Value (Tag a)))
-> (Set a -> FoldList a) -> Set a -> FoldList (Value (Tag a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> FoldList a
forall (f :: * -> *) a. Foldable f => f a -> FoldList a
FL.fromFoldable

    unpinch :: Value (Tag (Set a)) -> Parser (Set a)
unpinch (VSet FoldList (Value a)
xs) =
        (Set a -> a -> Set a) -> Set a -> FoldList a -> Set a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
FL.foldl' (\Set a
s !a
a -> a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
a Set a
s) Set a
forall a. Set a
S.empty
        (FoldList a -> Set a) -> Parser (FoldList a) -> Parser (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value a -> Parser a) -> FoldList (Value a) -> Parser (FoldList a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM Value a -> Parser a
forall a b. (Pinchable a, IsTType b) => Value b -> Parser a
checkedUnpinch FoldList (Value a)
xs