Saturday, September 20, 2014

Building Gtk2Hs GUIs with queries

Please comment on reddit
In my previous post Haskell::Reddit helped me find out that the continuation monad can be used to make an interesting query like interface. I've been using this interface to refactor my toy editor program and it's been working fairly well. I still haven't fixed the issue that started this tangent (opening a file twice results in two tabs) but that's side project coding for you.


My toy editor is not very complicated but it still took a while to build directly. Gtk2Hs is a great library but not as easy to use as HTML + JS. The web has made some amazing progress in making UIs easier to build and I'm hoping that some of those insights can be transferred to the native GUI world.



When you use the gtk api directly, you tend to build things in a hierarchical way based on how you want things laid out. But a lot of the times you want connections between components (I'm hoping to have components that aren't Gtk widgets eventually) that cross hierarchies:

This isn't too bad but once right click menus are added it could get messy. And even when the connections match the hierarchy, you don't want to tie layout to event handling logic.

Glade is supposed to be a solution to this but for my side project coding I'd rather work with direct code.

In the original version of the editor I had to have a second initialization phase after I did my layout to setup the callbacks correctly.
main :: IO ()
main :: IO ()
main = do
    initGUI
    window <- windowNew
    set window [windowDefaultWidth := 800, windowDefaultHeight := 600]
    
    mainBox <- vBoxNew False 0
    _ <- containerAdd window mainBox

    buttonBar <- hBoxNew False 0
    
    button <- buttonNewWithLabel "Open Project"
    saveButton <- buttonNewWithMnemonic "_Save Files"
    refreshButton <- buttonNewWithMnemonic "S_ynchronize Folders"
    boxPackStart buttonBar button PackNatural 0
    boxPackStart buttonBar saveButton PackNatural 0
    boxPackStart buttonBar refreshButton PackNatural 0
    widgetShowAll buttonBar
    
    boxPackStart mainBox buttonBar PackNatural 0
          
    editor <- makeEditor
    
    
    onClicked button $ newFileChooser $ loadFile editor
    onClicked saveButton $ saveFiles editor
    onClicked refreshButton $ refreshFolders editor
    
    onRowActivated (_fileTreeView editor) $ openFileChooserFile editor
    
    boxPackStart mainBox (mainPane editor) PackGrow 0
             

    onDestroy window mainQuit
    widgetShowAll button    
    widgetShowAll mainBox
    widgetShowAll window
    mainGUI

makeEditor  = do
        {- widget creation setup..etc -}
    let editorWindow =  EditorWindow { mainPane = mainVPane, 
                          _fileTreeView = fileTreeView, 
                          _fileTreeStore = treeStore, 
                          notebook = noteBook, 
                          _rootPath = filePath, 
                          nextGuiId = guiId,
                          sourceBuffers = buffers
                        } 
    consoleBookInitializer editorWindow
    return editorWindow
So these lines came after
editor <- makeEditor
:
    onClicked button $ newFileChooser $ loadFile editor
    onClicked saveButton $ saveFiles editor
    onClicked refreshButton $ refreshFolders editor

Because opening a project and refreshing the folders meant updating the file tree (it should also clear the tabs when opening a project... another bug), the callback needed to get the file tree somehow. But the buttons were created before the file tree since they are on top. Also EditorWindow needs to have the file tree created before it can be created.

I decided to tag components with a String identifier, like HTML ids, then I could query for the component based on the identifier. Like jQuery if the query does not find anything then nothing happens. So then I could setup callbacks without worrying about the order of creating components.

I could store each of the components in a separate container but after trying it out I gave up and went with Data.Dynamic. String identifiers and Data.Dynamic steps aren't the Haskell way but it was the best idea I had at the time. For some extra type-safety I added constants that put the identifiers together with their types.

data Named a = Named { _identifier :: String, _content :: a}
data Widgets = Widgets {  _widgets :: HaskQuery.Relation (Named Dynamic) (OrdIndex.OrdIndex String)}

type WidgetRef a = Named (Proxy a)

widgetReference :: String -> WidgetRef a
widgetReference identifier = Named { _identifier = identifier, _content = Proxy}

HaskQuery (as of this post) is just where I put all my query stuff. HaskQuery.Relation is a wrapper around Data.IntMap that makes the interface more SQL-like.

data Relation a b = Relation { _relation :: Data.IntMap.Lazy.IntMap a , 
    _lastRowId :: Int, _indices :: UpdatableIndex a b} 
    deriving (Show)

