{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}

module Data.Aeson.Ext
  ( generateJSONInstance,
    parseJSONDrop,
    toJSONDrop,
  )
where

import Data.Aeson
import Data.Aeson.Types
import GHC.Generics (Generic, Rep)
import Language.Haskell.TH

dropSize :: Type -> Q Int
dropSize :: Type -> Q Int
dropSize (ConT Name
n) = do
  Info
info <- Name -> Q Info
reify Name
n
  case Info
info of
    (TyConI (DataD Cxt
_ Name
_ [] Maybe Type
_ [Con]
cons [DerivClause]
_)) -> [Con] -> Q Int
forall (m :: * -> *). Monad m => [Con] -> m Int
go [Con]
cons
    (TyConI (NewtypeD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Type
_ Con
con [DerivClause]
_)) -> [Con] -> Q Int
forall (m :: * -> *). Monad m => [Con] -> m Int
go [Con
con]
    Info
_ -> String -> Q Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported."
  where
    -- Try only the first record constructor
    rec :: [Con] -> [VarBangType]
rec (Con
x : [Con]
_) = case Con
x of
      (RecC Name
_ [VarBangType]
f) -> [VarBangType]
f
      Con
_ -> String -> [VarBangType]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported"
    rec [] = String -> [VarBangType]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported"
    go :: [Con] -> m Int
go [Con]
cons = do
      let fields :: [VarBangType]
fields = [Con] -> [VarBangType]
rec [Con]
cons
      -- Find prefix from the first field
      let (Name
name, Bang
_, Type
_) = [VarBangType] -> VarBangType
forall a. [a] -> a
head [VarBangType]
fields
      let str :: String
str = Name -> String
nameBase Name
name
      Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> (Int -> Int) -> Int -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') String
str)
dropSize Type
_ = String -> Q Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported"

generateToJSONInstance :: Name -> DecQ
generateToJSONInstance :: Name -> DecQ
generateToJSONInstance Name
targetType =
  Name -> TypeQ
conT Name
targetType TypeQ -> (Type -> Q Int) -> Q Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Q Int
dropSize Q Int -> (Int -> DecQ) -> DecQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
s -> CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''ToJSON) (Name -> TypeQ
conT Name
targetType)) [Integer -> DecQ
gen_f (Integer -> DecQ) -> Integer -> DecQ
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s]
  where
    gen_f :: Integer -> DecQ
gen_f Integer
s = Name -> [ClauseQ] -> DecQ
funD (String -> Name
mkName String
"toJSON") [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE 'toJSONDrop ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
litE (Integer -> Lit
integerL Integer
s))) []]

generateFromJSONInstance :: Name -> DecQ
generateFromJSONInstance :: Name -> DecQ
generateFromJSONInstance Name
targetType =
  Name -> TypeQ
conT Name
targetType TypeQ -> (Type -> Q Int) -> Q Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Q Int
dropSize Q Int -> (Int -> DecQ) -> DecQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
s -> CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''FromJSON) (Name -> TypeQ
conT Name
targetType)) [Integer -> DecQ
gen_f (Integer -> DecQ) -> Integer -> DecQ
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s]
  where
    gen_f :: Integer -> DecQ
gen_f Integer
s = Name -> [ClauseQ] -> DecQ
funD (String -> Name
mkName String
"parseJSON") [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE 'parseJSONDrop ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
litE (Integer -> Lit
integerL Integer
s))) []]

generateJSONInstance :: Name -> Q [Dec]
generateJSONInstance :: Name -> Q [Dec]
generateJSONInstance Name
name = do
  Dec
from <- Name -> DecQ
generateFromJSONInstance Name
name
  Dec
to <- Name -> DecQ
generateToJSONInstance Name
name
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
from, Dec
to]

toJSONDrop ::
  forall a.
  (Generic a, GToJSON Zero (Rep a)) =>
  Int ->
  a ->
  Value
toJSONDrop :: Int -> a -> Value
toJSONDrop Int
prefix =
  Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions {fieldLabelModifier :: String -> String
fieldLabelModifier = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
prefix, omitNothingFields :: Bool
omitNothingFields = Bool
True, sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue}

parseJSONDrop ::
  forall a.
  (Generic a, GFromJSON Zero (Rep a)) =>
  Int ->
  Value ->
  Parser a
parseJSONDrop :: Int -> Value -> Parser a
parseJSONDrop Int
prefix = Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions {fieldLabelModifier :: String -> String
fieldLabelModifier = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
prefix, sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue}