ConsoleView.hs

{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE BinaryLiterals      #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable  #-}

module Phoityne.IO.GUI.GTK.ConsoleView (
  ConsoleDoubleClickedHandler
, setupConsoleView
, putStrConsole
, putStrLnConsole
, clearConsole
) where

-- モジュール
import Phoityne.IO.GUI.GTK.Constant
import Phoityne.IO.GUI.GTK.Utility

-- システム
import GHC.Float
import Graphics.UI.Gtk
import Control.Monad.IO.Class
import qualified Data.Text as T

-- |
--
--
type ConsoleDoubleClickedHandler = String -> IO ()

-- |
--
--
setupConsoleView :: Builder -> ConsoleDoubleClickedHandler -> IO ()
setupConsoleView builder evh = do
  textView <- builderGetObject builder castToTextView _NAME_CONSOLE_TEXT_VIEW

  _ <- on textView buttonPressEvent $ consoleDoubleClickedHandler textView evh
  _ <- on textView keyPressEvent $ eventKeyName >>= \k->if k==T.pack("F7") then return True else return False

  let widget = castToWidget textView

  fontDesc <- fontDescriptionNew
  fontDescriptionSetFamily fontDesc (_FONT_DESC)
  fontDescriptionSetSize fontDesc 9
  widgetOverrideFont widget $ Just fontDesc


-- |
--
--
consoleDoubleClickedHandler :: TextView -> ConsoleDoubleClickedHandler -> EventM EButton Bool
consoleDoubleClickedHandler self evh = eventClick >>= \case
  DoubleClick -> doubleClicked >> return True
  _           -> return False

  where
    doubleClicked = do
      (_, posYd) <- eventCoordinates 
      liftIO $ do
        scrollY <- textViewGetVadjustment self >>= adjustmentGetValue
        let posY = scrollY + posYd

        (stIter, _) <- textViewGetLineAtY self $ double2Int posY
        edIter <- textIterCopy stIter
        _ <- textViewForwardDisplayLineEnd self edIter
        buf  <- textViewGetBuffer self
        str <- textBufferGetText buf stIter edIter True
        evh str


-- |
--
--
clearConsole :: Builder -> IO ()
clearConsole builder = do
  view <- builderGetObject builder castToTextView _NAME_CONSOLE_TEXT_VIEW
  buf <- textViewGetBuffer view
  textBufferSetText buf (""::String)


-- |
--
--
putStrConsole :: Builder -> String -> IO ()
putStrConsole = append2Console

-- |
--
--
putStrLnConsole :: Builder -> String -> IO ()
putStrLnConsole builder str = append2Console builder (str ++ "\n")

-- |
--
--
append2Console :: Builder -> String -> IO ()
append2Console builder msg = do

  textView <- builderGetObject builder castToTextView _NAME_CONSOLE_TEXT_VIEW
  buf <- textViewGetBuffer textView
  iter <- textBufferGetEndIter buf
  textBufferInsert buf iter msg

  window <- builderGetObject builder castToWindow _WINDOW_NAME
  widgetShowAll window

  scroll <- builderGetObject builder castToScrolledWindow _NAME_CONSOLE_SCROLLED_WINDOW
  widgetShowAll scroll

  forceEvent

  lineNum <- textBufferGetLineCount buf
  iter <- textBufferGetIterAtLine buf lineNum
  _ <- textViewScrollToIter textView iter 0.0 Nothing

  forceEvent

  return ()