{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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 Control.Applicative (liftA2)
import Servant.Multipart.API (MultipartData(MultipartData), Input)

#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 = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (String -> Options
jsonOptions (forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName (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 = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON (String -> Options
jsonOptions (forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName (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 = forall {k} (f :: k -> *) (p :: k). GSomeJSON f => f p -> Value
gsomeToJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: String -> String
fieldLabelModifier     = String -> String -> String
snakeFieldModifier String
tname
  , constructorTagModifier :: String -> String
constructorTagModifier = String -> String -> String
snakeFieldModifier String
tname
  , omitNothingFields :: Bool
omitNothingFields      = Bool
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 forall a. a -> [a] -> [a]
: String -> [String]
camelWords String
restLs
      String
_       -> (String
us forall a. [a] -> [a] -> [a]
++ String
ls) forall a. a -> [a] -> [a]
: String -> [String]
camelWords String
rest
  where
   (String
us, String
restLs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span  Char -> Bool
isUpper String
s
   (String
ls, String
rest)   = 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 forall a. Eq a => a -> a -> Bool
== a
y = 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) = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
w forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
capitalise [String]
ws

wordsToSnake :: [String] -> String
wordsToSnake :: [String] -> String
wordsToSnake = forall a. [a] -> [[a]] -> [a]
intercalate String
"_" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (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 forall a. a -> [a] -> [a]
: String
s
capitalise String
"" = String
""

stripCommonPrefixWords :: String -> String -> [String]
stripCommonPrefixWords :: String -> String -> [String]
stripCommonPrefixWords String
xs String
ys =
  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) = 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 = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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))) = 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 = (forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall {k} (f :: k -> *) (p :: k). GSomeJSON f => f p -> Value
gsomeToJSON f p
x
  gsomeToJSON (R1 g p
y) = 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
      = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) (p :: k).
GSomeJSON f =>
Value -> Parser (f p)
gsomeParseJSON Value
js
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a b. (a -> b) -> a -> b
$  forall v. KeyMap v -> KeyMap v -> KeyMap v
Map.union Object
obj (forall v. [(Key, v)] -> KeyMap v
Map.fromList [Pair]
pairs)
addJsonFields Value
x [Pair]
_ = Value
x

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

-- Instance Monoid for TH of ghc < 8.6
#if !MIN_VERSION_template_haskell(2,17,0)

instance Semigroup a => Semigroup (Q a) where
  (<>) = liftA2 (<>)

instance Monoid a => Monoid (Q a) where
  mempty = pure mempty

#endif