FromJSONWith

Deep.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

{-|
Module:      Deep
Copyright:   (c) 2015 Ryan Scott
License:     BSD3
Stability:   Experimental
Portability: Template Haskell

A demonstration of what 'deriveJSONWith' can do.
-}
module Deep where

import           Data.Foldable.Deriving
import           FromJSONWithTH

data E a where
    Bool :: a ~ Bool => a          -> E a
    And  :: a ~ Bool => E a -> E a -> E a
    Or   :: a ~ Bool => E a -> E a -> E a
    Int  :: a ~ Int  => a          -> E a
    Add  :: a ~ Int  => E a -> E a -> E a

deriving instance Eq   (E a)
deriving instance Ord  (E a)
deriving instance Show (E a)
-- TODO: Replace with DeriveFoldable in GHC 7.12
deriveFoldable ''E
deriveJSONWith defaultOptions ''E

data RE a = RBool Bool
          | RAnd (RE Bool) (RE Bool)
          | ROr  (RE Bool) (RE Bool)
          | RInt Int
          | RAdd (RE Int) (RE Int)
  deriving (Eq, Ord, Read, Show)
deriveJSON remoteOptions ''RE

FromJSONWith.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

{-|
Module:      FromJSONWith
Copyright:   (c) 2011, 2012 Bryan O'Sullivan
             (c) 2011 MailRank, Inc.
             (c) 2015 Ryan Scott
License:     BSD3
Stability:   Experimental
Portability: Loads of extensions

A minor twist on 'FromJSON'.
-}
module FromJSONWith where

import           Control.Monad (zipWithM)

import           Data.Aeson
import           Data.Aeson.Types (Parser, parse)
import           Data.Either.Combinators (isLeft, isRight, fromLeft', fromRight')
import           Data.Fixed
import           Data.Functor.Identity (Identity(..))
import           Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as H (empty, foldrWithKey, insert, intersectionWith, lookup, toList)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashSet as HashSet (fromList, toList)
import           Data.HashSet (HashSet)
import           Data.Int
import qualified Data.IntMap as IntMap (fromList, toList)
import           Data.IntMap (IntMap)
import           Data.IntSet (IntSet)
import qualified Data.Map as M (empty, foldrWithKey, insert)
import           Data.Map (Map)
import           Data.Monoid
import           Data.Primitive.Types (Prim)
import           Data.Ratio
import           Data.Scientific (Scientific)
import qualified Data.Sequence as Seq (fromList, zip)
import           Data.Sequence (Seq)
import qualified Data.Set as Set (fromList, toList)
import           Data.Set (Set)
import qualified Data.Text as S (Text, pack, unpack)
import qualified Data.Text.Lazy as L (Text, fromStrict, toStrict)
import           Data.Time
import           Data.Tree (Tree(..))
import qualified Data.Vector.Generic as G (Vector, convert)
import qualified Data.Vector.Unboxed as U (Vector)
import qualified Data.Vector.Primitive as P (Vector)
import qualified Data.Vector.Storable as S (Vector)
import qualified Data.Vector as V (Vector, convert, length, toList, unsafeIndex, zipWithM)
import           Data.Word

import           Foreign.Storable (Storable)

class FromJSONWith a where
    parseJSONWith :: a -> Value -> Parser a
    default parseJSONWith :: FromJSON a => a -> Value -> Parser a
    parseJSONWith = const parseJSON

