{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Lambdabot.Plugin.Telegram.Bot.Generic where

import Data.Char
import Data.Text (Text)
import Data.Proxy
import qualified Data.Text as Text
import GHC.Generics
import GHC.TypeLits

import Lambdabot.Plugin.Telegram.Shared

-- | Helper type class used to derive 'FromCommand' via DeriveGeneric extension.
class GFromCommand command where
  gGetMessage :: command proxy -> Msg
  gGetPrefix :: command proxy -> Text

-- Empty data decl
instance GFromCommand V1 where
  gGetMessage :: V1 proxy -> Msg
gGetMessage V1 proxy
x = case V1 proxy
x of { }
  gGetPrefix :: V1 proxy -> Text
gGetPrefix  V1 proxy
x = case V1 proxy
x of { } 

instance (FromCommand c) => GFromCommand (K1 i c) where
  gGetMessage :: K1 i c proxy -> Msg
gGetMessage (K1 c
x) = c -> Msg
forall command. FromCommand command => command -> Msg
getMessage c
x
  gGetPrefix :: K1 i c proxy -> Text
gGetPrefix (K1 c
x) = c -> Text
forall command. FromCommand command => command -> Text
getPrefix c
x

instance (Constructor t, GFromCommand f) => GFromCommand (M1 C t f) where
  gGetMessage :: M1 C t f proxy -> Msg
gGetMessage (M1 f proxy
x) = f proxy -> Msg
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Msg
gGetMessage f proxy
x
  gGetPrefix :: M1 C t f proxy -> Text
gGetPrefix m :: M1 C t f proxy
m@(M1 f proxy
_) = Char -> Text -> Text
Text.cons Char
'@' (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
toKebabCase (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 C t f proxy -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C t f proxy
m

instance (GFromCommand f) => GFromCommand (M1 S t f) where
  gGetMessage :: M1 S t f proxy -> Msg
gGetMessage (M1 f proxy
x) = f proxy -> Msg
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Msg
gGetMessage f proxy
x
  gGetPrefix :: M1 S t f proxy -> Text
gGetPrefix (M1 f proxy
x) = f proxy -> Text
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Text
gGetPrefix f proxy
x

instance (GFromCommand f) => GFromCommand (M1 D t f) where
  gGetMessage :: M1 D t f proxy -> Msg
gGetMessage (M1 f proxy
x) = f proxy -> Msg
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Msg
gGetMessage f proxy
x
  gGetPrefix :: M1 D t f proxy -> Text
gGetPrefix (M1 f proxy
x) = f proxy -> Text
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Text
gGetPrefix f proxy
x

instance (GFromCommand f, GFromCommand g) => GFromCommand (f :+: g) where
  gGetMessage :: (:+:) f g proxy -> Msg
gGetMessage (L1 f proxy
x) = f proxy -> Msg
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Msg
gGetMessage f proxy
x
  gGetMessage (R1 g proxy
x) = g proxy -> Msg
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Msg
gGetMessage g proxy
x

  gGetPrefix :: (:+:) f g proxy -> Text
gGetPrefix (L1 f proxy
x) = f proxy -> Text
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Text
gGetPrefix f proxy
x
  gGetPrefix (R1 g proxy
x) = g proxy -> Text
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Text
gGetPrefix g proxy
x

instance (GFromCommand f, GFromCommand g) => GFromCommand (f :*: g) where
  gGetMessage :: (:*:) f g proxy -> Msg
gGetMessage (f proxy
x :*: g proxy
_y) = f proxy -> Msg
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Msg
gGetMessage f proxy
x
  gGetPrefix :: (:*:) f g proxy -> Text
gGetPrefix  (f proxy
x :*: g proxy
_y) = f proxy -> Text
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Text
gGetPrefix  f proxy
x

class FromCommand command where
  getMessage :: command -> Msg

  default getMessage :: (Generic command, GFromCommand (Rep command)) => command -> Msg
  getMessage command
x = Rep command Any -> Msg
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Msg
gGetMessage (command -> Rep command Any
forall a x. Generic a => a -> Rep a x
from command
x)

  getPrefix :: command -> Text

  default getPrefix :: (Generic command, GFromCommand (Rep command)) => command -> Text
  getPrefix command
x = Rep command Any -> Text
forall (command :: * -> *) proxy.
GFromCommand command =>
command proxy -> Text
gGetPrefix (command -> Rep command Any
forall a x. Generic a => a -> Rep a x
from command
x)

-- | Type class to identify the essence of incoming command and transform it to 'Msg' transport type.
instance FromCommand Msg where
  getMessage :: Msg -> Msg
getMessage = Msg -> Msg
forall a. a -> a
id
  getPrefix :: Msg -> Text
getPrefix = Text -> Msg -> Text
forall a b. a -> b -> a
const Text
""

-- | Transform incoming telegram command into 'Msg'.
fromCommand :: FromCommand command => command -> Msg
fromCommand :: command -> Msg
fromCommand command
cmd = Msg
old { msgMessage :: Text
msgMessage = command -> Text
forall command. FromCommand command => command -> Text
getPrefix command
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Msg -> Text
msgMessage Msg
old }
    where
      old :: Msg
old = command -> Msg
forall command. FromCommand command => command -> Msg
getMessage command
cmd

-- ** Helpers

-- | Helper to transform text into kebab case.
toKebabCase :: Text -> Text
toKebabCase :: Text -> Text
toKebabCase Text
txt =
  let str :: String
str = Text -> String
Text.unpack Text
txt
      uppers :: [Bool]
uppers = Char -> Bool
isUpper (Char -> Bool) -> String -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
str
      indices :: [(Int, Bool)]
indices = [Int] -> [Bool] -> [(Int, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Bool]
uppers :: [(Int, Bool)]
      onlyUpperIndices :: [Int]
onlyUpperIndices = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Int, Bool) -> Int) -> [(Int, Bool)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Bool) -> Int
forall a b. (a, b) -> a
fst ([(Int, Bool)] -> [Int]) -> [(Int, Bool)] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Int, Bool) -> Bool) -> [(Int, Bool)] -> [(Int, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, Bool) -> Bool
forall a b. (a, b) -> b
snd [(Int, Bool)]
indices
      go :: Int -> Text -> Text
go Int
ix Text
txt' =
        let (Text
begin, Text
end) = Int -> Text -> (Text, Text)
Text.splitAt Int
ix Text
txt'
        in [Text] -> Text
Text.concat [ Text
begin, Text
"-", Text -> Text
Text.toLower Text
end ]
  in Text -> Text
Text.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Int -> Text -> Text) -> Text -> [Int] -> Text
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Text -> Text
go Text
txt [Int]
onlyUpperIndices

data MaybeWith (modifier :: Modifier) a = MaybeWith a

data Modifier = AtEnd Symbol

instance (KnownSymbol postfix, FromCommand a, modifier ~ 'AtEnd postfix) =>
  FromCommand (MaybeWith modifier a) where

    getMessage :: MaybeWith modifier a -> Msg
getMessage (MaybeWith a
x) = a -> Msg
forall command. FromCommand command => command -> Msg
getMessage a
x
    getPrefix :: MaybeWith modifier a -> Text
getPrefix (MaybeWith a
x) = a -> Text
forall command. FromCommand command => command -> Text
getPrefix a
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Proxy postfix -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy postfix
forall k (t :: k). Proxy t
Proxy @postfix))