tabloid-0.3: RegexDefinitionController.hs

module RegexDefinitionController
    (  
     test
    , Controller
    , new
    , onUpdate
    , view
    ) where

import qualified Graphics.UI.Gtk.ModelView as MV 
import qualified RegexDefinitionView as View
import qualified Data.ByteString.Lazy.Char8 as L
import SimpleRegex
import Component
import Graphics.UI.Gtk
import Data.IORef
import Data.Maybe
import Data.List
import Control.Monad
import Control.Applicative
import Control.Concurrent
import WindowedApp
import qualified LoadSaveController as LSC

type Controller = Ref C

view = View.mainWidget . gui

new =  do
  lsc <- LSC.new (Just "regex")
  lscv <- (lsc .> LSC.view)
  v <- View.new lscv
  this <- newRef $ C Nothing v Nothing
  lsc .< (LSC.onLoad (Just (\cont -> 
                                (this .<< (\state -> do
                                             entrySetText (View.regexE (gui state)) (L.unpack cont)
                                             onCh state)))))

  lsc .< (LSC.onSave (Just (this .>> (\state -> 
                                          Just <$> L.pack <$> (entryGetText $ View.regexE (gui state))))))
                                        
  (View.regexE v) `onEntryActivate` (this .>> onAct)
  (View.regexE v) `onEditableChanged` (do 
                                        lsc .>> LSC.clearLabel
                                        this .<< onCh)
  (View.applyB v) `onClicked` (this .>> onAct)
  (View.applyB v) `widgetSetSensitivity` False
  return this

onUpdate :: Maybe ((Maybe (Regex,String)) -> IO ()) -> C -> C
onUpdate ma c = c { regexUpdateCB = ma }

-- internal main state record
data C = C
    { 
      regexUpdateCB :: Maybe (Maybe (Regex, String) -> IO ())
    , gui :: View.ViewState
    , currentRegex :: Maybe (Regex, String)
    }

-- internal callbacks and functions
onAct :: C -> IO ()
onAct c = do   
  case regexUpdateCB c of
    Just uf ->  uf (currentRegex c)
    _ -> return ()

onCh :: C -> IO C
onCh c = do 
  str <- entryGetText $ View.regexE (gui c)
  res <- compileWithError str
  let v = gui c
  c' <- case res of 
          Right r -> 
              do
                labelSetText (View.errorL (gui c)) ""
                (View.applyB v) `widgetSetSensitivity` (str /= "")
                return (c {currentRegex = Just (r, str)})
          Left err -> 
              do
                labelSetText (View.errorL (gui c)) err 
                (View.applyB v) `widgetSetSensitivity` False
                return (c {currentRegex = Nothing})
  return c'

-- tests
test = windowedApp "RegexDefinitionController test" $ do
         clut <- new
         clut .< onUpdate $ Just (\r ->
                                      case r of
                                        Nothing -> putStrLn "not ok"
                                        Just (_,str) -> putStrLn $ "ok" ++ str)
         mw <- View.mainWidget <$>  (clut .> gui)
         return mw