-- | Convert a value from JSON, failing if the types do not match.
fromJSONWith :: FromJSONWith a => a -> Value -> Result a
fromJSONWith e = parse $ parseJSONWith e
{-# INLINE fromJSONWith #-}

-- | Retrieve the value associated with the given key of an 'Object'.
-- The result is 'empty' if the key is not present or the value cannot
-- be converted to the desired type.
--
-- This accessor is appropriate if the key and value /must/ be present
-- in an object for it to be valid.  If the key and value are
-- optional, use 'retrieveWithMaybe' instead.
retrieveWith :: FromJSONWith a => a -> Object -> S.Text -> Parser a
retrieveWith e obj key = case H.lookup key obj of
    Nothing -> fail $ "key " ++ show key ++ " not present"
    Just v  -> parseJSONWith e v
{-# INLINE retrieveWith #-}

-- | Retrieve the value associated with the given key of an 'Object'.
-- The result is 'Nothing' if the key is not present, or 'empty' if
-- the value cannot be converted to the desired type.
--
-- This accessor is most useful if the key and value can be absent
-- from an object without affecting its validity.  If the key and
-- value are mandatory, use 'retrieveWith' instead.
retrieveWithMaybe :: FromJSONWith a => Maybe a -> Object -> S.Text -> Parser (Maybe a)
retrieveWithMaybe e obj key = case H.lookup key obj of
    Nothing -> pure Nothing
    Just v  -> parseJSONWith e v
{-# INLINE retrieveWithMaybe #-}

instance FromJSONWith Bool
instance FromJSONWith Char
instance FromJSONWith Double
instance FromJSONWith Float
instance FromJSONWith Int
instance FromJSONWith Int8
instance FromJSONWith Int16
instance FromJSONWith Int32
instance FromJSONWith Int64
instance FromJSONWith Integer
instance FromJSONWith Word
instance FromJSONWith Word8
instance FromJSONWith Word16
instance FromJSONWith Word32
instance FromJSONWith Word64
instance FromJSONWith ()
instance FromJSONWith S.Text
instance FromJSONWith L.Text
instance FromJSONWith IntSet
instance FromJSONWith Scientific
instance FromJSONWith ZonedTime
instance FromJSONWith UTCTime
instance FromJSONWith DotNetTime
instance FromJSONWith Value
instance FromJSONWith [Char]
instance FromJSONWith (Ratio Integer)
instance HasResolution a => FromJSONWith (Fixed a)

instance FromJSONWith a => FromJSONWith (Maybe a) where
    parseJSONWith _        Null = pure Nothing
    parseJSONWith (Just e) a    = Just <$> parseJSONWith e a
    parseJSONWith Nothing  _    = fail "Invariant failure."
    {-# INLINE parseJSONWith #-}

instance FromJSONWith a => FromJSONWith [a] where
    parseJSONWith l = withArray "[a]" $ zipWithM parseJSONWith l . V.toList
    {-# INLINE parseJSONWith #-}

instance FromJSONWith a => FromJSONWith (Dual a) where
    parseJSONWith (Dual d) = fmap Dual . parseJSONWith d
    {-# INLINE parseJSONWith #-}

instance FromJSONWith a => FromJSONWith (First a) where
    parseJSONWith (First f) = fmap First . parseJSONWith f
    {-# INLINE parseJSONWith #-}

instance FromJSONWith a => FromJSONWith (Last a) where
    parseJSONWith (Last l) = fmap Last . parseJSONWith l
    {-# INLINE parseJSONWith #-}

left, right :: S.Text
left  = "Left"
right = "Right"

instance (FromJSONWith a, FromJSONWith b) => FromJSONWith (Either a b) where
    parseJSONWith lr (Object (H.toList -> [(key, value)]))
        | isLeft lr  && key == left  = Left  <$> parseJSONWith (fromLeft' lr)  value
        | isRight lr && key == right = Right <$> parseJSONWith (fromRight' lr) value
    parseJSONWith _ _ = fail $
        "expected an object with a single property " ++
        "where the property key should be either " ++
        "\"Left\" or \"Right\""
    {-# INLINE parseJSONWith #-}

instance FromJSONWith a => FromJSONWith (Identity a) where
    parseJSONWith (Identity i) a = Identity <$> parseJSONWith i a
    {-# INLINE parseJSONWith #-}

instance FromJSONWith a => FromJSONWith (IntMap a) where
    parseJSONWith e = fmap IntMap.fromList . parseJSONWith (IntMap.toList e)
    {-# INLINE parseJSONWith #-}

instance (Ord a, FromJSONWith a) => FromJSONWith (Set a) where
    parseJSONWith s = fmap Set.fromList . parseJSONWith (Set.toList s)
    {-# INLINE parseJSONWith #-}

instance FromJSONWith v => FromJSONWith (Tree v) where
    parseJSONWith (Node a l) j = uncurry Node <$> parseJSONWith (a, l) j
    {-# INLINE parseJSONWith #-}

instance FromJSONWith a => FromJSONWith (Seq a) where
    parseJSONWith s = withArray "Seq a" $ traverse (uncurry parseJSONWith) . Seq.zip s . Seq.fromList . V.toList
    {-# INLINE parseJSONWith #-}

instance (Eq a, Hashable a, FromJSONWith a) => FromJSONWith (HashSet a) where
    parseJSONWith hs = fmap HashSet.fromList . parseJSONWith (HashSet.toList hs)
    {-# INLINE parseJSONWith #-}

instance FromJSONWith a => FromJSONWith (V.Vector a) where
    parseJSONWith v = withArray "Vector a" $ V.zipWithM parseJSONWith v
    {-# INLINE parseJSONWith #-}

vectorParseJSONWith :: (FromJSONWith a, G.Vector w a) => String -> w a -> Value -> Parser (w a)
vectorParseJSONWith s v = withArray s $ fmap V.convert . V.zipWithM parseJSONWith (G.convert v)
{-# INLINE vectorParseJSONWith #-}

instance (G.Vector U.Vector a, FromJSONWith a) => FromJSONWith (U.Vector a) where
    parseJSONWith = vectorParseJSONWith "Data.Vector.Unboxed.Vector a"

instance (Storable a, FromJSONWith a) => FromJSONWith (S.Vector a) where
    parseJSONWith = vectorParseJSONWith "Data.Vector.Storable.Vector a"

instance (Prim a, FromJSONWith a) => FromJSONWith (P.Vector a) where
    parseJSONWith = vectorParseJSONWith "Data.Vector.Primitive.Vector a"

mapHash :: (Eq k, Hashable k) => Map k v -> HashMap k v
mapHash = mapHashKey id
{-# INLINE mapHash #-}

-- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys.
mapHashKey :: (Eq k2, Hashable k2) => (k1 -> k2)
              -> Map k1 v -> HashMap k2 v
mapHashKey kv = M.foldrWithKey (H.insert . kv) H.empty
{-# INLINE mapHashKey #-}

-- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys and values.
mapHashKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)
              -> Map k1 v1 -> HashMap k2 v2
mapHashKeyVal fk kv = M.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty
{-# INLINE mapHashKeyVal #-}

hashMap :: Ord k => HashMap k v -> Map k v
hashMap = hashMapKey id
{-# INLINE hashMap #-}

-- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys.
hashMapKey :: (Ord k2) => (k1 -> k2)
           -> HashMap k1 v -> Map k2 v
hashMapKey kv = H.foldrWithKey (M.insert . kv) M.empty
{-# INLINE hashMapKey #-}

-- | Transform the keys and values of a 'H.HashMap'.
mapKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)
          -> HashMap k1 v1 -> HashMap k2 v2
mapKeyVal fk kv = H.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty
{-# INLINE mapKeyVal #-}

-- | Transform the keys of a 'H.HashMap'.
mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> HashMap k1 v -> HashMap k2 v
mapKey fk = mapKeyVal fk id
{-# INLINE mapKey #-}

instance FromJSONWith v => FromJSONWith (Map String v) where
    parseJSONWith m = fmap (hashMapKey S.unpack) . parseJSONWith (mapHashKey S.pack m)

instance FromJSONWith v => FromJSONWith (Map S.Text v) where
    parseJSONWith m = withObject "Map Text a" $
        fmap hashMap . traverse (uncurry parseJSONWith) . H.intersectionWith (,) (mapHash m)

instance FromJSONWith v => FromJSONWith (Map L.Text v) where
    parseJSONWith m = fmap (hashMapKey L.fromStrict) . parseJSONWith (mapHashKey L.toStrict m)

instance FromJSONWith v => FromJSONWith (HashMap String v) where
    parseJSONWith hm = fmap (mapKey S.unpack) . parseJSONWith (mapKey S.pack hm)

instance FromJSONWith v => FromJSONWith (HashMap S.Text v) where
    parseJSONWith hm = withObject "HashMap Text a" $ traverse (uncurry parseJSONWith) . H.intersectionWith (,) hm

instance FromJSONWith v => FromJSONWith (HashMap L.Text v) where
    parseJSONWith hm = fmap (mapKey L.fromStrict) . parseJSONWith (mapKey L.toStrict hm)

instance (FromJSONWith a, FromJSONWith b) => FromJSONWith (a, b) where
    parseJSONWith (a, b) = withArray "(a,b)" $ \ab ->
        let n = V.length ab
        in if n == 2
             then (,) <$> parseJSONWith a (V.unsafeIndex ab 0)
                      <*> parseJSONWith b (V.unsafeIndex ab 1)
             else fail $ "cannot unpack array of length " ++
                         show n ++ " into a pair"
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c) => FromJSONWith (a, b, c) where
    parseJSONWith (a, b, c) = withArray "(a,b,c)" $ \abc ->
        let n = V.length abc
        in if n == 3
             then (,,) <$> parseJSONWith a (V.unsafeIndex abc 0)
                       <*> parseJSONWith b (V.unsafeIndex abc 1)
                       <*> parseJSONWith c (V.unsafeIndex abc 2)
             else fail $ "cannot unpack array of length " ++
                          show n ++ " into a 3-tuple"
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d) => FromJSONWith (a, b, c, d) where
    parseJSONWith (a, b, c, d) = withArray "(a,b,c,d)" $ \abcd ->
        let n = V.length abcd
        in if n == 4
             then (,,,) <$> parseJSONWith a (V.unsafeIndex abcd 0)
                        <*> parseJSONWith b (V.unsafeIndex abcd 1)
                        <*> parseJSONWith c (V.unsafeIndex abcd 2)
                        <*> parseJSONWith d (V.unsafeIndex abcd 3)
             else fail $ "cannot unpack array of length " ++
                         show n ++ " into a 4-tuple"
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e) => FromJSONWith (a, b, c, d, e) where
    parseJSONWith (a, b, c, d, e) = withArray "(a,b,c,d,e)" $ \abcde ->
        let n = V.length abcde
        in if n == 5
             then (,,,,) <$> parseJSONWith a (V.unsafeIndex abcde 0)
                         <*> parseJSONWith b (V.unsafeIndex abcde 1)
                         <*> parseJSONWith c (V.unsafeIndex abcde 2)
                         <*> parseJSONWith d (V.unsafeIndex abcde 3)
                         <*> parseJSONWith e (V.unsafeIndex abcde 4)
             else fail $ "cannot unpack array of length " ++
                         show n ++ " into a 5-tuple"
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f) => FromJSONWith (a, b, c, d, e, f) where
    parseJSONWith (a, b, c, d, e, f) = withArray "(a,b,c,d,e,f)" $ \abcdef ->
        let n = V.length abcdef
        in if n == 6
             then (,,,,,) <$> parseJSONWith a (V.unsafeIndex abcdef 0)
                          <*> parseJSONWith b (V.unsafeIndex abcdef 1)
                          <*> parseJSONWith c (V.unsafeIndex abcdef 2)
                          <*> parseJSONWith d (V.unsafeIndex abcdef 3)
                          <*> parseJSONWith e (V.unsafeIndex abcdef 4)
                          <*> parseJSONWith f (V.unsafeIndex abcdef 5)
             else fail $ "cannot unpack array of length " ++
                         show n ++ " into a 6-tuple"
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f, FromJSONWith g) => FromJSONWith (a, b, c, d, e, f, g) where
    parseJSONWith (a, b, c, d, e, f, g) = withArray "(a,b,c,d,e,f,g)" $ \abcdefg ->
        let n = V.length abcdefg
        in if n == 7
             then (,,,,,,) <$> parseJSONWith a (V.unsafeIndex abcdefg 0)
                           <*> parseJSONWith b (V.unsafeIndex abcdefg 1)
                           <*> parseJSONWith c (V.unsafeIndex abcdefg 2)
                           <*> parseJSONWith d (V.unsafeIndex abcdefg 3)
                           <*> parseJSONWith e (V.unsafeIndex abcdefg 4)
                           <*> parseJSONWith f (V.unsafeIndex abcdefg 5)
                           <*> parseJSONWith g (V.unsafeIndex abcdefg 6)
             else fail $ "cannot unpack array of length " ++
                         show n ++ " into a 7-tuple"
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f, FromJSONWith g, FromJSONWith h) => FromJSONWith (a, b, c, d, e, f, g, h) where
    parseJSONWith (a, b, c, d, e, f, g, h) = withArray "(a,b,c,d,e,f,g,h)" $ \ary ->
        let n = V.length ary
        in if n /= 8
           then fail $ "cannot unpack array of length " ++
                       show n ++ " into an 8-tuple"
           else (,,,,,,,)
                <$> parseJSONWith a (V.unsafeIndex ary 0)
                <*> parseJSONWith b (V.unsafeIndex ary 1)
                <*> parseJSONWith c (V.unsafeIndex ary 2)
                <*> parseJSONWith d (V.unsafeIndex ary 3)
                <*> parseJSONWith e (V.unsafeIndex ary 4)
                <*> parseJSONWith f (V.unsafeIndex ary 5)
                <*> parseJSONWith g (V.unsafeIndex ary 6)
                <*> parseJSONWith h (V.unsafeIndex ary 7)
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f, FromJSONWith g, FromJSONWith h, FromJSONWith i) => FromJSONWith (a, b, c, d, e, f, g, h, i) where
    parseJSONWith (a, b, c, d, e, f, g, h, i) = withArray "(a,b,c,d,e,f,g,h,i)" $ \ary ->
        let n = V.length ary
        in if n /= 9
           then fail $ "cannot unpack array of length " ++
                       show n ++ " into a 9-tuple"
           else (,,,,,,,,)
                <$> parseJSONWith a (V.unsafeIndex ary 0)
                <*> parseJSONWith b (V.unsafeIndex ary 1)
                <*> parseJSONWith c (V.unsafeIndex ary 2)
                <*> parseJSONWith d (V.unsafeIndex ary 3)
                <*> parseJSONWith e (V.unsafeIndex ary 4)
                <*> parseJSONWith f (V.unsafeIndex ary 5)
                <*> parseJSONWith g (V.unsafeIndex ary 6)
                <*> parseJSONWith h (V.unsafeIndex ary 7)
                <*> parseJSONWith i (V.unsafeIndex ary 8)
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f, FromJSONWith g, FromJSONWith h, FromJSONWith i, FromJSONWith j) => FromJSONWith (a, b, c, d, e, f, g, h, i, j) where
    parseJSONWith (a, b, c, d, e, f, g, h, i, j) = withArray "(a,b,c,d,e,f,g,h,i,j)" $ \ary ->
        let n = V.length ary
        in if n /= 10
           then fail $ "cannot unpack array of length " ++
                       show n ++ " into a 10-tuple"
           else (,,,,,,,,,)
                <$> parseJSONWith a (V.unsafeIndex ary 0)
                <*> parseJSONWith b (V.unsafeIndex ary 1)
                <*> parseJSONWith c (V.unsafeIndex ary 2)
                <*> parseJSONWith d (V.unsafeIndex ary 3)
                <*> parseJSONWith e (V.unsafeIndex ary 4)
                <*> parseJSONWith f (V.unsafeIndex ary 5)
                <*> parseJSONWith g (V.unsafeIndex ary 6)
                <*> parseJSONWith h (V.unsafeIndex ary 7)
                <*> parseJSONWith i (V.unsafeIndex ary 8)
                <*> parseJSONWith j (V.unsafeIndex ary 9)
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f, FromJSONWith g, FromJSONWith h, FromJSONWith i, FromJSONWith j, FromJSONWith k) => FromJSONWith (a, b, c, d, e, f, g, h, i, j, k) where
    parseJSONWith (a, b, c, d, e, f, g, h, i, j, k) = withArray "(a,b,c,d,e,f,g,h,i,j,k)" $ \ary ->
        let n = V.length ary
        in if n /= 11
           then fail $ "cannot unpack array of length " ++
                       show n ++ " into an 11-tuple"
           else (,,,,,,,,,,)
                <$> parseJSONWith a (V.unsafeIndex ary 0)
                <*> parseJSONWith b (V.unsafeIndex ary 1)
                <*> parseJSONWith c (V.unsafeIndex ary 2)
                <*> parseJSONWith d (V.unsafeIndex ary 3)
                <*> parseJSONWith e (V.unsafeIndex ary 4)
                <*> parseJSONWith f (V.unsafeIndex ary 5)
                <*> parseJSONWith g (V.unsafeIndex ary 6)
                <*> parseJSONWith h (V.unsafeIndex ary 7)
                <*> parseJSONWith i (V.unsafeIndex ary 8)
                <*> parseJSONWith j (V.unsafeIndex ary 9)
                <*> parseJSONWith k (V.unsafeIndex ary 10)
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f, FromJSONWith g, FromJSONWith h, FromJSONWith i, FromJSONWith j, FromJSONWith k, FromJSONWith l) => FromJSONWith (a, b, c, d, e, f, g, h, i, j, k, l) where
    parseJSONWith (a, b, c, d, e, f, g, h, i, j, k, l) = withArray "(a,b,c,d,e,f,g,h,i,j,k,l)" $ \ary ->
        let n = V.length ary
        in if n /= 12
           then fail $ "cannot unpack array of length " ++
                       show n ++ " into a 12-tuple"
           else (,,,,,,,,,,,)
                <$> parseJSONWith a (V.unsafeIndex ary 0)
                <*> parseJSONWith b (V.unsafeIndex ary 1)
                <*> parseJSONWith c (V.unsafeIndex ary 2)
                <*> parseJSONWith d (V.unsafeIndex ary 3)
                <*> parseJSONWith e (V.unsafeIndex ary 4)
                <*> parseJSONWith f (V.unsafeIndex ary 5)
                <*> parseJSONWith g (V.unsafeIndex ary 6)
                <*> parseJSONWith h (V.unsafeIndex ary 7)
                <*> parseJSONWith i (V.unsafeIndex ary 8)
                <*> parseJSONWith j (V.unsafeIndex ary 9)
                <*> parseJSONWith k (V.unsafeIndex ary 10)
                <*> parseJSONWith l (V.unsafeIndex ary 11)
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f, FromJSONWith g, FromJSONWith h, FromJSONWith i, FromJSONWith j, FromJSONWith k, FromJSONWith l, FromJSONWith m) => FromJSONWith (a, b, c, d, e, f, g, h, i, j, k, l, m) where
    parseJSONWith (a, b, c, d, e, f, g, h, i, j, k, l, m) = withArray "(a,b,c,d,e,f,g,h,i,j,k,l,m)" $ \ary ->
        let n = V.length ary
        in if n /= 13
           then fail $ "cannot unpack array of length " ++
                       show n ++ " into a 13-tuple"
           else (,,,,,,,,,,,,)
                <$> parseJSONWith a (V.unsafeIndex ary 0)
                <*> parseJSONWith b (V.unsafeIndex ary 1)
                <*> parseJSONWith c (V.unsafeIndex ary 2)
                <*> parseJSONWith d (V.unsafeIndex ary 3)
                <*> parseJSONWith e (V.unsafeIndex ary 4)
                <*> parseJSONWith f (V.unsafeIndex ary 5)
                <*> parseJSONWith g (V.unsafeIndex ary 6)
                <*> parseJSONWith h (V.unsafeIndex ary 7)
                <*> parseJSONWith i (V.unsafeIndex ary 8)
                <*> parseJSONWith j (V.unsafeIndex ary 9)
                <*> parseJSONWith k (V.unsafeIndex ary 10)
                <*> parseJSONWith l (V.unsafeIndex ary 11)
                <*> parseJSONWith m (V.unsafeIndex ary 12)
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f, FromJSONWith g, FromJSONWith h, FromJSONWith i, FromJSONWith j, FromJSONWith k, FromJSONWith l, FromJSONWith m, FromJSONWith n) => FromJSONWith (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where
    parseJSONWith (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = withArray "(a,b,c,d,e,f,g,h,i,j,k,l,m,n)" $ \ary ->
        let num = V.length ary
        in if num /= 14
           then fail $ "cannot unpack array of length " ++
                       show num ++ " into a 14-tuple"
           else (,,,,,,,,,,,,,)
                <$> parseJSONWith a (V.unsafeIndex ary 0)
                <*> parseJSONWith b (V.unsafeIndex ary 1)
                <*> parseJSONWith c (V.unsafeIndex ary 2)
                <*> parseJSONWith d (V.unsafeIndex ary 3)
                <*> parseJSONWith e (V.unsafeIndex ary 4)
                <*> parseJSONWith f (V.unsafeIndex ary 5)
                <*> parseJSONWith g (V.unsafeIndex ary 6)
                <*> parseJSONWith h (V.unsafeIndex ary 7)
                <*> parseJSONWith i (V.unsafeIndex ary 8)
                <*> parseJSONWith j (V.unsafeIndex ary 9)
                <*> parseJSONWith k (V.unsafeIndex ary 10)
                <*> parseJSONWith l (V.unsafeIndex ary 11)
                <*> parseJSONWith m (V.unsafeIndex ary 12)
                <*> parseJSONWith n (V.unsafeIndex ary 13)
    {-# INLINE parseJSONWith #-}

instance (FromJSONWith a, FromJSONWith b, FromJSONWith c, FromJSONWith d, FromJSONWith e, FromJSONWith f, FromJSONWith g, FromJSONWith h, FromJSONWith i, FromJSONWith j, FromJSONWith k, FromJSONWith l, FromJSONWith m, FromJSONWith n, FromJSONWith o) => FromJSONWith (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where
    parseJSONWith (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = withArray "(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)" $ \ary ->
        let num = V.length ary
        in if num /= 15
           then fail $ "cannot unpack array of length " ++
                       show num ++ " into a 15-tuple"
           else (,,,,,,,,,,,,,,)
                <$> parseJSONWith a (V.unsafeIndex ary 0)
                <*> parseJSONWith b (V.unsafeIndex ary 1)
                <*> parseJSONWith c (V.unsafeIndex ary 2)
                <*> parseJSONWith d (V.unsafeIndex ary 3)
                <*> parseJSONWith e (V.unsafeIndex ary 4)
                <*> parseJSONWith f (V.unsafeIndex ary 5)
                <*> parseJSONWith g (V.unsafeIndex ary 6)
                <*> parseJSONWith h (V.unsafeIndex ary 7)
                <*> parseJSONWith i (V.unsafeIndex ary 8)
                <*> parseJSONWith j (V.unsafeIndex ary 9)
                <*> parseJSONWith k (V.unsafeIndex ary 10)
                <*> parseJSONWith l (V.unsafeIndex ary 11)
                <*> parseJSONWith m (V.unsafeIndex ary 12)
                <*> parseJSONWith n (V.unsafeIndex ary 13)
                <*> parseJSONWith o (V.unsafeIndex ary 14)
    {-# INLINE parseJSONWith #-}

FromJSONWithTH.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

-- Uncomment this for GHCi purposes
-- #define MIN_VERSION_template_haskell(x,y,z) 1

{-|
Module:      FromJSONWithTH
Copyright:   (c) 2011, 2012 Bryan O'Sullivan
             (c) 2011 MailRank, Inc.
             (c) 2015 Ryan Scott
License:     BSD3
Stability:   Experimental
Portability: Template Haskell

Functions to mechanically derive 'ToJSON' and 'FromJSONWith' instances.
This is mostly identical to 'Data.Aeson.TH', except with 'FromJSON' gutted
out and replaced with 'FromJSONWith'.
-}
module FromJSONWithTH
    ( -- * Encoding configuration
      Options(..), SumEncoding(..)
    , defaultOptions, defaultTaggedObject, remoteOptions

     -- * FromJSON, FromJSONWith and ToJSON derivation
    , deriveJSONWith
    , deriveFromJSONWith
    , mkParseJSONWith

    , deriveJSON
    , deriveToJSON
    , mkToJSON
    , deriveFromJSON
    , mkParseJSON
    ) where

--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

-- from aeson:
import Data.Aeson ( Object )
import FromJSONWith ( FromJSONWith(..), retrieveWith, retrieveWithMaybe )
import Data.Aeson.TH ( deriveJSON, deriveToJSON, mkToJSON
                     , deriveFromJSON, mkParseJSON
                     )
import Data.Aeson.Types ( Value(..), Parser
                        , Options(..)
                        , SumEncoding(..)
                        , defaultOptions
                        , defaultTaggedObject
                        )
-- from base:
import Control.Applicative ( pure, (<$>), (<*>) )
import Control.Monad       ( return, liftM2, fail, replicateM )
import Data.Bool           ( Bool(False, True), otherwise, (&&) )
import Data.Eq             ( (==) )
import Data.Function       ( ($), (.) )
import Data.Functor        ( fmap )
import Data.Int            ( Int )
import Data.Either         ( Either(Left, Right) )
import Data.List           ( (++), foldl, foldl', intercalate
                           , length, map, zip, genericLength, all
                           )
import Data.Maybe          ( Maybe(Nothing, Just) )
import Prelude             ( String, error, undefined )
import Text.Printf         ( printf )
import Text.Show           ( show )
-- from unordered-containers:
import qualified Data.HashMap.Strict as H ( lookup, toList )
-- from template-haskell:
import Language.Haskell.TH
import Language.Haskell.TH.Syntax ( VarStrictType )
-- from text:
import qualified Data.Text as T ( Text, pack, unpack )
-- from vector:
import qualified Data.Vector as V ( unsafeIndex, null, length )


--------------------------------------------------------------------------------
-- Convenience
--------------------------------------------------------------------------------

-- | Generates both 'ToJSON' and 'FromJSONWith' instance declarations for the
-- given data type.
--
-- This is a convienience function which is equivalent to calling both
-- 'deriveToJSON' and 'deriveFromJSONWith'.
deriveJSONWith :: Options
               -- ^ Encoding options.
               -> Name
               -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSONWith'
               -- instances.
               -> Q [Dec]
deriveJSONWith opts name =
    liftM2 (++)
           (deriveToJSON       opts name)
           (deriveFromJSONWith opts name)

remoteOptions :: Options
remoteOptions = defaultOptions {
    constructorTagModifier = \conTag -> case conTag of
        ('R':rest) -> rest
        _ -> error "Wrong constructor prefix"
  , fieldLabelModifier = \fieldLabel -> case fieldLabel of
        ('r':rest) -> rest
        _ -> error "Wrong field label prefix"
}

--------------------------------------------------------------------------------
-- FromJSONWith
--------------------------------------------------------------------------------

-- | Generates a 'FromJSONWith' instance declaration for the given data type.
deriveFromJSONWith :: Options
                   -- ^ Encoding options.
                   -> Name
                   -- ^ Name of the type for which to generate a 'FromJSONWith' instance
                   -- declaration.
                   -> Q [Dec]
deriveFromJSONWith opts name =
    withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
  where
    fromCons :: [TyVarBndr] -> [Con] -> Q Dec
    fromCons tvbs cons =
        instanceD (applyCon ''FromJSONWith typeNames)
                  (classType `appT` instanceType)
                  [ funD 'parseJSONWith
                         [ clause []
                                  (normalB $ consFromJSONWith name opts cons)
                                  []
                         ]
                  ]
      where
        classType = conT ''FromJSONWith
        typeNames = map tvbName tvbs
        instanceType = foldl' appT (conT name) $ map varT typeNames

-- | Generates a lambda expression which parses the JSON encoding of the given
-- data type.
mkParseJSONWith :: Options -- ^ Encoding options.
                -> Name -- ^ Name of the encoded type.
                -> Q Exp
mkParseJSONWith opts name =
    withType name (\_ cons -> consFromJSONWith name opts cons)

-- | Helper function used by both 'deriveFromJSONWith' and 'mkParseJSONWith'. Generates
-- code to parse the JSON encoding of a number of constructors. All constructors
-- must be from the same type.
consFromJSONWith :: Name
                 -- ^ Name of the type to which the constructors belong.
                 -> Options
                 -- ^ Encoding options
                 -> [Con]
                 -- ^ Constructors for which to generate JSON parsing code.
                 -> Q Exp

consFromJSONWith _ _ [] = error $ "Data.Aeson.FromJSONWith.TH.consFromJSONWith: "
                                  ++ "Not a single constructor given!"

consFromJSONWith tName opts [con] = do
  ref   <- newName "ref"
  value <- newName "value"
  rs    <- replicateM (numFields con) $ newName "_r"
  lamE [varP ref, varP value] (parseArgs tName opts con ref rs (Right value))

consFromJSONWith tName opts cons = do
  ref   <- newName "ref"
  value <- newName "value"

  let allNullaryMatches conName =
        [ do txt <- newName "txt"
             match (conP 'String [varP txt])
                   (guardedB $
                    [ liftM2 (,) (normalG $
                                    infixApp (varE txt)
                                             [|(==)|]
                                             ([|T.pack|] `appE`
                                                conStringE opts conName)
                                 )
                                 ([|pure|] `appE` conE conName)
                    ]
                    ++
                    [ liftM2 (,)
                        (normalG [|otherwise|])
                        ( [|noMatchFail|]
                          `appE` (varE ref)
                          `appE` (litE $ stringL $ show tName)
                          `appE` ([|T.unpack|] `appE` varE txt)
                        )
                    ]
                   )
                   []
        , do other <- newName "other"
             match (varP other)
                   (normalB $ [|noStringFail|]
                      `appE` (varE ref)
                      `appE` (litE $ stringL $ show tName)
                      `appE` ([|valueConName|] `appE` varE other)
                   )
                   []
        ]

      mixedMatches con rs =
          case sumEncoding opts of
            TaggedObject {tagFieldName, contentsFieldName} ->
              parseObject $ parseTaggedObject con rs tagFieldName contentsFieldName
            ObjectWithSingleField ->
              parseObject $ parseObjectWithSingleField con rs
            TwoElemArray ->
              [ do arr <- newName "array"
                   match (conP 'Array [varP arr])
                         (guardedB $
                          [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
                                                           [|(==)|]
                                                           (litE $ integerL 2))
                                       (parse2ElemArray con rs arr)
                          , liftM2 (,) (normalG [|otherwise|])
                                       (([|not2ElemArray|]
                                         `appE` (varE ref)
                                         `appE` (litE $ stringL $ show tName)
                                         `appE` ([|V.length|] `appE` varE arr)))
                          ]
                         )
                         []
              , do other <- newName "other"
                   match (varP other)
                         ( normalB
                           $ [|noArrayFail|]
                               `appE` (varE ref)
                               `appE` (litE $ stringL $ show tName)
                               `appE` ([|valueConName|] `appE` varE other)
                         )
                         []
              ]

      parseObject f =
          [ do obj <- newName "obj"
               match (conP 'Object [varP obj]) (normalB $ f obj) []
          , do other <- newName "other"
               match (varP other)
                     ( normalB
                       $ [|noObjectFail|]
                           `appE` (varE ref)
                           `appE` (litE $ stringL $ show tName)
                           `appE` ([|valueConName|] `appE` varE other)
                     )
                     []
          ]

      parseTaggedObject con rs typFieldName valFieldName obj = do
        conKey <- newName "conKey"
        doE [ bindS (varP conKey)
                    ([|retrieveWith|]
                      `appE` [|undefined|]
                      `appE` varE obj
                      `appE` ([|T.pack|] `appE` stringE typFieldName))
            , noBindS $ parseContents con rs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
            ]

      parse2ElemArray con rs arr = do
        conKey <- newName "conKey"
        conVal <- newName "conVal"
        let letIx n ix =
                valD (varP n)
                     (normalB ([|V.unsafeIndex|] `appE`
                                 varE arr `appE`
                                 litE (integerL ix)))
                     []
        letE [ letIx conKey 0
             , letIx conVal 1
             ]
             (caseE (varE conKey)
                    [ do txt <- newName "txt"
                         match (conP 'String [varP txt])
                               (normalB $ parseContents con
                                                        rs
                                                        txt
                                                        (Right conVal)
                                                        'conNotFoundFail2ElemArray
                               )
                               []
                    , do other <- newName "other"
                         match (varP other)
                               ( normalB
                                 $ [|firstElemNoStringFail|]
                                       `appE` (litE $ stringL $ show tName)
                                       `appE` ([|valueConName|] `appE` varE other)
                               )
                               []
                    ]
             )

      parseObjectWithSingleField con rs obj = do
        conKey <- newName "conKey"
        conVal <- newName "conVal"
        caseE ([e|H.toList|] `appE` varE obj)
              [ match (listP [tupP [varP conKey, varP conVal]])
                      (normalB $ parseContents con rs conKey (Right conVal) 'conNotFoundFailObjectSingleField)
                      []
              , do other <- newName "other"
                   match (varP other)
                         (normalB $ [|wrongPairCountFail|]
                                    `appE` (varE ref)
                                    `appE` (litE $ stringL $ show tName)
                                    `appE` ([|show . length|] `appE` varE other)
                         )
                         []
              ]

      parseContents con rs conKey contents errorFun =
          caseE (varE conKey)
                [ match wildP
                        ( guardedB $
                          [ do g <- normalG $ infixApp (varE conKey)
                                                       [|(==)|]
                                                       ([|T.pack|] `appE`
                                                          conNameExp opts con)
                               e <- parseArgs tName opts con ref rs contents
                               return (g, e)
                          ]
                          ++
                          [ liftM2 (,)
                                   (normalG [e|otherwise|])
                                   ( varE errorFun
                                     `appE` (varE ref)
                                     `appE` (litE $ stringL $ show tName)
                                     `appE` listE (map ( litE
                                                       . stringL
                                                       . constructorTagModifier opts
                                                       . nameBase
                                                       . getConName
                                                       ) cons
                                                  )
                                     `appE` ([|T.unpack|] `appE` varE conKey)
                                   )
                          ]
                        )
                        []
                ]

  lamE [varP ref, varP value] $ caseE (varE ref) $
    [ do rs <- replicateM (numFields con) $ newName "_r"
         match (conP conName $ map varP rs)
               (normalB $ caseE (varE value) $
                   if allNullaryToStringTag opts && all isNullary cons
                      then allNullaryMatches conName
                      else mixedMatches con rs
               )
               []
    | con <- cons
    , let conName = getConName con
    ]

parseNullaryMatches :: Name -> Name -> Name -> [Q Match]
parseNullaryMatches tName conName ref =
    [ do arr <- newName "arr"
         match (conP 'Array [varP arr])
               (guardedB $
                [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)
                             ([|pure|] `appE` conE conName)
                , liftM2 (,) (normalG [|otherwise|])
                             (parseTypeMismatch (varE ref) tName conName
                                (litE $ stringL "an empty Array")
                                (infixApp (litE $ stringL $ "Array of length ")
                                          [|(++)|]
                                          ([|show . V.length|] `appE` varE arr)
                                )
                             )
                ]
               )
               []
    , matchFailed ref tName conName "Array"
    ]

parseUnaryMatches :: Name -> Name -> [Q Match]
parseUnaryMatches conName r =
    [ do arg <- newName "arg"
         match (varP arg)
               ( normalB $ infixApp (conE conName)
                                    [|(<$>)|]
                                    ([|parseJSONWith|]
                                        `appE` varE r
                                        `appE` varE arg)
               )
               []
    ]

parseRecord :: Options -> Name -> Name -> [VarStrictType] -> Name -> [Name] -> ExpQ
parseRecord opts tName conName ts obj rs = do
    let x:xs = [ [|lookupFieldWith|]
                 `appE` (litE $ stringL $ show tName)
                 `appE` (litE $ stringL $ constructorTagModifier opts $ nameBase conName)
                 `appE` varE r
                 `appE` (varE obj)
                 `appE` ( [|T.pack|] `appE` fieldLabelExp opts field
                        )
               | ((field, _, _), r) <- zip ts rs
               ]

    foldl' (\a b -> infixApp a [|(<*>)|] b)
           (infixApp (conE conName) [|(<$>)|] x)
           xs

getValField :: Name -> String -> [MatchQ] -> Q Exp
getValField obj valFieldName matches = do
  val <- newName "val"
  doE [ bindS (varP val) $ [|retrieveWith|]
                            `appE` [|undefined|]
                            `appE` varE obj
                            `appE` ([|T.pack|] `appE`
                                       (litE $ stringL valFieldName))
      , noBindS $ caseE (varE val) matches
      ]

-- | Generates code to parse the JSON encoding of a single constructor.
parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
          -> Options -- ^ Encoding options.
          -> Con -- ^ Constructor for which to generate JSON parsing code.
          -> Name
          -> [Name]
          -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
                                        --   Right valName
          -> Q Exp
-- Nullary constructors.
parseArgs tName _ (NormalC conName []) ref _ (Left (valFieldName, obj)) =
  getValField obj valFieldName $ parseNullaryMatches tName conName ref
parseArgs tName _ (NormalC conName []) ref _ (Right valName) =
  caseE (varE valName) $ parseNullaryMatches tName conName ref

-- Unary constructors.
parseArgs _ _ (NormalC conName [_]) _ [r] (Left (valFieldName, obj)) =
  getValField obj valFieldName $ parseUnaryMatches conName  r
parseArgs _ _ (NormalC conName [_]) _ [r] (Right valName) =
  caseE (varE valName) $ parseUnaryMatches conName r

-- Polyadic constructors.
parseArgs tName _ (NormalC conName _) ref rs (Left (valFieldName, obj)) =
    getValField obj valFieldName $ parseProduct tName conName ref rs
parseArgs tName _ (NormalC conName _) ref rs (Right valName) =
    caseE (varE valName) $ parseProduct tName conName ref rs

-- Records.
parseArgs tName opts (RecC conName ts) _ rs (Left (_, obj)) =
    parseRecord opts tName conName ts obj rs
parseArgs tName opts (RecC conName ts) ref rs (Right valName) = do
  obj <- newName "recObj"
  caseE (varE valName)
    [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj rs) []
    , matchFailed ref tName conName "Object"
    ]

-- Infix constructors. Apart from syntax these are the same as
-- polyadic constructors.
parseArgs tName _ (InfixC _ conName _) ref rs (Left (valFieldName, obj)) =
    getValField obj valFieldName $ parseProduct tName conName ref rs
parseArgs tName _ (InfixC _ conName _) ref rs (Right valName) =
    caseE (varE valName) $ parseProduct tName conName ref rs

-- Existentially quantified constructors. We ignore the quantifiers
-- and proceed with the contained constructor.
parseArgs tName opts (ForallC _ _ con) ref rs contents =
    parseArgs tName opts con ref rs contents

-- | Generates code to parse the JSON encoding of an n-ary
-- constructor.
parseProduct :: Name -- ^ Name of the type to which the constructor belongs.
             -> Name -- ^ 'Con'structor name.
             -> Name
             -> [Name]
             -> [Q Match]
parseProduct tName conName ref rs =
    [ do let numArgs = genericLength rs
         arr <- newName "arr"
         -- List of: "parseJSONWith <r_IX> (arr `V.unsafeIndex` <IX>)"
         let x:xs = [ [|parseJSONWith|]
                      `appE` varE r
                      `appE`
                      infixApp (varE arr)
                               [|V.unsafeIndex|]
                               (litE $ integerL ix)
                    | (ix, r) <- zip [0 ..] rs
                    ]
         match (conP 'Array [varP arr])
               (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr)
                                           [|(==)|]
                                           (litE $ integerL numArgs)
                                )
                                ( foldl' (\a b -> infixApp a [|(<*>)|] b)
                                         (infixApp (conE conName) [|(<$>)|] x)
                                         xs
                                )
                                ( parseTypeMismatch (varE ref) tName conName
                                    (litE $ stringL $ "Array of length " ++ show numArgs)
                                    ( infixApp (litE $ stringL $ "Array of length ")
                                               [|(++)|]
                                               ([|show . V.length|] `appE` varE arr)
                                    )
                                )
               )
               []
    , matchFailed ref tName conName "Array"
    ]


--------------------------------------------------------------------------------
-- Parsing errors
--------------------------------------------------------------------------------

matchFailed :: Name -> Name -> Name -> String -> MatchQ
matchFailed ref tName conName expected = do
  other <- newName "other"
  match (varP other)
        ( normalB $ parseTypeMismatch (varE ref) tName conName
                      (litE $ stringL expected)
                      ([|valueConName|] `appE` varE other)
        )
        []

parseTypeMismatch :: ExpQ -> Name -> Name -> ExpQ -> ExpQ -> ExpQ
parseTypeMismatch ref tName conName expected actual =
    foldl appE
          [|parseTypeMismatch'|]
          [ ref
          , litE $ stringL $ nameBase conName
          , litE $ stringL $ show tName
          , expected
          , actual
          ]

class (FromJSONWith a) => LookupFieldWith a where
    lookupFieldWith :: String -> String -> a -> Object -> T.Text -> Parser a

instance (FromJSONWith a) => LookupFieldWith a where
    lookupFieldWith tName rec e obj key =
        case H.lookup key obj of
          Nothing -> unknownFieldFail e tName rec (T.unpack key)
          Just v  -> parseJSONWith e v

instance (FromJSONWith a) => LookupFieldWith (Maybe a) where
    lookupFieldWith _ _ = retrieveWithMaybe

unknownFieldFail :: fail -> String -> String -> String -> Parser fail
unknownFieldFail _ tName rec key =
    fail $ printf "When parsing the record %s of type %s the key %s was not present."
                  rec tName key

noArrayFail :: fail -> String -> String -> Parser fail
noArrayFail _ t o = fail $ printf "When parsing %s expected Array but got %s." t o

noObjectFail :: fail -> String -> String -> Parser fail
noObjectFail _ t o = fail $ printf "When parsing %s expected Object but got %s." t o

firstElemNoStringFail :: fail -> String -> String -> Parser fail
firstElemNoStringFail _ t o = fail $ printf "When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." t o

wrongPairCountFail :: fail -> String -> String -> Parser fail
wrongPairCountFail _ t n =
    fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs."
                  t n

noStringFail :: fail -> String -> String -> Parser fail
noStringFail _ t o = fail $ printf "When parsing %s expected String but got %s." t o

noMatchFail :: fail -> String -> String -> Parser fail
noMatchFail _ t o =
    fail $ printf "When parsing %s expected a String with the tag of a constructor but got %s." t o

not2ElemArray :: fail -> String -> Int -> Parser fail
not2ElemArray _ t i = fail $ printf "When parsing %s expected an Array of 2 elements but got %i elements" t i

conNotFoundFail2ElemArray :: fail -> String -> [String] -> String -> Parser fail
conNotFoundFail2ElemArray _ t cs o =
    fail $ printf "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s."
                  t (intercalate ", " cs) o

conNotFoundFailObjectSingleField :: fail -> String -> [String] -> String -> Parser fail
conNotFoundFailObjectSingleField _ t cs o =
    fail $ printf "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s."
                  t (intercalate ", " cs) o

conNotFoundFailTaggedObject :: fail -> String -> [String] -> String -> Parser fail
conNotFoundFailTaggedObject _ t cs o =
    fail $ printf "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s."
                  t (intercalate ", " cs) o

parseTypeMismatch' :: fail -> String -> String -> String -> String -> Parser fail
parseTypeMismatch' _ tName conName expected actual =
    fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."
                  conName tName expected actual


--------------------------------------------------------------------------------
-- Utility functions
--------------------------------------------------------------------------------

-- | Boilerplate for top level splices.
--
-- The given 'Name' must be from a type constructor. Furthermore, the
-- type constructor must be either a data type or a newtype. Any other
-- value will result in an exception.
withType :: Name
         -> ([TyVarBndr] -> [Con] -> Q a)
         -- ^ Function that generates the actual code. Will be applied
         -- to the type variable binders and constructors extracted
         -- from the given 'Name'.
         -> Q a
         -- ^ Resulting value in the 'Q'uasi monad.
withType name f = do
    info <- reify name
    case info of
      TyConI dec ->
        case dec of
          DataD    _ _ tvbs cons _ -> f tvbs cons
          NewtypeD _ _ tvbs con  _ -> f tvbs [con]
          other -> error $ "Data.Aeson.FromJSONWith.TH.withType: Unsupported type: "
                          ++ show other
      _ -> error "Data.Aeson.FromJSONWith.TH.withType: I need the name of a type."

-- | Extracts the name from a constructor.
getConName :: Con -> Name
getConName (NormalC name _)  = name
getConName (RecC name _)     = name
getConName (InfixC _ name _) = name
getConName (ForallC _ _ con) = getConName con

-- | Extracts the name from a type variable binder.
tvbName :: TyVarBndr -> Name
tvbName (PlainTV  name  ) = name
tvbName (KindedTV name _) = name

-- | Makes a string literal expression from a constructor's name.
conNameExp :: Options -> Con -> Q Exp
conNameExp opts = litE
                . stringL
                . constructorTagModifier opts
                . nameBase
                . getConName

-- | Creates a string literal expression from a record field label.
fieldLabelExp :: Options -- ^ Encoding options
              -> Name
              -> Q Exp
fieldLabelExp opts = litE . stringL . fieldLabelModifier opts . nameBase

-- | The name of the outermost 'Value' constructor.
valueConName :: Value -> String
valueConName (Object _) = "Object"
valueConName (Array  _) = "Array"
valueConName (String _) = "String"
valueConName (Number _) = "Number"
valueConName (Bool   _) = "Boolean"
valueConName Null       = "Null"

applyCon :: Name -> [Name] -> Q [Pred]
applyCon con typeNames = return (map apply typeNames)
  where apply t =
#if MIN_VERSION_template_haskell(2,10,0)
          AppT (ConT con) (VarT t)
#else
          ClassP con [VarT t]
#endif

conStringE :: Options -> Name -> Q Exp
conStringE opts = stringE . constructorTagModifier opts . nameBase

-- | If constructor is nullary.
isNullary :: Con -> Bool
isNullary (NormalC _ []) = True
isNullary _ = False

numFields :: Con -> Int
numFields (NormalC _ ts)    = length ts
numFields (RecC    _ ts)    = length ts
numFields InfixC{}           = 2
numFields (ForallC _ _ con) = numFields con