{-# LANGUAGE OverloadedStrings #-}

module Jet.Render where

import Control.Lens
import Control.Monad.State
import qualified Data.List as List
import Data.Maybe
import qualified Graphics.Vty as Vty
import Prettyprinter
import Prettyprinter.Render.Util.StackMachine (renderSimplyDecoratedA)

data Cursor = Cursor
  deriving (Int -> Cursor -> ShowS
[Cursor] -> ShowS
Cursor -> String
(Int -> Cursor -> ShowS)
-> (Cursor -> String) -> ([Cursor] -> ShowS) -> Show Cursor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cursor] -> ShowS
$cshowList :: [Cursor] -> ShowS
show :: Cursor -> String
$cshow :: Cursor -> String
showsPrec :: Int -> Cursor -> ShowS
$cshowsPrec :: Int -> Cursor -> ShowS
Show, Cursor -> Cursor -> Bool
(Cursor -> Cursor -> Bool)
-> (Cursor -> Cursor -> Bool) -> Eq Cursor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cursor -> Cursor -> Bool
$c/= :: Cursor -> Cursor -> Bool
== :: Cursor -> Cursor -> Bool
$c== :: Cursor -> Cursor -> Bool
Eq)

data Output = LineBreak | ImgChunk Vty.Image

renderScreen :: Int -> SimpleDocStream (Either Cursor Vty.Attr) -> [Vty.Image]
renderScreen :: Int -> SimpleDocStream (Either Cursor Attr) -> [Image]
renderScreen Int
winHeight SimpleDocStream (Either Cursor Attr)
doc = do
  let ([Output]
outputs, ([Attr]
_, Int
_, Maybe Int
mcursor)) =
        SimpleDocStream (Either Cursor Attr)
doc
          SimpleDocStream (Either Cursor Attr)
-> (SimpleDocStream (Either Cursor Attr)
    -> State ([Attr], Int, Maybe Int) [Output])
-> State ([Attr], Int, Maybe Int) [Output]
forall a b. a -> (a -> b) -> b
& SimpleDocStream (Either Cursor Attr)
-> State ([Attr], Int, Maybe Int) [Output]
toLineStream
          State ([Attr], Int, Maybe Int) [Output]
-> (State ([Attr], Int, Maybe Int) [Output]
    -> ([Output], ([Attr], Int, Maybe Int)))
-> ([Output], ([Attr], Int, Maybe Int))
forall a b. a -> (a -> b) -> b
& (State ([Attr], Int, Maybe Int) [Output]
 -> ([Attr], Int, Maybe Int)
 -> ([Output], ([Attr], Int, Maybe Int)))
-> ([Attr], Int, Maybe Int)
-> State ([Attr], Int, Maybe Int) [Output]
-> ([Output], ([Attr], Int, Maybe Int))
forall a b c. (a -> b -> c) -> b -> a -> c
flip State ([Attr], Int, Maybe Int) [Output]
-> ([Attr], Int, Maybe Int) -> ([Output], ([Attr], Int, Maybe Int))
forall s a. State s a -> s -> (a, s)
runState ([], Int
0, Maybe Int
forall a. Maybe a
Nothing)

  let allLines :: [Image]
allLines =
        [Output]
outputs [Output] -> ([Output] -> ([Image], [Image])) -> ([Image], [Image])
forall a b. a -> (a -> b) -> b
& (Output -> ([Image], [Image]) -> ([Image], [Image]))
-> ([Image], [Image]) -> [Output] -> ([Image], [Image])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr Output -> ([Image], [Image]) -> ([Image], [Image])
collapse ([], [])
          -- clean up anything remaining in the buffer
          ([Image], [Image]) -> (([Image], [Image]) -> [Image]) -> [Image]
forall a b. a -> (a -> b) -> b
& ( \([Image]
buf, [Image]
rest) ->
                if [Image] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Image]
buf
                  then [Image]
rest
                  else [Image] -> Image
Vty.horizCat [Image]
buf Image -> [Image] -> [Image]
forall a. a -> [a] -> [a]
: [Image]
rest
            )

  let cropped :: [Image]
cropped = case Maybe Int
mcursor of
        Maybe Int
Nothing -> [Image]
allLines
        Just Int
cursorPos -> Int -> Int -> [Image] -> [Image]
forall a. Int -> Int -> [a] -> [a]
takeSurroundingCursor Int
winHeight Int
cursorPos [Image]
allLines
  [Image]
cropped
  where
    collapse :: Output -> ([Image], [Image]) -> ([Image], [Image])
collapse Output
out ([Image]
buf, [Image]
rest) =
      case Output
out of
        Output
LineBreak -> ([], [Image] -> Image
Vty.horizCat [Image]
buf Image -> [Image] -> [Image]
forall a. a -> [a] -> [a]
: [Image]
rest)
        ImgChunk Image
img -> (Image
img Image -> [Image] -> [Image]
forall a. a -> [a] -> [a]
: [Image]
buf, [Image]
rest)

-- Take only enough lines to fill the screen, with the cursor centered don't print any more.
takeSurroundingCursor :: Int -> Int -> [a] -> [a]
takeSurroundingCursor :: Int -> Int -> [a] -> [a]
takeSurroundingCursor Int
height Int
cursorPos [a]
xs
  | Int