selectDynamicWithTypeM :: (Data.Typeable.Typeable a, Monad m) 
=> Data.Proxy.Proxy a 
-> Data.Dynamic.Dynamic 
-> Control.Monad.Trans.Cont.Cont (b->m b) a
selectDynamicWithTypeM proxy value = 
    Control.Monad.Trans.Cont.cont (\continuation -> 
                                        (\seed -> (case Data.Dynamic.fromDynamic value of 
                                                                    Just typed -> continuation typed seed 
                                                                    Nothing -> return seed)))

selectM :: Monad m => Relation a c -> Control.Monad.Trans.Cont.Cont (b -> m b) a
selectM relation = Control.Monad.Trans.Cont.cont (\continuation -> 
    (\seed -> Data.IntMap.Lazy.foldl 
        (\foldSeed value ->  foldSeed >>= continuation value) 
        (return seed) 
        (_relation relation)))

selectWidget :: Typeable a => Widgets -> String -> Proxy a -> (HaskQuery.Cont (b -> IO b) a)
selectWidget widgets identifier typeProxy = do        
        widget <- HaskQuery.selectM $ _widgets widgets
        HaskQuery.filterM $ (_identifier widget) == identifier
        selectedWidget <- HaskQuery.selectDynamicWithTypeM typeProxy (_content widget)
        return selectedWidget

selectWidgetRef :: Typeable a => Widgets -> WidgetRef a -> (HaskQuery.Cont (b -> IO b) a)
selectWidgetRef widgets widgetRef = selectWidget widgets (_identifier widgetRef) (_content widgetRef)

Ok, with that I could now change the direct file tree lookup for refreshing the file list to one that did a lookup for the file tree:

Before

makeEditor  = do
        {- widget creation setup..etc -}
    let editorWindow =  EditorWindow { mainPane = mainVPane, 
                          _fileTreeView = fileTreeView, 
                          _fileTreeStore = treeStore, 
                          notebook = noteBook, 
                          _rootPath = filePath, 
                          nextGuiId = guiId,
                          sourceBuffers = buffers
                        } 
    consoleBookInitializer editorWindow
    return editorWindow

refreshFolders editor = do
  canonicalRootPathMaybe <- atomically $ readTVar (_rootPath editor) 
  case canonicalRootPathMaybe of 
        Just canonicalRootPath -> do
                                    forest <- getDirContentsAsTree canonicalRootPath
                                    let fileTreeStore = _fileTreeStore editor 
                                    treeStoreClear fileTreeStore  
                                    treeStoreInsertForest fileTreeStore [] 0 forest
                                    return ()
        Nothing -> return ()

After

fileTreeStoreRef :: WidgetRef (TreeStore DirectoryEntry)
fileTreeStoreRef = widgetReference "fileTreeStore"

makeEditorWindow ::  IO EditorWindow
makeEditorWindow = do
    filePath <- atomically $ newTVar Nothing
    buffers <- atomically $ newTVar IntMap.empty
    propertyRelation <- atomically $ newTVar HaskQuery.empty
    widgetTVar <- atomically $ newTVar emptyWidgets
   
    guiId <- newIORef 0
    
    let editorWindow =  EditorWindow {   
                          _editorWidgets = widgetTVar,   
                          _rootPath = filePath, 
                          nextGuiId = guiId,
                          sourceBuffers = buffers,
                          _properties = propertyRelation
                        } 
    return editorWindow

refreshFolders :: EditorWindow -> IO ()
refreshFolders editor = do
  canonicalRootPathMaybe <- atomically $ readTVar (_rootPath editor) 
  case canonicalRootPathMaybe of 
        Just canonicalRootPath -> do
            forest <- getDirContentsAsTree canonicalRootPath
            _ <- HaskQuery.runQueryM $ do
                 widgets <- getWidgets (_editorWidgets editor)
                 fileTreeStore <- selectWidgetRef widgets fileTreeStoreRef 
                 HaskQuery.executeM $ do
                     treeStoreClear fileTreeStore  
                     treeStoreInsertForest fileTreeStore [] 0 forest
            return ()
        Nothing -> return ()

The new code is uglier but it's a lot easier to move pieces of code around and separate layout code from event connection code. EditorWindow can now be created without any Gtk widgets which might be useful for writing test code. Another nice thing is that I can now remove the file tree and replace it at run time. This might be useful if I want to rebuild parts of the layout.

I'm still experimenting with the best way to use queries and what the tradeoffs are but it has definitely helped me decouple my GUI code and it's making this project a lot more fun. The code version as of this post is at github/stevechy/HaskellEditor.