{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
module Telegram.Bot.API.Internal.Utils where

import Control.Applicative ((<|>))
import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), GToJSON, GFromJSON, genericToJSON, genericParseJSON, Zero)
import Data.Aeson.TH (deriveJSON)
import Data.Aeson.Types (Options(..), defaultOptions, Parser, Pair)
import Data.Char (isUpper, toUpper, toLower)
import Data.List (intercalate)
import GHC.Generics
import Language.Haskell.TH
import Servant.Multipart.API (MultipartData(MultipartData), Input)
import Telegram.Bot.API.Internal.TH ()

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as Map
#else
import qualified Data.HashMap.Strict as Map
#endif

deriveJSON' :: Name -> Q [Dec]
deriveJSON' :: Name -> Q [Dec]
deriveJSON' Name
name = Options -> Name -> Q [Dec]
deriveJSON (String -> Options
jsonOptions (Name -> String
nameBase Name
name)) Name
name

gtoJSON :: forall a d f. (Generic a, GToJSON Zero (Rep a), Rep a ~ D1 d f, Datatype d)
  => a -> Value
gtoJSON :: forall a (d :: Meta) (f :: * -> *).
(Generic a, GToJSON Zero (Rep a), Rep a ~ D1 d f, Datatype d) =>
a -> Value
gtoJSON = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (String -> Options
jsonOptions (Proxy3 d f a -> String
forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t d f a -> String
datatypeName (Proxy3 d f a
forall {k} {k} {k} (d :: k) (f :: k) (a :: k). Proxy3 d f a
Proxy3 :: Proxy3 d f a)))

gparseJSON :: forall a d f. (Generic a, GFromJSON Zero (Rep a), Rep a ~ D1 d f, Datatype d)
  => Value -> Parser a
gparseJSON :: forall a (d :: Meta) (f :: * -> *).
(Generic a, GFromJSON Zero (Rep a), Rep a ~ D1 d f, Datatype d) =>
Value -> Parser a
gparseJSON = Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON (String -> Options
jsonOptions (Proxy3 d f a -> String
forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t d f a -> String
datatypeName (Proxy3 d f a
forall {k} {k} {k} (d :: k) (f :: k) (a :: k). Proxy3 d f a
Proxy3 :: Proxy3 d f a)))


genericSomeToJSON :: (Generic a, GSomeJSON (Rep a)) => a -> Value
genericSomeToJSON :: forall a. (Generic a, GSomeJSON (Rep a)) => a -> Value
genericSomeToJSON = Rep a Any -> Value
forall p. Rep a p -> Value
forall {k} (f :: k -> *) (p :: k). GSomeJSON f => f p -> Value
gsomeToJSON (Rep a Any -> Value) -> (a -> Rep a Any) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

genericSomeParseJSON :: (Generic a, GSomeJSON (Rep a)) => Value -> Parser a
genericSomeParseJSON :: forall a. (Generic a, GSomeJSON (Rep a)) => Value -> Parser a
genericSomeParseJSON = (Rep a Any -> a) -> Parser (Rep a Any) -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Parser (Rep a Any) -> Parser a)
-> (Value -> Parser (Rep a Any)) -> Value -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser (Rep a Any)
forall p. Value -> Parser (Rep a p)
forall {k} (f :: k -> *) (p :: k).
GSomeJSON f =>
Value -> Parser (f p)
gsomeParseJSON

data Proxy3 d f a = Proxy3

jsonOptions :: String -> Options
jsonOptions :: String -> Options
jsonOptions String
tname = Options
defaultOptions
  { fieldLabelModifier     = snakeFieldModifier tname
  , constructorTagModifier = snakeFieldModifier tname
  , omitNothingFields      = True
  }

snakeFieldModifier :: String -> String -> String
snakeFieldModifier :: String -> String -> String
snakeFieldModifier String
xs String
ys = [String] -> String
wordsToSnake (String -> String -> [String]
stripCommonPrefixWords String
xs String
ys)

camelWords :: String -> [String]
camelWords :: String -> [String]
camelWords String
"" = []
camelWords String
s
  = case String
us of
      (Char
_:Char
_:String
_) -> String
us String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
camelWords String
restLs
      String
_       -> (String
us String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ls) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
camelWords String
rest
  where
   (String
us, String
restLs) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span  Char -> Bool
isUpper String
s
   (String
ls, String
rest)   = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isUpper String
restLs

stripCommonPrefix :: Eq a => [a] -> [a] -> [a]
stripCommonPrefix :: forall a. Eq a => [a] -> [a] -> [a]
stripCommonPrefix (a
x:[a]
xs) (a
y:[a]
ys) | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
stripCommonPrefix [a]
xs [a]
ys
stripCommonPrefix [a]
_ [a]
ys = [a]
ys

wordsToCamel :: [String] -> String
wordsToCamel :: [String] -> String
wordsToCamel [] = String
""
wordsToCamel (String
w:[String]
ws) = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
w String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
capitalise [String]
ws