cursorPos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
half Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
    [a]
xs
      [a] -> ([a] -> [a]) -> [a]
forall a b. a -> (a -> b) -> b
& Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
cursorPos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
half)
      [a] -> ([a] -> [a]) -> [a]
forall a b. a -> (a -> b) -> b
& Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
height
  | Bool
otherwise = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
height [a]
xs
  where
    half :: Int
half = Int
height Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

toLineStream ::
  SimpleDocStream (Either Cursor Vty.Attr) ->
  State ([Vty.Attr], Int, Maybe Int) [Output]
toLineStream :: SimpleDocStream (Either Cursor Attr)
-> State ([Attr], Int, Maybe Int) [Output]
toLineStream SimpleDocStream (Either Cursor Attr)
doc =
  (Text -> State ([Attr], Int, Maybe Int) [Output])
-> (Either Cursor Attr -> State ([Attr], Int, Maybe Int) [Output])
-> (Either Cursor Attr -> State ([Attr], Int, Maybe Int) [Output])
-> SimpleDocStream (Either Cursor Attr)
-> State ([Attr], Int, Maybe Int) [Output]
forall (f :: * -> *) out ann.
(Applicative f, Monoid out) =>
(Text -> f out)
-> (ann -> f out) -> (ann -> f out) -> SimpleDocStream ann -> f out
renderSimplyDecoratedA
    Text -> State ([Attr], Int, Maybe Int) [Output]
forall s (m :: * -> *) b.
(MonadState s m, Num b, Field2 s s b b,
 Field1 s s [Attr] [Attr]) =>
Text -> m [Output]
renderText
    Either Cursor Attr -> State ([Attr], Int, Maybe Int) [Output]
forall a.
Either Cursor Attr -> StateT ([Attr], Int, Maybe Int) Identity [a]
pushAnn
    Either Cursor Attr -> State ([Attr], Int, Maybe Int) [Output]
forall (m :: * -> *) s a p.
(MonadState s m, Field1 s s [a] [a]) =>
p -> m [Output]
popAnn
    SimpleDocStream (Either Cursor Attr)
doc
  where
    popAnn :: p -> m [Output]
popAnn p
_ = do
      ([a] -> Identity [a]) -> s -> Identity s
forall s t a b. Field1 s t a b => Lens s t a b
_1 (([a] -> Identity [a]) -> s -> Identity s) -> ([a] -> [a]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1
      -- Need to clear existing colors or they bleed to the right.
      [Output] -> m [Output]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Image -> Output
ImgChunk (Attr -> Text -> Image
Vty.text' Attr
Vty.defAttr Text
"")]
    pushAnn :: Either Cursor Attr -> StateT ([Attr], Int, Maybe Int) Identity [a]
pushAnn = \case
      Left Cursor
Cursor -> do
        Int
cursorLine <- Getting Int ([Attr], Int, Maybe Int) Int
-> StateT ([Attr], Int, Maybe Int) Identity Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int ([Attr], Int, Maybe Int) Int
forall s t a b. Field2 s t a b => Lens s t a b
_2
        (Maybe Int -> Identity (Maybe Int))
-> ([Attr], Int, Maybe Int) -> Identity ([Attr], Int, Maybe Int)
forall s t a b. Field3 s t a b => Lens s t a b
_3 ((Maybe Int -> Identity (Maybe Int))
 -> ([Attr], Int, Maybe Int) -> Identity ([Attr], Int, Maybe Int))
-> Int -> StateT ([Attr], Int, Maybe Int) Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= Int
cursorLine
        [a] -> StateT ([Attr], Int, Maybe Int) Identity [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Right Attr
ann -> do
        ([Attr] -> Identity [Attr])
-> ([Attr], Int, Maybe Int) -> Identity ([Attr], Int, Maybe Int)
forall s t a b. Field1 s t a b => Lens s t a b
_1 (([Attr] -> Identity [Attr])
 -> ([Attr], Int, Maybe Int) -> Identity ([Attr], Int, Maybe Int))
-> ([Attr] -> [Attr])
-> StateT ([Attr], Int, Maybe Int) Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Attr
ann Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
:)
        [a] -> StateT ([Attr], Int, Maybe Int) Identity [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
forall a. Monoid a => a
mempty
    -- prettyprinter always renders lines as a single text fragment
    renderText :: Text -> m [Output]
renderText Text
"\n" = do
      (b -> Identity b) -> s -> Identity s
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((b -> Identity b) -> s -> Identity s) -> b -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= b
1
      [Output] -> m [Output]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Output
LineBreak]
    -- prettyprinter never passes text with newlines here
    renderText Text
txt = do
      Attr
attr <- LensLike' (Const Attr) s [Attr] -> ([Attr] -> Attr) -> m Attr
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const Attr) s [Attr]
forall s t a b. Field1 s t a b => Lens s t a b
_1 (Attr -> Maybe Attr -> Attr
forall a. a -> Maybe a -> a
fromMaybe Attr
Vty.defAttr (Maybe Attr -> Attr) -> ([Attr] -> Maybe Attr) -> [Attr] -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attr] -> Maybe Attr
forall a. [a] -> Maybe a
listToMaybe)
      [Output] -> m [Output]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Image -> Output
ImgChunk (Attr -> Text -> Image
Vty.text' Attr
attr Text
txt)]