tabloid-0.45: HaskellCmdInputController.hs

{-# LANGUAGE OverloadedStrings #-}
module HaskellCmdInputController
    (
     Controller
     , new
     , onUpdate
     , view
     , OnUpdate
     , runText
     , Env
     ) where

import qualified Graphics.UI.Gtk.ModelView as MV 
import qualified TextInputView as View
import Graphics.UI.Gtk
import WindowedApp
import Component
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Concurrent.MVar
import qualified LoadSaveController as LSC
import Language.Haskell.Interpreter
import GHC.Exts( IsString(..) )
import Control.Concurrent
import Control.Applicative
import qualified Data.Map as M
import qualified Control.Exception as Exc
import Control.Parallel.Strategies
import Data.List

type Controller = Ref C

view = View.mainWidget . gui

new env = do
  buf <- textBufferNew Nothing
  textBufferSetText buf "\\env ->\n  let rows_t1 = env ! \"t1\" in\n  [[\"test\"]] ++ rows_t1"
  lsc <- LSC.new (Just "hs")
  lscv <- (lsc .> LSC.view)
  v@(View.V _ runB _ _ _) <- View.new buf lscv
  lock <- newEmptyMVar
  this <- newRef (C v "" Nothing buf lock env)
  runB `onClicked` (this .<< runText)
  lsc .< (LSC.onLoad (Just (\cont -> textBufferSetText buf (L.unpack cont))))
  lsc .< (LSC.onSave (Just (Just <$> L.pack <$> getBufferText buf)))       
  onBufferChanged buf (lsc .>> LSC.clearLabel)
  return this

type OnUpdate = [[String]] -> IO ()
type Env = M.Map String [[String]]

onUpdate :: Maybe OnUpdate -> C -> C
onUpdate cb state = state {executeCB = cb}
-- internal functions 
data C = C 
    { 
      gui :: View.ViewState
    , currentCmd :: String
    , executeCB :: Maybe OnUpdate
    , buffer :: TextBuffer
    , execLock :: MVar Bool
    , env :: IO Env
    }

getBufferText buf = do
  s <- textBufferGetStartIter buf
  e <- textBufferGetEndIter buf
  textBufferGetText buf s e True
  
runText :: C -> IO C
runText state = do
  locked <- tryPutMVar (execLock state) True
  if locked then
      case executeCB state of
        Just execCB -> 
            do
              text <- getBufferText (buffer state)
              forkOS $ executeCmd text execCB state
              return $ state
        Nothing -> 
            return state
    else return state

executeCmd text execCB state = do
  e <- env state
--  let e = M.insert "t1" [["Hallo"],["welt"]] M.empty
  postGUISync $ widgetSetSensitivity (View.cancelB $ gui state) False
  postGUISync $ widgetSetSensitivity (View.executeB $ gui state) False
  postGUISync $ widgetSetSensitivity (View.textView $ gui state) False
  postGUISync $ labelSetText (View.exitCodeL $ gui state) $ "Executing..."
  let haskellCode = "(" ++ text ++ ") :: (Map String [[String]] -> [[String]])"
  res <- runInterpreter (evalText haskellCode)
  case res of 
    Right func -> do 
      let ex_handler :: Exc.SomeException -> IO [[String]]
          ex_handler exc = postGUISync (labelSetText (View.exitCodeL $ gui state) ("Error: " ++ show exc)) >> return []
      lines <- Exc.catch (let res' = func e
                          in (res' `using` rnf) `seq` do
                            postGUISync $ labelSetText 
                                            (View.exitCodeL $ gui state) 
                                            ("Procuced " ++ show (length res') ++ " rows")
                            return res')
                         ex_handler
      postGUISync (execCB lines)

    Left errs -> 
      postGUISync $ labelSetText (View.exitCodeL $ gui state) ("Error: " ++ show  errs)

  postGUISync $ widgetSetSensitivity (View.cancelB $ gui state) False
  postGUISync $ widgetSetSensitivity (View.textView $ gui state) True
  postGUISync $ widgetSetSensitivity (View.executeB $ gui state) True
  takeMVar (execLock state)
  return ()
 where 
    evalText :: String -> Interpreter (Env -> [[String]])          
    evalText source = do
      setImports ["Data.Map", "Prelude", "Data.List", "Data.Char"]
      interpret source (undefined ::(Env -> [[String]]))
           
-- tests
main = windowedApp "HaskellCmdInputController test" $ do
         t <- new (return M.empty) :: IO Controller
         t .< onUpdate (Just ((mapM_ (putStrLn . show)) 
                              . (take 100)))
         t .> view