{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# 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 :: 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