{-# Language OverloadedStrings, GADTs #-}

{-|
Module      : Client.Commands.Arguments.Renderer
Description : Interpretation of argument specification as a renderer
Copyright   : (c) Eric Mertens, 2017
License     : ISC
Maintainer  : emertens@gmail.com

-}

module Client.Commands.Arguments.Renderer (render) where

import Client.Commands.Arguments.Spec (Arg(..), Args, ArgumentShape(RemainingArgument, TokenArgument))
import Client.Image.MircFormatting (parseIrcText')
import Client.Image.PackedImage (imageWidth, resizeImage, string, Image')
import Client.Image.Palette (palCommandPlaceholder, Palette)
import Control.Applicative.Free (runAp)
import Control.Lens (Const(..), view)
import Control.Monad.Trans.State (State, runState, state)
import Data.Functor.Compose (Compose(..))
import Data.Text qualified as Text
import Graphics.Vty (wcswidth)
import Graphics.Vty.Attributes (defAttr)

render ::
  Palette  {- ^ palette             -} ->
  r        {- ^ environment         -} ->
  Bool     {- ^ render placeholders -} ->
  Args r a {- ^ specification       -} ->
  String   {- ^ user input          -} ->
  Image'
render :: forall r a. Palette -> r -> Bool -> Args r a -> String -> Image'
render Palette
pal r
env Bool
placeholders Args r a
spec String
str = Image' -> Image'
extend (Image' -> Image'
addExcess Image'
img)
  where
    (Image'
img, String
excess) = (State String Image' -> String -> (Image', String))
-> String -> State String Image' -> (Image', String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State String Image' -> String -> (Image', String)
forall s a. State s a -> s -> (a, s)
runState String
str (State String Image' -> (Image', String))
-> (Renderer a -> State String Image')
-> Renderer a
-> (Image', String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Renderer a -> State String Image'
forall a. Renderer a -> State String Image'
getState
                  (Renderer a -> (Image', String)) -> Renderer a -> (Image', String)
forall a b. (a -> b) -> a -> b
$ Palette -> r -> Bool -> Args r a -> Renderer a
forall r a. Palette -> r -> Bool -> Args r a -> Renderer a
renderArgs Palette
pal r
env Bool
placeholders Args r a
spec

    addExcess :: Image' -> Image'
addExcess
      | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
excess = (Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<> Attr -> String -> Image'
string Attr
defAttr String
excess)
      | Bool
otherwise          = Image' -> Image'
forall a. a -> a
id

    extend :: Image' -> Image'
extend Image'
i
      | Image' -> Int
imageWidth Image'
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minLen = Int -> Image' -> Image'
resizeImage Int
minLen Image'
i
      | Bool
otherwise             = Image'
i
      where minLen :: Int
minLen = String -> Int
wcswidth String
str



renderArgs :: Palette -> r -> Bool -> Args r a -> Renderer a
renderArgs :: forall r a. Palette -> r -> Bool -> Args r a -> Renderer a
renderArgs Palette
pal r
r Bool
placeholders = (forall x. Arg r x -> Compose (State String) (Const Image') x)
-> Ap (Arg r) a -> Compose (State String) (Const Image') a
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp (Palette -> r -> Bool -> Arg r x -> Renderer x
forall r a b. Palette -> r -> Bool -> Arg r a -> Renderer b
renderArg Palette
pal r
r Bool
placeholders)

------------------------------------------------------------------------

type Renderer = Compose (State String) (Const Image')

getState :: Renderer a -> State String Image'
getState :: forall a. Renderer a -> State String Image'
getState = (Const Image' a -> Image')
-> StateT String Identity (Const Image' a) -> State String Image'
forall a b.
(a -> b) -> StateT String Identity a -> StateT String Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Const Image' a -> Image'
forall {k} a (b :: k). Const a b -> a
getConst (StateT String Identity (Const Image' a) -> State String Image')
-> (Renderer a -> StateT String Identity (Const Image' a))
-> Renderer a
-> State String Image'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Renderer a -> StateT String Identity (Const Image' a)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose

putState :: State String Image' -> Renderer a
putState :: forall a. State String Image' -> Renderer a
putState = State String (Const Image' a)
-> Compose (State String) (Const Image') a
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (State String (Const Image' a)
 -> Compose (State String) (Const Image') a)
-> (State String Image' -> State String (Const Image' a))
-> State String Image'
-> Compose (State String) (Const Image') a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Image' -> Const Image' a)
-> State String Image' -> State String (Const Image' a)
forall a b.
(a -> b) -> StateT String Identity a -> StateT String Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Image' -> Const Image' a
forall {k} a (b :: k). a -> Const a b
Const

------------------------------------------------------------------------

renderArg :: Palette -> r -> Bool -> Arg r a -> Renderer b
renderArg :: forall r a b. Palette -> r -> Bool -> Arg r a -> Renderer b
renderArg Palette
pal r
r Bool
placeholders Arg r a
spec = State String Image' -> Renderer b
forall a. State String Image' -> Renderer a
putState (State String Image' -> Renderer b)
-> State String Image' -> Renderer b
forall a b. (a -> b) -> a -> b
$

  let placeholder :: String -> State String Image'
placeholder String
name
        | Bool
placeholders = Image' -> State String Image'
forall a. a -> StateT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image'
" " Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<> Attr -> String -> Image'
string (Getting Attr Palette Attr -> Palette -> Attr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Attr Palette Attr
Lens' Palette Attr
palCommandPlaceholder Palette
pal) String
name)
        | Bool
otherwise    = Image' -> State String Image'
forall a. a -> StateT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Image'
forall a. Monoid a => a
mempty

      draw :: String -> Image'
draw = Bool -> Palette -> Text -> Image'
parseIrcText' Bool
True Palette
pal (Text -> Image') -> (String -> Text) -> String -> Image'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
  in

  case Arg r a
spec of
    Optional Args r a1
subspec -> Renderer a1 -> State String Image'
forall a. Renderer a -> State String Image'
getState (Palette -> r -> Bool -> Args r a1 -> Renderer a1
forall r a. Palette -> r -> Bool -> Args r a -> Renderer a
renderArgs Palette
pal r
r Bool
placeholders Args r a1
subspec)

    Extension String
name r -> String -> Maybe (Args r a)
ext ->
      do (String
lead,String
tok) <- (String -> ((String, String), String))
-> StateT String Identity (String, String)
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state String -> ((String, String), String)
token
         if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
tok then
           String -> State String Image'
placeholder String
name
         else do
           Image'
rest <- case r -> String -> Maybe (Args r a)
ext r
r String
tok of
                     Maybe (Args r a)
Nothing      -> Image' -> State String Image'
forall a. a -> StateT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Image'
forall a. Monoid a => a
mempty
                     Just Args r a
subspec -> Renderer a -> State String Image'
forall a. Renderer a -> State String Image'
getState (Palette -> r -> Bool -> Args r a -> Renderer a
forall r a. Palette -> r -> Bool -> Args r a -> Renderer a
renderArgs Palette
pal r
r Bool
placeholders Args r a
subspec)
           Image' -> State String Image'
forall a. a -> StateT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Image'
draw (String
leadString -> String -> String
forall a. [a] -> [a] -> [a]
++String
tok) Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<> Image'
rest)

    Argument ArgumentShape
TokenArgument String
name r -> String -> Maybe a
_ ->
      do (String
lead,String
tok) <- (String -> ((String, String), String))
-> StateT String Identity (String, String)
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state String -> ((String, String), String)
token
         if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
tok then
           String -> State String Image'
placeholder String
name
         else
           Image' -> State String Image'
forall a. a -> StateT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Image'
draw (String
leadString -> String -> String
forall a. [a] -> [a] -> [a]
++String
tok))

    Argument ArgumentShape
RemainingArgument String
name r -> String -> Maybe a
_ ->
      do String
rest <- (String -> (String, String)) -> StateT String Identity String
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (\String
x -> (String
x,String
""))
         if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
rest then
           String -> State String Image'
placeholder String
name
         else
           Image' -> State String Image'
forall a. a -> StateT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Image'
draw String
rest)

    MapEnv r -> s
f Args s a
inner -> Renderer a -> State String Image'
forall a. Renderer a -> State String Image'
getState (Renderer a -> State String Image')
-> Renderer a -> State String Image'
forall a b. (a -> b) -> a -> b
$ Palette -> s -> Bool -> Args s a -> Renderer a
forall r a. Palette -> r -> Bool -> Args r a -> Renderer a
renderArgs Palette
pal (r -> s
f r
r) Bool
placeholders Args s a
inner

token :: String -> ((String, String), String)
token :: String -> ((String, String), String)
token String
xs =
  let (String
lead, String
xs1) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span  (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
xs
      (String
tok , String
xs2) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
xs1
  in ((String
lead, String
tok), String
xs2)