packages feed

titan 1.0.0 → 1.0.2

raw patch · 53 files changed

+2924/−1 lines, 53 files

Files

+ src/CombinedEnvironment.hs view
@@ -0,0 +1,24 @@+-- | The environment that contains both the view and the model.+--+module CombinedEnvironment+   ( CEnv+   , module Exported+   , GEnv.extra+   )+  where++-- Generic libraries+import qualified Hails.MVC.GenericCombinedEnvironment as GEnv+import Hails.MVC.DefaultGtkEnvironment                as Exported++-- Internal libraries+import Model.ReactiveModel.ModelEvents                as Exported+import Model.ProtectedModel                           as Exported+import Model.Model  +import View                                           as Exported+import View.Objects                                   as Exported++import IOBridge ++-- The simplest definition: a view, a model, and a set of events+type CEnv = GEnv.CEnv View Model ModelEvent IOBridge
+ src/Controller.hs view
@@ -0,0 +1,44 @@+-- | This contains the main controller. Many operations will be+-- implemented in the Controller.* subsystem. This module simply+-- initialises program.++-- FIXME: A debug version could be included as a separate controller.++module Controller where++-- Uncomment the following line if you need to capture errors+-- import System.Glib.GError+import Graphics.UI.Gtk++-- Internal imports+import CombinedEnvironment+import Controller.Conditions+import Model.Model+import IOBridge++-- | Starts the program by creating the model,+-- the view, starting all the concurrent threads,+-- installing the handlers for all the conditions+-- and starting the view.+startController :: IO ()+startController = do+  -- Uncomment the following line if you need to debug errors+  -- handleGError (\(GError _ _ em) -> putStrLn em) $ do+  +    -- Initialise the visual layer+    initView++    -- Create an empty model+    ioBridge <- mkDefaultIOBridge+    cenv <- createCEnv emptyBM ioBridge++    -- Install the model and view handlers+    installHandlers cenv+  +    -- Notify the system's initialisation+    initialiseSystem $ model cenv++    mainWindow (uiBuilder (view cenv)) >>= widgetShowAll++    -- Run the view+    startView
+ src/Controller/Conditions.hs view
@@ -0,0 +1,14 @@+module Controller.Conditions where++import CombinedEnvironment+import Controller.Conditions.Buttons      as Buttons+import Controller.Conditions.CloseIDE     as CloseIDE+import Controller.Conditions.CurFrameInfo as CurFrameInfo+import Controller.Conditions.TraceViewer  as TraceViewer++installHandlers :: CEnv -> IO ()+installHandlers cenv = do+  Buttons.installCondition      cenv+  CloseIDE.installCondition     cenv+  CurFrameInfo.installCondition cenv+  TraceViewer.installCondition  cenv
+ src/Controller/Conditions/Buttons.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Controller.Conditions.Buttons where++import Control.Applicative+import Control.Exception+import Control.Monad+import Control.Monad.IfElse+import Data.Maybe+import Data.ReactiveValue+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Reactive+import Graphics.UI.Gtk.Reactive.Gtk2+import Hails.MVC.Model.ProtectedModel.Reactive+import Hails.Polling+import System.IO+import Text.Read                               (readMaybe)++import CombinedEnvironment+import FRP.Titan.Protocol+import IOBridge+import Model.Model (defaultFrame)++installCondition :: CEnv -> IO ()+installCondition cenv = do+  installConditionConnect            cenv+  installConditionDisconnect         cenv+  installConditionStep               cenv+  installConditionSkip               cenv+  installConditionStepUntil          cenv+  installConditionSkipBack           cenv+  installConditionRedo               cenv+  installConditionPlay               cenv+  installConditionStop               cenv+  installConditionPause              cenv+  installConditionDeleteTrace        cenv+  installConditionReplayTrace        cenv+  installConditionSaveTrace          cenv+  installConditionLoadTrace          cenv+  installConditionRefineTrace        cenv+  installConditionDiscardFuture      cenv+  installConditionSaveTraceUpToFrame cenv+  installConditionTravelToFrame      cenv+  installConditionTeleportToFrame    cenv+  installConditionIOSenseFrame       cenv+  installConditionModifyTime         cenv++-- gtkBuilderAccessor "toolBtnSaveTrace"          "Button"+installConditionSaveTrace cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnSaveTrace (uiBuilder (view cenv))+  btn =:> conditionVMSaveTrace cenv++conditionVMSaveTrace :: CEnv -> IO ()+conditionVMSaveTrace cenv = onViewAsync $ do+  window <- mainWindow (uiBuilder (view cenv))+  fch <- fileChooserDialogNew (Just "Save Yampa trace") Nothing+                              FileChooserActionSave+                              [("Cancel", ResponseCancel),+                               ("Save", ResponseAccept)]++  fileChooserSetDoOverwriteConfirmation fch True++  ytrfilt <- fileFilterNew+  fileFilterAddPattern ytrfilt "*.ytr"+  fileFilterSetName ytrfilt "Yampa Trace"+  fileChooserAddFilter fch ytrfilt++  nofilt <- fileFilterNew+  fileFilterAddPattern nofilt "*.*"+  fileFilterSetName nofilt "All Files"+  fileChooserAddFilter fch nofilt++  widgetShow fch+  response <- dialogRun fch+  case response of+    ResponseCancel -> putStrLn "You cancelled..."+    ResponseAccept -> do nwf <- fileChooserGetFilename fch+                         case nwf of+                           Nothing   -> putStrLn "Nothing"+                           Just path -> do putStrLn ("New file path is:\n" ++ path)+                                           n <- sendToYampaSocketSync (extra cenv) "GetTrace"+                                           case n >>= readMaybe of+                                             Just (Just s) -> writeFile path s+                                             _             -> return ()+    ResponseDeleteEvent -> putStrLn "You closed the dialog window..."++  widgetDestroy fch++-- gtkBuilderAccessor "toolBtnLoadTrace"          "Button"+installConditionLoadTrace cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnLoadTrace (uiBuilder (view cenv))+  btn =:> conditionVMLoadTrace cenv++conditionVMLoadTrace :: CEnv -> IO ()+conditionVMLoadTrace cenv = do+  window <- mainWindow (uiBuilder (view cenv))+  fch <- fileChooserDialogNew (Just "Open Yampa trace") Nothing+                              FileChooserActionOpen+                              [("Cancel", ResponseCancel),+                               ("Load", ResponseAccept)]++  ytrfilt <- fileFilterNew+  fileFilterAddPattern ytrfilt "*.ytr"+  fileFilterSetName ytrfilt "Yampa Trace"+  fileChooserAddFilter fch ytrfilt++  nofilt <- fileFilterNew+  fileFilterAddPattern nofilt "*.*"+  fileFilterSetName nofilt "All Files"+  fileChooserAddFilter fch nofilt++  widgetShow fch+  response <- dialogRun fch+  fp <- case response of+          ResponseCancel -> putStrLn "You cancelled..." >> return Nothing+          ResponseAccept -> do nwf <- fileChooserGetFilename fch+                               case nwf of+                                 Nothing   -> putStrLn "Nothing" >> return Nothing+                                 Just path -> putStrLn ("New file path is:\n" ++ path) >> return (Just path)+          ResponseDeleteEvent -> putStrLn "You closed the dialog window..." >> return Nothing++  widgetDestroy fch+  awhen fp $ \p -> do+    contents <- readFile p+    sendToYampaSocketAsync (extra cenv) (show (LoadTraceFromString contents))++-- gtkBuilderAccessor "toolBtnRefineTrace"        "Button"+installConditionRefineTrace cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnRefineTrace (uiBuilder (view cenv))+  btn =:> conditionVMRefineTrace cenv++conditionVMRefineTrace :: CEnv -> IO ()+conditionVMRefineTrace cenv = return ()++-- gtkBuilderAccessor "toolBtnDiscardFuture"      "Button"+installConditionDiscardFuture cenv = void $ do+  let curFrameField' = mkFieldAccessor selectedFrameField (model cenv)++  btn <- toolButtonActivateField <$> toolBtnDiscardFuture (uiBuilder (view cenv))+  (btn `governingR` curFrameField') =:> conditionVMDiscardFuture cenv++conditionVMDiscardFuture :: CEnv -> Maybe Int -> IO ()+conditionVMDiscardFuture cenv Nothing  = return ()+conditionVMDiscardFuture cenv (Just i) = do+  sendToYampaSocketAsync (extra cenv) (show (DiscardFuture i))++-- gtkBuilderAccessor "toolBtnSaveTraceUpToFrame" "Button"+installConditionSaveTraceUpToFrame cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnSaveTraceUpToFrame (uiBuilder (view cenv))+  btn =:> conditionVMSaveTraceUpToFrame cenv++conditionVMSaveTraceUpToFrame :: CEnv -> IO ()+conditionVMSaveTraceUpToFrame cenv = do+  window <- mainWindow (uiBuilder (view cenv))+  fch <- fileChooserDialogNew (Just "Save Yampa trace") Nothing+                              FileChooserActionSave+                              [("Cancel", ResponseCancel),+                               ("Save", ResponseAccept)]++  fileChooserSetDoOverwriteConfirmation fch True++  ytrfilt <- fileFilterNew+  fileFilterAddPattern ytrfilt "*.ytr"+  fileFilterSetName ytrfilt "Yampa Trace"+  fileChooserAddFilter fch ytrfilt++  nofilt <- fileFilterNew+  fileFilterAddPattern nofilt "*.*"+  fileFilterSetName nofilt "All Files"+  fileChooserAddFilter fch nofilt++  widgetShow fch+  response <- dialogRun fch+  case response of+    ResponseCancel -> putStrLn "You cancelled..."+    ResponseAccept -> do nwf <- fileChooserGetFilename fch+                         case nwf of+                           Nothing   -> putStrLn "Nothing"+                           Just path -> putStrLn ("New file path is:\n" ++ path)+    ResponseDeleteEvent -> putStrLn "You closed the dialog window..."++  widgetDestroy fch++-- gtkBuilderAccessor "toolBtnTravelToFrame"      "Button"+installConditionTravelToFrame cenv = void $ do+  let curFrameField' = mkFieldAccessor selectedFrameField (model cenv)++  btn <- toolButtonActivateField <$> toolBtnTravelToFrame (uiBuilder (view cenv))+  (btn `governingR` curFrameField') =:> conditionVMTravelToFrame cenv++conditionVMTravelToFrame :: CEnv -> Maybe Int -> IO ()+conditionVMTravelToFrame cenv Nothing  = return ()+conditionVMTravelToFrame cenv (Just i) =+  sendToYampaSocketAsync (extra cenv) (show (TravelToFrame i))++-- gtkBuilderAccessor "toolBtnTeleportToFrame"    "Button"+installConditionTeleportToFrame cenv = void $ do+  let curFrameField' = mkFieldAccessor selectedFrameField (model cenv)++  btn <- toolButtonActivateField <$> toolBtnTeleportToFrame (uiBuilder (view cenv))+  (btn `governingR` curFrameField') =:> conditionVMTeleportToFrame cenv++conditionVMTeleportToFrame :: CEnv -> Maybe Int -> IO ()+conditionVMTeleportToFrame cenv Nothing  = return ()+conditionVMTeleportToFrame cenv (Just i) =+  sendToYampaSocketAsync (extra cenv) (show (JumpTo i))++-- gtkBuilderAccessor "toolBtnIOSenseFrame"       "Button"+installConditionIOSenseFrame cenv = void $ do+  let curFrameField' = mkFieldAccessor selectedFrameField (model cenv)++  btn <- toolButtonActivateField <$> toolBtnIOSenseFrame (uiBuilder (view cenv))+  (btn `governingR` curFrameField') =:> conditionVMIOSenseFrame cenv++conditionVMIOSenseFrame :: CEnv -> Maybe Int -> IO ()+conditionVMIOSenseFrame cenv Nothing  = return ()+conditionVMIOSenseFrame cenv (Just i) =+  sendToYampaSocketAsync (extra cenv) (show (IOSense i))++-- gtkBuilderAccessor "toolBtnModifyTime"         "Button"+installConditionModifyTime cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnModifyTime (uiBuilder (view cenv))+  btn =:> conditionVMModifyTime cenv++conditionVMModifyTime :: CEnv -> IO ()+conditionVMModifyTime cenv = return ()++installConditionConnect cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnConnect (uiBuilder (view cenv))+  btn =:> conditionVMConnect cenv++installConditionDisconnect cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnDisconnect (uiBuilder (view cenv))+  btn =:> conditionVMDisconnect cenv++installConditionStep cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnStep (uiBuilder (view cenv))+  btn =:> conditionVMStep cenv++installConditionStepUntil cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnStepUntil (uiBuilder (view cenv))+  btn =:> conditionVMStepUntil cenv++installConditionSkip cenv = do+  btn <- toolButtonActivateField <$> toolBtnSkip (uiBuilder (view cenv))+  btn =:> conditionVMSkip cenv++installConditionSkipBack cenv = do+  btn <- toolButtonActivateField <$> toolBtnSkipBack (uiBuilder (view cenv))+  btn =:> conditionVMSkipBack cenv++installConditionRedo cenv = do+  btn <- toolButtonActivateField <$> toolBtnRedo (uiBuilder (view cenv))+  btn =:> conditionVMRedo cenv++installConditionPlay cenv = do+  btn <- toolButtonActivateField <$> toolBtnPlay (uiBuilder (view cenv))+  btn =:> conditionVMPlay cenv++installConditionStop cenv = do+  btn <- toolButtonActivateField <$> toolBtnStop (uiBuilder (view cenv))+  btn =:> conditionVMStop cenv++installConditionPause cenv = do+  btn <- toolButtonActivateField <$> toolBtnPause (uiBuilder (view cenv))+  btn =:> conditionVMPause cenv++installConditionDeleteTrace cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnDeleteTrace (uiBuilder (view cenv))+  btn =:> conditionVMDeleteTrace cenv++installConditionReplayTrace cenv = void $ do+  btn <- toolButtonActivateField <$> toolBtnReplayTrace (uiBuilder (view cenv))+  btn =:> conditionVMReplayTrace cenv++conditionVMConnect cenv =+  catch (do startYampaSocket (extra cenv)+            r <- getFromYampaSocketSync (extra cenv)+            print r+            eventField <- pollingReactive (getFromEventSocketSync (extra cenv)) (Just 10)+            debugEntry <- txtDebug (uiBuilder (view cenv))+            let debugEntrySetter v = postGUIAsync (get debugEntry textViewBuffer >>= (\b -> set b [textBufferText := v]))+            liftR show eventField =:> debugEntrySetter+            ((const ()) <^> (guardRO' eventField (== Just "CurrentFrameChanged"))) =:> conditionVMTimeChanged cenv+            ((const ()) <^> (guardRO' eventField (== Just "CurrentFrameChanged"))) =:> conditionVMFrameChanged cenv+            ((const ()) <^> (guardRO' eventField (== Just "HistoryChanged")))      =:> conditionVMHistoryChanged cenv+            ((const ()) <^> (guardRO' eventField (== Just "HistoryChanged")))      =:> conditionVMMaxTimeChanged cenv++        )+        (\(e :: IOException) -> hPutStrLn stderr "Cannot connect to Yampa socket")++-- | TODO: Make this reactive+conditionVMMaxTimeChanged cenv = do+  entryGT <- txtMaxTime (uiBuilder (view cenv))+  maxTime <- sendToYampaSocketSync (extra cenv) (show GetMaxTime)+  putStrLn $ "Received " ++ show maxTime+  case maxTime >>= readMaybe of+    Just (MaxTime time) -> postGUIAsync $ entrySetText entryGT $ show time+    _                   -> return ()++-- | TODO: Make this reactive+conditionVMTimeChanged cenv = do+  entryGT <- txtGlobalTime (uiBuilder (view cenv))+  curTime <- sendToYampaSocketSync (extra cenv) (show GetCurrentTime)+  putStrLn $ "Received " ++ show curTime+  case curTime >>= readMaybe of+    Just (CurrentTime time) -> postGUIAsync $ entrySetText entryGT $ show time+    _                       -> return ()++-- | TODO: Make this reactive+conditionVMFrameChanged cenv = do+  let curSimFrame' = mkFieldAccessor curSimFrameField (model cenv)+  entryGT <- txtGlobalTime (uiBuilder (view cenv))+  n       <- sendToYampaSocketSync (extra cenv) (show GetCurrentFrame)+  case n >>= readMaybe of+    Just (CurrentFrame m') -> do putStrLn $ "Current Frame is " ++ show m'+                                 reactiveValueWrite curSimFrame' (Just m')+    _                      -> reactiveValueWrite curSimFrame' Nothing++-- | TODO: Make this reactive+--+-- TODO: Bug: This resets the frame list to the default values.+conditionVMHistoryChanged cenv = do+  let fs = mkFieldAccessor framesField (model cenv)+  n <- sendToYampaSocketSync (extra cenv) (show SummarizeHistory)+  putStrLn $ "Received " ++ show n+  case n >>= readMaybe of+    Just (CurrentHistory m') -> do putStrLn $ "Show have now " ++ show m' ++ " frames"+                                   reactiveValueWrite fs $ map defaultFrame [0..(m'-1)]+    _                        -> do putStrLn "Could not read any number of frames"+                                   reactiveValueWrite fs []++conditionVMDisconnect cenv =+  catch (stopYampaSocket (extra cenv))+        (\(e :: IOException) -> hPutStrLn stderr "Failure trying to disconnect from Yampa socket")++conditionVMStep cenv =+  sendToYampaSocketAsync (extra cenv) (show Step)++conditionVMSkip cenv =+  sendToYampaSocketAsync (extra cenv) (show Skip)++conditionVMStepUntil cenv =+  sendToYampaSocketAsync (extra cenv) (show StepUntil)++conditionVMSkipBack cenv =+  sendToYampaSocketAsync (extra cenv) (show SkipBack)++conditionVMRedo cenv =+  sendToYampaSocketAsync (extra cenv) (show Redo)++conditionVMPlay cenv =+  sendToYampaSocketAsync (extra cenv) (show Play)++conditionVMStop cenv =+  sendToYampaSocketAsync (extra cenv) (show Stop)++conditionVMPause cenv =+  sendToYampaSocketAsync (extra cenv) (show Pause)++conditionVMDeleteTrace cenv =+  sendToYampaSocketAsync (extra cenv) (show DeleteTrace)++conditionVMReplayTrace cenv =+  sendToYampaSocketAsync (extra cenv) (show ReplayTrace)
+ src/Controller/Conditions/CloseIDE.hs view
@@ -0,0 +1,66 @@+-- | Condition: The program ends when the main window is closed++module Controller.Conditions.CloseIDE+    (installCondition)+  where++-- External libraries+import Control.Arrow+import Control.Monad+import Control.Monad.Reader (liftIO)+import Graphics.UI.Gtk++-- Internal libraries+import CombinedEnvironment hiding (installCondition)+import View.Objects++-- TODO:+-- filter :: (a -> Bool) -> RV a -> RV a+-- only changes when f a == True+--+-- edge :: (a -> Bool) -> RV a -> RV a+-- only changes when f a becomes True after being False+--+-- also filterM and edgeM+--+-- liftIO :: m a -> RO a m+--+-- wrapIO :: m a -> (a -> m ()) -> RV a m -- Passive+--+-- The following probably exists already:+-- wrapWO :: (a -> m b) -> RV a+--++installCondition :: CEnv -> IO()+installCondition cenv = void $ do+  mw <- mainWindow $ uiBuilder $ view cenv+  mw `on` deleteEvent $ liftIO $ conditionVM cenv++-- | Enforces the condition in View to Model direction+conditionVM :: CEnv -> IO Bool+conditionVM cenv = do+  b <- checkExit cenv+  when b $ onViewAsync destroyView+  return (not b)++-- Returns true if the operation can continue, false otherwise+checkExit :: CEnv -> IO Bool+checkExit cenv = do+  let (v,m) = (view &&& model) cenv+  let ui = uiBuilder v+  win <- mainWindow ui+  dialog <- messageDialogNew (Just win) [DialogModal] MessageQuestion ButtonsNone+              "Exit?"+  dialogAddButton dialog "Cancel"               ResponseCancel+  dialogAddButton dialog "Exit"                 ResponseYes++  dialogSetDefaultResponse dialog ResponseCancel++  -- Run the dialog and process the result+  widgetShowAll dialog+  r <- dialogRun dialog+  res <- case r of+           ResponseYes -> return True+           _           -> return False -- Cancel or close the dialog without answering+  widgetDestroy dialog+  return res
+ src/Controller/Conditions/CurFrameInfo.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Controller.Conditions.CurFrameInfo where++import Control.Applicative+import Control.Exception+import Control.Monad+import Control.Monad.IfElse+import Data.Maybe+import Data.ReactiveValue+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Reactive+import Graphics.UI.Gtk.Reactive.Gtk2+import Hails.MVC.Model.ProtectedModel.Reactive+import System.IO+import Text.Read                               (readMaybe)++import CombinedEnvironment+import IOBridge++installCondition :: CEnv -> IO ()+installCondition cenv = do+  installConditionInput       cenv+  installConditionModifyInput cenv++  installConditionShowFrame   cenv+  installConditionShowTime    cenv+  installConditionShowDTime   cenv++installConditionModifyInput cenv = do+  let curFrameField'      = mkFieldAccessor selectedFrameField      (model cenv)+      curFrameInputField' = mkFieldAccessor selectedFrameInputField (model cenv)+      curFrameData        = liftR2 (,) curFrameField' curFrameInputField'++  btn <- toolButtonActivateField <$> toolBtnModifyInput (uiBuilder (view cenv))+  (btn `governingR` curFrameData) =:> conditionVMModifyInput cenv++installConditionInput cenv = do+  let curFrameField'      = mkFieldAccessor selectedFrameField (model cenv)+  let curFrameInputField' = mkFieldAccessor selectedFrameInputField (model cenv)+  txtFrameInput' <- entryTextReactive <$> txtFrameInput (uiBuilder (view cenv))++  curFrameField' =:> wrapMW (\f ->+    case f of+      Just ix -> do+        let command = "GetInput " ++ show (ix :: Int)+        n <- sendToYampaSocketSync (extra cenv) command+        case n >>= readMaybe of+          Just (Just x) -> do putStrLn ("Want to show " ++ show x)+                              postGUIAsync $ do reactiveValueWrite txtFrameInput' x+                                                reactiveValueWrite curFrameInputField' (Just x)+          _      -> postGUIAsync $ do reactiveValueWrite txtFrameInput' ""+                                      reactiveValueWrite curFrameInputField' Nothing+      Nothing -> do reactiveValueWrite txtFrameInput' ""+                    reactiveValueWrite curFrameInputField' Nothing+   )++conditionVMModifyInput :: CEnv -> (Maybe Int, Maybe String) -> IO ()+conditionVMModifyInput cenv (Just ix, Just info) = do+    let command = "ModifyInputAt " ++ show ix ++ " " ++ show info+    sendToYampaSocketAsync (extra cenv) command+    print command+conditionVMModifyInput _ _ = return ()++installConditionShowFrame cenv = do+  let curFrameField' = mkFieldAccessor selectedFrameField (model cenv)+  txtFrameNumber' <- entryTextReactive <$> txtFrameNumber      (uiBuilder (view cenv))++  liftR (maybe "" show) curFrameField' =:> txtFrameNumber'++installConditionShowTime cenv = do+  let curFrameField' = mkFieldAccessor selectedFrameField (model cenv)+  txtFrameTime' <- entryTextReactive <$> txtFrameTime (uiBuilder (view cenv))++  curFrameField' =:> wrapMW (\f ->+       case f of+        Just ix -> do+          let command = "GetGTime " ++ show (ix :: Int)+          n <- sendToYampaSocketSync (extra cenv) command+          case n >>= readMaybe of+            Just (Just x) -> do putStrLn ("Want to show " ++ show x)+                                postGUIAsync $ reactiveValueWrite txtFrameTime' (show (x :: Double))+            _      -> postGUIAsync $ reactiveValueWrite txtFrameTime' ""+        Nothing -> reactiveValueWrite txtFrameTime' ""+    )++installConditionShowDTime cenv = do+  let curFrameField' = mkFieldAccessor selectedFrameField (model cenv)+  txtFrameDTime' <- entryTextReactive <$> txtFrameDTime (uiBuilder (view cenv))++  curFrameField' =:> wrapMW (\f ->+      case f of+       Just ix -> do+         let command = "GetDTime " ++ show (ix :: Int)+         n <- sendToYampaSocketSync (extra cenv) command+         case n >>= readMaybe of+           Just (Just x) -> do putStrLn ("Want to show " ++ show x)+                               postGUIAsync $ reactiveValueWrite txtFrameDTime' (show (x :: Double))+           _      -> postGUIAsync $ reactiveValueWrite txtFrameDTime' ""+       Nothing -> reactiveValueWrite txtFrameDTime' ""+    )
+ src/Controller/Conditions/TraceViewer.hs view
@@ -0,0 +1,64 @@+-- | The TraceViewer contains the rules that create and keep the+--   GUI stream widget in sync with the trace in the model.+module Controller.Conditions.TraceViewer where++import Data.ReactiveValue+import Graphics.UI.Gtk hiding (Frame)+import Graphics.UI.Gtk.StreamChart+import Hails.MVC.Model.ProtectedModel.Reactive++import CombinedEnvironment+import Model.Model+import View.Objects++installCondition :: CEnv -> IO ()+installCondition cenv = do+  installTraceViewerSelection cenv+  installTraceViewerFrames    cenv++-- | Install Rule that keeps the user selection in the view in sync+-- with the selection in the model.+installTraceViewerSelection :: CEnv -> IO ()+installTraceViewerSelection cenv = do+  let traceViewer = streamChart (view cenv)++  let curFrameField' = mkFieldAccessor selectedFrameField (model cenv)+  let framesField'   = mkFieldAccessor framesField        (model cenv)++  -- TODO: Make streamchart reactive+  streamChartOnButtonEvent traceViewer $ \press p -> do+    fs <- reactiveValueRead (mkFieldAccessor framesField (model cenv))+    if p >= length fs || p < 0+      then do putStrLn "Out of range"+              reactiveValueWrite curFrameField' Nothing+      else if press+             then putStrLn $ "Pressed: "  ++ show (fs!!p)+             else do putStrLn $ "Released: " ++ show (fs!!p)+                     reactiveValueWrite curFrameField' (Just p)++  curFrameField' =:>+    wrapMW (\frame -> putStrLn $ "The selection changed " ++ show frame)++-- | Install Rule that keeps the frames model field in sync with the frames in+-- the view.+installTraceViewerFrames :: CEnv -> IO ()+installTraceViewerFrames cenv = do+  let traceViewer = streamChart (view cenv)+  -- Debug+  let framesField'   = mkFieldAccessor framesField        (model cenv)+  let curFrameField' = mkFieldAccessor selectedFrameField (model cenv)+  let curSimFrame'   = mkFieldAccessor curSimFrameField   (model cenv)+  liftR3 markSelectedFrame curFrameField' curSimFrame' framesField'+    =:> wrapMW (onViewAsync . streamChartSetList traceViewer)+  framesField' =:> wrapMW (\fs -> putStrLn $ "Frames changed:" ++ show fs)++markSelectedFrame :: Maybe Int -> Maybe Int -> [Frame] -> [Frame]+markSelectedFrame c s [] = []+markSelectedFrame c s (f:fs) = mark f : markSelectedFrame c' s' fs+  where+    mark = markSelected . markCurrent+    markSelected = if s == Just 0 then frameSelect  else frameDeselect+    markCurrent  = if c == Just 0 then frameCurrent else frameNotCurrent+    c'           = toJust $ maybe (-1) (\x -> x - 1) c+    s'           = toJust $ maybe (-1) (\x -> x - 1) s+    toJust n = if n < 0 then Nothing else Just n
+ src/FRP/Titan/Protocol.hs view
@@ -0,0 +1,33 @@+module FRP.Titan.Protocol where++-- Basic Titan Protocol++data Response = CurrentFrame   Int+              | CurrentHistory Int+              | CurrentTime    Float+              | MaxTime        Float+  deriving Read++data TitanEvent = HistoryChanched+  deriving Read++data TitanCommand = GetMaxTime+                  | GetCurrentTime+                  | GetCurrentFrame+                  | SummarizeHistory+                  | Step+                  | Skip+                  | StepUntil+                  | SkipBack+                  | Redo+                  | Play+                  | Stop+                  | Pause+                  | DeleteTrace+                  | ReplayTrace+                  | TravelToFrame Int+                  | JumpTo Int+                  | IOSense Int+                  | DiscardFuture Int+                  | LoadTraceFromString String+  deriving Show
+ src/Graphics/UI/Gtk/GtkView.hs view
@@ -0,0 +1,27 @@+-- | Implements the generic view class for the Gtk GUI manager.+module Graphics.UI.Gtk.GtkView where++import Graphics.UI.View+import Graphics.UI.Gtk++-- | A GtkGUI is a collection of elements that may be initialised We use this+-- class to make the Instantiation of View simpler.+class GtkGUI a where+  initialise :: IO a++-- | A GtkView simply encapsulates a GtkGUI.+data GtkGUI a => GtkView a = GtkView a++-- | Extracts the GUI from a GtkView+getGUI :: GtkGUI a => GtkView a -> a+getGUI (GtkView x) = x++-- | Instantiates the generic View for Gtk views using the default GtkGUI+-- initialiser and the default Gtk counterparts of the View class functions.+instance GtkGUI a => View (GtkView a) where+  initView   _  = initGUI >> return ()+  createView    = initialise >>= (return . GtkView)+  startView  _  = mainGUI+  onViewSync _  = postGUISync+  onViewAsync _ = postGUIAsync+  destroyView _ = mainQuit
+ src/Graphics/UI/Gtk/StreamChart.hs view
@@ -0,0 +1,129 @@+module Graphics.UI.Gtk.StreamChart where++import Control.Monad+import Data.IORef+import Data.Maybe+import Graphics.Rendering.Cairo as Cairo+import Graphics.UI.Gtk+import System.Glib.Types++data StreamChart a = StreamChart DrawingArea (IORef ([a], StreamChartParams a))+type StreamChartParams a = a -> StreamChartStyle+data StreamChartStyle =+  StreamChartStyle+    { renderFGColor :: (Double, Double, Double, Double)+    , renderBGColor :: (Double, Double, Double, Double)+    , renderDot     :: Bool+    , renderLetter  :: Maybe Char+    }++defaultStreamChartStyle = StreamChartStyle+  { renderFGColor = (0.5, 0.6, 0.7, 1.0)+  , renderBGColor = (0.9, 0.2, 0.1, 0.9)+  , renderDot     = True+  , renderLetter  = Nothing+  }++streamChartNew :: IO (StreamChart a)+streamChartNew = do+  da <- drawingAreaNew+  defaultParamsRef <- newIORef ([], \_ -> defaultStreamChartStyle)++  let sc = StreamChart da defaultParamsRef++  da `on` exposeEvent $ liftIO $ redrawStreamChart sc++  widgetAddEvents da [PointerMotionMask, Button1MotionMask, KeyPressMask, KeyReleaseMask]++  return sc++instance GObjectClass (StreamChart a) where+  toGObject (StreamChart drawingArea _) = toGObject drawingArea+  unsafeCastGObject o = StreamChart (unsafeCastGObject o) undefined+instance ObjectClass (StreamChart a)+instance WidgetClass (StreamChart a)+instance DrawingAreaClass (StreamChart a)++redrawStreamChart :: StreamChart a -> IO Bool+redrawStreamChart (StreamChart drawingArea scRef) = do+  (es, styleF) <- readIORef scRef+  dw           <- widgetGetDrawWindow drawingArea++  (w, h) <- widgetGetSize drawingArea+  regio  <- regionRectangle $ Rectangle 0 0 w h+  drawWindowBeginPaintRegion dw regio+  renderWithDrawable dw $ streamChartRenderBlocksCairo styleF es+  drawWindowEndPaint dw++  return True++streamChartSetList :: StreamChart a -> [a] -> IO ()+streamChartSetList sc@(StreamChart da scRef) ls' = do+  modifyIORef scRef (\(_,styleF) -> (ls',styleF))+  invalidateStreamChart sc++streamChartSetStyle :: StreamChart a -> StreamChartParams a -> IO ()+streamChartSetStyle sc@(StreamChart da scRef) styleF' = do+  modifyIORef scRef (\(ls,styleF) -> (ls,styleF'))+  invalidateStreamChart sc+  -- redrawStreamChart sc++invalidateStreamChart :: StreamChart a -> IO ()+invalidateStreamChart (StreamChart da _) = do+  (w, h) <- widgetGetSize da+  let rect = Rectangle 0 0 w h+  dw <- widgetGetWindow da+  case dw of+    Nothing -> return ()+    Just dw' -> drawWindowInvalidateRect dw' rect True++streamChartRenderBlocksCairo :: (a -> StreamChartStyle) -> [a] -> Render ()+streamChartRenderBlocksCairo rSettingsF bs = streamChartRenderBlocksCairo' rSettingsF bs 0++streamChartRenderBlocksCairo' :: (a -> StreamChartStyle) -> [a] -> Double -> Render ()+streamChartRenderBlocksCairo' rSettingsF []      baseX = return ()+streamChartRenderBlocksCairo' rSettingsF (bk:bs) baseX = do+  let rSettings = rSettingsF bk+      (rF,gF,bF,aF) = renderFGColor rSettings+      (rB,gB,bB,aB) = renderBGColor rSettings++  setSourceRGBA rB gB bB aB+  Cairo.rectangle baseX 0 20 80+  fill++  setSourceRGBA rF gF bF aF+  Cairo.rectangle baseX 0 20 80+  stroke++  when (renderDot rSettings) $ do+    setSourceRGBA 0 0 0 1.0+    Cairo.arc (baseX + 10) 40 3 0 (2 * pi)+    fill++  when (isJust $ renderLetter rSettings) $ do+    let x = fromJust $ renderLetter rSettings+    te <- textExtents [x]+    let textW = textExtentsWidth te+        textH = textExtentsHeight te+    setSourceRGBA 0.0 0.0 0.0 1.0+    moveTo (baseX + 10 - (textW / 2)) (40 - (textExtentsYbearing te / 2)) -- (40 - textH / 2)+    showText [x]++    liftIO (print $ textExtentsXbearing te)+    liftIO (print $ textExtentsYbearing te)++  streamChartRenderBlocksCairo' rSettingsF bs (baseX + 20)++streamChartOnButtonEvent :: StreamChart a -> (Bool -> Int -> IO ()) -> IO ()+streamChartOnButtonEvent (StreamChart da scRef) handler = do+    da `on` buttonPressEvent   $ myHandler (handler True)+    da `on` buttonReleaseEvent $ myHandler (handler False)+    return ()+  where+    myHandler :: (Int -> IO ()) -> EventM EButton Bool+    myHandler handler = do+      (x,y) <- eventCoordinates+      let x' = round x+          y' = round y+      liftIO $ postGUIAsync $ handler (x' `div` 20)+      return False
+ src/Graphics/UI/View.hs view
@@ -0,0 +1,42 @@+-- | This class encapsulates GUI apis with some basic common operations:+-- initialise the GUI, destroy the GUI, execute in the GUI Thread, etc.++-- NOTE: This code is stable, but the design is experimental.+-- It works fine, but I doubt it's a good solution in the long term. In+-- particular, I do not like having to use the dummy type Null to define the+-- Class.++module Graphics.UI.View where++-- | Null is a parametric datatype with a non-parametric constructor.++-- NOTE: IT simplifies the class definition.+data Null a = Null++-- | A Class for View (GUI) managers. GUI managers usually have similar+-- operations: initialise, destroy, run operation in the GUI thread, etc.+-- This class encapsulates all these operations to provide a unique interface.+class View a where+  initView    :: Null a -> IO ()+  createView  :: IO a+  startView   :: a -> IO ()+  onViewSync  :: a -> IO b -> IO b+  onViewAsync :: a -> IO () -> IO ()+  destroyView :: a -> IO ()++-- | An Element Accessor to access elements of kind+-- b from Views of kind a is a function that takes an+-- a and returns a b.+--+-- This type is defined to make signatures shorter+-- and more declarative.+type ViewElementAccessor a b = (a -> b)++-- | An Element Accessor to access elements of kind+-- b from Views of kind a is a function that takes an+-- a and returns an IO b.+--+-- This is the IO counterpart of the previous type. It is+-- used more often because most element accessors run+-- inside the IO monad.+type ViewElementAccessorIO a b = ViewElementAccessor a (IO b)
+ src/Hails/Graphics/UI/Gtk/Builder.hs view
@@ -0,0 +1,22 @@+module Hails.Graphics.UI.Gtk.Builder where++import Graphics.UI.Gtk++-- | Returns a builder from which the objects in this part of the interface+-- can be accessed.+loadDefaultInterface :: (String -> IO String) -> IO Builder+loadDefaultInterface getDataFileName =+  loadInterface =<< getDataFileName "Interface.glade"++-- | Returns a builder from which the objects in this part of the interface+-- can be accessed.+loadInterface :: String -> IO Builder+loadInterface builderPath = do+  builder <- builderNew+  builderAddFromFile builder builderPath+  return builder+  +-- | Returns an element from a builder+fromBuilder :: (GObjectClass cls) =>+                (GObject -> cls) -> String -> Builder -> IO cls+fromBuilder f s b = builderGetObject b f s
+ src/Hails/Graphics/UI/Gtk/Helpers/Combo.hs view
@@ -0,0 +1,44 @@+module Hails.Graphics.UI.Gtk.Helpers.Combo where++import Data.List+import Data.Maybe+import Graphics.UI.Gtk++addTextColumn :: (TreeModelClass (model row), TypedTreeModelClass model)+                => ComboBox -> model row -> (row -> Maybe String) -> IO()+addTextColumn cb st f = do++  comboBoxSetModel cb (Just st)+  renderer <- cellRendererTextNew+  cellLayoutPackStart cb renderer True+  cellLayoutSetAttributes cb renderer st $ map (cellText :=).maybeToList.f+  return ()++type TypedComboBox a = (ComboBox, ListStore a)++typedComboBoxCombo :: TypedComboBox a -> ComboBox+typedComboBoxCombo = fst++typedComboBoxStore :: TypedComboBox a -> ListStore a+typedComboBoxStore = snd++typedComboBoxGetSelected :: TypedComboBox a -> IO (Maybe a)+typedComboBoxGetSelected (cb, ls) = do+  sel  <- get cb comboBoxActive+  list <- listStoreToList ls+  if sel < 0 || length list <= sel+   then return Nothing+   else return $ Just $ list!!sel++typedComboBoxGetSelectedUnsafe :: TypedComboBox a -> IO a+typedComboBoxGetSelectedUnsafe (cb, ls) = do+  sel  <- get cb comboBoxActive+  list <- listStoreToList ls+  return $ list!!sel++typedComboBoxSetSelected :: (Eq a) => TypedComboBox a -> a -> IO ()+typedComboBoxSetSelected (cb, ls) x = do+  list <- listStoreToList ls+  case elemIndex x list of+   Nothing -> return ()+   Just ix -> set cb [ comboBoxActive := ix ]
+ src/Hails/Graphics/UI/Gtk/Helpers/FileDialog.hs view
@@ -0,0 +1,42 @@+module Hails.Graphics.UI.Gtk.Helpers.FileDialog+  ( openOpenFileDialog+  )+  where++import Graphics.UI.Gtk++type Ext = ([String], String)++-- Auxiliary functions: open file dialogs+openOpenFileDialog :: String -> [Ext] -> IO (Maybe String)+openOpenFileDialog title exts = do++  dialog <- fileChooserDialogNew+              (Just title)           --dialog title+              Nothing+              FileChooserActionOpen  --the kind of dialog we want+              [("gtk-cancel"         --The buttons to display+               ,ResponseCancel)+              ,("gtk-ok"+               , ResponseAccept)]++  ffs <- extsToFilters exts+  mapM_ (fileChooserAddFilter dialog) ffs++  widgetShow dialog+  result <- dialogRun dialog+  res <- case result of+           ResponseAccept -> fileChooserGetFilename dialog+           _              -> return Nothing+  widgetDestroy dialog+  return res++extsToFilters :: [Ext] -> IO [FileFilter]+extsToFilters = mapM extToFilter++extToFilter :: Ext -> IO FileFilter+extToFilter (pats, name) = do+  ff <- fileFilterNew+  fileFilterSetName ff name+  mapM_ (fileFilterAddPattern ff) pats+  return ff
+ src/Hails/Graphics/UI/Gtk/Helpers/MenuItem.hs view
@@ -0,0 +1,6 @@+module Hails.Graphics.UI.Gtk.Helpers.MenuItem where++import Graphics.UI.Gtk++menuItemGetLabel :: MenuItemClass self => self -> IO (Maybe Label)+menuItemGetLabel = fmap (fmap castToLabel) . binGetChild
+ src/Hails/Graphics/UI/Gtk/Helpers/MessageDialog.hs view
@@ -0,0 +1,10 @@+module Hails.Graphics.UI.Gtk.Helpers.MessageDialog where++import Graphics.UI.Gtk+import Control.Monad++popupError :: String -> String -> IO ()+popupError t s = do+  md <- messageDialogNew Nothing [DialogModal] MessageError ButtonsOk s+  set md [ windowTitle := t ]+  void $ dialogRun md >> widgetDestroy md
+ src/Hails/Graphics/UI/Gtk/Reactive.hs view
@@ -0,0 +1,71 @@+-- | Contains functions to define fields from Gtk widgets. In reality,+-- most widgets have different properties, all of which can be treated+-- as different fields. This module oversimplifies that vision and+-- provides one field for the most "important" of those attributes: a string+-- field for a text-box, a bool field for a checkbox, etc.+-- +-- This module is deeply incomplete. Feel free to add other definitions+-- in you find them useful.+--+-- Also, it should not be here at all. Instead, it should be moved+-- to a separate library.+module Hails.Graphics.UI.Gtk.Reactive+   ( module Hails.Graphics.UI.Gtk.Reactive+   , module Exported+   )+  where++-- External libraries+import Control.Monad+import GHC.Float+import Graphics.UI.Gtk++-- Internal libraries+import Hails.Graphics.UI.Gtk.Helpers.Combo+import Hails.MVC.Controller.Reactive as Exported++-- An Entry's main reactive view field is a string with the contents+-- of the text box+type ReactiveViewEntry = ReactiveViewField String++reactiveEntry :: Entry -> ReactiveViewEntry+reactiveEntry entry = ReactiveViewField+ { onChange = void . (onEditableChanged entry)+ , rvfGet   = get entry entryText+ , rvfSet   = \t -> set entry [ entryText := t ]+ }++reactiveCheckMenuItem :: CheckMenuItem -> ReactiveViewField Bool+reactiveCheckMenuItem item = ReactiveViewField+ { onChange = void . (on item checkMenuItemToggled)+ , rvfGet   = checkMenuItemGetActive item+ , rvfSet   = checkMenuItemSetActive item+ }++reactiveToggleButton :: ToggleButtonClass a => a -> ReactiveViewField Bool+reactiveToggleButton item = ReactiveViewField+ { onChange = void . (on item toggled)+ , rvfGet   = toggleButtonGetActive item+ , rvfSet   = toggleButtonSetActive item+ }++reactiveSpinButton :: SpinButtonClass a => a -> ReactiveViewField Int+reactiveSpinButton item = ReactiveViewField+ { onChange = void . (onValueSpinned item)+ , rvfGet   = spinButtonGetValueAsInt item+ , rvfSet   = spinButtonSetValue item . fromIntegral+ }++reactiveScale :: RangeClass a => a -> ReactiveViewField Float+reactiveScale item = ReactiveViewField+ { onChange = void . (on item valueChanged)+ , rvfGet   = fmap double2Float $ get item rangeValue+ , rvfSet   = \t -> set item [ rangeValue := float2Double t ]+ }++reactiveTypedComboBoxUnsafe :: (Eq a) => ListStore a -> ComboBox -> ReactiveViewField a+reactiveTypedComboBoxUnsafe ls item = ReactiveViewField+ { onChange = void . (on item changed)+ , rvfGet   = typedComboBoxGetSelectedUnsafe (item, ls)+ , rvfSet   = typedComboBoxSetSelected (item, ls)+ }
+ src/Hails/Graphics/UI/Gtk/Simplify/AboutDialog.hs view
@@ -0,0 +1,46 @@+-- | Condition: The page of the main notebook visible at each moment+-- is the that corresponds to the selected branch in the category+-- tree.++module Hails.Graphics.UI.Gtk.Simplify.AboutDialog+    (installHandlers)+  where++import Control.Arrow+import Control.Monad+import Control.Monad.Reader (liftIO)+import Data.ExtraVersion+import Graphics.UI.Gtk+import Graphics.UI.Gtk.GtkView+import Graphics.UI.View+-- import Graphics.UI.Gtk.GenericView+import Hails.MVC.GenericCombinedEnvironment+import Hails.MVC.Model.ReactiveModel (Event)+import Hails.MVC.Model.ProtectedModel.VersionedModel+import Hails.MVC.Model.ProtectedModel.NamedModel++installHandlers :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b,+                    Event c, MenuItemClass d)+                => CEnv a b c+                -> (ViewElementAccessorIO (GtkView a) d)+                -> (ViewElementAccessorIO (GtkView a) AboutDialog)+                -> IO ()+installHandlers cenv mF dF = void $ do+  let vw = view cenv+  mn <- mF vw+  mn `on` menuItemActivate $ liftIO (onViewAsync vw (condition cenv dF))++condition :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b, Event c)+                => CEnv a b c+                -> (ViewElementAccessorIO (GtkView a) AboutDialog)+                -> IO ()+condition cenv dF = do+  let (vw, pm) = (view &&& model) cenv+  dg <- dF vw+  vn <- fmap versionToString $ getVersion pm+  pr <- getName pm+  set dg [ aboutDialogVersion := vn ]+  set dg [ aboutDialogProgramName := pr ]+  set dg [ aboutDialogName := pr ]+  _ <- dialogRun dg+  widgetHide dg
+ src/Hails/Graphics/UI/Gtk/Simplify/Logger.hs view
@@ -0,0 +1,97 @@+module Hails.Graphics.UI.Gtk.Simplify.Logger+    (installHandlers, installHandlersUnique)+  where++import Control.Arrow+import Control.Monad+import Hails.MVC.Model.ReactiveModel (Event)+import Control.Monad.Reader (liftIO)+import Data.Maybe+import Hails.MVC.GenericCombinedEnvironment+import Graphics.UI.Gtk+-- import Graphics.UI.Gtk.GenericView+import Graphics.UI.Gtk.GtkView+import Graphics.UI.View+import System.Log as Log+import System.Log.Formatter+import System.Log.Handler+import System.Log.Logger++import Hails.MVC.Model.ProtectedModel.LoggedModel++installHandlersUnique :: (GtkGUI a, LoggedBasicModel b,+                          Event c, MenuItemClass d)+                      => CEnv a b c+                      -> (ViewElementAccessorIO (GtkView a) d)+                      -> IO ()+installHandlersUnique cenv mF = void $ do+  rl <- getRootLogger+  let lhs = [] :: [ ListStoreLogHandler ]+  let rl' = setHandlers lhs rl+  saveGlobalLogger rl'+  installHandlers cenv mF++installHandlers :: (GtkGUI a, LoggedBasicModel b,+                    Event c, MenuItemClass d)+                => CEnv a b c+                -> (ViewElementAccessorIO (GtkView a) d)+                -> IO ()+installHandlers cenv mF = void $ do+  let (vw, pm) = (view &&& model) cenv++  lsLogHandler <- listStoreLogHandlerNew+  log <- getLog pm+  -- let nl = setHandlers [lsLogHandler] log+  let nl = addHandler lsLogHandler log+  saveGlobalLogger nl++  w  <- createLogWindow $ lslhStore lsLogHandler+  mn <- mF vw+  mn `on` menuItemActivate $ liftIO (widgetShowAll w)++createLogWindow :: ListStore String -> IO Window+createLogWindow ls = do+  w <- windowNew+  set w [ windowTitle := "Log" ]+  windowSetDefaultSize w 400 300+  s <- scrolledWindowNew Nothing Nothing+  containerAdd w s+  tv <- treeViewNewWithModel ls+  treeViewSetHeadersVisible tv False+  addTextColumn tv ls Just+  containerAdd s tv+  w `on` deleteEvent $ liftIO $ widgetHide w >> return True+  return w -- , ls)++addTextColumn :: (TreeModelClass (model row), TypedTreeModelClass model)+                => TreeView -> model row -> (row -> Maybe String) -> IO()+addTextColumn tv st f = do+  col <- treeViewColumnNew+  renderer <- cellRendererTextNew+  cellLayoutPackStart col renderer True+  cellLayoutSetAttributes col renderer st $ map (cellText :=).maybeToList.f+  _ <- treeViewAppendColumn tv col+  return ()++data ListStoreLogHandler = ListStoreLogHandler+ { lslhStore     :: ListStore String+ , lslhLevel     :: Log.Priority+ , lslhFormatter :: LogFormatter ListStoreLogHandler+ }++instance LogHandler ListStoreLogHandler where+ getLevel         = lslhLevel+ setLevel x l     = x { lslhLevel = l }+ getFormatter     = lslhFormatter+ setFormatter x f = x { lslhFormatter = f }+ emit x l _       = listStoreAppend (lslhStore x) (snd l) >> return ()+ close _          = return ()++listStoreLogHandlerNew :: IO ListStoreLogHandler+listStoreLogHandlerNew = do+  ls <- listStoreNew []+  return ListStoreLogHandler+           { lslhStore     = ls+           , lslhLevel     = DEBUG+           , lslhFormatter = nullFormatter+           }
+ src/Hails/Graphics/UI/Gtk/Simplify/NameAndVersionTitleBar.hs view
@@ -0,0 +1,36 @@+module Hails.Graphics.UI.Gtk.Simplify.NameAndVersionTitleBar where++import Control.Arrow+import Control.Monad+import Control.Monad.Reader (liftIO)+import Data.ExtraVersion+-- import Graphics.UI.Gtk.GenericView+import Graphics.UI.Gtk+import Graphics.UI.Gtk.GtkView+import Graphics.UI.View+import Hails.MVC.GenericCombinedEnvironment+import Hails.MVC.Model.ReactiveModel (Event)+import Hails.MVC.Model.ProtectedModel.VersionedModel+import Hails.MVC.Model.ProtectedModel.NamedModel++installHandlers :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b, Event c)+                => CEnv a b c+                -> (ViewElementAccessorIO (GtkView a) Window)+                -> IO ()+installHandlers cenv wF = void $ do+  let vw = view cenv+  w <- wF vw+  w `on` mapEvent $ liftIO (onViewAsync vw (condition cenv wF)) >> return False++condition :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b, Event c)+          => CEnv a b c+          -> (ViewElementAccessorIO (GtkView a) Window)+          -> IO ()+condition cenv wF = do+  let (vw, pm) = (view &&& model) cenv+  w  <- wF vw+  pn <- getName pm+  vn <- fmap versionToString $ getVersion pm+  t  <- windowGetTitle w+  let titleMust = pn ++ " " ++ vn+  when (t /= titleMust) $ windowSetTitle w titleMust
+ src/Hails/Graphics/UI/Gtk/Simplify/ProgramMainWindow.hs view
@@ -0,0 +1,27 @@+module Hails.Graphics.UI.Gtk.Simplify.ProgramMainWindow where++import Control.Monad.Reader (liftIO)+import Hails.MVC.Model.ReactiveModel (Event)+import Hails.MVC.GenericCombinedEnvironment+import Graphics.UI.View+-- import Graphics.UI.Gtk.GenericView+import Graphics.UI.Gtk+import Graphics.UI.Gtk.GtkView++installHandlers :: (GtkGUI a, Event c)+                => CEnv a b c+                -> (ViewElementAccessorIO (GtkView a) Window)+                -> IO ()+installHandlers cenv wF = do+  let vw = view cenv+  w  <- wF vw+  _  <- w `on` deleteEvent $ liftIO $ condition cenv+  return ()++condition :: (GtkGUI a, Event c)+          => CEnv a b c+          -> IO Bool+condition cenv = do+  let vw = view cenv+  onViewAsync vw $ destroyView vw+  return False
+ src/Hails/Graphics/UI/Gtk/Simplify/ReactiveGtk.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+module Hails.Graphics.UI.Gtk.Simplify.ReactiveGtk where++import Control.Monad (void)+import Control.Monad.Reader (liftIO)++import Graphics.UI.Gtk++import Data.ReactiveValue++menuItemActivateField :: MenuItem -> ReactiveFieldActivatable +menuItemActivateField m = mkActivatable op+ where op f = void (m `on` menuItemActivate $ liftIO f)++buttonActivateField :: Button -> ReactiveFieldActivatable +buttonActivateField b = mkActivatable op+ where op f = void (b `onClicked` f)++toolButtonActivateField :: ToolButton -> ReactiveFieldActivatable +toolButtonActivateField t = mkActivatable op+ where op f = void (t `onToolButtonClicked` f)++instance ReactiveValueActivatable ToolButton where+  defaultActivation = toolButtonActivateField++instance ReactiveValueActivatable Button where+  defaultActivation = buttonActivateField++instance ReactiveValueActivatable MenuItem where+  defaultActivation = menuItemActivateField
+ src/Hails/Graphics/UI/Gtk/Simplify/RootLogger.hs view
@@ -0,0 +1,93 @@+module Hails.Graphics.UI.Gtk.Simplify.RootLogger+    (installHandlers, installHandlersUnique)+  where++import Control.Monad.Reader (liftIO)+import Data.Maybe+-- import GenericCombinedEnvironment+import Graphics.UI.Gtk+-- import Graphics.UI.Gtk.GenericView+import Hails.MVC.GenericCombinedEnvironment+import Graphics.UI.Gtk.GtkView+import Graphics.UI.View+import Hails.MVC.Model.ReactiveModel (Event)+import System.Log as Log+import System.Log.Formatter+import System.Log.Handler+import System.Log.Logger++installHandlersUnique :: (GtkGUI a,+                          Event c, MenuItemClass d)+                      => CEnv a b c+                      -> (ViewElementAccessorIO (GtkView a) d)+                      -> IO ()+installHandlersUnique cenv mF = fmap (const ()) $ do+  rl <- getRootLogger+  let lhs = [] :: [ListStoreLogHandler]+  let rl' = setHandlers lhs rl+  saveGlobalLogger rl'+  installHandlers cenv mF++installHandlers :: (GtkGUI a,+                    Event c, MenuItemClass d)+                => CEnv a b c+                -> (ViewElementAccessorIO (GtkView a) d)+                -> IO ()+installHandlers cenv mF = fmap (const ()) $ do+  let vw = view cenv++  lsLogHandler <- listStoreLogHandlerNew+  rl <- getRootLogger+  let nl = addHandler lsLogHandler rl+  saveGlobalLogger nl++  w  <- createLogWindow $ lslhStore lsLogHandler+  mn <- mF vw+  mn `on` menuItemActivate $ liftIO (widgetShowAll w)++createLogWindow :: ListStore String -> IO Window+createLogWindow ls = do+  w <- windowNew+  set w [ windowTitle := "Log" ]+  windowSetDefaultSize w 400 300+  s <- scrolledWindowNew Nothing Nothing+  containerAdd w s+  tv <- treeViewNewWithModel ls+  treeViewSetHeadersVisible tv False+  addTextColumn tv ls Just+  containerAdd s tv+  w `on` deleteEvent $ liftIO $ widgetHide w >> return True+  return w -- , ls)++addTextColumn :: (TreeModelClass (model row), TypedTreeModelClass model)+                => TreeView -> model row -> (row -> Maybe String) -> IO()+addTextColumn tv st f = do+  col <- treeViewColumnNew+  renderer <- cellRendererTextNew+  cellLayoutPackStart col renderer True+  cellLayoutSetAttributes col renderer st $ map (cellText :=).maybeToList.f+  _ <- treeViewAppendColumn tv col+  return ()++data ListStoreLogHandler = ListStoreLogHandler+ { lslhStore     :: ListStore String+ , lslhLevel     :: Log.Priority+ , lslhFormatter :: LogFormatter ListStoreLogHandler+ }++instance LogHandler ListStoreLogHandler where+ getLevel         = lslhLevel+ setLevel x l     = x { lslhLevel = l }+ getFormatter     = lslhFormatter+ setFormatter x f = x { lslhFormatter = f }+ emit x l _       = listStoreAppend (lslhStore x) (snd l) >> return ()+ close _          = return ()++listStoreLogHandlerNew :: IO ListStoreLogHandler+listStoreLogHandlerNew = do+  ls <- listStoreNew []+  return ListStoreLogHandler+           { lslhStore     = ls+           , lslhLevel     = DEBUG+           , lslhFormatter = nullFormatter+           }
+ src/Hails/Graphics/UI/Gtk/Simplify/UpdateCheck.hs view
@@ -0,0 +1,74 @@+module Hails.Graphics.UI.Gtk.Simplify.UpdateCheck where++-- External Imports+import Control.Concurrent+import Control.Exception as E+import Control.Monad+import Data.Maybe+import Graphics.UI.View+import Graphics.UI.Gtk.GtkView+-- import Graphics.UI.Gtk.GenericView+import Hails.MVC.GenericCombinedEnvironment+import Network.HTTP+import Network.URI++-- Internal Imports+import Data.ExtraVersion+import Data.ReactiveValue+import Hails.MVC.Model.ProtectedModel.UpdatableModel++installHandlers :: (GtkGUI a, UpdatableBasicModel b,+                    UpdateNotifiableEvent c, ReactiveValueActivatable d)+                => CEnv a b c+                -> (ViewElementAccessorIO (GtkView a) d)+                -> IO ()+installHandlers cenv mF = do+  let vw = view cenv+  mn <- mF vw+  defaultActivation mn `reactiveValueOnCanRead` onViewAsync vw (condition cenv)++condition :: (GtkGUI a, UpdatableBasicModel b, UpdateNotifiableEvent c)+          => CEnv a b c+          -> IO ()+condition cenv = void $+  forkIO $ E.handle (constantlyHandle (return ())) $ do+    let pm = model cenv+    url <- getUpdateURI pm+    v   <- (netRead url) :: IO (Either String Version)+    case v of+      (Left  _) -> return ()+      (Right s) -> setMaxVersionAvail pm s++netRead :: Read a => String -> IO (Either String a)+netRead url = do+  v <- downloadURL url+  case v of+   (Left s)  -> return (Left s)+   (Right s) -> E.handle (constantlyHandle (return $ Left "Format error"))+                         (return $ Right $ read s)++-- FIXME: use anyway and create ignoringExceptions+constantlyHandle :: a -> E.SomeException -> a+constantlyHandle a _ = a++{- | Download a URL.  (Left errorMessage) if an error,+ - (Right doc) if success.+ -}+downloadURL :: String -> IO (Either String String)+downloadURL url =+    do resp <- simpleHTTP request+       case resp of+         Left x -> return $ Left ("Error connecting: " ++ show x)+         Right r ->+             case rspCode r of+               (2,_,_) -> return $ Right (rspBody r)+               (3,_,_) -> -- A HTTP redirect+                 case findHeader HdrLocation r of+                   Nothing -> return $ Left (show r)+                   Just url' -> downloadURL url'+               _ -> return $ Left (show r)+    where request = Request {rqURI = uri,+                             rqMethod = GET,+                             rqHeaders = [],+                             rqBody = ""}+          uri = fromJust $ parseURI url
+ src/Hails/Graphics/UI/Gtk/Simplify/VersionNumberTitleBar.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-}+module Hails.Graphics.UI.Gtk.Simplify.VersionNumberTitleBar where++-- External imports+import Control.Arrow+import Control.Monad+import Control.Monad.Reader (liftIO)+import Data.ExtraVersion+import Graphics.UI.Gtk+-- import Graphics.UI.Gtk.GenericView ()+import Graphics.UI.Gtk.GtkView+import Graphics.UI.View+import Hails.MVC.GenericCombinedEnvironment+import Hails.MVC.Model.ReactiveModel (Event)+import Hails.MVC.Model.ProtectedModel++-- Internal imports+import Data.ReactiveValue+import Hails.MVC.Model.ProtectedModel.VersionedModel++installHandlers :: (GtkGUI a, VersionedBasicModel b, Event c) => CEnv a b c+                -> (ViewElementAccessorIO (GtkView a) Window)+                -> IO ()+installHandlers cenv wF = void $ do+  let (vw, pm) = (view &&& model) cenv+  w <- wF vw+  w `on` mapEvent $ liftIO (condition cenv wF) >> return False++  -- -- let l f = do _ <- w `on` mapEvent $ liftIO f >> return False+  -- --              return ()+  -- let -- v1 :: (GtkGUI a, VersionedBasicModel b) => TypedReactiveValue (ProtectedModelVersion a b) String+  --     v1 = TypedReactiveValue (ProtectedModelVersion pm w) (undefined :: String)+  --     -- v2 :: TypedReactiveValue Window String+  --     v2 = TypedReactiveValue w (undefined :: String)+  -- v1 =:> v2++-- type WindowTitle = TypedReactiveValue Window String+-- +-- instance ReactiveValueWrite Window String where+--   reactiveValueWrite w v = do+--     t  <- windowGetTitle w+--     when (t /= v) $ windowSetTitle w v+-- +-- data ProtectedModelVersion a b =+--   ProtectedModelVersion (ProtectedModel a b) Window+-- +-- type ProgramVersion a b = TypedReactiveValue (ProtectedModelVersion a b) String+-- +-- instance (VersionedBasicModel b, Event c) => ReactiveValueRead (ProtectedModelVersion b c) String where+--   reactiveValueOnCanRead (ProtectedModelVersion _ w) _ op = do+--     _ <- do w `on` mapEvent $ liftIO op >> return False+--     return ()+--   reactiveValueRead (ProtectedModelVersion pm _) = do+--     fmap versionToString $ getVersion pm++condition :: (GtkGUI a, VersionedBasicModel b, Event c) => CEnv a b c+          -> (ViewElementAccessorIO (GtkView a) Window)+          -> IO ()+condition cenv wF = do+  let (vw, pm) = (view &&& model) cenv+  w  <- wF vw+  vn <- fmap versionToString $ getVersion pm+  t  <- windowGetTitle w+  when (t /= vn) $ windowSetTitle w vn
+ src/Hails/Graphics/UI/Gtk/THBuilderAccessor.hs view
@@ -0,0 +1,53 @@+module Hails.Graphics.UI.Gtk.THBuilderAccessor where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib++gtkBuilderAccessor :: String -> String -> Q [Dec]+gtkBuilderAccessor name kind = sequenceQ+ -- Signature: <accessor> :: Builder -> IO <WidgetType>+ [ sigD (mkName name)+        (appT (appT arrowT (conT (mkName "Builder")))+              (appT (conT (mkName "IO")) (conT (mkName kind)))+        )+ -- Implementation: <accessor> :: fromBuilder castTo<WidgetType> "<accessor>"+ , funD (mkName name)+        [ clause [] +                 -- Just apply the casting operation and the name to the+                 -- builder accessor+                 (normalB+                   (appE                                         +                     (appE (varE (mkName "fromBuilder"))           +                           (varE (mkName ("castTo" ++ kind))))   +                     (litE (stringL name))                       +                   )                                             +                 )                                               +                 []+        ]+ ]++-- | Accessor for Glade objects from Gtk Builders encapsulated in+-- Views, by name and -- type.+gtkViewAccessor :: String -> String -> String -> String -> Q [Dec]+gtkViewAccessor builderModule uiAccessor name kind = sequenceQ+  -- Declaration+  [ sigD funcName+         -- Builder -> IO Kind+         (appT (appT arrowT (conT (mkName "View")))           +               (appT (conT (mkName "IO")) (conT (mkName kind))))+  -- Implementation+  , funD funcName                                                 +         -- castedOnBuilder objectName+         [clause [varP builderName]+                 (normalB (appE (varE funcNameInBuilder)+                                (appE (varE (mkName uiAccessor))+                                      (varE builderName)+                                )+                          )) []]+  ]++  where castedAccess      = appE (varE (mkName "fromBuilder")) casting+        casting           = varE (mkName ("castTo" ++ kind))+        funcName          = mkName name+        funcNameInBuilder = mkName $ builderModule ++ ('.' : name) +        builderName       = mkName "b"
+ src/Hails/I18N/Gettext.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}+-- | This module contains the function we need to use to get automatic+-- translation on all the strings in our programs.+module Hails.I18N.Gettext where++import Text.I18N.GetText+import System.IO.Unsafe+import Codec.Binary.UTF8.String+ +__ :: String -> String+__ s +#ifdef linux_HOST_OS+ | isUTF8Encoded s' = decodeString s'+#endif+ | otherwise        = s'+  where s' = unsafePerformIO $ getText s
+ src/Hails/I18N/Language.hs view
@@ -0,0 +1,31 @@+module Hails.I18N.Language where++import qualified Control.Exception as E+import           Control.Exception.Extra+import           Control.Monad+import           System.Directory+import           System.FilePath+import           System.Locale.SetLocale+import           System.Environment.SetEnv+import           Text.I18N.GetText++-- | Installs the current language using the LC_ALL and LANGUAGE+-- environment variables and other gettext methods.+installLanguage :: String -> IO ()+installLanguage app = void $ do++  -- Read the config file if it exists+  dir <- getAppUserDataDirectory app+  let file = dir </> "default-language"++  -- lang == "" if no value was found+  lang <- E.handle (anyway (return "")) $ do+             cs <- fmap lines $ readFile file+             return $ if null cs then "" else head cs+  +  -- Update locale and language only if a value has been found+  unless (null lang) $ E.handle (anyway (return ())) $ do+    setLocale LC_ALL (Just lang)+    setEnv "LANGUAGE" lang+  bindTextDomain app $ Just "." +  textDomain $ Just app
+ src/Hails/MVC/Controller/ConditionDirection.hs view
@@ -0,0 +1,10 @@+-- | Conditions to update a program can go from the view to the model+-- and from the model to the view. Future versions must "ignore" this+-- completely and simply work even if the constraints are of kind +-- Model-to-Model or View-to-View++module Hails.MVC.Controller.ConditionDirection where++data ConditionDirection = VM+                        | MV+
+ src/Hails/MVC/Controller/Conditions/Config.hs view
@@ -0,0 +1,32 @@+module Hails.MVC.Controller.Conditions.Config where++import qualified Control.Exception as E+import           Control.Monad+import           System.FilePath+import           System.Directory++import Control.Exception.Extra++-- | A config IO layer reads and writes +-- an environment from a string. It's like a+-- read/show combination for configuration files+-- to and from Environments+type ConfigIO e = ( Maybe String -> e -> IO () -- Reader+                  , e -> IO String             -- Shower+                  )++defaultRead :: ConfigIO e -> String -> e -> IO()+defaultRead (readConf, _) app cenv = +  void $ E.handle (anyway (readConf Nothing cenv)) $ do+    dir <- getAppUserDataDirectory app+    let file = dir </> "config"+    c <- readFile file+    readConf (Just c) cenv++defaultWrite :: ConfigIO e -> String -> e -> IO()+defaultWrite (_, showConf) app cenv = +  void $ E.handle (anyway (return ())) $ do+    dir <- getAppUserDataDirectory app+    createDirectoryIfMissing True dir+    let file = dir </> "config"+    writeFile file =<< showConf cenv
+ src/Hails/MVC/Controller/Reactive.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleContexts #-}+module Hails.MVC.Controller.Reactive where++-- External libraries+import Control.Monad++-- Internal libraries+import Hails.MVC.Controller.ConditionDirection+-- import Hails.MVC.Model.ReactiveModel (FullEvent (FullEvent))+import Hails.MVC.Model.ProtectedModel+import Hails.MVC.Model.ReactiveModel.Events+import Hails.MVC.View.GtkView+import Hails.MVC.Model.ProtectedModel.Reactive+import qualified Hails.MVC.GenericCombinedEnvironment as GEnv+import Graphics.UI.Gtk.GtkView++data ReactiveViewField b = ReactiveViewField+ { onChange :: IO () -> IO ()+ , rvfGet   :: IO b+ , rvfSet   :: b -> IO ()+ }++type Condition a b c = GEnv.CEnv a b c -> IO()++(=:=) :: (Eq b+         , ReactiveReadWriteField a b c e+         , InitialisedEvent e+         , GtkGUI d) =>+         ReactiveViewField b -> a -> Condition d c e+(=:=) vField mField cenv = do+  let pm = GEnv.model cenv+  onChange vField condVM+  mapM_ (\ev -> onEvent pm ev condMV) evs+ where evs    = initialisedEvent : events mField+       condMV = cond vField mField MV cenv+       condVM = cond vField mField VM cenv++cond :: (Eq b, ReactiveReadWriteField a b c e, GtkGUI d, InitialisedEvent e) => +          ReactiveViewField b -> a -> ConditionDirection -> +          Condition d c e+cond vField mField cd cenv = onViewAsync $ do+  let pm = GEnv.model cenv+  mShould <- rvfGet vField+  vShould <- getter mField pm+  when (mShould /= vShould) $ +    case cd of+     MV -> rvfSet vField vShould+     VM -> setter mField pm mShould
+ src/Hails/MVC/DefaultGtkEnvironment.hs view
@@ -0,0 +1,18 @@+-- | The environment that contains both the view and the model.+--+module Hails.MVC.DefaultGtkEnvironment+   ( view+   , GEnv.model+   , GEnv.createCEnv+   , GEnv.installCondition+   , GEnv.installConditions+   )+  where++-- Internal libraries+import qualified Graphics.UI.Gtk.GtkView              as GtkView+import qualified Hails.MVC.GenericCombinedEnvironment as GEnv+import Hails.MVC.Model.ReactiveModel++view :: (GtkView.GtkGUI a, Event c) => GEnv.CEnv a b c d -> a+view = GtkView.getGUI . GEnv.view
+ src/Hails/MVC/GenericCombinedEnvironment.hs view
@@ -0,0 +1,64 @@+-- | This module contains the necessary functions to manipulate a global+-- environment that gives access to the view and the model in a MVC-structured+-- program with a Gtk View.+--+-- It contains the necessary functions to create an environment+-- that holds a View and a Protected Reactive Model.+--+-- Although this code is stable, the design is experimental. Usage in real+-- applications should give way to better implementations.+module Hails.MVC.GenericCombinedEnvironment+   ( CEnv (view, model, extra)+   , createCEnv+   , installConditions+   , installCondition+   )+  where++-- Internal libraries+import Graphics.UI.View+import Graphics.UI.Gtk.GtkView+import Hails.MVC.Model.ProtectedModel+import Hails.MVC.Model.ReactiveModel (Event)++-- | Given a GUI and a Type for the events, a CEnv contains a View and a+-- Protected Model.+data (GtkGUI a, Event c) => CEnv a b c d = CEnv+  { view  :: GtkView a+  , model :: ProtectedModel b c+  , extra :: d+  }++-- | To create an Environment, we just need to provide the+-- default internal model. The initialisation operations+-- for the view and the protected model are called internally.+createCEnv :: (GtkGUI a, Event c) => b -> d -> IO (CEnv a b c d)+createCEnv emptyBM extraData = do+  m <- startProtectedModel emptyBM+  v <- createView+  return CEnv { view = v, model = m, extra = extraData }++-- | Installs a condition in the Combined Environment.+--+-- NOTE: This is an experimental function and might be removed in the future.+installCondition :: (GtkGUI a, Event c) => CEnv a b c d -> (CEnv a b c d -> IO()) -> IO()+installCondition cenv cond = cond cenv++-- | Installs several conditions in the Combined Environment.+--+-- FIXME: I really don't like the syntax+--   installConditions cenv +--      [ rv1 =:= rf1+--      , ...+--      ]+--+--   I'd rather use+--   installConditions cenv $ do+--     rv1 =:= rf1+--     rv2 =:= rf2+--     ...+--   Which means that I would have to define a monad.+--+-- NOTE: This is an experimental function and might be removed in the future.+installConditions :: (GtkGUI a, Event c) => CEnv a b c d -> [ CEnv a b c d -> IO() ] -> IO ()+installConditions cenv conds = mapM_ (installCondition cenv) conds
+ src/Hails/MVC/Model/THAccessors.hs view
@@ -0,0 +1,158 @@+-- | This module uses Template Haskell to declare getters and setters+--   for a given field and type that access the ProtectedModel in the+--   IO Monad and the reactive model.++module Hails.MVC.Model.THAccessors where++-- External imports+import Data.Char+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib++-- Creates a setter and a getter at ProtectedModel level that works in the IO Monad+protectedModelAccessors :: String -> String -> Q [Dec]+protectedModelAccessors fname ftype = sequenceQ+  -- Declare plain setter+  [ sigD setterName setterType+  , funD setterName [clause [varP (mkName "pm"), varP (mkName "n")] +                     (normalB (appE (appE (varE (mkName "applyToReactiveModel"))+                                          (varE (mkName "pm"))+                                    )+                                    (infixE Nothing +                                            (varE (mkName ("RM.set" ++ fname)))+                                            (Just (varE (mkName "n")))+                                    )+                              )+                     )+                     []+                     ]+  -- Declare plain getter+  , sigD getterName getterType+  , funD getterName [clause []+                     (normalB (infixE Nothing +                                      (varE (mkName "onReactiveModel")) +                                      (Just (varE (mkName ("RM.get" ++ fname))))+                              )+                     )+                     []+                     ]+  ]+ where setterName = mkName ("set" ++ fname)+       getterName = mkName ("get" ++ fname)+       setterType = appT pmTo typeToIO+       getterType = appT pmTo ioType+       pmTo       = appT arrowT (conT (mkName "ProtectedModel"))+       typeToIO   = appT (appT arrowT (conT (mkName ftype))) ioNil+       ioNil      = appT (conT (mkName "IO")) (conT (mkName "()"))+       ioType     = appT (conT (mkName "IO")) (conT (mkName ftype))++-- | Creates a setter and a getter that works at ReactiveModel level.+reactiveModelAccessors :: String -> String -> Q [Dec]+reactiveModelAccessors fname ftype = sequenceQ+  -- Declare plain setter+  [ sigD setterName setterType+  , funD setterName +                    [clause +                     -- Setter args: rm (reactive model), n (value)+                     [varP (mkName "rm"), varP (mkName "n")]+                     -- Main result: triggerEvent rm' ev+                     (normalB (appE (appE (varE (mkName "triggerEvent"))+                                          (varE (mkName "rm'"))+                                    )+                                    (varE (mkName "ev"))+                              )+                     )+                     -- Where rm' = updated rm+                     [valD (varP (mkName "rm'"))+                           (normalB (infixE (Just (varE (mkName "rm")))+                                            (varE (mkName "onBasicModel"))+                                            (Just (lamE [varP (mkName "b")]+                                                        (recUpdE (varE (mkName "b"))+                                                                 [fieldExp +                                                                   (mkName fnamelc)+                                                                   (varE (mkName "n"))+                                                                 ]+                                                        )+                                                  )+                                            )+                                    )+                           )+                           []+                      -- Where ev = Corresponding Event+                      , valD (varP (mkName "ev"))+                             (normalB (conE (mkName (fname ++ "Changed"))))+                             []+                      ]+                    ]                     +  -- Declare plain getter+  , sigD getterName getterType+  , funD getterName [clause []+                     -- recordField . basicModel+                     (normalB (infixE (Just (varE (mkName fnamelc)))+                                      (varE (mkName ".")) +                                      (Just (varE (mkName "basicModel")))+                              )+                     )+                     []+                     ]+  ]+ where setterName = mkName ("set" ++ fname)+       getterName = mkName ("get" ++ fname)+       setterType = appT rmTo typeToRM+       getterType = appT rmTo (conT (mkName ftype))+       rmTo       = appT arrowT (conT (mkName "ReactiveModel"))+       typeToRM   = appT (appT arrowT (conT (mkName ftype))) (conT (mkName "ReactiveModel"))+       fnamelc    = lcFst fname+       +-- | Creates a setter and a getter that works at ReactiveModel level.+nonReactiveModelAccessors :: String -> Q Type -> Q [Dec]+nonReactiveModelAccessors fname ftype = sequenceQ+  -- Declare plain setter+  [ sigD setterName setterType+  , funD setterName +                    [clause +                     -- Setter args: rm (reactive model), n (value)+                     [varP (mkName "rm"), varP (mkName "n")]+                     -- Main result: triggerEvent rm' ev+                     (normalB (varE (mkName "rm'")))+                     -- Where rm' = updated rm+                     [valD (varP (mkName "rm'"))+                           (normalB (infixE (Just (varE (mkName "rm")))+                                            (varE (mkName "onBasicModel"))+                                            (Just (lamE [varP (mkName "b")]+                                                        (recUpdE (varE (mkName "b"))+                                                                 [fieldExp +                                                                   (mkName fnamelc)+                                                                   (varE (mkName "n"))+                                                                 ]+                                                        )+                                                  )+                                            )+                                    )+                           )+                           []+                      ]+                    ]                     +  -- Declare plain getter+  , sigD getterName getterType+  , funD getterName [clause []+                     -- recordField . basicModel+                     (normalB (infixE (Just (varE (mkName fnamelc)))+                                      (varE (mkName ".")) +                                      (Just (varE (mkName "basicModel")))+                              )+                     )+                     []+                     ]+  ]+ where setterName = mkName ("set" ++ fname)+       getterName = mkName ("get" ++ fname)+       setterType = appT rmTo typeToRM+       getterType = appT rmTo ftype+       rmTo       = appT arrowT (conT (mkName "ReactiveModel"))+       typeToRM   = appT (appT arrowT ftype) (conT (mkName "ReactiveModel"))+       fnamelc    = lcFst fname++lcFst :: String -> String         +lcFst []     = []+lcFst (x:xs) = (toLower x) : xs
+ src/Hails/MVC/Model/THFields.hs view
@@ -0,0 +1,158 @@+-- | This module uses Template Haskell to declare reactive fields for+--   a given model field and type that access the ProtectedModel in+--   the IO Monad and the reactive model.++module Hails.MVC.Model.THFields where++-- External imports+import Data.Char+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib++-- | Creates a setter and a getter that works at ProtectedModel level+-- inside the IO Monad+protectedField :: String -> Q Type -> String -> String -> Q [Dec]+protectedField fname ftype pmodel event = sequenceQ+  -- Declare plain field+  [ sigD setterName setterType+  , funD setterName [clause []+                     -- Main result: setter field+                     (normalB (appE (varE (mkName "reSetter"))+                                    (varE fieldName)+                              )+                     )+                     -- where+                     []+                    ]                     +  -- Declare plain getter+  , sigD getterName getterType+  , funD getterName [clause []+                     -- Main result: getter field+                     (normalB (appE (varE (mkName "reGetter"))+                                    (varE fieldName)+                              )+                     )+                     []+                     ]+  -- Declare protected field+  , sigD fieldName fieldType+  , funD fieldName [clause []+                     (normalB +                      (recConE (mkName "ReactiveElement")+                               [fieldExp+                                 (mkName "reEvents")+                                 (listE [conE (mkName +                                                ("RM." ++ fname ++ "Changed"))+                                        ]+                                 )+                               , fieldExp+                                 (mkName "reSetter")+                                 (lamE [varP (mkName "pm")+                                       , varP (mkName "c")+                                       ] +                                    (infixE +                                     (Just (varE (mkName "pm")))+                                     (varE (mkName "applyToReactiveModel"))+                                     (Just (infixE Nothing+                                            (varE (mkName +                                                   ("RM." ++ "set" ++ fname)+                                                  )+                                            )+                                            (Just (varE (mkName "c")))+                                           )+                                     )+                                    )+                                 )+                               , fieldExp (mkName "reGetter")+                                          (infixE +                                            Nothing+                                            (varE (mkName "onReactiveModel"))+                                            (Just (varE (mkName+                                                          ("RM." ++ "get" ++ fname)))+                                            )+                                          )+                               ]+                      )+                     )+                    []+                   ]+  ]+ where setterName = mkName ("set" ++ fname)+       getterName = mkName ("get" ++ fname)+       fieldName  = mkName (fnamelc ++ "Field")+       setterType = appT pmTo typeToIO+       getterType = appT pmTo ioType+       fieldType  = appT+                     (appT+                       (appT (conT (mkName "ReactiveElement")) +                             ftype+                       )+                       (conT (mkName pmodel))+                     )+                     (conT (mkName event))+       pmTo       = appT arrowT (conT (mkName "ProtectedModel"))+       typeToIO   = appT (appT arrowT ftype) ioNil+       ioNil      = appT (conT (mkName "IO")) (conT (mkName "()"))+       ioType     = appT (conT (mkName "IO")) ftype+                    +       fnamelc    = lcFst fname++-- | Creates a setter and a getter that works at ReactiveModel level.+reactiveField :: String -> Q Type -> Q [Dec]+reactiveField fname ftype = sequenceQ+  -- Declare plain setter+  [ sigD setterName setterType+  , funD setterName [clause []+                     -- Main result: just use the field's setter+                     (normalB (appE (varE (mkName "fieldSetter"))+                                    (varE fieldName)+                              )+                     )+                     -- where+                     []+                    ]                     +  -- Declare plain getter+  , sigD getterName getterType+  , funD getterName [clause []+                     -- Main result: just use the field's getter+                     (normalB (appE (varE (mkName "fieldGetter"))+                                    (varE fieldName)+                              )+                     )+                     []+                     ]+  -- Declare field with 4 elements +  , sigD fieldName fieldType+  , funD fieldName [clause []+                     (normalB +                      (tupE+                       [ varE (mkName fnamelc)                        -- function to read from model+                       , varE (mkName "preTrue")                      -- precondition to update model+                       , lamE [varP (mkName "v"), varP (mkName "b")]  -- function to update model+                         (recUpdE (varE (mkName "b"))+                          [fieldExp +                           (mkName fnamelc)+                           (varE (mkName "v"))+                          ]+                         )+                       , (conE (mkName (fname ++ "Changed")))           -- Event to trigger when changed+                       ]+                      )+                     )+                     []+                    ]+  ]+ where setterName = mkName ("set" ++ fname)+       getterName = mkName ("get" ++ fname)+       fieldName  = mkName (fnamelc ++ "Field")+       setterType = appT rmTo typeToRM+       getterType = appT rmTo ftype+       fieldType  = appT (conT (mkName "Field")) ftype+       rmTo       = appT arrowT (conT (mkName "ReactiveModel"))+       typeToRM   = appT (appT arrowT ftype) +                         (conT (mkName "ReactiveModel"))+       fnamelc    = lcFst fname++lcFst :: String -> String         +lcFst []     = []+lcFst (x:xs) = (toLower x) : xs
+ src/Hails/MVC/View/DefaultView.hs view
@@ -0,0 +1,21 @@+-- | Contains basic operations related to the GUI+--+module Hails.MVC.View.DefaultView where++-- External libraries+import Graphics.UI.Gtk+import Graphics.UI.Gtk.StreamChart++import Model.Model as Model++import Hails.MVC.View.GladeView++-- | This datatype should hold the elements that we must track in the+-- future (for instance, treeview models)+data View = View+  { uiBuilder   :: Builder+  , streamChart :: StreamChart Model.Frame+  }++instance GladeView View where+  ui = uiBuilder
+ src/Hails/MVC/View/GladeView.hs view
@@ -0,0 +1,9 @@+-- | The environment that contains both the view and the model.+--+module Hails.MVC.View.GladeView where++-- Internal libraries+import Graphics.UI.Gtk.Builder++class GladeView a where+   ui :: a -> Builder
+ src/Hails/MVC/View/GtkView.hs view
@@ -0,0 +1,30 @@+-- | Contains basic operations related to the GUI+module Hails.MVC.View.GtkView where++-- External libraries+import Control.Monad+import Graphics.UI.Gtk+-- import Graphics.UI.Gtk.GtkView (GtkGUI(..))+-- import qualified Graphics.UI.Gtk.GtkView as GtkView+-- import Language.Haskell.TH++-- | Initialises the GUI. This must be called before+-- any other GUI operation.+initView :: IO ()+initView = void initGUI++-- | Starts a thread for the view.+startView :: IO ()+startView = mainGUI++-- | Executes an operation on the view thread synchronously+onViewSync :: IO a -> IO a+onViewSync = postGUISync++-- | Executes an operation on the view thread asynchronously+onViewAsync :: IO () -> IO ()+onViewAsync = postGUIAsync++-- | Destroys the view thread+destroyView :: IO ()+destroyView = mainQuit
+ src/Hails/MVC/View/Reactive.hs view
@@ -0,0 +1,14 @@+module Hails.MVC.View.Reactive+  ( Accessor+  , Setter+  , Getter+  )+ where++-- External libraries+import Graphics.UI.Gtk++-- Internal libraries+import Hails.MVC.Model.ProtectedModel.Reactive++type Accessor a = Builder -> IO a
+ src/IOBridge.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE ScopedTypeVariables #-}+module IOBridge where++import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.IfElse+import Data.Bits+import Data.List+import Data.IORef+import Data.Maybe+import Graphics.UI.Gtk+import Network.BSD+import Network.Socket+import System.IO+import Foreign.Ptr++-- | Bridge between the local debugger and the debugging GUI+type IOBridge = IORef IOBridge'++data IOBridge' = IOBridge'+  { yampaSocket :: Maybe YampaHandle }++mkDefaultIOBridge :: IO IOBridge+mkDefaultIOBridge =+  newIORef $ IOBridge' { yampaSocket = Nothing }++-- | Communication Handles+data YampaHandle = YampaHandle+  { commHandle  :: Handle+  , eventHandle :: Handle+  }++-- | Create communication handles to talk to Yampa simulation+--+-- TODO: Make this safe and may return type Maybe+openYampaHandle :: IO YampaHandle -- ^ Handles to communicate with FRP simulation+openYampaHandle = YampaHandle <$> openYampaCommHandle <*> openYampaEventHandle++-- | Open Sync communication channel with FRP simulation++openYampaCommHandle :: IO Handle -- ^ Handle to send commands and receive+                                 --    results from FRP debugger.+openYampaCommHandle = do+  -- Shamelessly taken from RWH++  let hostname = "localhost"+      port     = "8081"+  -- Look up the hostname and port. Either raises an exception or returns a+  -- nonempty list. First element in that list is supposed to be the best+  -- option.+  addrinfos <- getAddrInfo Nothing (Just hostname) (Just port)+  let serveraddr = head addrinfos++  -- Establish a socket for communication+  sock <- socket (addrFamily serveraddr) Stream defaultProtocol++  -- Mark the socket for keep-alive handling since it may be idle+  -- for long periods of time+  setSocketOption sock KeepAlive 1++  -- Connect to server+  connect sock (addrAddress serveraddr)++  -- Make a Handle out of it for convenience+  h <- socketToHandle sock ReadWriteMode++  -- We're going to set buffering to BlockBuffering and then+  -- explicitly call hFlush after each message, below, so that+  -- messages get logged immediately+  hSetBuffering h LineBuffering++  -- Save off the socket, program name, and server address in a handle+  return h++openYampaEventHandle :: IO Handle -- ^ Handle to use for logging+openYampaEventHandle = do+  let hostname = "localhost"+      port     = "8082"+  -- Look up the hostname and port.  Either raises an exception+  -- or returns a nonempty list.  First element in that list+  -- is supposed to be the best option.+  addrinfos <- getAddrInfo Nothing (Just hostname) (Just port)+  let serveraddr = head addrinfos++  -- Establish a socket for communication+  sock <- socket (addrFamily serveraddr) Stream defaultProtocol++  -- Mark the socket for keep-alive handling since it may be idle+  -- for long periods of time+  setSocketOption sock KeepAlive 1++  -- Connect to server+  connect sock (addrAddress serveraddr)++  -- Make a Handle out of it for convenience+  h <- socketToHandle sock ReadWriteMode++  -- We're going to set buffering to BlockBuffering and then+  -- explicitly call hFlush after each message, below, so that+  -- messages get logged immediately+  hSetBuffering h LineBuffering++  -- Save off the socket, program name, and server address in a handle+  return h++stopYampaSocket ioBridgeRef = do+  ioBridge <- readIORef ioBridgeRef+  let mSocket = yampaSocket ioBridge+  awhen mSocket $ \socket -> do+    hClose (commHandle socket)+    let ioBridge' = ioBridge { yampaSocket = Nothing }+    writeIORef ioBridgeRef ioBridge'++startYampaSocket ioBridgeRef = do+  ioBridge <- readIORef ioBridgeRef+  let mSocket = yampaSocket ioBridge+  when (isNothing mSocket) $ do+    handle <- openYampaHandle+    let mSocket'  = Just handle+        ioBridge' = ioBridge { yampaSocket = mSocket' }+    writeIORef ioBridgeRef ioBridge'++sendToYampaSocketSync ioBridgeRef msg =+  catch (sendToYampaSocketSync' ioBridgeRef msg)+        (\(e :: IOException) -> do hPutStrLn stderr ("Send failed when trying to send " ++ msg ++ " with " ++ show e)+                                   return Nothing)++sendToYampaSocketSync' ioBridgeRef msg = do+  ioBridge <- readIORef ioBridgeRef+  whenMaybe (yampaSocket ioBridge) $ \socket -> do+    hPutStrLn stderr ("Debug: Sending " ++ msg)+    hPutStrLn (commHandle socket) msg+    hFlush (commHandle socket)+    waitForInput (commHandle socket) 10000+    s <- hGetLine (commHandle socket)+    hPutStrLn stderr ("Debug: received " ++ s)+    return (Just s)++getFromYampaSocketSync ioBridgeRef =+  catch (getFromYampaSocketSync' ioBridgeRef)+        (\(e :: IOException) -> do hPutStrLn stderr ("Reading failed")+                                   return Nothing)++getFromYampaSocketSync' ioBridgeRef = do+  ioBridge <- readIORef ioBridgeRef+  let mSocket = yampaSocket ioBridge+  whenMaybe (yampaSocket ioBridge) $ \socket ->+    Just <$> hGetLine (commHandle socket)++getFromEventSocketSync ioBridgeRef =+  catch (getFromEventSocketSync' ioBridgeRef)+        (\(e :: IOException) -> do hPutStrLn stderr ("Reading failed " ++ show e)+                                   return Nothing)++getFromEventSocketSync' ioBridgeRef = do+  ioBridge <- readIORef ioBridgeRef+  whenMaybe (yampaSocket ioBridge) $ \socket -> do+    eof <- hIsEOF (eventHandle socket)+    if eof+      then do putStrLn "Got nothing in the event log"+              return Nothing+      else do s <- hGetLine  (eventHandle socket)+              putStrLn $ "Event log got: " ++ show s+              return (Just s)++sendToYampaSocketAsync ioBridgeRef msg =+  catch (sendToYampaSocketAsync' ioBridgeRef msg)+        (\(e :: IOException) -> do hPutStrLn stderr ("Send failed when trying to send " ++ msg)+                                   return ())++sendToYampaSocketAsync' ioBridgeRef msg = do+  ioBridge <- readIORef ioBridgeRef+  let mSocket = yampaSocket ioBridge+  awhen mSocket $ \socket -> do+    hPutStrLn stderr ("Debug: Sending " ++ msg)+    hFlush stderr+    hPutStrLn (commHandle socket) msg++waitForInput handle n = do+  eof <- hIsEOF handle+  when eof $ do+    threadDelay n+    waitForInput handle n++whenMaybe :: Maybe a -> (a -> IO (Maybe b)) -> IO (Maybe b)+whenMaybe Nothing  _ = return Nothing+whenMaybe (Just x) f = f x
+ src/Model/Model.hs view
@@ -0,0 +1,67 @@+module Model.Model where++-- | Application Model. Contains information about the simulation and the+--   frames captured so far.+data Model = Model+  { selectedFrame         :: Maybe Int      -- ^ Currently selected frame in the GUI+  , selectedFrameInput    :: Maybe String   -- ^ Input of currently selected frame+  , curSimFrame           :: Maybe Int      -- ^ Currently simulated frame in the game+  , frames                :: [Frame]        -- ^ (Best) knowledge of frames in the game+  }++-- | Default model with no loaded simulation.+emptyBM :: Model+emptyBM = Model+  { selectedFrame      = Nothing+  , selectedFrameInput = Nothing+  , curSimFrame        = Nothing+  , frames             = []+  }++-- | Game frame.+data Frame = Frame+  { fSelected   :: Bool+  , fCached     :: Bool+  , fCurrent    :: Bool+  , fBreakpoint :: Bool+  , fError      :: Bool+  , fNumber     :: Int+  }+ deriving (Show, Eq)++frameDeselect :: Frame -> Frame+frameDeselect f = f { fSelected = False }++frameSelect :: Frame -> Frame+frameSelect f = f { fSelected = True }++frameNotCurrent :: Frame -> Frame+frameNotCurrent f = f { fCurrent = False }++frameCurrent :: Frame -> Frame+frameCurrent f = f { fCurrent = True }++defaultSelectedFrame   = Frame True  True False False False+defaultFrame           = Frame False True False False False+defaultCurrentFrame    = Frame False False True False False+defaultBreakpointFrame = Frame False True False True  False+defaultErrorFrame      = Frame False True False False True++-- | Selection of frames used to visualize the Stream Viewer.+defaultFrames = zipWith ($)+         [ defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultErrorFrame,    defaultFrame,           defaultCurrentFrame+         , defaultFrame,         defaultBreakpointFrame, defaultSelectedFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame,           defaultFrame+         , defaultFrame,         defaultFrame+         ]+         [0..]
+ src/Model/ProtectedModel.hs view
@@ -0,0 +1,12 @@+module Model.ProtectedModel+   ( ProtectedModel+   , onEvent+   , waitFor+   , module Exported+   )+  where++import Model.ProtectedModel.ProtectedModelInternals+import Model.ReactiveModel.ModelEvents               as Exported+import Model.ProtectedModel.ProtectedFields          as Exported+import Hails.MVC.Model.ProtectedModel.Initialisation as Exported
+ src/Model/ProtectedModel/ProtectedFields.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TemplateHaskell #-}+-- | This module holds the functions to access and modify the project name+-- in a reactive model.+module Model.ProtectedModel.ProtectedFields where++-- Internal imports+import Hails.MVC.Model.THFields+import Hails.MVC.Model.ProtectedModel.Reactive++import Model.Model+import qualified Model.ReactiveModel as RM+import Model.ReactiveModel.ModelEvents+import Model.ProtectedModel.ProtectedModelInternals++-- protectedField {- Model field -} {- Field type -}    {- Model name -} {- event name -}+-- protectedField "Language"        [t|Maybe Language|] "Model"          "ModelEvent"+protectedField "SelectedFrame"      [t|Maybe Int|]    "Model"          "ModelEvent"+protectedField "SelectedFrameInput" [t|Maybe String|] "Model"          "ModelEvent"+protectedField "CurSimFrame"        [t|Maybe Int|]    "Model"          "ModelEvent"+protectedField "Frames"             [t|[Frame]|]      "Model"          "ModelEvent"
+ src/Model/ProtectedModel/ProtectedModelInternals.hs view
@@ -0,0 +1,19 @@+-- | Contains the protected model definition used by other modules to+-- declare the protected fields.+--+module Model.ProtectedModel.ProtectedModelInternals+   ( ProtectedModel+   , GPM.onReactiveModel+   , GPM.fromReactiveModel+   , GPM.applyToReactiveModel+   , GPM.onEvent+   , GPM.onEvents+   , GPM.waitFor+   )+  where++import Model.Model+import Model.ReactiveModel.ModelEvents+import qualified Hails.MVC.Model.ProtectedModel as GPM++type ProtectedModel = GPM.ProtectedModel Model ModelEvent
+ src/Model/ReactiveModel.hs view
@@ -0,0 +1,25 @@+-- | This module holds the reactive program model. It holds a program+-- model, but includes events that other threads can listen to, so+-- that a change in a part of the model is notified to other parts of+-- the program. The reactive model is not necessarily concurrent (it+-- doesn't have its own thread), although a facility is included to+-- make it also concurrent (so that event handlers can be called as+-- soon as they are present).+module Model.ReactiveModel+   ( ReactiveModel+   -- * Construction+   , emptyRM+   -- * Access+   , pendingEvents+   , pendingHandlers+   -- * Modification+   , getPendingHandler+   , onEvent+   , module Exported+   )+  where++import Model.ReactiveModel.ReactiveModelInternals+import Hails.MVC.Model.ReactiveModel.Initialisation as Exported+import Model.ReactiveModel.ReactiveFields           as Exported+import Model.ReactiveModel.ModelEvents              as Exported
+ src/Model/ReactiveModel/ModelEvents.hs view
@@ -0,0 +1,24 @@+module Model.ReactiveModel.ModelEvents where++import qualified Hails.MVC.Model.ReactiveModel as GRM+import Hails.MVC.Model.ReactiveModel.Events++-- Implement this interface if you want automatic update notification+-- import Hails.MVC.Model.ProtectedModel.UpdatableModel++data ModelEvent = UncapturedEvent+                | Initialised+                | SelectedFrameChanged+                | SelectedFrameInputChanged+                | CurSimFrameChanged+                | FramesChanged+ deriving (Eq,Ord)++instance GRM.Event ModelEvent where+  undoStackChangedEvent = UncapturedEvent++-- instance UpdateNotifiableEvent ModelEvent where+--   updateNotificationEvent = MaxVersionAvailable++instance InitialisedEvent ModelEvent where+  initialisedEvent = Initialised
+ src/Model/ReactiveModel/ReactiveFields.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}+module Model.ReactiveModel.ReactiveFields where++-- External imports+import qualified Hails.MVC.Model.ReactiveFields as RFs+import Hails.MVC.Model.ReactiveFields+         (fieldGetter, fieldSetter, preTrue)+import Hails.MVC.Model.THFields++-- Internal imports+import Model.Model+import Model.ReactiveModel.ReactiveModelInternals+import Model.ReactiveModel.ModelEvents++-- A Field of type A lets us access a reactive field of type a from+-- a Model, and it triggers a ModelEvent+type Field a = RFs.Field a Model ModelEvent++-- reactiveField {- Field name -} {- Field type -}+-- reactiveField "Status"         [t|Status|]+reactiveField "SelectedFrame"      [t|Maybe Int|]+reactiveField "SelectedFrameInput" [t|Maybe String|]+reactiveField "CurSimFrame"        [t|Maybe Int|]+reactiveField "Frames"             [t|[Frame]|]
+ src/Model/ReactiveModel/ReactiveModelInternals.hs view
@@ -0,0 +1,32 @@+-- | This module has been generated by hails.+--+-- This module holds the reactive program model. It holds a program model,+-- but includes events that other threads can listen to, so that a change+-- in a part of the model is notified to another part of the program. The+-- reactive model is not necessarily concurrent (it doesn't have its own thread),+-- although a facility is included to make it also concurrent (so that+-- event handlers can be called as soon as they are present).+module Model.ReactiveModel.ReactiveModelInternals+   ( ReactiveModel+   , GRM.basicModel+   -- * Construction+   , GRM.emptyRM+   -- * Access+   , GRM.pendingEvents+   , GRM.pendingHandlers+   -- * Modification+   , GRM.getPendingHandler+   , GRM.onEvent+   , GRM.onEvents+   , GRM.onBasicModel+   , GRM.triggerEvent+   )+  where++-- Internal imports+-- import GenericModel.GenericReactiveModel+import Model.Model+import Model.ReactiveModel.ModelEvents+import qualified Hails.MVC.Model.ReactiveModel as GRM++type ReactiveModel = GRM.ReactiveModel Model ModelEvent (IO ())
+ src/Paths.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module Paths (getDataFileName) where++-- These imports are necessary only in Windows+#if !defined(linux_HOST_OS) && !defined(darwin_HOST_OS)+import System.Win32.Types+import System.Win32.Registry++import System.Environment+import Foreign.Ptr (castPtr)+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.C.String (peekCWString, withCWString)+import Control.Exception (bracket, throwIO, handle)+import Control.Exception.Extra (anyway)+#endif++import qualified Paths.CustomPaths as P++-- This code is only used in Windows. It depends on the Windows registry+#if !defined(linux_HOST_OS) && !defined(darwin_HOST_OS)+-- // parse a string from a registry value of certain type+parseRegString :: RegValueType -> LPBYTE -> IO String+parseRegString ty mem+   | ty == rEG_SZ        = peekCWString (castPtr mem)+   | ty == rEG_EXPAND_SZ = peekCWString (castPtr mem) >>=+                              expandEnvironmentStrings+   | otherwise           = ioError (userError "Invalid registry value type")++-- // FFI import of the ExpandEnvironmentStrings function needed+-- // to make use of the registry values+expandEnvironmentStrings :: String -> IO String+expandEnvironmentStrings toexpand =+   withCWString toexpand $ \input ->+   allocaBytes 512 $ \output ->+   do c_ExpandEnvironmentStrings input output 256+      peekCWString output+foreign import stdcall unsafe "windows.h ExpandEnvironmentStringsW"+  c_ExpandEnvironmentStrings :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD++getAppKey :: IO HKEY+getAppKey =+  handle+   (anyway (openKey hKEY_LOCAL_MACHINE regPath))+   (openKey hKEY_CURRENT_USER regPath)++-- The default program's key in the registry+regPath :: String+regPath = "SOFTWARE\\" ++ vendorKey ++ "\\" ++ programKey++openKey :: HKEY -> String -> IO HKEY+openKey k path = regOpenKeyEx k path kEY_QUERY_VALUE++-- Search for a value labeled 'Path' in the application HKey+getAppPathFromReg :: IO String+getAppPathFromReg =+   bracket getAppKey regCloseKey $ \usfkey ->+   allocaBytes 512 $ \mem ->+   do ty <- regQueryValueEx usfkey "Path" mem 512+      parseRegString ty mem++#endif++-- This part is OS-dependent+getDataDir :: IO FilePath+getDataDir =+#if !defined(linux_HOST_OS) && !defined(darwin_HOST_OS)+  handle (anyway P.getDataDir) $ do+    fp <- getAppPathFromReg+    return (fp ++ pathSeparator:"data")+#else+   do fp <- P.getDataDir+      return (fp ++ pathSeparator:"data")+#endif++getDataFileName :: FilePath -> IO FilePath+getDataFileName name =+  fmap (`joinFileName` name) getDataDir+  -- myPutStrLn $ "Going to open " ++ res+  -- return res++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir fname+  | isPathSeparator (last dir) = dir ++ fname+  | otherwise                  = dir ++ pathSeparator:fname++pathSeparator :: Char+pathSeparator =+#if !defined(linux_HOST_OS) && !defined(darwin_HOST_OS)+  '\\'+#else+  '/'+#endif++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/' || c == '\\'
+ src/Paths/CustomPaths.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE CPP #-}+module Paths.CustomPaths+  (module Paths_titan+#ifndef linux_HOST_OS+  , module Paths.CustomPaths+#endif+  )+ where++import Paths_titan++#ifndef linux_HOST_OS+vendorKey :: String+vendorKey = ""++programKey :: String+programKey = ""+#endif
+ src/View.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE MultiWayIf #-}+-- | Contains basic operations related to the GUI+--+module View (module Exported) where++-- External libraries+import Graphics.UI.Gtk+import Graphics.UI.Gtk.GtkView (GtkGUI(..))+import Graphics.UI.Gtk.StreamChart++-- Internal libraries+import Hails.MVC.View.GtkView     as Exported+import Hails.MVC.View.DefaultView as Exported+import View.Objects++import Model.Model                as Model++-- | Add all initialisers to the initialise operation and store+-- everything we'll need in the view. We need this operation here+-- because the URL to the glade file depends on the application+-- name.+instance GtkGUI View where+  initialise = do+    ui <- loadInterface++    -- Initialize stream chart+    streamChart <- streamChartNew :: IO (StreamChart Model.Frame)+    widgetSetSizeRequest streamChart 10000 10000++    -- Add stream chart to view+    -- viewport `onResize` (do (w,h) <- widgetGetSize window+    --                       adjustmentSetPageSize adjustX w+    --                       adjustmentSetPageSize adjustY h)+    -- containerAdd viewport streamChart+    -- containerAdd sw viewport+    sw  <- scrollFrameSelection ui+    scrolledWindowAddWithViewport sw streamChart++    -- Set rendering properties+    streamChartSetStyle streamChart defaultRenderSettingsF++    return $ View ui streamChart++-- | This funciton determines the style of the stream chart based on the kind+-- of frame.+defaultRenderSettingsF :: Model.Frame -> StreamChartStyle+defaultRenderSettingsF = \c ->+  StreamChartStyle+    { renderFGColor = (0.5, 0.6, 0.7, 1.0)+    , renderBGColor = if | fSelected c       -> (0.8, 0.8, 0.8, 0.9)+                         | fCurrent c        -> (1.0, 0.6, 0.0, 0.9)+                         | fError c          -> (0.9, 0.2, 0.1, 0.9)+                         | (not $ fCached c) -> (0.9, 0.9, 0.9, 1.0)+                         | otherwise         -> (0.1, 0.9, 0.1, 0.9)+    , renderDot     = if | fBreakpoint c     -> True+                         | otherwise         -> False+    , renderLetter  = if | fError c          -> Just 'X'+                         | otherwise         -> Nothing+    }
+ src/View/Objects.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TemplateHaskell #-}+module View.Objects where++-- External imports+import Graphics.UI.Gtk+import Hails.Graphics.UI.Gtk.Builder+import Hails.Graphics.UI.Gtk.THBuilderAccessor++-- Internal imports+import Paths++loadInterface :: IO Builder+loadInterface = loadDefaultInterface getDataFileName++-- gtkBuilderAccessor element name type name+-- gtkBuilderAccessor "mainMenu"   "Menu"+gtkBuilderAccessor "mainWindow"                "Window"+gtkBuilderAccessor "toolBtnConnect"            "ToolButton"+gtkBuilderAccessor "toolBtnDisconnect"         "ToolButton"+gtkBuilderAccessor "toolBtnStep"               "ToolButton"+gtkBuilderAccessor "toolBtnSkip"               "ToolButton"+gtkBuilderAccessor "toolBtnStepUntil"          "ToolButton"+gtkBuilderAccessor "toolBtnSkipBack"           "ToolButton"+gtkBuilderAccessor "toolBtnRedo"               "ToolButton"+gtkBuilderAccessor "toolBtnPlay"               "ToolButton"+gtkBuilderAccessor "toolBtnStop"               "ToolButton"+gtkBuilderAccessor "toolBtnPause"              "ToolButton"+gtkBuilderAccessor "toolBtnDeleteTrace"        "ToolButton"+gtkBuilderAccessor "toolBtnReplayTrace"        "ToolButton"+gtkBuilderAccessor "toolBtnSaveTrace"          "ToolButton"+gtkBuilderAccessor "toolBtnLoadTrace"          "ToolButton"+gtkBuilderAccessor "toolBtnRefineTrace"        "ToolButton"+gtkBuilderAccessor "toolBtnDiscardFuture"      "ToolButton"+gtkBuilderAccessor "toolBtnSaveTraceUpToFrame" "ToolButton"+gtkBuilderAccessor "toolBtnTravelToFrame"      "ToolButton"+gtkBuilderAccessor "toolBtnTeleportToFrame"    "ToolButton"+gtkBuilderAccessor "toolBtnIOSenseFrame"       "ToolButton"+gtkBuilderAccessor "toolBtnModifyInput"        "ToolButton"+gtkBuilderAccessor "toolBtnModifyTime"         "ToolButton"+gtkBuilderAccessor "txtFrameNumber"            "Entry"+gtkBuilderAccessor "txtFrameTime"              "Entry"+gtkBuilderAccessor "txtFrameDTime"             "Entry"+gtkBuilderAccessor "txtFrameInput"             "Entry"+gtkBuilderAccessor "txtFrameLast"              "Entry"+gtkBuilderAccessor "txtGlobalTime"             "Entry"+gtkBuilderAccessor "txtMaxTime"                "Entry"+gtkBuilderAccessor "txtFinished"               "Entry"+gtkBuilderAccessor "txtDebug"                  "TextView"+gtkBuilderAccessor "scrollFrameSelection"      "ScrolledWindow"
titan.cabal view
@@ -2,7 +2,7 @@ build-type:    Simple  name:          titan-version:       1.0.0+version:       1.0.2 author:        Ivan Perez maintainer:    ivan.perez@keera.co.uk homepage:      http://github.com/keera-studios/haskell-titan@@ -48,6 +48,60 @@    main-is:     Main.hs++  other-modules:+    CombinedEnvironment+    Controller+    Controller.Conditions+    Controller.Conditions.Buttons+    Controller.Conditions.CloseIDE+    Controller.Conditions.CurFrameInfo+    Controller.Conditions.TraceViewer+    FRP.Titan.Protocol+    Graphics.UI.Gtk.GtkView+    Graphics.UI.Gtk.StreamChart+    Graphics.UI.View+    Hails.Graphics.UI.Gtk.Builder+    Hails.Graphics.UI.Gtk.Helpers.Combo+    Hails.Graphics.UI.Gtk.Helpers.FileDialog+    Hails.Graphics.UI.Gtk.Helpers.MenuItem+    Hails.Graphics.UI.Gtk.Helpers.MessageDialog+    Hails.Graphics.UI.Gtk.Reactive+    Hails.Graphics.UI.Gtk.Simplify.AboutDialog+    Hails.Graphics.UI.Gtk.Simplify.Logger+    Hails.Graphics.UI.Gtk.Simplify.NameAndVersionTitleBar+    Hails.Graphics.UI.Gtk.Simplify.ProgramMainWindow+    Hails.Graphics.UI.Gtk.Simplify.ReactiveGtk+    Hails.Graphics.UI.Gtk.Simplify.RootLogger+    Hails.Graphics.UI.Gtk.Simplify.UpdateCheck+    Hails.Graphics.UI.Gtk.Simplify.VersionNumberTitleBar+    Hails.Graphics.UI.Gtk.THBuilderAccessor+    Hails.I18N.Gettext+    Hails.I18N.Language+    Hails.MVC.Controller.ConditionDirection+    Hails.MVC.Controller.Conditions.Config+    Hails.MVC.Controller.Reactive+    Hails.MVC.DefaultGtkEnvironment+    Hails.MVC.GenericCombinedEnvironment+    Hails.MVC.Model.THAccessors+    Hails.MVC.Model.THFields+    Hails.MVC.View.DefaultView+    Hails.MVC.View.GladeView+    Hails.MVC.View.GtkView+    Hails.MVC.View.Reactive+    IOBridge+    Model.Model+    Model.ProtectedModel+    Model.ProtectedModel.ProtectedFields+    Model.ProtectedModel.ProtectedModelInternals+    Model.ReactiveModel+    Model.ReactiveModel.ModelEvents+    Model.ReactiveModel.ReactiveFields+    Model.ReactiveModel.ReactiveModelInternals+    Paths+    Paths.CustomPaths+    View+    View.Objects    build-depends:       base              >=4.7 && < 4.13