{-# Language OverloadedStrings, GADTs #-}
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 ->
r ->
Bool ->
Args r a ->
String ->
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)