TextView.hs

{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2017 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}
{-# LANGUAGE TemplateHaskell #-}

module Simple.UI.Widgets.TextView (
    TextView,
    TextViewClass,
    castToTextView,
    textViewNew
) where

import           Control.Lens                  (makeLensesFor, (.=))
import           Control.Monad
import qualified Graphics.Vty                  as Vty

import           Simple.UI.Core.Internal.UIApp

import           Simple.UI.Core.Attribute
import           Simple.UI.Core.Draw
import           Simple.UI.Core.ListenerList
import           Simple.UI.Widgets.Text
import           Simple.UI.Widgets.Widget

data TextView = TextView
    { _textViewParent  :: Text
    , _textViewYOffset :: Attribute Int
    , _textViewHeight  :: Attribute Int
    }

makeLensesFor [("_textViewParent", "textViewParent")] ''TextView

class TextClass w => TextViewClass w where
    castToTextView :: w -> TextView

instance TextViewClass TextView where
    castToTextView = id

instance TextClass TextView where
    castToText = _textViewParent

instance WidgetClass TextView where
    castToWidget = castToWidget . _textViewParent

    overrideWidget = overrideWidgetHelper textViewParent

textViewNew :: Maybe String -> UIApp u TextView
textViewNew s = do
    textView <- textViewNewOverride s

    on_ textView draw $ textViewDraw textView
    on_ textView keyPressed $ textViewKeyPressed textView

    return textView

textViewNewOverride :: Maybe String -> UIApp u TextView
textViewNewOverride s = override <$> textViewNewDefault s
    where
      textViewComputeSize textView = do
          maybeText <- get textView text

          case maybeText of
              Nothing -> return (1, 1)
              Just _text -> do
                  let ls = lines _text
                  let ws = map length ls

                  let w = maximum ws
                  let l = length ls

                  return ( if w == 0 then 1 else w
                         , if l == 0 then 1 else l
                         )

      override textView = overrideWidget textView $ do
          virtualWidgetName .= "textview"
          virtualWidgetComputeSize .= textViewComputeSize textView

textViewNewDefault :: Maybe String -> UIApp u TextView
textViewNewDefault s = do
    parent <- textNew s

    yOffset <- attributeNew 0
    height <- attributeNew 0

    return TextView
        { _textViewParent  = parent
        , _textViewYOffset = yOffset
        , _textViewHeight  = height
        }

textViewDraw :: TextView -> Drawing -> Int -> Int -> UIApp u ()
textViewDraw textView drawing _ height = do
    set textView _textViewHeight height
    maybeText <- get textView text

    forM_ maybeText $ \_text -> do
        fg <- get textView colorForeground
        bg <- get textView colorBackground
        style <- get textView colorStyle

        let ls = lines _text
        let l = length ls

        yOffset' <- get textView _textViewYOffset
        let yOffset = if height + yOffset' > l
                          then nat $ l - height
                          else yOffset'

        drawingRun drawing $ do
            let minH = min height l
            let h = height - l
            let dy = if h <= 0 then 0 else h `div` 2

            drawingSetAttrs fg bg style
            drawingClear
            forM_ (zip [dy..] [0 .. minH - 1]) $ \(y, i) ->
                drawingPutString 0 y (ls !! (i + yOffset))

textViewKeyPressed :: TextView -> Vty.Key -> [Vty.Modifier]-> UIApp u ()
textViewKeyPressed textView key _ = do
    height <- get textView _textViewHeight
    yOffset <- get textView _textViewYOffset

    case key of
        Vty.KUp ->
            when (yOffset > 0) $
                set textView _textViewYOffset (yOffset - 1)

        Vty.KDown -> do
            maybeText <- get textView text
            forM_ maybeText $ \_text -> do
                let l = length . lines $ _text
                when (l - height > yOffset) $
                    set textView _textViewYOffset (yOffset + 1)

        Vty.KPageUp ->
            if yOffset > 5
                then set textView _textViewYOffset (yOffset - 5)
                else set textView _textViewYOffset 0

        Vty.KPageDown -> do
            maybeText <- get textView text
            forM_ maybeText $ \_text -> do
                let l = length . lines $ _text
                if l - height > yOffset + 5
                    then set textView _textViewYOffset (yOffset + 5)
                    else set textView _textViewYOffset (nat $ l - height)

        _ ->
            return ()

nat :: Int -> Int
nat x = if x < 0 then 0 else x