{-# 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
import           Client.Image.MircFormatting
import           Client.Image.PackedImage
import           Client.Image.Palette
import           Control.Applicative.Free
import           Control.Lens
import           Control.Monad.Trans.State
import           Data.Functor.Compose
import qualified Data.Text as Text
import           Graphics.Vty (wcswidth)
import           Graphics.Vty.Attributes

render ::
  Palette  {- ^ palette             -} ->
  r        {- ^ environment         -} ->
  Bool     {- ^ render placeholders -} ->
  Args r a {- ^ specification       -} ->
  String   {- ^ user input          -} ->
  Image'
render :: 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 :: 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)
-> Args r a -> Renderer 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 :: Renderer a -> State String Image'
getState = (Const Image' a -> Image')
-> StateT String Identity (Const Image' a) -> State String Image'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Const Image' a -> Image'
forall a k (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 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose

putState :: State String Image' -> Renderer a
putState :: State String Image' -> Renderer a
putState = State String (Const Image' a) -> Renderer a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (State String (Const Image' a) -> Renderer a)
-> (State String Image' -> State String (Const Image' a))
-> State String Image'
-> Renderer a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Image' -> Const Image' a)
-> State String Image' -> State String (Const Image' a)
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 :: 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 (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 (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 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)

    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 (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 (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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null String
tok then
           String -> State String Image'
placeholder String
name
         else
           Image' -> State String Image'
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 (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) = (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)