wordsToSnake :: [String] -> String
wordsToSnake :: [String] -> String
wordsToSnake = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower)

capitalise :: String -> String
capitalise :: String -> String
capitalise (Char
c:String
s) = Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
s
capitalise String
"" = String
""

stripCommonPrefixWords :: String -> String -> [String]
stripCommonPrefixWords :: String -> String -> [String]
stripCommonPrefixWords String
xs String
ys =
  [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
stripCommonPrefix (String -> [String]
camelWords String
xs) (String -> [String]
camelWords (String -> String
capitalise String
ys))


class GSomeJSON f where
  gsomeToJSON :: f p -> Value
  gsomeParseJSON :: Value -> Parser (f p)

instance GSomeJSON f => GSomeJSON (D1 d f) where
  gsomeToJSON :: forall (p :: k). D1 d f p -> Value
gsomeToJSON (M1 f p
x) = f p -> Value
forall (p :: k). f p -> Value
forall {k} (f :: k -> *) (p :: k). GSomeJSON f => f p -> Value
gsomeToJSON f p
x
  gsomeParseJSON :: forall (p :: k). Value -> Parser (D1 d f p)
gsomeParseJSON Value
js = f p -> M1 D d f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D d f p) -> Parser (f p) -> Parser (M1 D d f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f p)
forall (p :: k). Value -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GSomeJSON f =>
Value -> Parser (f p)
gsomeParseJSON Value
js

instance (ToJSON a, FromJSON a) => GSomeJSON (C1 c (S1 s (K1 i a))) where
  gsomeToJSON :: forall (p :: k). C1 c (S1 s (K1 i a)) p -> Value
gsomeToJSON (M1 (M1 (K1 a
x))) = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x
  gsomeParseJSON :: forall (p :: k). Value -> Parser (C1 c (S1 s (K1 i a)) p)
gsomeParseJSON Value
js = S1 s (K1 i a) p -> M1 C c (S1 s (K1 i a)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (S1 s (K1 i a) p -> M1 C c (S1 s (K1 i a)) p)
-> (a -> S1 s (K1 i a) p) -> a -> M1 C c (S1 s (K1 i a)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a p -> S1 s (K1 i a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i a p -> S1 s (K1 i a) p)
-> (a -> K1 i a p) -> a -> S1 s (K1 i a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 C c (S1 s (K1 i a)) p)
-> Parser a -> Parser (M1 C c (S1 s (K1 i a)) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
js

instance (GSomeJSON f, GSomeJSON g) => GSomeJSON (f :+: g) where
  gsomeToJSON :: forall (p :: k). (:+:) f g p -> Value
gsomeToJSON (L1 f p
x) = f p -> Value
forall (p :: k). f p -> Value
forall {k} (f :: k -> *) (p :: k). GSomeJSON f => f p -> Value
gsomeToJSON f p
x
  gsomeToJSON (R1 g p
y) = g p -> Value
forall (p :: k). g p -> Value
forall {k} (f :: k -> *) (p :: k). GSomeJSON f => f p -> Value
gsomeToJSON g p
y

  gsomeParseJSON :: forall (p :: k). Value -> Parser ((:+:) f g p)
gsomeParseJSON Value
js
      = f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f p -> (:+:) f g p) -> Parser (f p) -> Parser ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f p)
forall (p :: k). Value -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GSomeJSON f =>
Value -> Parser (f p)
gsomeParseJSON Value
js
    Parser ((:+:) f g p)
-> Parser ((:+:) f g p) -> Parser ((:+:) f g p)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g p -> (:+:) f g p) -> Parser (g p) -> Parser ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (g p)
forall (p :: k). Value -> Parser (g p)
forall {k} (f :: k -> *) (p :: k).
GSomeJSON f =>
Value -> Parser (f p)
gsomeParseJSON Value
js

addJsonFields :: Value -> [Pair] -> Value
addJsonFields :: Value -> [Pair] -> Value
addJsonFields (Object Object
obj) [Pair]
pairs = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$  Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
Map.union Object
obj (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ [Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
Map.fromList ((Pair -> Bool) -> [Pair] -> [Pair]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Pair -> Bool) -> Pair -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pair -> Bool
isNull) [Pair]
pairs)
addJsonFields Value
x [Pair]
_ = Value
x

isNull :: Pair -> Bool
isNull :: Pair -> Bool
isNull (Key
_, Value
Null) = Bool
True
isNull Pair
_ = Bool
False

addMultipartFields :: [Input] -> MultipartData tag -> MultipartData tag
addMultipartFields :: forall tag. [Input] -> MultipartData tag -> MultipartData tag
addMultipartFields [Input]
newFields (MultipartData [Input]
currenFields [FileData tag]
files)
      = [Input] -> [FileData tag] -> MultipartData tag
forall tag. [Input] -> [FileData tag] -> MultipartData tag
MultipartData ([Input]
newFields [Input] -> [Input] -> [Input]
forall a. Semigroup a => a -> a -> a
<> [Input]
currenFields) [FileData tag]
files