{-# 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) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState String
str forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Renderer a -> State String Image'
getState
                  forall a b. (a -> b) -> a -> b
$ 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
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char
' 'forall a. Eq a => a -> a -> Bool
/=) String
excess = (forall a. Semigroup a => a -> a -> a
<> Attr -> String -> Image'
string Attr
defAttr String
excess)
      | Bool
otherwise          = forall a. a -> a
id

    extend :: Image' -> Image'
extend Image'
i
      | Image' -> Int
imageWidth Image'
i 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 (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall a. State String Image' -> Renderer a
putState forall a b. (a -> b) -> a -> b
$

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

      draw :: String -> Image'
draw = Bool -> Palette -> Text -> Image'
parseIrcText' Bool
True Palette
pal 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 -> forall a. Renderer a -> State String Image'
getState (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) <- forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state String -> ((String, String), String)
token
         if 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      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
                     Just Args r a
subspec -> forall a. Renderer a -> State String Image'
getState (forall r a. Palette -> r -> Bool -> Args r a -> Renderer a
renderArgs Palette
pal r
r Bool
placeholders Args r a
subspec)
           forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Image'
draw (String
leadforall a. [a] -> [a] -> [a]
++String
tok) forall a. Semigroup a => a -> a -> a
<> Image'
rest)

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

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

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