{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ < 806
{-# LANGUAGE TypeInType #-}
#endif
module Codec.Winery.Class (Serialise(..)
  , VarInt(..)
  , BundleSerialise(..)
  , bundleRecord
  , bundleRecordDefault
  , bundleVariant
  , alterSchemaGen
  , alterExtractor
  , getSchema
  , schema
  , withSchema
  , unexpectedSchema
  , mkExtractor
  , extractListBy
  , buildVariantExtractor
  , gschemaGenRecord
  , gtoBuilderRecord
  , gextractorRecord
  , extractorRecord'
  , gdecodeCurrentRecord
  , GEncodeProduct(..)
  , GDecodeProduct(..)
  , GSerialiseRecord(..)
  , GSerialiseProduct(..)
  , gschemaGenProduct
  , gtoBuilderProduct
  , gextractorProduct
  , gdecodeCurrentProduct
  , extractorProduct'
  , GConstructorCount(..)
  , GDecodeVariant(..)
  , GEncodeVariant(..)
  , GSerialiseVariant(..)
  , gschemaGenVariant
  , gtoBuilderVariant
  , gextractorVariant
  , gdecodeCurrentVariant
  , gvariantExtractors
  , Subextractor(..)
  , extractField
  , extractFieldBy
  , buildExtractor
  , buildRecordExtractor
  , bextractors
  , buildRecordExtractorF
  , bextractorsF
  ) where

import Barbies hiding (Void)
import Barbies.Constraints
import Barbies.TH
import Control.Applicative
import Control.Exception
import Control.Monad.Reader
import qualified Data.ByteString as B
import qualified Data.ByteString.FastBuilder as BB
import qualified Data.ByteString.Lazy as BL
import Data.Bits
import Data.Complex
import Data.Dynamic
import Data.Fixed
import Data.Functor.Compose
import Data.Functor.Identity
import qualified Data.Functor.Product as F
import Data.List (elemIndex)
import qualified Data.List.NonEmpty as NE
import Data.Monoid as M
import Data.Kind (Type)
import Data.Proxy
import Data.Ratio (Ratio, (%), numerator, denominator)
import Data.Scientific (Scientific, scientific, coefficient, base10Exponent)
import Data.Semigroup as S
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HM
import Data.Int
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.Map as M
import Data.Ord (Down(..))
import Data.Word
import Codec.Winery.Base as W
import Codec.Winery.Internal
import qualified Data.Sequence as Seq
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Unboxed as UV
import Prettyprinter hiding ((<>), SText, SChar)
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Typeable
import Data.Void (Void)
import Unsafe.Coerce
import GHC.Float (castWord32ToFloat, castWord64ToDouble)
import GHC.Natural
import GHC.Generics
import GHC.TypeLits

-- | Serialisable datatype
--
class Typeable a => Serialise a where
  -- | Obtain the schema of the datatype.
  schemaGen :: Proxy a -> SchemaGen Schema
  schemaGen = bundleSchemaGen bundleSerialise
  {-# INLINE schemaGen #-}

  -- | Serialise a value.
  toBuilder :: a -> BB.Builder
  toBuilder = bundleToBuilder bundleSerialise
  {-# INLINE toBuilder #-}

  -- | A value of 'Extractor a' interprets a schema and builds a function from
  -- 'Term' to @a@. This must be equivalent to 'decodeCurrent' when the schema
  -- is the current one.
  --
  -- If @'extractor' s@ returns a function, the function must return a
  -- non-bottom for any 'Term' @'decodeTerm' s@ returns.
  --
  -- It must not return a function if an unsupported schema is supplied.
  --
  -- @getDecoderBy extractor (schema (Proxy @a))@ must be @Right d@
  -- where @d@ is equivalent to 'decodeCurrent'.
  --
  extractor :: Extractor a
  extractor = bundleExtractor bundleSerialise
  {-# INLINE extractor #-}

  -- | Decode a value with the current schema.
  --
  -- @'decodeCurrent' `evalDecoder` 'toBuilder' x@ ≡ x
  decodeCurrent :: Decoder a
  decodeCurrent = bundleDecodeCurrent bundleSerialise
  {-# INLINE decodeCurrent #-}

  -- | Instead of the four methods above, you can supply a bundle.
  bundleSerialise :: BundleSerialise a
  bundleSerialise = BundleSerialise
    { bundleSchemaGen = schemaGen
    , bundleToBuilder = toBuilder
    , bundleExtractor = extractor
    , bundleDecodeCurrent = decodeCurrent
    }

  {-# MINIMAL schemaGen, toBuilder, extractor, decodeCurrent | bundleSerialise #-}

-- | A bundle of 'Serialise' methods
data BundleSerialise a = BundleSerialise
  { bundleSchemaGen :: Proxy a -> SchemaGen Schema
  , bundleToBuilder :: a -> BB.Builder
  , bundleExtractor :: Extractor a
  , bundleDecodeCurrent :: Decoder a
  }

-- | Modify 'bundleSchemaGen'
alterSchemaGen :: (SchemaGen Schema -> SchemaGen Schema)
  -> BundleSerialise a -> BundleSerialise a
alterSchemaGen f bundle = bundle { bundleSchemaGen = f . bundleSchemaGen bundle }

-- | Modify 'bundleExtractor'
alterExtractor :: (Extractor a -> Extractor a)
  -> BundleSerialise a -> BundleSerialise a
alterExtractor f bundle = bundle { bundleExtractor = f (bundleExtractor bundle) }

-- | A bundle of generic implementations for records
bundleRecord :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a)
  => (Extractor a -> Extractor a) -- extractor modifier
  -> BundleSerialise a
bundleRecord f = BundleSerialise
  { bundleSchemaGen = gschemaGenRecord
  , bundleToBuilder = gtoBuilderRecord
  , bundleExtractor = f $ gextractorRecord Nothing
  , bundleDecodeCurrent = gdecodeCurrentRecord
  }
{-# INLINE bundleRecord #-}
{-# DEPRECATED bundleRecord "Use bundleVia instead" #-}

-- | A bundle of generic implementations for records, with a default value
bundleRecordDefault :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a)
  => a -- default value
  -> (Extractor a -> Extractor a) -- extractor modifier
  -> BundleSerialise a
bundleRecordDefault def f = BundleSerialise
  { bundleSchemaGen = gschemaGenRecord
  , bundleToBuilder = gtoBuilderRecord
  , bundleExtractor = f $ gextractorRecord $ Just def
  , bundleDecodeCurrent = gdecodeCurrentRecord
  }
{-# INLINE bundleRecordDefault #-}
{-# DEPRECATED bundleRecordDefault "Use bundleVia instead" #-}

-- | A bundle of generic implementations for variants
bundleVariant :: (GSerialiseVariant (Rep a), GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a, Typeable a)
  => (Extractor a -> Extractor a) -- extractor modifier
  -> BundleSerialise a
bundleVariant f = BundleSerialise
  { bundleSchemaGen = gschemaGenVariant
  , bundleToBuilder = gtoBuilderVariant
  , bundleExtractor = f $ gextractorVariant
  , bundleDecodeCurrent = gdecodeCurrentVariant
  }
{-# INLINE bundleVariant #-}
{-# DEPRECATED bundleVariant "Use bundleVia instead" #-}

-- | Bind a schema. While this does not change the semantics, it helps reducing the schema size
-- when it has multiple children with the specified type (use TypeApplications to specify a type).
withSchema :: forall a. Serialise a => SchemaGen Schema -> SchemaGen Schema
withSchema gen = SchemaGen $ \seen -> if S.member rep seen
  then unSchemaGen gen seen
  else do
    let seen' = S.insert rep seen
    let (reps', g) = unSchemaGen (getSchema (Proxy @a)) seen
    let (reps, f) = unSchemaGen gen seen'
    (reps <> reps', \xs -> SLet (g xs) $ f $ rep : xs)
  where
    rep = typeRep (Proxy @a)

-- | Obtain a schema on 'SchemaGen', binding a fixpoint when necessary.
-- If you are hand-rolling a definition of 'schemaGen', you should call this
-- instead of 'schemaGen'.
getSchema :: forall proxy a. Serialise a => proxy a -> SchemaGen Schema
getSchema p = SchemaGen $ \seen -> if S.member rep seen
  then (S.singleton rep, \xs -> case elemIndex rep xs of
    Just i -> SVar i
    Nothing -> error $ "getSchema: impossible " ++ show (rep, seen, xs))
    -- request a fixpoint for rep when it detects a recursion
  else case unSchemaGen (schemaGen (Proxy @a)) (S.insert rep seen) of
    (reps, f)
      | S.member rep reps -> (reps, \xs -> SFix $ f (rep : xs))
      | otherwise -> (reps, f)
  where
    rep = typeRep p

-- | Obtain the schema of the datatype.
--
-- /"Tell me what you drink, and I will tell you what you are."/
schema :: forall proxy a. Serialise a => proxy a -> Schema
schema p = case unSchemaGen (schemaGen (Proxy @a)) (S.singleton rep) of
  (reps, f)
    | S.member rep reps -> SFix $ f [rep]
    | otherwise -> f []
  where
    rep = typeRep p

unexpectedSchema :: forall f a. Serialise a => Schema -> Strategy' (f a)
unexpectedSchema actual = throwStrategy
  $ UnexpectedSchema [] (pretty $ schema (Proxy @a)) actual

mkExtractor :: forall a. Typeable a => (Schema -> Strategy' (Term -> a)) -> Extractor a
mkExtractor = Extractor . fmap addTrail . recursiveStrategy where
  addTrail (Strategy f) = Strategy $ \env -> case f env of
    Left e -> Left $! pushTrace (typeRep (Proxy @a)) e
    Right a -> Right a
{-# INLINE mkExtractor #-}

-- | Handle (recursive) schema bindings.
recursiveStrategy :: forall a. Typeable a => (Schema -> Strategy' (Term -> a)) -> Schema -> Strategy' (Term -> a)
recursiveStrategy k sch = Strategy $ \(StrategyEnv ofs decs) -> case sch of
  SVar i
    | point : _ <- drop i decs -> case point of
      BoundSchema ofs' sch' -> recursiveStrategy k sch' `unStrategy` StrategyEnv ofs' (drop (ofs - ofs') decs)
      DynDecoder dyn -> case fromDynamic dyn of
        Nothing -> Left $ TypeMismatch [] i
          (typeRep (Proxy @(Term -> a)))
          (dynTypeRep dyn)
        Just a -> Right a
    | otherwise -> Left $ UnboundVariable [] i
  SFix s -> mfix $ \a -> recursiveStrategy k s `unStrategy` StrategyEnv (ofs + 1) (DynDecoder (toDyn a) : decs)
  SLet s t -> recursiveStrategy k t `unStrategy` StrategyEnv (ofs + 1) (BoundSchema ofs s : decs)
  s -> k s `unStrategy` StrategyEnv ofs decs

instance Serialise Tag where
  schemaGen = gschemaGenVariant
  toBuilder = gtoBuilderVariant
  extractor = gextractorVariant
  decodeCurrent = gdecodeCurrentVariant

instance Serialise Schema where
  schemaGen = gschemaGenVariant
  toBuilder = gtoBuilderVariant
  extractor = gextractorVariant
  decodeCurrent = gdecodeCurrentVariant

instance Serialise () where
  schemaGen _ = pure $ SProduct mempty
  toBuilder = mempty
  {-# INLINE toBuilder #-}
  extractor = pure ()
  decodeCurrent = pure ()

instance Serialise Bool where
  schemaGen _ = pure SBool
  toBuilder False = BB.word8 0
  toBuilder True = BB.word8 1
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SBool -> pure $ \case
      TBool b -> b
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = (/=0) <$> getWord8

instance Serialise Word8 where
  schemaGen _ = pure SWord8
  toBuilder = BB.word8
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SWord8 -> pure $ \case
      TWord8 i -> i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = getWord8

instance Serialise Word16 where
  schemaGen _ = pure SWord16
  toBuilder = BB.word16LE
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SWord16 -> pure $ \case
      TWord16 i -> i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = getWord16

instance Serialise Word32 where
  schemaGen _ = pure SWord32
  toBuilder = BB.word32LE
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SWord32 -> pure $ \case
      TWord32 i -> i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = getWord32

instance Serialise Word64 where
  schemaGen _ = pure SWord64
  toBuilder = BB.word64LE
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SWord64 -> pure $ \case
      TWord64 i -> i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = getWord64

instance Serialise Word where
  schemaGen _ = pure SWord64
  toBuilder = BB.word64LE . fromIntegral
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SWord64 -> pure $ \case
      TWord64 i -> fromIntegral i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = fromIntegral <$> getWord64

instance Serialise Int8 where
  schemaGen _ = pure SInt8
  toBuilder = BB.word8 . fromIntegral
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SInt8 -> pure $ \case
      TInt8 i -> i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = fromIntegral <$> getWord8

instance Serialise Int16 where
  schemaGen _ = pure SInt16
  toBuilder = BB.word16LE . fromIntegral
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SInt16 -> pure $ \case
      TInt16 i -> i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = fromIntegral <$> getWord16

instance Serialise Int32 where
  schemaGen _ = pure SInt32
  toBuilder = BB.word32LE . fromIntegral
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SInt32 -> pure $ \case
      TInt32 i -> i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = fromIntegral <$> getWord32

instance Serialise Int64 where
  schemaGen _ = pure SInt64
  toBuilder = BB.word64LE . fromIntegral
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SInt64 -> pure $ \case
      TInt64 i -> i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = fromIntegral <$> getWord64

instance Serialise Int where
  schemaGen _ = pure SInteger
  toBuilder = toBuilder . VarInt
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SInteger -> pure $ \case
      TInteger i -> fromIntegral i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = decodeVarIntFinite

instance Serialise Float where
  schemaGen _ = pure SFloat
  toBuilder = BB.floatLE
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SFloat -> pure $ \case
      TFloat x -> x
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = castWord32ToFloat <$> getWord32

instance Serialise Double where
  schemaGen _ = pure SDouble
  toBuilder = BB.doubleLE
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SDouble -> pure $ \case
      TDouble x -> x
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = castWord64ToDouble <$> getWord64

instance Serialise T.Text where
  schemaGen _ = pure SText
  toBuilder = toBuilder . T.encodeUtf8
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SText -> pure $ \case
      TText t -> t
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = do
    len <- decodeVarInt
    T.decodeUtf8With T.lenientDecode <$> getBytes len

-- | Encoded in variable-length quantity.
newtype VarInt a = VarInt { getVarInt :: a } deriving (Show, Read, Eq, Ord, Enum
  , Bounded, Num, Real, Integral, Bits, Typeable)

instance (Typeable a, Bits a, Integral a) => Serialise (VarInt a) where
  schemaGen _ = pure SInteger
  toBuilder = varInt . getVarInt
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SInteger -> pure $ \case
      TInteger i -> fromIntegral i
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = VarInt <$> decodeVarInt

instance Serialise Integer where
  schemaGen _ = pure SInteger
  toBuilder = toBuilder . VarInt
  {-# INLINE toBuilder #-}
  extractor = getVarInt <$> extractor
  decodeCurrent = getVarInt <$> decodeCurrent

instance Serialise Natural where
  schemaGen _ = pure SInteger
  toBuilder = toBuilder . toInteger
  extractor = naturalFromInteger <$> extractor
  decodeCurrent = naturalFromInteger <$> decodeCurrent

instance Serialise Char where
  schemaGen _ = pure SChar
  toBuilder = toBuilder . fromEnum
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SChar -> pure $ \case
      TChar c -> c
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = toEnum <$> decodeVarInt

instance Serialise a => Serialise (Maybe a) where
  schemaGen = gschemaGenVariant
  toBuilder = gtoBuilderVariant
  extractor = gextractorVariant
  decodeCurrent = gdecodeCurrentVariant

instance Serialise B.ByteString where
  schemaGen _ = pure SBytes
  toBuilder bs = varInt (B.length bs) <> BB.byteString bs
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SBytes -> pure $ \case
      TBytes bs -> bs
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = decodeVarInt >>= getBytes

instance Serialise BL.ByteString where
  schemaGen _ = pure SBytes
  toBuilder = toBuilder . BL.toStrict
  {-# INLINE toBuilder #-}
  extractor = BL.fromStrict <$> extractor
  decodeCurrent = BL.fromStrict <$> decodeCurrent

-- | time-1.9.1
nanosecondsToNominalDiffTime :: Int64 -> NominalDiffTime
nanosecondsToNominalDiffTime = unsafeCoerce . MkFixed . (*1000) . fromIntegral

instance Serialise UTCTime where
  schemaGen _ = pure SUTCTime
  toBuilder = toBuilder . utcTimeToPOSIXSeconds
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \case
    SUTCTime -> pure $ \case
      TUTCTime bs -> bs
      t -> throw $ InvalidTerm t
    s -> unexpectedSchema s
  decodeCurrent = posixSecondsToUTCTime <$> decodeCurrent

instance Serialise NominalDiffTime where
  schemaGen _ = pure SInt64
  toBuilder x = case unsafeCoerce x of
    MkFixed p -> toBuilder (fromIntegral (p `div` 1000) :: Int64)
  {-# INLINE toBuilder #-}
  extractor = nanosecondsToNominalDiffTime <$> extractor
  decodeCurrent = nanosecondsToNominalDiffTime <$> decodeCurrent

-- | Extract a list or an array of values.
extractListBy :: Typeable a => Extractor a -> Extractor (V.Vector a)
extractListBy (Extractor plan) = mkExtractor $ \case
  SVector s -> do
    getItem <- plan s
    return $ \case
      TVector xs -> V.map getItem xs
      t -> throw $ InvalidTerm t
  s -> throwStrategy $ UnexpectedSchema [] "SVector" s
{-# INLINE extractListBy #-}

instance Serialise a => Serialise [a] where
  schemaGen _ = SVector <$> getSchema (Proxy @a)
  toBuilder xs = varInt (length xs)
      <> foldMap toBuilder xs
  {-# INLINE toBuilder #-}
  extractor = V.toList <$> extractListBy extractor
  decodeCurrent = do
    n <- decodeVarInt
    replicateM n decodeCurrent

instance Serialise a => Serialise (NE.NonEmpty a) where
  schemaGen _ = SVector <$> getSchema (Proxy @a)
  toBuilder = toBuilder . NE.toList
  {-# INLINE toBuilder #-}
  extractor = NE.fromList . V.toList <$> extractListBy extractor
  decodeCurrent = NE.fromList <$> decodeCurrent

instance Serialise a => Serialise (V.Vector a) where
  schemaGen _ = SVector <$> getSchema (Proxy @a)
  toBuilder xs = varInt (V.length xs)
    <> foldMap toBuilder xs
  {-# INLINE toBuilder #-}
  extractor = extractListBy extractor
  decodeCurrent = do
    n <- decodeVarInt
    V.replicateM n decodeCurrent

instance (SV.Storable a, Serialise a) => Serialise (SV.Vector a) where
  schemaGen _ = SVector <$> getSchema (Proxy @a)
  toBuilder = toBuilder . (SV.convert :: SV.Vector a -> V.Vector a)
  {-# INLINE toBuilder #-}
  extractor = SV.convert <$> extractListBy extractor
  decodeCurrent = do
    n <- decodeVarInt
    SV.replicateM n decodeCurrent

instance (UV.Unbox a, Serialise a) => Serialise (UV.Vector a) where
  schemaGen _ = SVector <$> getSchema (Proxy @a)
  toBuilder = toBuilder . (UV.convert :: UV.Vector a -> V.Vector a)
  {-# INLINE toBuilder #-}
  extractor = UV.convert <$> extractListBy extractor
  decodeCurrent = do
    n <- decodeVarInt
    UV.replicateM n decodeCurrent

instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where
  schemaGen _ = schemaGen (Proxy @[(k, v)])
  toBuilder m = toBuilder (M.size m)
    <> M.foldMapWithKey (curry toBuilder) m
  {-# INLINE toBuilder #-}
  extractor = M.fromList <$> extractor
  decodeCurrent = M.fromList <$> decodeCurrent

instance (Eq k, Hashable k, Serialise k, Serialise v) => Serialise (HM.HashMap k v) where
  schemaGen _ = schemaGen (Proxy @[(k, v)])
  toBuilder m = toBuilder (HM.size m)
    <> HM.foldrWithKey (\k v r -> toBuilder (k, v) <> r) mempty m
  {-# INLINE toBuilder #-}
  extractor = HM.fromList <$> extractor
  decodeCurrent = HM.fromList <$> decodeCurrent

instance (Serialise v) => Serialise (IM.IntMap v) where
  schemaGen _ = schemaGen (Proxy @[(Int, v)])
  toBuilder m = toBuilder (IM.size m)
    <> IM.foldMapWithKey (curry toBuilder) m
  {-# INLINE toBuilder #-}
  extractor = IM.fromList <$> extractor
  decodeCurrent = IM.fromList <$> decodeCurrent

instance (Ord a, Serialise a) => Serialise (S.Set a) where
  schemaGen _ = schemaGen (Proxy @[a])
  toBuilder s = toBuilder (S.size s) <> foldMap toBuilder s
  {-# INLINE toBuilder #-}
  extractor = S.fromList <$> extractor
  decodeCurrent = S.fromList <$> decodeCurrent

instance Serialise IS.IntSet where
  schemaGen _ = schemaGen (Proxy @[Int])
  toBuilder s = toBuilder (IS.size s) <> IS.foldr (mappend . toBuilder) mempty s
  {-# INLINE toBuilder #-}
  extractor = IS.fromList <$> extractor
  decodeCurrent = IS.fromList <$> decodeCurrent

instance Serialise a => Serialise (Seq.Seq a) where
  schemaGen _ = schemaGen (Proxy @[a])
  toBuilder s = toBuilder (length s) <> foldMap toBuilder s
  {-# INLINE toBuilder #-}
  extractor = Seq.fromList <$> extractor
  decodeCurrent = Seq.fromList <$> decodeCurrent

instance (Integral a, Serialise a) => Serialise (Ratio a) where
  schemaGen _ = schemaGen (Proxy @(a, a))
  toBuilder x = toBuilder (numerator x, denominator x)
  {-# INLINE toBuilder #-}
  extractor = uncurry (%) <$> extractor
  decodeCurrent = uncurry (%) <$> decodeCurrent

instance Serialise Scientific where
  schemaGen _ = schemaGen (Proxy @(Integer, Int))
  toBuilder s = toBuilder (coefficient s, base10Exponent s)
  {-# INLINE toBuilder #-}
  extractor = mkExtractor $ \s -> case s of
    SWord8 -> f (fromIntegral :: Word8 -> Scientific) s
    SWord16 -> f (fromIntegral :: Word16 -> Scientific) s
    SWord32 -> f (fromIntegral :: Word32 -> Scientific) s
    SWord64 -> f (fromIntegral :: Word64 -> Scientific) s
    SInt8 -> f (fromIntegral :: Int8 -> Scientific) s
    SInt16 -> f (fromIntegral :: Int16 -> Scientific) s
    SInt32 -> f (fromIntegral :: Int32 -> Scientific) s
    SInt64 -> f (fromIntegral :: Int64 -> Scientific) s
    SInteger -> f fromInteger s
    SFloat -> f (realToFrac :: Float -> Scientific) s
    SDouble -> f (realToFrac :: Double -> Scientific) s
    _ -> f (uncurry scientific) s
    where
      f c = runExtractor (c <$> extractor)
  decodeCurrent = scientific <$> decodeCurrent <*> decodeCurrent

instance (Serialise a, Serialise b) => Serialise (a, b) where
  schemaGen = gschemaGenProduct
  toBuilder = gtoBuilderProduct
  extractor = gextractorProduct
  decodeCurrent = gdecodeCurrentProduct
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

instance (Serialise a, Serialise b, Serialise c) => Serialise (a, b, c) where
  schemaGen = gschemaGenProduct
  toBuilder = gtoBuilderProduct
  extractor = gextractorProduct
  decodeCurrent = gdecodeCurrentProduct
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

instance (Serialise a, Serialise b, Serialise c, Serialise d) => Serialise (a, b, c, d) where
  schemaGen = gschemaGenProduct
  toBuilder = gtoBuilderProduct
  extractor = gextractorProduct
  decodeCurrent = gdecodeCurrentProduct
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e) => Serialise (a, b, c, d, e) where
  schemaGen = gschemaGenProduct
  toBuilder = gtoBuilderProduct
  extractor = gextractorProduct
  decodeCurrent = gdecodeCurrentProduct
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e, Serialise f) => Serialise (a, b, c, d, e, f) where
  schemaGen = gschemaGenProduct
  toBuilder = gtoBuilderProduct
  extractor = gextractorProduct
  decodeCurrent = gdecodeCurrentProduct
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

instance (Serialise a, Serialise b) => Serialise (Either a b) where
  schemaGen = gschemaGenVariant
  toBuilder = gtoBuilderVariant
  extractor = gextractorVariant
  decodeCurrent = gdecodeCurrentVariant
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

instance Serialise Ordering where
  schemaGen = gschemaGenVariant
  toBuilder = gtoBuilderVariant
  extractor = gextractorVariant
  decodeCurrent = gdecodeCurrentVariant
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

deriving instance Serialise a => Serialise (Identity a)
deriving instance (Serialise a, Typeable b, Typeable k) => Serialise (Const a (b :: k))

deriving instance Serialise Any
deriving instance Serialise All
deriving instance Serialise a => Serialise (Down a)
deriving instance Serialise a => Serialise (Product a)
deriving instance Serialise a => Serialise (Sum a)
deriving instance Serialise a => Serialise (Dual a)
deriving instance Serialise a => Serialise (M.Last a)
deriving instance Serialise a => Serialise (M.First a)
deriving instance Serialise a => Serialise (S.Last a)
deriving instance Serialise a => Serialise (S.First a)
deriving instance Serialise a => Serialise (ZipList a)
deriving instance Serialise a => Serialise (Max a)
deriving instance Serialise a => Serialise (Min a)
deriving instance (Typeable k, Typeable f, Typeable a, Serialise (f a)) => Serialise (Alt f (a :: k))
deriving instance (Typeable j, Typeable k, Typeable f, Typeable g, Typeable a, Serialise (f (g a))) => Serialise (Compose f (g :: j -> k) (a :: j))
#if MIN_VERSION_base(4,12,0)
deriving instance (Typeable k, Typeable f, Typeable a, Serialise (f a)) => Serialise (Ap f (a :: k))
#endif

instance (Typeable k, Typeable a, Typeable b, a ~ b) => Serialise ((a :: k) :~: b) where
  schemaGen _ = pure $ SProduct mempty
  toBuilder = mempty
  extractor = pure Refl
  decodeCurrent = pure Refl
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

instance (Serialise a, Serialise b) => Serialise (Arg a b) where
  schemaGen = gschemaGenProduct
  toBuilder = gtoBuilderProduct
  extractor = gextractorProduct
  decodeCurrent = gdecodeCurrentProduct
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

instance Serialise a => Serialise (Complex a) where
  schemaGen = gschemaGenProduct
  toBuilder = gtoBuilderProduct
  extractor = gextractorProduct
  decodeCurrent = gdecodeCurrentProduct
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

instance Serialise Void where
  schemaGen _ = pure $ SVariant V.empty
  toBuilder = mempty
  extractor = Extractor $ const $ throwStrategy "No extractor for Void"
  decodeCurrent = error "No decodeCurrent for Void"
  {-# INLINE toBuilder #-}
  {-# INLINE decodeCurrent #-}

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

-- | Generic implementation of 'schemaGen' for a record.
gschemaGenRecord :: forall proxy a. (GSerialiseRecord (Rep a), Generic a, Typeable a) => proxy a -> SchemaGen Schema
gschemaGenRecord _ = SRecord . V.fromList <$> recordSchema (Proxy @(Rep a))

-- | Generic implementation of 'toBuilder' for a record.
gtoBuilderRecord :: (GEncodeProduct (Rep a), Generic a) => a -> BB.Builder
gtoBuilderRecord = productEncoder . from
{-# INLINE gtoBuilderRecord #-}

data FieldDecoder i a = FieldDecoder !i !(Maybe a) !(Schema -> Strategy' (Term -> a))

-- | Generic implementation of 'extractor' for a record.
gextractorRecord :: forall a. (GSerialiseRecord (Rep a), Generic a, Typeable a)
  => Maybe a -- ^ default value (optional)
  -> Extractor a
gextractorRecord def = mkExtractor
  $ fmap (fmap (to .)) $ extractorRecord'
  (from <$> def)

-- | Generic implementation of 'extractor' for a record.
extractorRecord' :: (GSerialiseRecord f)
  => Maybe (f x) -- ^ default value (optional)
  -> Schema -> Strategy' (Term -> f x)
extractorRecord' def (SRecord schs) = Strategy $ \decs -> do
    let go :: FieldDecoder T.Text x -> Either WineryException (Term -> x)
        go (FieldDecoder name def' p) = case lookupWithIndexV name schs of
          Nothing -> case def' of
            Just d -> Right (const d)
            Nothing -> Left $ FieldNotFound [] name (map fst $ V.toList schs)
          Just (i, sch) -> case p sch `unStrategy` decs of
            Right getItem -> Right $ \case
              t@(TRecord xs) -> maybe (throw $ InvalidTerm t) (getItem . snd) $ xs V.!? i
              t -> throw $ InvalidTerm t
            Left e -> Left e
    unTransFusion (recordExtractor def) go
extractorRecord' _ s = throwStrategy $ UnexpectedSchema [] "a record" s
{-# INLINE gextractorRecord #-}

-- | Synonym for 'gdecodeCurrentProduct'
gdecodeCurrentRecord :: (GDecodeProduct (Rep a), Generic a) => Decoder a
gdecodeCurrentRecord = to <$> productDecoder
{-# INLINE gdecodeCurrentRecord #-}

-- | Encode all the fields
class GEncodeProduct f where
  productEncoder :: f x -> BB.Builder

instance GEncodeProduct U1 where
  productEncoder _ = mempty
  {-# INLINE productEncoder #-}

instance (GEncodeProduct f, GEncodeProduct g) => GEncodeProduct (f :*: g) where
  productEncoder (f :*: g) = productEncoder f <> productEncoder g
  {-# INLINE productEncoder #-}

instance Serialise a => GEncodeProduct (S1 c (K1 i a)) where
  productEncoder (M1 (K1 a)) = toBuilder a
  {-# INLINE productEncoder #-}

instance GEncodeProduct f => GEncodeProduct (C1 c f) where
  productEncoder (M1 a) = productEncoder a
  {-# INLINE productEncoder #-}

instance GEncodeProduct f => GEncodeProduct (D1 c f) where
  productEncoder (M1 a) = productEncoder a
  {-# INLINE productEncoder #-}

class GDecodeProduct f where
  productDecoder :: Decoder (f x)

instance GDecodeProduct U1 where
  productDecoder = pure U1

instance Serialise a => GDecodeProduct (K1 i a) where
  productDecoder = K1 <$> decodeCurrent
  {-# INLINE productDecoder #-}

instance GDecodeProduct f => GDecodeProduct (M1 i c f) where
  productDecoder = M1 <$> productDecoder
  {-# INLINE productDecoder #-}

instance (GDecodeProduct f, GDecodeProduct g) => GDecodeProduct (f :*: g) where
  productDecoder = (:*:) <$> productDecoder <*> productDecoder
  {-# INLINE productDecoder #-}

class GSerialiseRecord f where
  recordSchema :: proxy f -> SchemaGen [(T.Text, Schema)]
  recordExtractor :: Maybe (f x) -> TransFusion (FieldDecoder T.Text) ((->) Term) (Term -> f x)

instance (GSerialiseRecord f, GSerialiseRecord g) => GSerialiseRecord (f :*: g) where
  recordSchema _ = (++) <$> recordSchema (Proxy @f) <*> recordSchema (Proxy @g)
  recordExtractor def = (\f g -> (:*:) <$> f <*> g)
    <$> recordExtractor ((\(x :*: _) -> x) <$> def)
    <*> recordExtractor ((\(_ :*: x) -> x) <$> def)
  {-# INLINE recordExtractor #-}

instance (Serialise a, Selector c) => GSerialiseRecord (S1 c (K1 i a)) where
  recordSchema _ = do
    s <- getSchema (Proxy @a)
    pure [(T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x), s)]
  recordExtractor def = TransFusion $ \k -> fmap (fmap (M1 . K1)) $ k $ FieldDecoder
    (T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x))
    (unK1 . unM1 <$> def)
    (runExtractor extractor)
  {-# INLINE recordExtractor #-}

instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where
  recordSchema _ = recordSchema (Proxy @f)
  recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def)

instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where
  recordSchema _ = recordSchema (Proxy @f)
  recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def)

class GSerialiseProduct f where
  productSchema :: proxy f -> SchemaGen [Schema]
  productExtractor :: Compose (State Int) (TransFusion (FieldDecoder Int) ((->) Term)) (Term -> f x)

instance GSerialiseProduct U1 where
  productSchema _ = pure []
  productExtractor = pure (pure U1)

instance (Serialise a) => GSerialiseProduct (K1 i a) where
  productSchema _ = pure <$> getSchema (Proxy @a)
  productExtractor = Compose $ State $ \i ->
    ( TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder i Nothing (runExtractor extractor)
    , i + 1)

instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where
  productSchema _ = productSchema (Proxy @f)
  productExtractor = fmap M1 <$> productExtractor

instance (GSerialiseProduct f, GSerialiseProduct g) => GSerialiseProduct (f :*: g) where
  productSchema _ = (++) <$> productSchema (Proxy @f) <*> productSchema (Proxy @g)
  productExtractor = liftA2 (:*:) <$> productExtractor <*> productExtractor

gschemaGenProduct :: forall proxy a. (Generic a, GSerialiseProduct (Rep a)) => proxy a -> SchemaGen Schema
gschemaGenProduct _ = SProduct . V.fromList <$> productSchema (Proxy @(Rep a))
{-# INLINE gschemaGenProduct #-}

gtoBuilderProduct :: (Generic a, GEncodeProduct (Rep a)) => a -> BB.Builder
gtoBuilderProduct = productEncoder . from
{-# INLINE gtoBuilderProduct #-}

-- | Generic implementation of 'extractor' for a record.
gextractorProduct :: forall a. (GSerialiseProduct (Rep a), Generic a, Typeable a)
  => Extractor a
gextractorProduct = mkExtractor $ fmap (to .) . extractorProduct'
{-# INLINE gextractorProduct #-}

-- | Generic implementation of 'extractor' for a record.
gdecodeCurrentProduct :: forall a. (GDecodeProduct (Rep a), Generic a)
  => Decoder a
gdecodeCurrentProduct = to <$> productDecoder
{-# INLINE gdecodeCurrentProduct #-}

extractorProduct' :: GSerialiseProduct f => Schema -> Strategy' (Term -> f x)
extractorProduct' sch
  | Just schs <- strip sch = Strategy $ \recs -> do
    let go :: FieldDecoder Int x -> Either WineryException (Term -> x)
        go (FieldDecoder i _ p) = do
          getItem <- if i < length schs
            then p (schs V.! i) `unStrategy` recs
            else Left $ ProductTooSmall [] $ length schs
          return $ \case
            TProduct xs -> getItem $ maybe (throw $ InvalidTerm (TProduct xs)) id
              $ xs V.!? i
            t -> throw $ InvalidTerm t
    unTransFusion (getCompose productExtractor `evalState` 0) go
  where
    strip (SProduct xs) = Just xs
    strip (SRecord xs) = Just $ V.map snd xs
    strip _ = Nothing
extractorProduct' sch = throwStrategy $ UnexpectedSchema [] "a product" sch

-- | Generic implementation of 'schemaGen' for an ADT.
gschemaGenVariant :: forall proxy a. (GSerialiseVariant (Rep a), Typeable a, Generic a) => proxy a -> SchemaGen Schema
gschemaGenVariant _ = SVariant . V.fromList <$> variantSchema (Proxy @(Rep a))

-- | Generic implementation of 'toBuilder' for an ADT.
gtoBuilderVariant :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), Generic a) => a -> BB.Builder
gtoBuilderVariant = variantEncoder (variantCount (Proxy :: Proxy (Rep a))) 0 . from
{-# INLINE gtoBuilderVariant #-}

-- | Generic implementation of 'extractor' for an ADT.
gextractorVariant :: (GSerialiseVariant (Rep a), Generic a, Typeable a)
  => Extractor a
gextractorVariant = buildVariantExtractor gvariantExtractors
{-# INLINE gextractorVariant #-}

-- | Collect extractors as a 'HM.HashMap' keyed by constructor names
gvariantExtractors :: (GSerialiseVariant (Rep a), Generic a) => HM.HashMap T.Text (Extractor a)
gvariantExtractors = fmap to <$> variantExtractor
{-# INLINE gvariantExtractors #-}

-- | Bundle a 'HM.HashMap' of 'Extractor's into an extractor of a variant.
buildVariantExtractor :: (Generic a, Typeable a)
  => HM.HashMap T.Text (Extractor a)
  -> Extractor a
buildVariantExtractor extractors = mkExtractor $ \case
  SVariant schs0 -> Strategy $ \decs -> do
    ds' <- traverse (\(name, sch) -> case HM.lookup name extractors of
      Nothing -> Left $ FieldNotFound [] name (HM.keys extractors)
      Just f -> runExtractor f sch `unStrategy` decs) schs0
    return $ \case
      TVariant i _ v -> maybe (throw InvalidTag) ($ v) $ ds' V.!? i
      t -> throw $ InvalidTerm t
  s -> throwStrategy $ UnexpectedSchema [] "a variant" s

gdecodeCurrentVariant :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a) => Decoder a
gdecodeCurrentVariant = decodeVarInt >>= fmap to . variantDecoder (variantCount (Proxy :: Proxy (Rep a)))
{-# INLINE gdecodeCurrentVariant #-}

class GConstructorCount f where
  variantCount :: proxy f -> Int

instance (GConstructorCount f, GConstructorCount g) => GConstructorCount (f :+: g) where
  variantCount _ = variantCount (Proxy @f) + variantCount (Proxy @g)
  {-# INLINE variantCount #-}

instance GConstructorCount (C1 i f) where
  variantCount _ = 1
  {-# INLINE variantCount #-}

instance GConstructorCount f => GConstructorCount (D1 i f) where
  variantCount _ = variantCount (Proxy @f)
  {-# INLINE variantCount #-}

class GDecodeVariant f where
  variantDecoder :: Int -> Int -> Decoder (f x)

instance (GDecodeVariant f, GDecodeVariant g) => GDecodeVariant (f :+: g) where
  variantDecoder len i
    | i < len' = L1 <$> variantDecoder len' i
    | otherwise = R1 <$> variantDecoder (len - len') (i - len')
    where
      -- Nested ':+:' are balanced
      -- cf. https://github.com/GaloisInc/cereal/blob/cereal-0.5.8.1/src/Data/Serialize.hs#L659
      len' = unsafeShiftR len 1
  {-# INLINE variantDecoder #-}

instance GDecodeProduct f => GDecodeVariant (C1 i f) where
  variantDecoder _ _ = M1 <$> productDecoder
  {-# INLINE variantDecoder #-}

instance GDecodeVariant f => GDecodeVariant (D1 i f) where
  variantDecoder len i = M1 <$> variantDecoder len i
  {-# INLINE variantDecoder #-}

class GEncodeVariant f where
  variantEncoder :: Int -> Int -> f x -> BB.Builder

instance (GEncodeVariant f, GEncodeVariant g) => GEncodeVariant (f :+: g) where
  variantEncoder len i (L1 f) = variantEncoder (unsafeShiftR len 1) i f
  variantEncoder len i (R1 g) = variantEncoder (len - len') (i + len') g
    where
      -- Nested ':+:' are balanced
      -- cf. https://github.com/GaloisInc/cereal/blob/cereal-0.5.8.1/src/Data/Serialize.hs#L659
      len' = unsafeShiftR len 1
  {-# INLINE variantEncoder #-}

instance (GEncodeProduct f) => GEncodeVariant (C1 i f) where
  variantEncoder _ !i (M1 a) = varInt i <> productEncoder a
  {-# INLINE variantEncoder #-}

instance GEncodeVariant f => GEncodeVariant (D1 i f) where
  variantEncoder len i (M1 a) = variantEncoder len i a
  {-# INLINE variantEncoder #-}

class GSerialiseVariant f where
  variantSchema :: proxy f -> SchemaGen [(T.Text, Schema)]
  variantExtractor :: HM.HashMap T.Text (Extractor (f x))

instance (GSerialiseVariant f, GSerialiseVariant g) => GSerialiseVariant (f :+: g) where
  variantSchema _ = (++) <$> variantSchema (Proxy @f) <*> variantSchema (Proxy @g)
  variantExtractor = fmap (fmap L1) variantExtractor
    <> fmap (fmap R1) variantExtractor

instance (GSerialiseProduct f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'False) f) where
  variantSchema _ = do
    s <- productSchema (Proxy @f)
    return [(T.pack $ symbolVal (Proxy @name), SProduct $ V.fromList s)]
  variantExtractor = HM.singleton (T.pack $ symbolVal (Proxy @name)) (M1 <$> Extractor extractorProduct')

instance (GSerialiseRecord f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'True) f) where
  variantSchema _ = do
    s <- recordSchema (Proxy @f)
    return [(T.pack $ symbolVal (Proxy @name), SRecord $ V.fromList s)]
  variantExtractor = HM.singleton (T.pack $ symbolVal (Proxy @name)) (M1 <$> Extractor (extractorRecord' Nothing))

instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where
  variantSchema _ = variantSchema (Proxy @f)
  variantExtractor = fmap M1 <$> variantExtractor

-- | An extractor for individual fields. This distinction is required for
-- handling recursions correctly.
--
-- Recommended extension: ApplicativeDo
newtype Subextractor a = Subextractor { unSubextractor :: Extractor a }
  deriving (Functor, Applicative, Alternative)

-- | Extract a field of a record.
extractField :: Serialise a => T.Text -> Subextractor a
extractField = extractFieldBy extractor
{-# INLINE extractField #-}

-- | Extract a field using the supplied 'Extractor'.
extractFieldBy :: Extractor a -> T.Text -> Subextractor a
extractFieldBy (Extractor g) name = Subextractor $ Extractor $ \case
  SRecord schs -> case lookupWithIndexV name schs of
    Just (i, sch) -> do
      m <- g sch
      return $ \case
        TRecord xs -> maybe (throw $ InvalidTerm (TRecord xs)) (m . snd) $ xs V.!? i
        t -> throw $ InvalidTerm t
    _ -> throwStrategy $ FieldNotFound [] name (map fst $ V.toList schs)
  s -> throwStrategy $ UnexpectedSchema [] "a record" s

-- | Build an extractor from a 'Subextractor'.
buildExtractor :: Typeable a => Subextractor a -> Extractor a
buildExtractor (Subextractor e) = mkExtractor $ runExtractor e
{-# INLINE buildExtractor #-}

instance (Typeable k, Typeable b, Typeable h, ApplicativeB b, ConstraintsB b, TraversableB b, AllBF Serialise h b, FieldNamesB b) => Serialise (Barbie b (h :: k -> Type)) where
  schemaGen _ = fmap (SRecord . V.fromList . (`appEndo`[]) . bfoldMap getConst)
    $ btraverse (\(F.Pair (Dict :: Dict (ClassF Serialise h) a) (Const k))
        -> Const . Endo . (:) . (,) k <$> schemaGen (Proxy @(h a)))
    $ baddDicts (bfieldNames :: b (Const T.Text))
  toBuilder = bfoldMap (\(F.Pair (Dict :: Dict (ClassF Serialise h) a) x) -> toBuilder x) . baddDicts
  {-# INLINE toBuilder #-}
  decodeCurrent = fmap Barbie $ btraverse (\Dict -> decodeCurrent) (bdicts :: b (Dict (ClassF Serialise h)))
  {-# INLINE decodeCurrent #-}
  extractor = fmap Barbie $ buildRecordExtractorF bextractorsF

buildRecordExtractorF :: (Typeable b, Typeable h, TraversableB b) => b (Compose Subextractor h) -> Extractor (b h)
buildRecordExtractorF = buildExtractor . btraverse getCompose
{-# INLINE buildRecordExtractorF #-}

-- | Collect extractors for record fields
bextractorsF :: forall b h. (ConstraintsB b, AllBF Serialise h b, FieldNamesB b) => b (Compose Subextractor h)
bextractorsF = bmapC @(ClassF Serialise h) (Compose . extractField . getConst) bfieldNames
{-# INLINABLE bextractorsF #-}

buildRecordExtractor :: (Typeable b, TraversableB b) => b Subextractor -> Extractor (b Identity)
buildRecordExtractor = buildExtractor . btraverse (fmap Identity)
{-# INLINE buildRecordExtractor #-}

-- | Collect extractors for record fields
bextractors :: forall b. (ConstraintsB b, AllB Serialise b, FieldNamesB b) => b Subextractor
bextractors = bmapC @Serialise (extractField . getConst) bfieldNames
{-# INLINABLE bextractors #-}


{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

-- | A custom prelude
--
-- $license

module StdLib (

      identity
    , (&)
    , uncons
    , applyN
    , print
    , io

    , LText
    , LByteString

    , CIText
    , CIByteString

      -- * List

    , (L.\\)
    , head
    , nubOrd
    , nubOn
    , sortOn
    , count
    , chunksOf

      -- * Show

    , Print(..)
    , putText
    , putLText
    , tshow
    , bshow
    , blshow

      -- * Bool

    , bool
    , whenM
    , unlessM
    , ifM
    , guardM
    , while
    , whileM

      -- * Debug

    , undefined
    , error
    , trace
    , traceM
    , traceIO
    , traceShow
    , traceShowM
    , notImplemented

      -- * Monad

    , Monad(..)
    , MonadPlus(..)

    , (=<<)
    , (>=>)
    , (<=<)
    , forever

    , join
    , mfilter
    , filterM
    , mapAndUnzipM
    , zipWithM
    , zipWithM_
    , foldM
    , foldM_
    , replicateM
    , replicateM_
    , concatMapM
    , concatForM
    , whenJust
    , unlessNull

    , guard
    , when
    , unless

    , liftM
    , liftM2
    , liftM3
    , liftM4
    , liftM5
    , liftM'
    , liftM2'
    , ap

    , (<$!>)

      -- * Applicative

    , orAlt
    , orEmpty
    , eitherA

      -- * Either

    , maybeToLeft
    , maybeToRight
    , leftToMaybe
    , rightToMaybe
    , eitherToMaybe

      -- * Text

    , txtpack
    , txtunpack
    , ltxtpack
    , ltxtunpack
    , txt2ltxt
    , txt2bs
    , bs2txt
    , lbs2txt
    , ltxt2lbs
    , bs2ltxt
    , lbs2bs
    , bs2lbs

      -- * Set

    , setFromList

      -- * Map

    , mapFromList

      -- * Case-insensitive text

    , ci
    , ciOriginal

      -- * Time

    , Milliseconds
    , utcTimeToEpochTime

      -- * Async

    , async_

      -- * Re-exports

    , (P.$)
    , (P.$!)
    , P.minBound
    , P.maxBound

#if __GLASGOW_HASKELL__ >= 808
    , MonadFail(..)
#endif

    , module X
    ) where

import qualified Control.Monad.IO.Class as IO (liftIO)
import qualified Data.ByteString as X (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.CaseInsensitive as CI
import qualified Data.List as L
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Debug.Trace as T
import qualified Prelude as P
import qualified Prelude

import           Control.Applicative as X (Alternative (..), Applicative (..),
                                           Const (..), ZipList (..), liftA,
                                           liftA2, liftA3, optional, (<**>))
import           Control.Concurrent as X hiding (throwTo)
import           Control.Concurrent.Async as Async
import           Control.Monad hiding ((<$!>))
import           Control.Monad.Except as X (Except, ExceptT, MonadError,
                                            catchError, runExcept, runExceptT,
                                            throwError)
import           Control.Monad.IO.Class as X (MonadIO)
import           Control.Monad.Reader as X (MonadReader, Reader, ReaderT, ask,
                                            asks, local, runReader, runReaderT)
import           Control.Monad.ST as X
import           Control.Monad.State as X (MonadState, State, StateT,
                                           evalStateT, execState, execStateT,
                                           get, gets, modify, put, runStateT,
                                           withState)
import           Control.Monad.Trans as X (MonadTrans (..), lift)
import           Control.Monad.Trans.Maybe as X (runMaybeT)
import           Data.Bits as X
import           Data.Bool as X hiding (bool)
import           Data.ByteString as X (ByteString)
import           Data.Char as X (Char, isSpace)
import           Data.Complex as X
import           Data.Either as X
import           Data.Eq as X
import           Data.Foldable as X hiding (foldl1, foldr1, maximum, maximumBy,
                                     minimum, minimumBy)
import           Data.Function as X (const, fix, flip, on, (.))
import           Data.Functor as X (Functor (..), void, ($>), (<$>))
import           Data.Functor.Identity as X
import           Data.Int as X
import           Data.IntMap as X (IntMap)
import           Data.IntSet as X (IntSet)
import           Data.List as X (break, drop, filter, intercalate, isPrefixOf,
                                 replicate, reverse, sortBy, splitAt, take)
import           Data.List.NonEmpty as X (NonEmpty (..), nonEmpty)
import           Data.Map as X (Map)
import           Data.Maybe as X hiding (fromJust)
import           Data.Monoid as X hiding ((<>))
import           Data.Ord as X
import           Data.Semigroup as X hiding (First, Last, getFirst, getLast)
import           Data.Sequence as X (Seq)
import           Data.Set as X (Set)
import           Data.Text as X (Text)
import           Data.Time as X
import           Data.Time.Clock.POSIX
import           Data.Traversable as X
import           Data.Tuple as X
import           Data.Word as X
import           GHC.Enum as X (Enum (..))
import           GHC.Exts as X (Constraint, FunPtr, Ptr, the)
import           GHC.Float as X hiding (log)
import           GHC.Int as X
import           GHC.IO as X (IO)
import           GHC.Num as X
import           GHC.Real as X
import           GHC.Show as X
import           GHC.Stack
import           Numeric as X (showHex)
import           System.Directory as X (createDirectoryIfMissing, doesFileExist,
                                        getCurrentDirectory,
                                        setCurrentDirectory)
import           System.Environment as X (getArgs, getEnvironment, lookupEnv,
                                          setEnv, unsetEnv)
import           System.Exit as X
import           System.FilePath as X (FilePath, takeBaseName, (</>))
import           System.IO as X (BufferMode (..), Handle, hClose, hFlush,
                                 hSetBinaryMode, hWaitForInput)
import           System.Process as X (readProcess, readProcessWithExitCode)
import           Text.Printf as X (PrintfArg, hPrintf, printf)
import           Text.Read as X (Read, readEither, readMaybe, reads)

type LText = Data.Text.Lazy.Text

type LByteString = Data.ByteString.Lazy.ByteString

type CIText = CI.CI Text

type CIByteString = CI.CI ByteString

infixl 1 &

(&) :: a -> (a -> b) -> b
x & f = f x

identity :: a -> a
identity x = x

uncons :: [a] -> Maybe (a, [a])
uncons []     = Nothing
uncons (x:xs) = Just (x, xs)

applyN :: Int -> (a -> a) -> a -> a
applyN n f = X.foldr (.) identity (X.replicate n f)

print :: (MonadIO m, Show a) => a -> m ()
print = io . putStrLn . tshow

io :: MonadIO m => IO a -> m a
io = IO.liftIO

-- * List

head :: Foldable f => f a -> Maybe a
head = foldr (\x _ -> return x) Nothing

sortOn :: Ord o => (a -> o) -> [a] -> [a]
sortOn = sortBy . comparing

-- O(n * log n)
nubOrd :: Ord a => [a] -> [a]
nubOrd l = go Set.empty l
  where
    go _ []     = []
    go s (x:xs) =
      if x `Set.member` s
      then go s xs
      else x : go (Set.insert x s) xs

nubOn :: Eq b => (a -> b) -> [a] -> [a]
nubOn f = fmap snd
        . L.nubBy ((==) `on` fst)
        . fmap (\x -> let y = f x in y `Prelude.seq` (y, x))

count :: Eq a => a -> [a] -> Int
count x = length . filter (x ==)

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf n xs = take n xs : chunksOf n (drop n xs)

-- * Show

class Print a where
    putStr :: MonadIO m => a -> m ()
    putStrLn :: MonadIO m => a -> m ()

instance Print Text where
    putStr = io . T.putStr
    putStrLn = io . T.putStrLn

instance Print LText where
    putStr = io . TL.putStr
    putStrLn = io . TL.putStrLn

instance Print BS.ByteString where
    putStr = io . BS.putStr
    putStrLn = io . BS8.putStrLn

instance Print LByteString where
    putStr = io . BL.putStr
    putStrLn = io . BL8.putStrLn

instance Print [Char] where
    putStr = io . Prelude.putStr
    putStrLn = io . Prelude.putStrLn

putText :: MonadIO m => Text -> m ()
putText = putStrLn
{-# SPECIALIZE putText :: Text -> IO () #-}

putLText :: MonadIO m => LText -> m ()
putLText = putStrLn
{-# SPECIALIZE putLText :: LText -> IO () #-}

tshow :: Show a => a -> Text
tshow = T.pack . show

{-# WARNING bshow "'bshow' remains in code" #-}
bshow :: Show a => a -> ByteString
bshow = BS8.pack . show

{-# WARNING blshow "'blshow' remains in code" #-}
blshow :: Show a => a -> LByteString
blshow = BL8.pack . show

-- * Bool

bool :: a -> a -> Bool -> a
bool f t p = if p then t else f

whenM :: Monad m => m Bool -> m () -> m ()
whenM p m = p >>= flip when m

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM p m = p >>= flip unless m

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM p x y = p >>= \b -> if b then x else y

guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f

while :: Monad m => m Bool -> m a -> m ()
while cond action = do
    c <- cond
    when c P.$ do
        _ <- action
        while cond action

-- | While loop. run 'f' while 'p'
whileM :: (MonadPlus m1, Monad m) => (a -> m Bool) -> m a -> m (m1 a)
whileM p f = go
  where
    go = do
      x <- f
      r <- p x
      if r then (return x `mplus`) `liftM` go else return mzero

{-# WARNING undefined "'undefined' remains in code" #-}
undefined :: HasCallStack => a
undefined = P.undefined

{-# WARNING error "'error' remains in code" #-}
error :: HasCallStack => P.String -> a
error = P.error

{-# WARNING trace "'trace' remains in code" #-}
trace :: P.String -> a -> a
trace = T.trace

{-# WARNING traceShow "'traceShow' remains in code" #-}
traceShow :: Show a => a -> a
traceShow a = T.trace (P.show a) a

{-# WARNING traceShowM "'traceShowM' remains in code" #-}
traceShowM :: (Show a, Monad m) => a -> m ()
traceShowM a = T.traceM (P.show a)

{-# WARNING traceM "'traceM' remains in code" #-}
traceM :: Monad m => P.String -> m ()
traceM = T.traceM

{-# WARNING traceIO "'traceIO' remains in code" #-}
traceIO :: P.String -> IO ()
traceIO = T.traceIO

{-# WARNING notImplemented "'notImplemented' remains in code" #-}
notImplemented :: a
notImplemented = P.error "Not implemented"

-- * Monad

concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = liftM concat (mapM f xs)

whenJust :: Monad m => Maybe a -> m () -> m ()
whenJust = when . isJust

unlessNull :: Monad m => [a] -> m () -> m ()
unlessNull = unless . L.null

concatForM :: (Monad m, Traversable t) => t a -> (a -> m [b]) -> m [b]
concatForM ls m = fmap concat (forM ls m)

liftM' :: Monad m => (a -> b) -> m a -> m b
liftM' = (<$!>)
{-# INLINE liftM' #-}

liftM2' :: Monad m => (a -> b -> c) -> m a -> m b -> m c
liftM2' f a b = do
    x <- a
    y <- b
    let z = f x y
    z `Prelude.seq` return z
{-# INLINE liftM2' #-}

(<$!>) :: Monad m => (a -> b) -> m a -> m b
f <$!> m = do
    x <- m
    let z = f x
    z `Prelude.seq` return z
{-# INLINE (<$!>) #-}

-- * Applicative

orAlt :: (Alternative f, Monoid a) => f a -> f a
orAlt f = f <|> pure mempty

orEmpty :: Alternative f => Bool -> a -> f a
orEmpty b a = if b then pure a else empty

eitherA :: Alternative f => f a -> f b -> f (Either a b)
eitherA a b = (Left <$> a) <|> (Right <$> b)

-- * Either

leftToMaybe :: Either l r -> Maybe l
leftToMaybe = either Just (const Nothing)

rightToMaybe :: Either l r -> Maybe r
rightToMaybe = either (const Nothing) Just

maybeToRight :: l -> Maybe r -> Either l r
maybeToRight l = maybe (Left l) Right

maybeToLeft :: r -> Maybe l -> Either l r
maybeToLeft r = maybe (Right r) Left

eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Left _)  = Nothing
eitherToMaybe (Right r) = Just r

-- * Text / ByteString

txtpack :: Prelude.String -> Text
txtpack = T.pack

txtunpack :: Text -> Prelude.String
txtunpack = T.unpack

ltxtpack :: Prelude.String -> LText
ltxtpack = TL.pack

ltxtunpack :: LText -> Prelude.String
ltxtunpack = TL.unpack

txt2ltxt :: Text -> LText
txt2ltxt = TL.fromStrict

txt2bs :: Text -> ByteString
txt2bs = T.encodeUtf8

bs2txt :: ByteString -> Text
bs2txt = T.decodeUtf8

lbs2txt :: LByteString -> Text
lbs2txt = TL.toStrict . TL.decodeUtf8

ltxt2lbs :: LText -> LByteString
ltxt2lbs = TL.encodeUtf8

bs2ltxt :: LByteString -> LText
bs2ltxt = TL.decodeUtf8

lbs2bs :: LByteString -> ByteString
lbs2bs = BL.toStrict

bs2lbs :: ByteString -> LByteString
bs2lbs = BL.fromChunks . (:[])

-- * Set

setFromList :: Ord a => [a] -> Set a
setFromList = Set.fromList

-- * Map

mapFromList :: Ord a => [(a, b)] -> Map a b
mapFromList = Map.fromList

-- * Case-insensitive

ci :: CI.FoldCase s => s -> CI.CI s
ci = CI.mk

ciOriginal :: CI.CI a -> a
ciOriginal = CI.original

-- * Time

type Milliseconds = Double

utcTimeToEpochTime :: UTCTime -> Integer
utcTimeToEpochTime = round . utcTimeToPOSIXSeconds

-- * Async

-- | Just like 'Async.async' but ignores the return value 'Async'
--
-- An 'Async' is a Haskell RTS thread that writes to a TMVar when
-- finished.
--
-- 'cancel' will send the Haskell thread a @SIGKILL@ signal but you don't
-- need to explicitly kill the thread. If the 'Async' can be garbage
-- collected, the thread will still run to completion and then be
-- properly cleaned up.
--
-- However, if there is an exception in the 'Async', then an exception
-- won't be propagate to the "parent" thread (unless 'wait' is somehow
-- used)
async_ :: IO a -> IO ()
async_ = void . Async.async


{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances, DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables, BangPatterns, ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module:      Data.Configurator.FromValue.Implementation
-- Copyright:   (c) 2016 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>

module Data.Configurator.FromValue.Implementation where

import           Prelude
import           Control.Applicative
import           Control.Arrow (first, second)
import           Control.Monad (ap)
import qualified Control.Monad.Fail as Fail
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import           Data.Complex (Complex((:+)))
import           Data.Configurator.Types
                   ( Value(..)
                   , ConversionError(..)
                   , ConversionErrorWhy(..)
                   , defaultConversionError
                   )
import           Data.Configurator.Types.Internal
                   ( MultiErrors
                   , singleError
                   , toErrors
                   )
import           Data.Fixed (Fixed, HasResolution)
import           Data.Int(Int8, Int16, Int32, Int64)
-- import           Data.Monoid
import           Data.Ratio ( Ratio, (%) )
import           Data.Scientific
                   ( Scientific,  coefficient, base10Exponent, normalize
                   , floatingOrInteger, toRealFloat, toBoundedInteger )
import           Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import           Data.Text.Encoding(encodeUtf8)
import           Data.Typeable(Typeable, TypeRep, typeOf)
#if !(MIN_VERSION_base(4,8,0))
import           Data.Word(Word)
#endif
import           Data.Word(Word8, Word16, Word32, Word64)
import           Foreign.C.Types(CFloat, CDouble)

type ConversionErrors = MultiErrors ConversionError

-- | An action to turn a 'Maybe' 'Value' into zero or one values of type @a@,
--   and possibly report errors/warnings.
newtype MaybeParser a = MaybeParser {
      unMaybeParser :: Maybe Value -> (Maybe a, ConversionErrors)
    } deriving (Functor, Typeable)

-- | An action to turn a 'Value' into zero or one values of type @a@,
--   and possibly report errors/warnings.
newtype ValueParser a = ValueParser {
      unValueParser :: Value -> (Maybe a, ConversionErrors)
    } deriving (Functor, Typeable)

data ListParserResult a =
     NonListError
   | ListError
   | ListOk a [Value]
     deriving (Functor, Typeable)

-- | An action to turn a @['Value']@ into zero or one values of type @a@,
--   and possibly report errors/warnings.
newtype ListParser a = ListParser {
      unListParser :: [Value] -> (ListParserResult a, ConversionErrors)
    } deriving (Functor, Typeable)

instance Applicative MaybeParser where
    pure a = MaybeParser $ \_v -> (Just a, mempty)
    (<*>) ff fa =
        MaybeParser $ \v ->
            case unMaybeParser ff v of
              (Nothing, w) -> (Nothing, w)
              (Just f , w) ->
                  case unMaybeParser fa v of
                    (Nothing, w') -> (Nothing   , w <> w')
                    (Just a , w') -> (Just (f a), w <> w')

instance Applicative ValueParser where
    pure a = ValueParser $ \_v -> (Just a, mempty)
    (<*>) ff fa =
        ValueParser $ \v ->
            case unValueParser ff v of
              (Nothing, w) -> (Nothing, w)
              (Just f , w) ->
                  case unValueParser fa v of
                    (Nothing, w') -> (Nothing   , w <> w')
                    (Just a , w') -> (Just (f a), w <> w')

instance Alternative ValueParser where
    empty   = ValueParser $ \_v -> (Nothing, mempty)
    f <|> g = ValueParser $ \v ->
                 case unValueParser f v of
                   (Nothing, Nothing) -> unValueParser g v
                   (Nothing, w) ->
                       case unValueParser g v of
                         (Nothing, w') -> (Nothing, w <> w')
                         res -> res
                   res -> res

    some v = repeat <$> v
    many v = some v <|> pure []

instance Alternative MaybeParser where
    empty   = MaybeParser $ \_v -> (Nothing, mempty)
    f <|> g = MaybeParser $ \v ->
                 case unMaybeParser f v of
                   (Nothing, Nothing) -> unMaybeParser g v
                   (Nothing, w) ->
                       case unMaybeParser g v of
                         (Nothing, w') -> (Nothing, w <> w')
                         res -> res
                   res -> res

    some v = repeat <$> v
    many v = some v <|> pure []

instance Monad MaybeParser where
#if !(MIN_VERSION_base(4,8,0))
    return = pure
#endif
    m >>= k  = MaybeParser $ \v ->
                   case unMaybeParser m v of
                     (Just a, w) ->
                         case w of
                           Nothing -> unMaybeParser (k a) v
                           Just _  -> let (mb, w') = unMaybeParser (k a) v
                                       in (mb, w <> w')
                     (Nothing, w) -> (Nothing, w)

    fail = Fail.fail

instance Monad ValueParser where
#if !(MIN_VERSION_base(4,8,0))
    return = pure
#endif
    m >>= k  = ValueParser $ \v ->
                   case unValueParser m v of
                     (Just a, w) ->
                         case w of
                           Nothing -> unValueParser (k a) v
                           Just _  -> let (mb, w') = unValueParser (k a) v
                                       in (mb, w <> w')
                     (Nothing, w) -> (Nothing, w)

    fail = Fail.fail

instance Fail.MonadFail MaybeParser where
    fail msg = MaybeParser $ \_v -> (Nothing, singleError (failError msg))

instance Fail.MonadFail ValueParser where
    fail msg = ValueParser $ \_v -> (Nothing, singleError (failError msg))

failError :: String -> ConversionError
failError msg = defaultConversionError {
                  conversionErrorLoc = "fail",
                  conversionErrorWhy = MonadFail,
                  conversionErrorMsg = Just (T.pack msg)
                }

runMaybeParser :: MaybeParser a -> Maybe Value -> (Maybe a, [ConversionError])
runMaybeParser p = second toErrors . unMaybeParser p

runValueParser :: ValueParser a -> Value -> (Maybe a, [ConversionError])
runValueParser p = second toErrors . unValueParser p

instance Applicative ListParser where
    pure a = ListParser $ \vs -> (ListOk a vs, mempty)
    (<*>) = ap

instance Alternative ListParser where
    empty   = ListParser $ \_v -> (ListError, mempty)
    f <|> g = ListParser $ \v ->
                 case unListParser f v of
                   (ListError, Nothing)  -> unListParser g v
                   (ListError, w) ->
                       case unListParser g v of
                         (ListError, w') -> (ListError, w <> w')
                         res -> res
                   res -> res

instance Monad ListParser where
#if !(MIN_VERSION_base(4,8,0))
    return = pure
#endif
    m >>= k  = ListParser $ \v ->
                   case unListParser m v of
                     (ListOk a v', w) ->
                         case w of
                           Nothing -> unListParser (k a) v'
                           Just _  -> let (mb, w') = unListParser (k a) v'
                                       in (mb, w <> w')
                     (ListError, w) ->
                         (ListError, w)
                     (NonListError, w) ->
                         (NonListError, w)

    fail = Fail.fail

instance Fail.MonadFail ListParser where
    fail msg = ListParser $ \_v -> (NonListError, singleError (failError msg))

-- | Turns a 'ValueParser' into a 'MaybeParser'.  If the 'Maybe' 'Value' the
--   parser is passed is 'Nothing' (which normally means a key was not found),
--   then this returns the @Nothing@ value with no errors or warnings.
--   Otherwise, it passes the 'Value' to the subparser.  If the
--   subparser returns a result value, then this returns 'Just' the value.
--   Otherwise, if the subparser does not return a value,  then this does
--   not return a value.
--
--   Any errors/warnings returned by the subparser are returned exactly as-is.

optionalValue :: ValueParser a -> MaybeParser (Maybe a)
optionalValue p =
    MaybeParser $ \mv ->
       case mv of
         Nothing -> (Just Nothing, mempty)
         Just v  -> first (Just <$>) (unValueParser p v)

-- | Turns a 'ValueParser' into a 'MaybeParser'.  If the 'Maybe' 'Value' the
--   parser is passed is 'Nothing' (which normally means a key was not found),
--   then this does not return a value and also returns a 'missingValueError'.
--   Otherwise,  the 'Value' is passed to the subparser,  and the result
--   and any errors/warnings are returned as-is.

requiredValue :: forall a. Typeable a => ValueParser a -> MaybeParser a
requiredValue p =
    MaybeParser $ \mv ->
        case mv of
          Nothing -> (Nothing, err)
          Just v  -> unValueParser p v
  where
    funcName = "requiredValue"
    err = singleError $ missingValueError funcName (typeOf (undefined :: a))

missingValueError :: Text -> TypeRep -> ConversionError
missingValueError funcName typ = defaultConversionError {
      conversionErrorLoc  = funcName,
      conversionErrorWhy  = MissingValue,
      conversionErrorType = Just typ
   }

-- | Turns a 'ListParser' into a 'ValueParser'.  It first checks that the
--   'Value' the 'ValueParser' is passed is a 'List' Value.  If it's not,
--   this returns no result as well as a 'typeError'.  Otherwise, it passes
--   the list of results to the 'ListParser' subparser.
--
--   If the subparser consumes all of the list elements,  this returns the
--   value and errors as-is.   If there are leftover list elements,  this
--   returns the value, and adds a message warning of the extra elements
--   to the list of errors.
--
--   The difference from 'listValue\'' is that this returns values with
--   unconsumed list elements (discarding the list elements).

listValue :: forall a. Typeable a => ListParser a -> ValueParser a
listValue p =
    ValueParser $ \v ->
        case v of
          List vs ->
              case unListParser p vs of
                (ListOk a vs', errs) ->
                   case vs' of
                     []    -> (Just a, errs)
                     (_:_) -> (,) (Just a) $! errs <> extraErr vs
                (_, errs)  -> (Nothing, errs)
          _ -> (Nothing, typeErr v)
  where
    fn = "listValue"
    extraErr vs = singleError $ extraValuesError fn vs (typeOf (undefined :: a))
    typeErr  v  = singleError $ typeError        fn v  (typeOf (undefined :: a))

-- | Turns a 'ListParser' into a 'ValueParser'.  It first checks that the
--   'Value' the 'ValueParser' is passed is a 'List' Value.  If it's not,
--   this returns no result as well as a 'typeError'.  Otherwise, it passes
--   the list of results to the 'ListParser' subparser.
--
--   If the subparser consumes all of the list elements,  this returns the
--   value and errors as-is.   If there are leftover list elements,  this
--   returns no value, and adds a message warning of the extra elements
--   to the list of errors.
--
--   The difference from 'listValue' is that this never returns a value if
--   there are unconsumed list elements. (discarding both the value returned
--   and the list element.)

listValue' :: forall a. Typeable a => ListParser a -> ValueParser a
listValue' p =
    ValueParser $ \v ->
        case v of
          List vs ->
              case unListParser p vs of
                (ListOk a vs', errs) ->
                   case vs' of
                     []    -> (Just a, errs)
                     (_:_) -> (,) Nothing $! errs <> extraErr vs
                (_, errs)  -> (Nothing, errs)
          _ -> (Nothing, typeErr v)
  where
    fn = "listValue'"
    extraErr vs = singleError $ extraValuesError fn vs (typeOf (undefined :: a))
    typeErr  v  = singleError $ typeError        fn v  (typeOf (undefined :: a))

-- | Turns a 'ValueParser' into a 'ListParser' that consumes a single element.
--
--   If there are no list elements left, this returns list error value and an
--   'ExhaustedValues' error.
--
--   If there is an element left,  it is passed to the value parser.  If the
--   value parser returns a value,  it is returned along with the errors as-is.
--   If the value parser returns no value,  then this returns a non-list error
--   value and the list of errors returned by the value parser.
--
--   The difference between a "list error value" and a "non-list error value",
--   is that the 'Alternative' instance for 'ListParser' recovers from "list
--   error" values but does not recover from "non-list error" values.   This
--   behavior was chosen so that the 'optional', 'some', and 'many' combinators
--   work on 'ListParser's in a way that is hopefully least surprising.

listElem :: forall a. (Typeable a) => ValueParser a -> ListParser a
listElem p =
    ListParser $ \vs ->
        case vs of
          [] -> (ListError, exhaustedError)
          (v:vs') -> case unValueParser p v of
                       (Nothing, errs) -> (NonListError, errs)
                       (Just a,  errs) -> (ListOk a vs', errs)
  where
    exhaustedError = singleError defaultConversionError {
                       conversionErrorLoc  = "listElem",
                       conversionErrorWhy  = ExhaustedValues,
                       conversionErrorType = Just (typeOf (undefined :: a))
                     }

extraValuesError :: Text -> [Value] -> TypeRep -> ConversionError
extraValuesError funcName vals typ
    = defaultConversionError {
        conversionErrorLoc  = funcName,
        conversionErrorWhy  = ExtraValues,
        conversionErrorVal  = Just (List vals),
        conversionErrorType = Just typ
      }

typeError :: Text -> Value -> TypeRep -> ConversionError
typeError funcName val typ
    = defaultConversionError {
        conversionErrorLoc  = funcName,
        conversionErrorWhy  = TypeError,
        conversionErrorVal  = Just val,
        conversionErrorType = Just typ
      }

boundedIntegerValue :: forall a. (Typeable a, Integral a, Bounded a)
                    => ValueParser a
boundedIntegerValue =
    ValueParser $ \v ->
        case v of
          (Number r) ->
              case toBoundedInteger r of
                ja@(Just _) -> (ja     , mempty)
                Nothing     -> (Nothing, overflowErr r)
          _ -> (Nothing, typeErr v)
  where
    fn = "boundedIntegerValue"
    overflowErr v = singleError (overflowError fn v (typeOf (undefined :: a)))
    typeErr     v = singleError (typeError     fn v (typeOf (undefined :: a)))

overflowError :: Text -> Scientific -> TypeRep -> ConversionError
overflowError fn val typ = valueError fn (Number val) typ "overflow"

valueError :: Text -> Value -> TypeRep -> Text -> ConversionError
valueError funcName val typ msg
    = defaultConversionError {
        conversionErrorLoc  = funcName,
        conversionErrorWhy  = ValueError,
        conversionErrorVal  = Just val,
        conversionErrorType = Just typ,
        conversionErrorMsg  = Just msg
      }

integralValue :: forall a. (Typeable a, Integral a) => ValueParser a
integralValue =
    ValueParser $ \v ->
        case v of
          Number r ->
              if base10Exponent r >= 0
              then toIntegral r
              else let r' = normalize r
                   in if base10Exponent r' >= 0
                      then toIntegral r'
                      else (Nothing, intErr r)
          _  -> (Nothing, typeErr v)
  where
    fn = "integralValue"
    intErr  r = singleError (notAnIntegerError fn r (typeOf (undefined :: a)))
    typeErr v = singleError (typeError         fn v (typeOf (undefined :: a)))

    toIntegral r =
        case floatingOrInteger r of
          Right a -> (Just a, mempty)
          -- This case should be impossible:
          Left  (_::Float) -> (Nothing, intErr r)

notAnIntegerError :: Text -> Scientific -> TypeRep -> ConversionError
notAnIntegerError fn val typ = valueError fn (Number val) typ "not an integer"

fractionalValue :: forall a. (Typeable a, Fractional a) => ValueParser a
fractionalValue =
    ValueParser $ \v ->
        case v of
          Number r ->
              let !c   = coefficient    r
                  !e   = base10Exponent r
                  !r'  = fromRational $! if e >= 0
                                         then (c * 10^e) % 1
                                         else c % (10^(- e))
               in (Just r', mempty)
          _ -> (Nothing, typeErr v)
  where
    fn = "fractionalValue"
    typeErr v = singleError (typeError fn v (typeOf (undefined :: a)))

realFloatValue :: forall a. (Typeable a, RealFloat a) => ValueParser a
realFloatValue = realFloatValue_ (typeOf (undefined :: a))

realFloatValue_ :: (RealFloat a) => TypeRep -> ValueParser a
realFloatValue_ typ =
    ValueParser $ \v ->
        case v of
          Number (toRealFloat -> !r) -> (Just r, mempty)
          _ -> (Nothing, typeErr v)
  where
    fn = "realFloatValue"
    typeErr v = singleError (typeError fn v typ)

fixedValue :: forall a. (Typeable a, HasResolution a) => ValueParser (Fixed a)
fixedValue = fractionalValue
  -- FIXME: optimize fixedValue and/or Data.Fixed

class FromMaybeValue a where
    fromMaybeValue :: MaybeParser a
    default fromMaybeValue :: (Typeable a, FromValue a) => MaybeParser a
    fromMaybeValue = requiredValue fromValue

class FromValue a where
    fromValue :: ValueParser a

class FromListValue a where
    fromListValue :: ListParser a

instance FromValue a => FromMaybeValue (Maybe a) where
    fromMaybeValue = optionalValue fromValue

instance FromMaybeValue Bool
instance FromValue Bool where
   fromValue = boolValue

boolValue :: ValueParser Bool
boolValue =
    ValueParser $ \v ->
        case v of
          Bool b -> (Just b, mempty)
          _ -> (Nothing, typeErr v (typeOf True))
  where
    fn = "boolValue"
    typeErr v t = singleError (typeError fn v t)

instance FromMaybeValue Value where
    fromMaybeValue = MaybeParser $ \mv -> (mv, mempty)
instance FromValue Value where
    fromValue = ValueParser $ \v -> (Just v, mempty)

instance FromMaybeValue Int
instance FromValue Int where
    fromValue = boundedIntegerValue

instance FromMaybeValue Integer
instance FromValue Integer where
    fromValue = integralValue

instance FromMaybeValue Int8
instance FromValue Int8 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Int16
instance FromValue Int16 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Int32
instance FromValue Int32 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Int64
instance FromValue Int64 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word
instance FromValue Word where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word8
instance FromValue Word8 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word16
instance FromValue Word16 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word32
instance FromValue Word32 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word64
instance FromValue Word64 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Double
instance FromValue Double where
    fromValue = realFloatValue

instance FromMaybeValue Float
instance FromValue Float where
    fromValue = realFloatValue

instance FromMaybeValue CDouble
instance FromValue CDouble where
    fromValue = realFloatValue

instance FromMaybeValue CFloat
instance FromValue CFloat where
    fromValue = realFloatValue

instance (Typeable a, Integral a) => FromMaybeValue (Ratio a)
instance (Typeable a, Integral a) => FromValue (Ratio a) where
    fromValue = fractionalValue

instance FromMaybeValue Scientific
instance FromValue Scientific where
    fromValue = scientificValue

scientificValue :: ValueParser Scientific
scientificValue =
    ValueParser $ \v ->
        case v of
          Number r -> (Just r, mempty)
          _ -> (Nothing, typeErr v)
  where
    fn = "scientificValue"
    typeErr v = singleError (typeError fn v (typeOf (undefined :: Scientific)))

instance (Typeable a, RealFloat a) => FromMaybeValue (Complex a)
instance (Typeable a, RealFloat a) => FromValue (Complex a) where
    fromValue = (:+ 0) <$> realFloatValue_ (typeOf (undefined :: Complex a))

instance (Typeable a, HasResolution a) => FromMaybeValue (Fixed a)
instance (Typeable a, HasResolution a) => FromValue (Fixed a) where
    fromValue = fixedValue

instance FromMaybeValue Text
instance FromValue Text where
    fromValue = textValue

textValue :: ValueParser Text
textValue = textValue_ (typeOf (undefined :: Text))

textValue_ :: TypeRep -> ValueParser Text
textValue_ typ =
    ValueParser $ \v ->
        case v of
          String r -> (Just r, mempty)
          _ -> (Nothing, typeErr v typ)
  where
    fn = "textValue"
    typeErr v t = singleError (typeError fn v t)

instance FromMaybeValue Char
instance FromValue Char where
    fromValue = charValue

charValue :: ValueParser Char
charValue =
    ValueParser $ \v ->
        case v of
          String txt ->
              case T.uncons txt of
                Nothing           -> (Nothing, charErr txt)
                Just (c,txt')
                    | T.null txt' -> (Just  c, mempty)
                    | otherwise   -> (Nothing, charErr txt)
          _ -> (Nothing, typeErr v)
  where
    fn  = "charValue"
    typ = typeOf (undefined :: Char)
    msg = "expecting exactly one character"
    charErr v = singleError (valueError fn (String v) typ msg)
    typeErr v = singleError (typeError fn v typ)

instance FromMaybeValue L.Text
instance FromValue L.Text where
    fromValue = L.fromStrict <$> textValue_ (typeOf (undefined :: L.Text))

instance FromMaybeValue B.ByteString
instance FromValue B.ByteString where
    fromValue = encodeUtf8 <$> textValue_ (typeOf (undefined :: B.ByteString))

instance FromMaybeValue LB.ByteString
instance FromValue LB.ByteString where
    fromValue = convert <$> textValue_ (typeOf (undefined :: LB.ByteString))
      where convert = LB.fromStrict . encodeUtf8

-- AJ
-- instance FromMaybeValue String
-- instance FromValue String where
--     fromValue = T.unpack <$> textValue_ (typeOf (undefined :: String))

instance ( Typeable a, FromValue a
         , Typeable b, FromValue b ) => FromMaybeValue (a,b)
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b ) => FromValue (a,b) where
    fromValue = listValue fromListValue
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b ) => FromListValue (a,b) where
    fromListValue = (,) <$> listElem fromValue <*> listElem fromValue

instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c ) => FromMaybeValue (a,b,c)
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c ) => FromValue (a,b,c) where
    fromValue = listValue fromListValue
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c ) => FromListValue (a,b,c) where
    fromListValue = (,,) <$> listElem fromValue <*> listElem fromValue
                         <*> listElem fromValue

instance (Typeable a, FromValue a) => FromMaybeValue [a]
instance (Typeable a, FromValue a) => FromValue [a] where
    fromValue = listValue (many (listElem fromValue))

instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c
         , Typeable d, FromValue d ) => FromMaybeValue (a,b,c,d)
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c
         , Typeable d, FromValue d ) => FromValue (a,b,c,d) where
    fromValue = listValue fromListValue
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c
         , Typeable d, FromValue d ) => FromListValue (a,b,c,d) where
    fromListValue = (,,,) <$> listElem fromValue <*> listElem fromValue
                          <*> listElem fromValue <*> listElem fromValue

{--
parserFail :: forall a. Typeable a => T.Text -> Maybe T.Text -> ValueParser a
parserFail loc msg = ValueParser $ \st -> (Nothing, failError, st)
       where
         failError = singleError defaultConversionError {
                       conversionErrorLoc  = loc
                       conversionErrorWhy  = MonadFail,
                       conversionErrorType = Just (typeRep (undefined :: a)),
                       conversionErrorMsg  = msg
                     }
--}

{--
defaultValue :: Typeable a => a -> ValueParser a -> ValueParser a
defaultValue def m =
    ValueParser $ \vs ->
        case vs of
          (Nothing:vs') -> (Just def, mempty, vs')
          _
--}


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
-- {-# LANGUAGE PolyKinds #-}
-- {-# LANGUAGE AllowAmbiguousTypes #-}

{-# OPTIONS_GHC -ddump-splices #-}
{-# OPTIONS_GHC -fprint-explicit-kinds #-}

module Deep.Example where

import           Data.List

import           Deep.Expr

import           Language.Haskell.TH

import           Data.Char (ord)

import           GHC.Generics
import           Data.Void

import           Data.Bifunctor

import           Data.Complex

import           Data.Ratio

import           GHC.Real

import           Data.Proxy

-- import           Debug.Trace

-- deriving instance Generic (Ratio a) -- XXX: This instance should probably be in 'base'

data Nat = Z | S Nat deriving (Generic, Show)

data Example = N Nat | B Bool deriving (Generic, Show)

thExample1 :: Q Exp
thExample1 = do
  exp <-
    [|
      case the @(Either Int Bool) (Right False) of
        Left x -> x * 2
        Right y -> fromEnum y
    |]
  transformExpr exp

thExample2 :: Q Exp
thExample2 = do
  exp <-
    [| case (True, the @Int 7) of
         (x, y) -> fromEnum x + y
    |]
  transformExpr exp

data Example' = N' Int | B' Bool deriving (Show, Generic)

thExample3 :: Q Exp
thExample3 = do
  exp <-
    [|
      case B' False of
        N' n -> N' (n+2)
        B' b -> B' (not b)
    |]
  transformExpr exp

instance GPURep Example' where
  type TypeHead Example' = Example'

data Example3 = X Int Float deriving (Show, Generic)

instance GPURep Example3 where
  type TypeHead Example3 = Example3

data Example4 = E1 Int | E2 Float | E3 Bool deriving (Show, Generic)

instance GPURep Example4 where
  type TypeHead Example4 = Example4

thExample4 :: Q Exp
thExample4 = do
  exp <-
    [| case E2 23.0 of
        E1 x -> 2
        E2 y -> 4
        E3 z -> 6
    |]
  transformExpr exp

data Example5 = A1 Float Float | A2 Int deriving (Show, Generic)

instance GPURep Example5 where
  type TypeHead Example5 = Example5

thExample5 :: Q Exp
thExample5 = do
  exp <-
    [| case A1 2.3 7.5 of
        A2 x -> fromIntegral x
        A1 x y -> x + y
    |]

  transformExpr exp

-- instance GPURep a => GPURep (Ratio a)

transformDecTailRec
  [d|
  thExample6 :: Int -> Bool
  thExample6 x =
    if x == 0
      then True
      else if x == 1
            then False
            else thExample6 (x - 2)
  |]

data IntPair = IntPair Int Int deriving (Show, Generic)

instance GPURep IntPair where
  type TypeHead IntPair = IntPair

thExample7 :: Q Exp
thExample7 = do
  exp <-
    [| case IntPair 1 2 of
        IntPair x y ->
          if x == 0
            then y
            else x
    |]
  r <- transformExpr exp
  return r

-- transformDecTailRec
--   [d|
thExample8 :: IntPair -> Int
thExample8 p =
  case p of
    IntPair x y -> y

-- -- thExample9_aj5t :: IntPair -> Int
-- -- thExample9_aj5t p_aj5x
-- --   = (gpuAbs
-- --        (TailRec
-- --           ((\ thExample9_aj5t
-- --               -> \ p_aj5x
-- --                    -> (CaseExp p_aj5x)
-- --                         ((SafeSumMatch (Data.Proxy.Proxy :: Proxy (TypeHead (Tagged2 (TypeHead IntPair :: *) IntPair (Int, Int)) :: *)))
-- --                            (OneSumMatch
-- --                               (ProdMatch
-- --                                  (\ x_aj5y
-- --                                     -> OneProdMatch
-- --                                          (\ y_aj5z
-- --                                             -> ((IfThenElse ((Equal x_aj5y) (Lit 0)))
-- --                                                   (DoneExp
-- --                                                      ((construct thExample8) p_aj5x)))
-- --                                                  (thExample9_aj5t
-- --                                                     (((construct IntPair)
-- --                                                         ((Sub x_aj5y) (Lit 1)))
-- --                                                        ((Mul x_aj5y) y_aj5z)))))))))
-- --              StepExp)))
-- --       p_aj5x

--   thExample9 :: IntPair -> Int
--   thExample9 p =
--     case p of
--       IntPair x y ->
--         if x == 0
--           then thExample8 p
--           else thExample9 (IntPair (x-1) (x*y))

--   |]

thExample9_aijJ :: IntPair -> Int
thExample9_aijJ p_aijN
  = (gpuAbs
       (TailRec
          ((\ thExample9_aijJ
              -> \ p_aijN
                   -> (CaseExp p_aijN)
                        ((SafeSumMatch (Proxy @(KindOf IntPair)) (Proxy @IntPair))
                           (OneSumMatch
                              (ProdMatch
                                 (\ x_aijO
                                    -> OneProdMatch
                                         (\ y_aijP -> undefined))))))
                                            -- -> ((IfThenElse ((Equal x_aijO) (Lit 0)))
                                            --       (DoneExp
                                            --          ((construct thExample8) p_aijN)))
                                            --      (thExample9_aijJ
                                            --         (((construct IntPair)
                                            --             ((Sub x_aijO) (Lit 1)))
                                            --            ((Mul x_aijO) y_aijP)))))))))
             StepExp)))
      p_aijN

-- transformDecTailRec
--   [d|
--   mandelbrot_nextZ :: (Complex (Ratio Integer), Complex (Ratio Integer)) -> Complex (Ratio Integer)
--   mandelbrot_nextZ t =
--     case t of
--       (c, z) -> (z*z) + c

--   -- shouldFail :: Complex (Ratio Integer) -> (Ratio Integer)
--   -- shouldFail t =
--   --   case t of
--   --     (x, y) -> x + y

--   mandelbrot_helper :: (Int, Complex (Ratio Integer), Complex (Ratio Integer)) -> Maybe Int
--   mandelbrot_helper t =
--     case t of
--       (iters, c, z) ->
--         if iters == 50
--           then Nothing
--           else
--             case z of
--               (:+) real imag ->
--                 if ((real*real) + (imag*imag)) > 4
--                   then Just iters
--                   else mandelbrot_helper (iters+1, c, mandelbrot_nextZ (c, z))

--   mandelbrot_point :: Complex (Ratio Integer) -> Maybe Int
--   mandelbrot_point c = mandelbrot_helper (0, c, 0)

--   |]


{-# OPTIONS_GHC -fno-warn-orphans #-}

module TinyLang.Prelude
    ( module Export
    , module TinyLang.Prelude
    ) where

-- base
------------------------------
import           Control.Applicative       as Export
import           Control.Exception         as Export
import           Control.Monad             as Export
import           Control.Monad.IO.Class    as Export
import           Data.Bifunctor            as Export
import           Data.Bool                 as Export
import           Data.Char                 as Export
import           Data.Coerce               as Export
import           Data.Complex              as Export
import           Data.Either               as Export
import           Data.Foldable             as Export
import           Data.Function             as Export
import           Data.Functor              as Export
import           Data.Functor.Compose      as Export
import           Data.Functor.Identity     as Export
import           Data.List                 as Export
import           Data.Maybe                as Export
import           Data.Monoid               as Export hiding (First (..),
                                                      Last (..))
import           Data.Ord                  as Export
import           Data.Proxy                as Export
import           Data.Ratio                as Export
import           Data.Semigroup            as Export
import           Data.String               as Export
import           Data.Traversable          as Export
import           Data.Tuple                as Export
import           Data.Void                 as Export
import           Debug.Trace               as Export
import           GHC.Exts                  as Export (groupWith, sortWith)
import           GHC.Generics              as Export (Generic, Generic1)
import           GHC.Stack                 as Export
import           Numeric                   as Export
import           System.IO                 as Export
import           Text.Read                 as Export (Read (..), readEither,
                                                      readMaybe)

-- transformers
------------------------------
import           Control.Monad.Trans.Maybe as Export

-- mtl
------------------------------
import           Control.Monad.Except      as Export
import           Control.Monad.Reader      as Export
import           Control.Monad.State       as Export

-- containers
------------------------------
import           Data.IntMap.Strict        as Export (IntMap)
import           Data.IntSet               as Export (IntSet)
import           Data.Map.Strict           as Export (Map)
import           Data.Set                  as Export (Set)

-- hashable
------------------------------
import           Data.Hashable             as Export

-- unordered-containers
------------------------------
import           Data.HashMap.Strict       as Export (HashMap)
import           Data.HashSet              as Export (HashSet)

import qualified Data.IntMap.Strict        as IntMap

import           Test.QuickCheck.Property

-- vector
------------------------------

import           Data.Vector               as Export (Vector)

infixr 9 .*
infixr 2 ?

newtype PairT b f a = PairT
    { unPairT :: f (b, a)
    }

instance Functor f => Functor (PairT b f) where
    fmap f (PairT p) = PairT $ fmap (fmap f) p

instance Hashable a => Hashable (IntMap a) where
    hashWithSalt salt = hashWithSalt salt . IntMap.toList

-- Feels so weird not to have it by default.
instance Testable (Either String ()) where
    property = property . \case
        Left err -> failed { reason = err }
        Right () -> succeeded

(.*) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.*) = (.) . (.)
{-# INLINABLE (.*) #-}

(?) :: Alternative f => Bool -> a -> f a
(?) b x = x <$ guard b
{-# INLINABLE (?) #-}

visitExtract :: (Functor t, Functor f) => (t a -> a) -> (a -> f b) -> t a -> f (t b)
visitExtract ext f a = (<$ a) <$> f (ext a)
{-# INLINABLE visitExtract #-}

firstF :: Functor f => (a -> f c) -> (a, b) -> f (c, b)
firstF f (x, y) = flip (,) y <$> f x
{-# INLINABLE firstF #-}

foldlM' :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
foldlM' f z xs = foldr step return xs z where
  step x r a = f a x >>= (r $!)
{-# INLINABLE foldlM' #-}

foldMapA :: (Foldable t, Applicative f, Monoid b) => (a -> f b) -> t a -> f b
foldMapA f = foldr (\x r -> mappend <$> f x <*> r) (pure mempty)
{-# INLINABLE foldMapA #-}

-- | Fold a monadic function over a 'Foldable'. The monadic version of 'foldMap'.
foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
foldMapM f xs = foldr step return xs mempty where
    step x r z = f x >>= \y -> r $! z `mappend` y
{-# INLINABLE foldMapM #-}

asumMap :: (Foldable t, Alternative f) => (a -> f b) -> t a -> f b
asumMap f = foldr ((<|>) . f) empty
{-# INLINABLE asumMap #-}

mapMaybeA :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b]
mapMaybeA f = foldr (\x r -> maybe id (:) <$> f x <*> r) (pure empty)
{-# INLINABLE mapMaybeA #-}

fromOption :: (Foldable f, Applicative g) => g a -> f a -> g a
fromOption = foldr (const . pure)
{-# INLINABLE fromOption #-}

-- | This function generalizes 'eitherToMaybe', 'eitherToList',
-- 'listToMaybe' and other such functions.
reoption :: (Foldable f, Alternative g) => f a -> g a
reoption = fromOption empty
{-# INLINABLE reoption #-}

forBind :: (Monad m, Traversable m, Applicative f) => m a -> (a -> f (m b)) -> f (m b)
forBind a f = join <$> traverse f a
{-# INLINABLE forBind #-}