{-# 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 :: forall a.
(Generic a, GPinchable (Rep a)) =>
a -> Value (GTag (Rep a))
genericPinch = forall (f :: * -> *) a. GPinchable f => f a -> Value (GTag f)
gPinch forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a.
(Generic a, GPinchable (Rep a)) =>
Value (GTag (Rep a)) -> Parser a
genericUnpinch = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a x. Generic a => Rep a x -> a
G.to forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = 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 .= :: forall a. Pinchable a => Int16 -> a -> FieldPair
.= a
value = (Int16
fid, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => Value a -> SomeValue
SomeValue (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 ?= :: forall a. Pinchable a => Int16 -> Maybe a -> FieldPair
?= Maybe a
value = (Int16
fid, forall a. IsTType a => Value a -> SomeValue
SomeValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pinchable a => a -> Value (Tag a)
pinch 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {k} {v}.
Hashable k =>
HashMap k v -> (k, Maybe v) -> HashMap k v
go 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) = 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 :: forall a. Pinchable a => Int16 -> a -> Value TStruct
union Int16
k a
v = HashMap Int16 SomeValue -> Value TStruct
VStruct (forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton Int16
k (forall a. IsTType a => Value a -> SomeValue
SomeValue forall a b. (a -> b) -> a -> b
$ 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) .: :: forall a. Pinchable a => Value TStruct -> Int16 -> Parser a
.: Int16
fieldId = do
    SomeValue Value a
someValue <- forall {m :: * -> *} {a}. MonadFail m => String -> Maybe a -> m a
note (String
"Field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int16
fieldId forall a. [a] -> [a] -> [a]
++ String
" is absent.")
               forall a b. (a -> b) -> a -> b
$ Int16
fieldId forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HM.lookup` HashMap Int16 SomeValue
items
    (Value (Tag a)
value :: Value (Tag a)) <-
        forall {m :: * -> *} {a}. MonadFail m => String -> Maybe a -> m a
note (String
"Field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int16
fieldId forall a. [a] -> [a] -> [a]
++ String
" has the incorrect type. " forall a. [a] -> [a] -> [a]
++
              String
"Expected '" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. IsTType a => TType a
ttype :: TType (Tag a)) forall a. [a] -> [a] -> [a]
++ String
"' but " forall a. [a] -> [a] -> [a]
++
              String
"got '" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. IsTType a => Value a -> TType a
valueTType Value a
someValue) forall a. [a] -> [a] -> [a]
++ String
"'")
          forall a b. (a -> b) -> a -> b
$ forall a b. (IsTType a, IsTType b) => Value a -> Maybe (Value b)
castValue Value a
someValue
    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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
        Just a
v -> 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) .:? :: forall a. Pinchable a => Value TStruct -> Int16 -> Parser (Maybe a)
.:? Int16
fieldId =
    case Maybe (Value (Tag a))
value of
        Maybe (Value (Tag a))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just Value (Tag a)
v  -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HM.lookup` HashMap Int16 SomeValue
items forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(SomeValue Value a
v) -> 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 :: forall a b. (Pinchable a, IsTType b) => Value b -> Parser a
checkedUnpinch = case forall a b. (IsTType a, IsTType b) => Maybe (a :~: b)
ttypeEqT of
    Maybe (Tag a :~: b)
Nothing -> forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
        String
"Type mismatch. Expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TType (Tag a)
ttypeA forall a. [a] -> [a] -> [a]
++ String
". Got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TType b
ttypeB
    Just (Tag a :~: b
Refl :: Tag a :~: b) -> forall a. Pinchable a => Value (Tag a) -> Parser a
unpinch
  where
    ttypeA :: TType (Tag a)
ttypeA = forall a. IsTType a => TType a
ttype :: TType (Tag a)
    ttypeB :: TType b
ttypeB = 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 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 -> m k v -> r
foldlWithKey = forall a v.
(IsTType a, IsTType v) =>
FoldList (MapItem a v) -> Value TMap
VMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map forall {a} {a}.
(Pinchable a, Pinchable a) =>
(a, a) -> MapItem (Tag a) (Tag a)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall k v. Value k -> Value v -> MapItem k v
MapItem (forall a. Pinchable a => a -> Value (Tag a)
pinch a
k) (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 :: forall k v m a.
(Pinchable k, Pinchable v) =>
(k -> v -> m -> m) -> m -> Value a -> Parser m
unpinchMap k -> v -> m -> m
mapInsert m
mapEmpty (VMap FoldList (MapItem k v)
xs) =
    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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM 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) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (Pinchable a, IsTType b) => Value b -> Parser a
checkedUnpinch Value b
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = forall (m :: * -> *) a. Monad m => a -> m a
return m
mapEmpty
unpinchMap k -> v -> m -> m
_ m
_ Value a
x = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to read map. Got " forall a. [a] -> [a] -> [a]
++ 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 = forall a. a -> a
id
    unpinch :: Value (Tag (Value a)) -> Parser (Value a)
unpinch = 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
VBinary
    unpinch :: Value (Tag ByteString) -> Parser ByteString
unpinch (VBinary ByteString
b) = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict
    unpinch :: Value (Tag ByteString) -> Parser ByteString
unpinch (VBinary ByteString
b) = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8
    unpinch :: Value (Tag Text) -> Parser Text
unpinch (VBinary ByteString
b) = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TLE.encodeUtf8
    unpinch :: Value (Tag Text) -> Parser Text
unpinch (VBinary ByteString
b) = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 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
VBool
    unpinch :: Value (Tag Bool) -> Parser Bool
unpinch (VBool Bool
x) = 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
VByte
    unpinch :: Value (Tag Int8) -> Parser Int8
unpinch (VByte Int8
x) = 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
VDouble
    unpinch :: Value (Tag Double) -> Parser Double
unpinch (VDouble Double
x) = 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
VInt16
    unpinch :: Value (Tag Int16) -> Parser Int16
unpinch (VInt16 Int16
x) = 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
VInt32
    unpinch :: Value (Tag Int32) -> Parser Int32
unpinch (VInt32 Int32
x) = 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
VInt64
    unpinch :: Value (Tag Int64) -> Parser Int64
unpinch (VInt64 Int64
x) = 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 = forall a. IsTType a => FoldList (Value a) -> Value TList
VList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map forall a. Pinchable a => a -> Value (Tag a)
pinch forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
        forall a. [a] -> Vector a
V.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
FL.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM 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 = forall a. IsTType a => FoldList (Value a) -> Value TList
VList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map forall a. Pinchable a => a -> Value (Tag a)
pinch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => f a -> FoldList a
FL.fromFoldable

    unpinch :: Value (Tag [a]) -> Parser [a]
unpinch (VList FoldList (Value a)
xs) = forall (t :: * -> *) a. Foldable t => t a -> [a]
FL.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM 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 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 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 = forall k v m a.
(Pinchable k, Pinchable v) =>
(k -> v -> m -> m) -> m -> Value a -> Parser m
unpinchMap forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert 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 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 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 = forall k v m a.
(Pinchable k, Pinchable v) =>
(k -> v -> m -> m) -> m -> Value a -> Parser m
unpinchMap forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert 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 = forall a. IsTType a => FoldList (Value a) -> Value TSet
VSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map forall a. Pinchable a => a -> Value (Tag a)
pinch forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
FL.foldl' (\HashSet a
s !a
a -> forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert a
a HashSet a
s) forall a. HashSet a
HS.empty
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM 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 = forall a. IsTType a => FoldList (Value a) -> Value TSet
VSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> FoldList a -> FoldList b
FL.map forall a. Pinchable a => a -> Value (Tag a)
pinch forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
FL.foldl' (\Set a
s !a
a -> forall a. Ord a => a -> Set a -> Set a
S.insert a
a Set a
s) forall a. Set a
S.empty
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
FL.mapM forall a b. (Pinchable a, IsTType b) => Value b -> Parser a
checkedUnpinch FoldList (Value a)
xs