{-# 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 :: 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
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 :: 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
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 :: a -> Value
genericSomeToJSON = Rep a Any -> 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 a x. Generic a => a -> Rep a x
from

genericSomeParseJSON :: (Generic a, GSomeJSON (Rep a)) => Value -> Parser a
genericSomeParseJSON :: Value -> Parser a
genericSomeParseJSON = (Rep a Any -> a) -> Parser (Rep a Any) -> Parser a
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
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 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 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 :: [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 :: D1 d f p -> Value
gsomeToJSON (M1 f p
x) = f p -> Value
forall k (f :: k -> *) (p :: k). GSomeJSON f => f p -> Value
gsomeToJSON f p
x
  gsomeParseJSON :: Value -> Parser (D1 d f p)
gsomeParseJSON Value
js = f p -> D1 d f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> D1 d f p) -> Parser (f p) -> Parser (D1 d f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: 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 :: Value -> Parser (C1 c (S1 s (K1 i a)) p)
gsomeParseJSON Value
js = (M1 S s (K1 i a) p -> C1 c (S1 s (K1 i a)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 S s (K1 i a) p -> C1 c (S1 s (K1 i a)) p)
-> (a -> M1 S s (K1 i a) p) -> a -> C1 c (S1 s (K1 i a)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a p -> M1 S 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 -> M1 S s (K1 i a) p)
-> (a -> K1 i a p) -> a -> M1 S 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 -> C1 c (S1 s (K1 i a)) p)
-> Parser a -> Parser (C1 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 :: (:+:) f g p -> Value
gsomeToJSON (L1 f p
x) = 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 k (f :: k -> *) (p :: k). GSomeJSON f => f p -> Value
gsomeToJSON g p
y

  gsomeParseJSON :: 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 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 (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 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 ([Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
Map.fromList [Pair]
pairs)
addJsonFields Value
x [Pair]
_ = Value
x

addMultipartFields :: [Input] -> MultipartData tag -> MultipartData tag
addMultipartFields :: [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

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

instance Semigroup a => Semigroup (Q a) where
  <> :: Q a -> Q a -> Q a
(<>) = (a -> a -> a) -> Q a -> Q a -> Q a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => Monoid (Q a) where
  mempty :: Q a
mempty = a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

#endif