summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreasBaldeau <>2011-01-08 18:31:42 (GMT)
committerLuite Stegeman <luite@luite.com>2011-01-08 18:31:42 (GMT)
commit20a0b559a636aebee9d364f75ffc73511c54f807 (patch)
tree14f12dc37eea31f4bda671728e3edd8972229b51
version 0.1.00.1.0
-rw-r--r--LICENSE32
-rw-r--r--LambdaCat.hs149
-rw-r--r--LambdaCat/CmdArgs.hs99
-rw-r--r--LambdaCat/Configure.hs74
-rw-r--r--LambdaCat/History.hs160
-rw-r--r--LambdaCat/Internal/Class.hs136
-rw-r--r--LambdaCat/Session.hs159
-rw-r--r--LambdaCat/Supplier.hs63
-rw-r--r--LambdaCat/Supplier/Web.hs57
-rw-r--r--LambdaCat/UI.hs26
-rw-r--r--LambdaCat/UI/Glade.hs537
-rw-r--r--LambdaCat/UI/Glade/PersistentTabId.hs99
-rw-r--r--LambdaCat/Utils.hs80
-rw-r--r--LambdaCat/View.hs38
-rw-r--r--LambdaCat/View/Web.hs143
-rw-r--r--Main.hs21
-rw-r--r--README.md73
-rw-r--r--STYLE.md275
-rw-r--r--Setup.hs4
-rw-r--r--lambdacat.cabal76
-rw-r--r--lambdacat.glade179
-rw-r--r--lambdacat.gtkrc8
22 files changed, 2488 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..5cf65db
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,32 @@
+Copyright (c) 2010-2011, Andreas Baldeau, Daniel Ehlers
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in
+ the documentation and/or other materials provided with the
+ distribution.
+
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this
+ software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
diff --git a/LambdaCat.hs b/LambdaCat.hs
new file mode 100644
index 0000000..b6beaaa
--- /dev/null
+++ b/LambdaCat.hs
@@ -0,0 +1,149 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module : LambdaCat
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module (re-)exports the most important functions and datatypes you
+-- need, to write your own configuration file.
+
+module LambdaCat
+ (
+ -- * Main entry point
+ lambdacat
+
+ -- * Configuration
+ , LambdaCatConf (..)
+
+ , defaultConfig
+ , defaultModifySupplierURI
+ )
+where
+
+import Network.URI
+import System.Exit
+import System.IO
+
+import Config.Dyre
+import Config.Dyre.Compile
+
+import LambdaCat.CmdArgs
+import LambdaCat.Configure
+import LambdaCat.Supplier
+import LambdaCat.Supplier.Web
+import LambdaCat.UI.Glade as UI
+import LambdaCat.Utils
+import LambdaCat.View.Web
+ ( webView
+ )
+
+-- | Lambdacat's default configuration.
+defaultConfig :: LambdaCatConf
+defaultConfig = LambdaCatConf
+ { modifySupplierURI = defaultModifySupplierURI
+ , supplierList = [ ( webSupplier
+ , [ "http:"
+ , "https:"
+ , "about:"
+ ]
+ )
+ ]
+ , viewList = [ ( webView
+ , [ "about:"
+ , "http:"
+ , "https:"
+ , "file:"
+ ]
+ , []
+ )
+ ]
+ , homeURI = "http://www.haskell.org"
+ , defaultURI = "about:blank"
+ , defaultTitle = "(Untitled)"
+ }
+
+-- | The URI modifier used in the default configuration. It tries to add a
+-- proper protocol if none is specified.
+defaultModifySupplierURI :: URI -> URI
+defaultModifySupplierURI uri@URI
+ { uriScheme = ""
+ , uriAuthority = Just _
+ } = prepend "http://" uri
+defaultModifySupplierURI uri@URI
+ { uriScheme = ""
+ , uriAuthority = Nothing
+ , uriPath = '/' : _
+ } = prepend "file://" uri
+defaultModifySupplierURI uri@URI
+ { uriScheme = ""
+ , uriAuthority = Nothing
+ , uriPath = _ : _
+ } = prepend "http://" uri
+defaultModifySupplierURI uri = uri
+
+-- | Add a String to the beginning of the given URI.
+prepend :: String -> URI -> URI
+prepend prfx uri = stringToURI $ prfx ++ show uri
+
+-- | This is the real main function. It is called by the dyre stack.
+mainCat
+ :: Maybe String -- ^ Just the error that occured during the compilation
+ -- of the user configuration, Nothing if none occured.
+ -> LambdaCatConf -- ^ The users configuration.
+ -> IO ()
+mainCat e cfg = do
+ maybe (return ()) error e
+
+ setLCC cfg
+ args <- getCmdArgs
+
+ let uria = map stringToURI $ uris args
+ us = if null uria
+ then [homeURI cfg]
+ else uria
+
+ ui <- UI.init :: IO GladeUI
+ mapM_ (supplyForView (UI.update ui undefined) embedView) us
+
+ mainLoop ui
+
+-- | Lambdacat's main function. It processes commandline parameters, handles
+-- recompilation of the user configuration and calls the real main function.
+-- Use this as the main function in your user configuration file.
+lambdacat
+ :: LambdaCatConf -- ^ Configuration to use. Just start with
+ -- 'defaultConfig' and overwrite fields as you wish.
+ -> IO ()
+lambdacat cfg = do
+ args <- getCmdArgs
+
+ if recompile args
+ then do
+ customCompile dparams
+ me <- getErrorString dparams
+
+ case me of
+ Just e -> do
+ hPutStrLn stderr e
+ exitFailure
+
+ Nothing ->
+ return ()
+
+ else wrapMain dparams (Nothing, cfg)
+
+-- | Configuration for dyre.
+dparams :: Params (Maybe String, LambdaCatConf)
+dparams =
+ let dps = defaultParams
+ { projectName = "lambdacat"
+ , realMain = uncurry mainCat
+ , showError = \(_, c) s -> (Just s, c)
+ , statusOut = putStrLn
+ }
+ in dps { ghcOpts = ["-eventlog"] }
+
diff --git a/LambdaCat/CmdArgs.hs b/LambdaCat/CmdArgs.hs
new file mode 100644
index 0000000..95431b4
--- /dev/null
+++ b/LambdaCat/CmdArgs.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- |
+-- Module : LambdaCat.CmdArgs
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module is used for command line parsing.
+
+module LambdaCat.CmdArgs
+ (
+ -- * Command line argument representation
+ CmdArgs
+
+ -- * Selectors
+ , recompile
+ , uris
+
+ -- * Retreiving command line arguments
+ , getCmdArgs
+ )
+where
+
+import Data.Version
+import System.Environment
+
+import System.Console.CmdArgs hiding
+ ( CmdArgs
+ , cmdArgs
+ )
+import qualified System.Console.CmdArgs as CA
+
+import Paths_lambdacat
+
+-- | CmdArgs stores the arguments given on the command line.
+data CmdArgs = CmdArgs
+ { recompile :: Bool -- ^ If set, recompilation of user configuration
+ -- is forced.
+ , ouris :: [String] -- ^ The URIs given by the @-u@ flags.
+ , auris :: [String] -- ^ The URIs specified without any flag.
+ -- , rts :: String -- For future use.
+ , ignoreL :: [String] -- ^ This is used to allow correct parsing of
+ -- dyres command line arguments (please ignore).
+ , ignoreB :: Bool -- ^ The same as 'ignoreL'.
+ }
+ deriving (Show, Eq, Data, Typeable)
+
+-- | This value specifies how the command line arguments should be parsed by
+-- the CmdArgs package and what help texts should be displayed.
+cmdArgs :: CmdArgs
+cmdArgs = CmdArgs
+ { recompile = def
+ &= explicit
+ &= name "recompile"
+ &= help "Recompile your config file and quit"
+
+ , ouris = def
+ &= explicit
+ &= name "u"
+ &= name "uri"
+ &= typ "URI"
+ &= help "Load this URI (may be used more than once)"
+
+ , auris = def
+ &= typ "URIS"
+ &= args
+{-
+ , rts = def
+ &= explicit &= name "rts"
+ &= (help $ "Specifies runtime system settings, "
+ ++ "e.g.: lambdacat --rts=\"-ls\"")
+-}
+
+ , ignoreL = def
+ &= explicit
+ &= name "dyre-master-binary"
+ &= help "For internal use only, should be hidden in the future"
+
+ , ignoreB = def
+ &= explicit
+ &= name "deny-reconf"
+ &= help "For internal use only, should be hidden in the future"
+ }
+ &= summary ("lambdacat " ++ showVersion version)
+ &= verbosity
+
+-- | Get the String representations of the URIs given on command line.
+uris :: CmdArgs -> [String]
+uris ca = ouris ca ++ auris ca -- TODO: Parse the URIs right here...
+
+-- | Get the representation of the given command line arguments.
+getCmdArgs :: IO CmdArgs
+getCmdArgs = do
+ _ <- getArgs -- TODO: Get rid of this dirty hack.
+ CA.cmdArgs cmdArgs
+
diff --git a/LambdaCat/Configure.hs b/LambdaCat/Configure.hs
new file mode 100644
index 0000000..878d57d
--- /dev/null
+++ b/LambdaCat/Configure.hs
@@ -0,0 +1,74 @@
+-- |
+-- Module : LambdaCat.Configure
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides the data structure 'LambdaCatConf' which holds
+-- lambdacats global configuration. The configuration can easily accessed
+-- through 'lambdaCatConf'.
+
+module LambdaCat.Configure
+ (
+ -- * The configuration data structure
+ LambdaCatConf (..)
+ , Protocol
+
+ -- * Global access
+ , lambdaCatConf
+ , setLCC
+ )
+where
+
+import Data.IORef
+import Network.URI
+import System.IO.Unsafe
+
+import LambdaCat.Internal.Class
+ ( View (..)
+ , Supplier (..)
+ )
+
+-- | Lambdacat's configuration datatype.
+data LambdaCatConf = LambdaCatConf
+ { supplierList
+ :: [(Supplier, [Protocol])] -- ^ Suppliers with supported
+ -- protocols.
+ , viewList
+ :: [(View, [Protocol], [String])] -- ^ Views with supported
+ -- protocols.
+ , homeURI
+ :: URI -- ^ URI of the home page.
+ , modifySupplierURI
+ :: URI -> URI -- ^ Function to modify the URIs
+ -- before they are given to the
+ -- Supplier.
+ , defaultURI
+ :: URI -- ^ Default URI for e.g. a
+ -- new tab.
+ , defaultTitle
+ :: String -- ^ Default title for views that
+ -- don't (yet) have a title.
+ }
+
+-- | Type for protocols. A protocol is a uri schema of the form "<name>:"
+type Protocol = String
+
+-- | This IORef holds the global configuration. It can be accessed through
+-- 'lambdaCatConf'.
+cfgIORef :: IORef LambdaCatConf
+cfgIORef = unsafePerformIO $ newIORef (undefined :: LambdaCatConf)
+
+-- | Global value that provides access to the global configuration.
+lambdaCatConf :: LambdaCatConf
+lambdaCatConf = unsafePerformIO $ readIORef cfgIORef
+
+-- | Sets the lambdacat configuration.
+--
+-- This function should be called only once by the lambdacat main
+-- function and is only for internal use.
+setLCC :: LambdaCatConf -> IO ()
+setLCC = writeIORef cfgIORef
+
diff --git a/LambdaCat/History.hs b/LambdaCat/History.hs
new file mode 100644
index 0000000..5588eb2
--- /dev/null
+++ b/LambdaCat/History.hs
@@ -0,0 +1,160 @@
+-- |
+-- Module : LambdaCat.History
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides lambdacat's history functionality. The history is
+-- not stored linear as in other browsers, it is stored as a tree. This way
+-- navigating backwards and then along another path no navigation history is
+-- lost.
+
+module LambdaCat.History
+ (
+ -- * The data structure
+ History
+
+ -- * Construction
+ , singleton
+
+ -- * Navigation
+ , back
+ , forward
+
+ -- * Modification
+ , insert
+ , insertAndForward
+ , updateCurrent
+
+ -- * Query
+ , current
+ , hasBack
+ , hasForward
+ , getForwards
+ )
+where
+
+import Data.IntMap
+ ( IntMap
+ )
+import qualified Data.IntMap as IntMap
+import Data.Maybe
+ ( fromJust
+ , isJust
+ )
+import Network.URI
+
+-- | Directed tree with 'URI's as weights.
+type History = DTree URI
+
+-- | Weighted directed tree
+data DTree a = DTree
+ { dTreeWeight :: a -- ^ Weight of the node.
+ , dTreeBack :: Maybe (Int, DTree a) -- ^ The nodes parent, if any.
+ -- The Int is the number by which
+ -- this node can be reached from
+ -- its parent.
+ , dTreeForward :: IntMap (DTree a) -- ^ The numbered childs.
+ }
+ deriving Show
+
+-- | A tree with one node.
+singleton
+ :: a -- ^ The weight for the node.
+ -> DTree a -- ^ The new tree.
+singleton weight = DTree
+ { dTreeWeight = weight
+ , dTreeBack = Nothing
+ , dTreeForward = IntMap.empty
+ }
+
+-- | Move backwards in the tree.
+back
+ :: DTree a -- ^ Tree to navigate in.
+ -> Maybe (DTree a) -- ^ Just the parent node or Nothing if none.
+back dt =
+ case dTreeBack dt of
+ Just (index, dt') ->
+ let newDt = dt { dTreeBack = Nothing }
+ forwMap = dTreeForward dt'
+ in Just dt' { dTreeForward = IntMap.insert index newDt forwMap }
+
+ Nothing ->
+ Nothing
+
+-- | Indicates, if a back operation on the tree is possible.
+hasBack :: DTree a -> Bool
+hasBack = isJust . dTreeBack
+
+-- | Move forward in the tree.
+forward
+ :: Int -- ^ Number of the child node to navigate to.
+ -> DTree a -- ^ The tree to navigate in.
+ -> Maybe (DTree a) -- ^ Just the child node or Nothing if not existing.
+forward index dt =
+ case mdt' of
+ Just dt' ->
+ Just $ dt' { dTreeBack = Just (index, newDt) }
+
+ Nothing ->
+ Nothing
+
+ where
+ forwMap = dTreeForward dt
+
+ (mdt', forwMap') =
+ IntMap.updateLookupWithKey (\_ -> const Nothing) index forwMap
+
+ newDt = dt { dTreeForward = forwMap' }
+
+-- | Returns the weight of the trees current node.
+current :: DTree a -> a
+current = dTreeWeight
+
+-- | Replace the weight at the current node.
+updateCurrent :: a -> DTree a -> DTree a
+updateCurrent a tree = tree { dTreeWeight = a }
+
+-- | Indicates if a forward operation on this tree is possible.
+hasForward :: DTree a -> Bool
+hasForward = not . IntMap.null . dTreeForward
+
+-- | Returns a list of child nodes identified by its numbers and their
+-- weights.
+getForwards :: DTree a -> [(Int, a)]
+getForwards =
+ map withSnd . IntMap.toList . dTreeForward
+
+ where
+ withSnd :: (Int, DTree a) -> (Int, a)
+ withSnd (key, dt) = (key, dTreeWeight dt)
+
+-- | Insert a new child node adjacent to the trees current node.
+insert :: a -> DTree a -> DTree a
+insert weight dt =
+ dt { dTreeForward = IntMap.insert (newIndex forwMap) newDt forwMap }
+
+ where
+ forwMap = dTreeForward dt
+ newDt = singleton weight
+
+-- | Insert a new child node adjacent to the tress current node and then
+-- move forward to it.
+insertAndForward :: a -> DTree a -> DTree a
+insertAndForward weight dt =
+ fromJust . forward index $
+ dt { dTreeForward = IntMap.insert index newDt forwMap }
+
+ where
+ forwMap = dTreeForward dt
+ newDt = singleton weight
+ index = newIndex forwMap
+
+-- | Internal function to generate the next free index on an IntMap.
+newIndex :: IntMap a -> Int
+newIndex m
+ | IntMap.null m = 0
+ | otherwise = 1 + fst (IntMap.findMax m)
+
diff --git a/LambdaCat/Internal/Class.hs b/LambdaCat/Internal/Class.hs
new file mode 100644
index 0000000..de4ce4f
--- /dev/null
+++ b/LambdaCat/Internal/Class.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE ExistentialQuantification
+ , FunctionalDependencies
+ , MultiParamTypeClasses
+ #-}
+
+-- |
+-- Module : LambdaCat.Internal.Class
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides the basic type classes and data types that cannot be
+-- put into other modules due to cyclic dependencies.
+--
+-- All the classes are reexported by other modules, so there is no need to
+-- expose this module.
+
+module LambdaCat.Internal.Class
+ (
+ -- * Type classes
+ UIClass (..)
+ , ViewClass (..)
+ , SupplierClass (..)
+
+ -- * The @Callback@ type
+ , Callback
+
+ -- * Wrapper types for the type classes
+ , View (..)
+ , Supplier (..)
+ )
+where
+
+import Network.URI
+
+import Graphics.UI.Gtk.Abstract.Widget
+
+-- | Datatype for callback functions.
+type Callback ui meta = ui -> meta -> IO ()
+
+-- | Class of user interfaces for lambdacat.
+class UIClass ui meta | ui -> meta where
+ -- | Initializes the UI and returns an UI handle.
+ init :: IO ui
+
+ -- | The main loop for the UI.
+ mainLoop :: ui -> IO ()
+
+ -- | Function to give to 'embed'.
+ update :: ui -> meta -> Callback ui meta -> IO ()
+ update ui meta f = f ui meta
+
+ -- | Embed the view into the given UI.
+ --
+ -- For this function the meta data COULD be undefined but is here to have
+ -- a unique function interface for the supplier.
+ embedView :: View -> Callback ui meta
+
+ -- | Replace one view with a new view. The view that should be replaced
+ -- SHOULD be determind by @meta@. The type of the new view is determined
+ -- by the first argument.
+ replaceView :: View -> Callback ui meta
+
+ -- | Inform the @ui@ that the view has changed its URI.
+ changedURI :: View -> Callback ui meta
+
+ -- | Inform the @ui@ that @view@ has updated its title.
+ changedTitle :: View -> Callback ui meta
+
+ -- | Inform the @ui@ that @view@ has changed its progress state.
+ changedProgress :: Int -> Callback ui meta
+
+ -- | Inform the @ui@ that @view@ has changes its status.
+ changedStatus :: String -> Callback ui meta
+
+-- | Class of viewers, that can render and handle content behind an 'URI'.
+class ViewClass view where
+ -- | Creates a new view.
+ new :: IO view
+
+ -- | Ask the view to embed its widget by calling the given function.
+ -- Also give the callback function to the widget.
+ embed :: UIClass ui meta
+ => view -- ^ The view to embed.
+ -> (Widget -> IO ()) -- ^ Function to embed the widget.
+ -> (Callback ui meta -> IO ())
+ -> IO ()
+
+ -- | Destructor, allow cleaning up when the view is discarded.
+ destroy :: view -> IO ()
+
+ -- | Ask the view to load the given URI.
+ load :: view -> URI -> IO Bool
+
+ -- | Ask the view for the current URI. If no URI is available, 'nullURI'
+ -- must be returned.
+ getCurrentURI :: view -> IO URI
+
+ -- | Ask the view for the current title.
+ getCurrentTitle :: view -> IO String
+
+ -- | Ask the view for the current progress. This must return a value
+ -- between 0 and 100
+ getCurrentProgress :: view -> IO Int
+
+-- | Class of suppliers, which retrieve content and select appropiate viewers.
+class SupplierClass supplier where
+ -- | Ask the supplier for an appropriated view for the URI.
+ supplyView :: supplier -> URI -> IO (Maybe View)
+
+ -- supplyContent :: TODO
+
+-- | Encapsulates any instance of ViewClass.
+data View = forall view . ViewClass view => View view
+
+instance ViewClass View where
+ new = return (error "Can't create existential quantificated datatype")
+
+ embed (View view) = embed view
+ destroy (View view) = destroy view
+
+ load (View view) = load view
+
+ getCurrentURI (View view) = getCurrentURI view
+ getCurrentTitle (View view) = getCurrentTitle view
+ getCurrentProgress (View view) = getCurrentProgress view
+
+-- | Encapsulates any instance of SupplierClass.
+data Supplier = forall supplier . SupplierClass supplier
+ => Supplier supplier
+
+instance SupplierClass Supplier where
+ supplyView (Supplier supplier) = supplyView supplier
+
diff --git a/LambdaCat/Session.hs b/LambdaCat/Session.hs
new file mode 100644
index 0000000..4c49148
--- /dev/null
+++ b/LambdaCat/Session.hs
@@ -0,0 +1,159 @@
+-- |
+-- Module : LambdaCat.Session
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides some basic session handling.
+
+module LambdaCat.Session
+ (
+ -- * Datatypes
+ MSession
+ , Session (..)
+ , Tab (..)
+
+ -- * Concurrent session handling
+ , newMSession
+ , updateMSession
+ , withMSession
+
+ -- * Session access and manipulation
+ , newSession
+ , getSession
+
+ , newTab
+ , getTab
+ , updateTab
+ , deleteTab
+ )
+where
+
+import Control.Concurrent.MVar
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Network.URI (URI)
+
+import LambdaCat.History (History)
+import qualified LambdaCat.History as History
+import LambdaCat.View
+
+-- | This datatype stores session related information.
+data Session tabIdent tabmeta = Session
+ { sessionTabs :: Map tabIdent (Tab tabmeta) -- ^ Map of tab's.
+ , sessionTabActive :: Maybe tabIdent -- ^ ID of the currently
+ -- active tab.
+ }
+
+-- | Datatypes for save concurrent access to session data.
+newtype MSession tabIdent tabMeta = MSession
+ { unMSession :: MVar (Session tabIdent tabMeta) -- ^ Extract the stored
+ -- MVar.
+ }
+
+-- | Datatype representation of a tab.
+data Tab tabmeta = Tab
+ { tabView :: View -- ^ Current view of the tab.
+ , tabMeta :: tabmeta -- ^ Metadata connected to the tab.
+ , tabHistory :: History -- ^ History of the tab.
+ }
+
+-- | Create a (mutable) 'Session' for save concurrent access.
+newMSession :: IO (MSession tabIdent tabMeta)
+newMSession = return . MSession =<< newMVar newSession
+
+-- | Create a session.
+newSession :: Session tabIdent tabMeta
+newSession = Session
+ { sessionTabs = Map.empty
+ , sessionTabActive = Nothing
+ }
+
+-- | Create a new 'Tab' in the given session and add the given URI to its
+-- initial 'History'.
+newTab :: Ord tabIdent
+ => tabIdent -- ^ The tab's identifier.
+ -> View -- ^ The tab's view.
+ -> tabMeta -- ^ Metadata to store with the tab.
+ -> URI -- ^ The initial URI for the history.
+ -> Session tabIdent tabMeta -- ^ Session to add the tab to.
+ -> Session tabIdent tabMeta -- ^ Session containing the tab.
+newTab ti view tm uri session =
+ session { sessionTabs = Map.insert ti tab sessTabs }
+ where
+ tab = Tab
+ { tabView = view
+ , tabHistory = History.singleton uri
+ , tabMeta = tm
+ }
+
+ sessTabs = sessionTabs session
+
+-- | Update a tab within a 'Session'
+updateTab :: (Eq tabIdent, Ord tabIdent)
+ => Session tabIdent tabMeta -- ^ The session to
+ -- operate on.
+ -> tabIdent -- ^ Identifier of the tab
+ -- that should be modified.
+ -> (Tab tabMeta -> Maybe (Tab tabMeta)) -- ^ Function that performs
+ -- the update. If 'Nothing'
+ -- is returned the tab gets
+ -- deleted.
+ -> Session tabIdent tabMeta -- ^ Modified session.
+updateTab session tabId f =
+ session { sessionTabs = newTabs }
+ where
+ tabs = sessionTabs session
+ newTabs = Map.updateWithKey search tabId tabs -- TODO fix
+ search _ = f
+
+-- | Get a tab specified by its identifier from the given session.
+getTab
+ :: Ord tabIdent
+ => tabIdent -- ^ Identifier of the tab to get.
+ -> Session tabIdent tabMeta -- ^ Session to get the tab from.
+ -> Maybe (Tab tabMeta) -- ^ 'Nothing' if no tab for the identifier
+ -- is found in the session.
+getTab ti session =
+ Map.lookup ti sessTabs
+ where
+ sessTabs = sessionTabs session
+
+-- | Removes a tab from the session.
+deleteTab
+ :: Ord tabIdent
+ => tabIdent -- ^ Identifier of the tab to remove.
+ -> Session tabIdent tabMeta -- ^ Session to remove from.
+ -> Session tabIdent tabMeta -- ^ Session without the tab.
+deleteTab ident session =
+ session { sessionTabs = Map.delete ident tabs }
+ where
+ tabs = sessionTabs session
+
+-- | Return the current session stored in the 'MSession'.
+getSession :: MSession tabIdent tabMeta -> IO (Session tabIdent tabMeta)
+getSession = readMVar . unMSession
+
+-- | Update the session stored in the given 'MSession' by applying the given
+-- function and storing the result back in the MSession.
+--
+-- During this operation no other thread can access the session. If one tries
+-- it will block.
+updateMSession
+ :: MSession tabIdent tabMeta
+ -> (Session tabIdent tabMeta -> IO (Session tabIdent tabMeta, a))
+ -> IO a
+updateMSession msession = modifyMVar (unMSession msession)
+
+-- | Apply the given function to current session.
+--
+-- While the function is processed no other thread can access the session. If
+-- one tries it will block.
+withMSession
+ :: MSession tabIdent tabMeta
+ -> (Session tabIdent tabMeta -> IO a)
+ -> IO a
+withMSession msession = withMVar (unMSession msession)
+
diff --git a/LambdaCat/Supplier.hs b/LambdaCat/Supplier.hs
new file mode 100644
index 0000000..048bb0e
--- /dev/null
+++ b/LambdaCat/Supplier.hs
@@ -0,0 +1,63 @@
+-- |
+-- Module : LambdaCat.Supplier
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- A supplier gets the content for a given URI and passes it to a matching
+-- view.
+
+module LambdaCat.Supplier
+ (
+ -- * Class and wrapper
+ SupplierClass (..)
+ , Supplier (..)
+
+ -- * Callback type
+ , Callback
+
+ -- * Supplying for views
+ , supplyForView
+ )
+where
+
+import Data.List
+ ( find
+ )
+import Data.Maybe
+ ( isJust
+ )
+import Network.URI
+
+import LambdaCat.Configure
+import LambdaCat.Internal.Class
+
+-- | Selects a proper supplier for the given URI.
+supplyForView
+ :: (Callback ui meta -> IO ())
+ -> (View -> Callback ui meta)
+ -> URI
+ -> IO ()
+supplyForView callbackHdl embedHdl uri = do
+ let suppliers = supplierList lambdaCatConf
+ uri' = modifySupplierURI lambdaCatConf uri
+ protocol = uriScheme uri'
+ mSupply = find (\(_s, ps) -> isJust $ find (== protocol) ps)
+ suppliers
+
+ case mSupply of
+ Just (supply, _) -> do
+ mView <- supplyView supply uri'
+
+ case mView of
+ Just view ->
+ callbackHdl $ embedHdl view
+
+ Nothing ->
+ putStrLn $ "Load view for unhandled uri" ++ show uri'
+
+ Nothing ->
+ putStrLn $ "Can't find a supplier for protocol:" ++ protocol
+
diff --git a/LambdaCat/Supplier/Web.hs b/LambdaCat/Supplier/Web.hs
new file mode 100644
index 0000000..aefcbfa
--- /dev/null
+++ b/LambdaCat/Supplier/Web.hs
@@ -0,0 +1,57 @@
+-- |
+-- Module : LambdaCat.Supplier.Web
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides the basic 'WebSupplier'. It doesn't really supply
+-- content but creates a view that then loads the content.
+
+module LambdaCat.Supplier.Web
+ (
+ -- * Supplier
+ webSupplier
+
+ -- * Module exports
+ , module LambdaCat.Supplier
+ )
+where
+
+import Data.List
+ ( find
+ )
+import Data.Maybe
+ ( isJust
+ )
+import Network.URI
+
+import LambdaCat.Configure
+import LambdaCat.Supplier
+import LambdaCat.View
+
+-- | The WebSupplier datatype.
+data WebSupplier = WebSupplier
+
+-- | Type specification constant to use in configuration.
+webSupplier :: Supplier
+webSupplier = Supplier WebSupplier
+
+instance SupplierClass WebSupplier where
+ supplyView _ uri =
+ let viewers = viewList lambdaCatConf
+ protocol = uriScheme uri
+ mViewConst =
+ find (\(_vc, ps, _) -> isJust $ find (== protocol) ps) viewers
+
+ in case mViewConst of
+ Just (vc, _, _) -> do
+ view <- createView vc
+
+ _status <- load view uri
+ return $ Just view
+
+ Nothing ->
+ return Nothing
+
diff --git a/LambdaCat/UI.hs b/LambdaCat/UI.hs
new file mode 100644
index 0000000..7a209ed
--- /dev/null
+++ b/LambdaCat/UI.hs
@@ -0,0 +1,26 @@
+-- |
+-- Module : LambdaCat.UI
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module exports the relevant typeclasses and datastructures to
+-- implement your own UI for lambdacat.
+
+module LambdaCat.UI
+ ( module LambdaCat.Internal.Class
+ , module LambdaCat.View
+ )
+where
+
+import LambdaCat.Internal.Class
+ ( UIClass (..)
+ , Callback
+ )
+import LambdaCat.View
+ ( ViewClass (..)
+ , View (..)
+ )
+
diff --git a/LambdaCat/UI/Glade.hs b/LambdaCat/UI/Glade.hs
new file mode 100644
index 0000000..f6768fa
--- /dev/null
+++ b/LambdaCat/UI/Glade.hs
@@ -0,0 +1,537 @@
+{-# LANGUAGE FlexibleInstances
+ , MultiParamTypeClasses
+ , OverloadedStrings
+ , RankNTypes
+ , TypeSynonymInstances
+ #-}
+
+-- |
+-- Module : LambdaCat.UI.Glade
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides a Glade based UI.
+
+module LambdaCat.UI.Glade
+ (
+ -- * The UI type
+ GladeUI
+
+ -- * Module exports
+ , module LambdaCat.UI
+ )
+where
+
+import Control.Monad
+ ( when
+ )
+import Control.Monad.Trans
+import Data.Maybe
+import Network.URI
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Glade
+
+import LambdaCat.Configure
+ ( LambdaCatConf (..)
+ , lambdaCatConf
+ )
+import LambdaCat.History
+import LambdaCat.Session
+import LambdaCat.Supplier
+import LambdaCat.UI
+import LambdaCat.UI.Glade.PersistentTabId
+import LambdaCat.Utils
+import Paths_lambdacat
+
+-- | Datatype storing all the relevant information about the UI.
+data GladeUI = GladeUI
+ { gladeXML :: GladeXML -- ^ The contents of the Glade
+ -- file.
+ , gladeWindow :: Window -- ^ The UI's main window.
+ , gladeStatBar :: Statusbar -- ^ The UI's statusbar.
+ , viewContainer :: Notebook -- ^ The notebook used for
+ -- tabbing.
+ , gladeSession :: MSession TabId TabMeta -- ^ The UI's session.
+ }
+
+-- | Datatype for storing meta data with each tab.
+data TabMeta = TabMeta
+ { tabMetaIdent :: TabId -- ^ The tab's identifier.
+ , tabMetaLabel :: Label -- ^ The label widget.
+ , tabMetaImage :: Image -- ^ The image for the favicon.
+ , tabMetaContainer :: Container -- ^ The container that holds the view.
+ }
+
+instance UIClass GladeUI TabMeta where
+ init = do
+ _ <- initGUI
+
+ spath <- getDataFileName "lambdacat.gtkrc"
+ rcParse spath
+
+ fpath <- getDataFileName "lambdacat.glade"
+ Just xml <- xmlNew fpath
+ window <- xmlGetWidget xml castToWindow "mainWindow"
+ notebook <- xmlGetWidget xml castToNotebook "viewNotebook"
+ statbar <- xmlGetWidget xml castToStatusbar "statusbar"
+ session <- newMSession
+ return GladeUI
+ { gladeSession = session
+ , gladeXML = xml
+ , gladeWindow = window
+ , gladeStatBar = statbar
+ , viewContainer = notebook
+ }
+
+ mainLoop ui = do
+ let notebook = viewContainer ui
+ -- statbar = gladeStatBar ui
+ xml = gladeXML ui
+ window = gladeWindow ui
+ session = gladeSession ui
+
+ tabVisibility notebook
+
+ -- General / Events --------------------------------------------------
+
+ _ <- onDestroy window mainQuit
+
+ _ <- notebook `on` switchPage $ \newActive -> do
+ (view, meta) <- withNthNotebookTab notebook session newActive $
+ \tab -> return (tabView tab, tabMeta tab)
+ uri <- getCurrentURI view
+ progress <- getCurrentProgress view
+
+ updateAddressBar ui uri
+ updateProgress ui progress
+ changedTitle view ui meta
+
+ -- Toolbar / Events --------------------------------------------------
+
+ addressEntry <- xmlGetWidget xml castToEntry "addressEntry"
+
+ addTab <- xmlGetToolButton xml "addTabButton"
+ _ <- onToolButtonClicked addTab $ do
+ supplyForView (update ui undefined) embedView $
+ defaultURI lambdaCatConf
+ widgetGrabFocus addressEntry
+
+ homeButton <- xmlGetToolButton xml "homeButton"
+ _ <- onToolButtonClicked homeButton $
+ supplyForView (update ui undefined) replaceViewCurrent $
+ homeURI lambdaCatConf
+
+ _ <- addressEntry `on` keyPressEvent $ do
+ val <- eventKeyVal
+
+ case keyName val of
+ "Return" -> do
+ text <- liftIO $ entryGetText addressEntry
+
+ case stringToURI text of
+ uri
+ | uri /= nullURI -> do
+ liftIO $ supplyForView
+ (update ui $ error "addressEntry")
+ replaceViewCurrent
+ uri
+ return True
+
+ | otherwise ->
+ return False -- handle error
+
+ _ ->
+ return False
+
+ addressItem <- xmlGetWidget xml castToToolItem "addressItem"
+ addressItem `set` [ toolItemExpand := True ]
+
+ quitItem <- xmlGetWidget xml castToMenuItem "quitItem"
+ _ <- onActivateLeaf quitItem mainQuit
+
+ infoItem <- xmlGetWidget xml castToMenuItem "infoItem"
+ _ <- onActivateLeaf infoItem $ supplyForView (update ui undefined)
+ embedView
+ "about:info"
+
+ pageBack <- xmlGetToolButton xml "backButton"
+ _ <- onToolButtonClicked pageBack $ do
+ (view, muri) <- withCurrentTab ui $ \tab tabId sess -> do
+ let history = tabHistory tab
+ history' = if hasBack history
+ then fromJust $ back history
+ else history
+ newuri = current history'
+ view = tabView tab
+ return ( updateTab sess tabId $ const . Just $
+ tab { tabHistory = history' }
+ , ( view
+ , if hasBack history
+ then Just newuri
+ else Nothing
+ )
+ ) -- TODO: Put expressions into let-block
+
+ maybe (return ()) (\uri -> load view uri >> return ()) muri
+
+ forwardButton <- xmlGetToolButton xml "forwardButton"
+ _ <- onToolButtonClicked forwardButton $ do
+ (view, muri) <- withCurrentTab ui $ \tab tabId sess -> do
+ let history = tabHistory tab
+ history' =
+ if hasForward history
+ then fromJust $ forward
+ (fst . last . getForwards $ history)
+ history
+ else history
+ newuri = current history'
+ view = tabView tab
+ return ( updateTab sess tabId $ const . Just $
+ tab { tabHistory = history' }
+ , ( view
+ , if hasForward history
+ then Just newuri
+ else Nothing
+ )
+ ) -- TODO: Cleanup
+
+ maybe (return ()) (\uri -> load view uri >> return ()) muri
+
+ pageReload <- xmlGetToolButton xml "reloadButton"
+ _ <- onToolButtonClicked pageReload $ do
+ view <- withCurrentTab ui $ \tab _ sess ->
+ return (sess, tabView tab)
+
+ _ <- getCurrentURI view >>= load view
+ return ()
+
+ widgetShowAll window
+ -- start GTK mainloop
+ mainGUI
+
+ changedURI view ui meta = do
+ let ident = tabMetaIdent meta -- TODO: Check this.
+ thisTabId = tabMetaIdent meta
+
+ uri <- getCurrentURI view
+
+ doit <- withCurrentTab ui $ \_ tabid session ->
+ return (session, tabid == thisTabId)
+ when doit $ updateAddressBar ui uri
+
+ updateMSession (gladeSession ui) $ \session ->
+ return ( updateTab session ident $ \tab ->
+ let history = tabHistory tab
+ in Just $ tab { tabHistory = updateCurrent uri history }
+ , ()
+ ) -- TODO: Cleanup
+
+ return ()
+
+ changedTitle view ui meta = do
+ let label = tabMetaLabel meta
+ window = gladeWindow ui
+
+ title <- getCurrentTitle view
+
+ set label [ labelLabel := if null title
+ then defaultTitle lambdaCatConf
+ else title
+ ]
+ set window [ windowTitle := title ]
+
+ return ()
+
+ changedProgress progress ui meta = do
+ let thisTabId = tabMetaIdent meta
+
+ doit <- withCurrentTab ui $ \_ tabid session ->
+ return (session, tabid == thisTabId)
+ when doit $ updateProgress ui progress
+
+ changedStatus status ui meta = do
+ let sb = gladeStatBar ui
+ thisTabId = tabMetaIdent meta
+
+ doit <- withCurrentTab ui $ \_ tabid session ->
+ return (session, tabid == thisTabId)
+ when doit $ do
+ cntx <- statusbarGetContextId sb "status"
+
+ case status of
+ "" ->
+ statusbarPop sb cntx
+ stat -> do
+ statusbarPop sb cntx
+ _ <- statusbarPush sb cntx stat
+ return ()
+
+ replaceView view ui meta = do
+ replaceViewLocal view (tabMetaContainer meta) ui meta
+ newURI <- getCurrentURI view
+ oldView <- updateMSession (gladeSession ui) $ \session -> do
+ let Just tab = getTab (tabMetaIdent meta) session
+ oldView = tabView tab
+ history = tabHistory tab
+ history' = insertAndForward newURI history
+ session' = updateTab session (tabMetaIdent meta) $
+ \t -> Just $ t
+ { tabView = view
+ , tabHistory = history'
+ }
+ return (session', oldView)
+
+ destroy oldView
+
+ embedView view ui _ = do
+ let noteBook = viewContainer ui
+
+ scrolledWindow <- scrolledWindowNew Nothing Nothing
+ tabId <- genNewId
+
+ setContainerId scrolledWindow tabId
+
+ (labelWidget, img, label) <- tabWidget $ do
+ removeTId <- noteBook `get` (notebookChildPosition scrolledWindow)
+ notebookRemovePage noteBook removeTId
+
+ withContainerId scrolledWindow $ \removeTabId -> do
+ kView <- updateMSession (gladeSession ui) $ \session -> do
+ let kv = tabView . fromJust $ getTab removeTabId session
+ return (deleteTab removeTabId session, kv)
+
+ destroy kView
+ tabVisibility noteBook
+
+ let newMeta = TabMeta
+ { tabMetaIdent = tabId
+ , tabMetaLabel = label
+ , tabMetaImage = img
+ , tabMetaContainer = castToContainer scrolledWindow
+ }
+
+ embed view (embedHandle scrolledWindow) (update ui newMeta)
+ startURI <- getCurrentURI view
+
+ updateMSession (gladeSession ui) $ \session -> do
+ let session' = newTab tabId view newMeta startURI session
+ return (session' {sessionTabActive = Just tabId}, ())
+
+ pageId <- notebookAppendPageMenu
+ noteBook
+ scrolledWindow
+ labelWidget
+ labelWidget
+
+ widgetShowAll noteBook
+ tabVisibility noteBook
+
+ notebookSetCurrentPage noteBook pageId
+
+ return ()
+
+ where
+ embedHandle scrolledWindow widget = do
+ containerAdd scrolledWindow widget
+ return ()
+
+ tabWidget closeCallback = do
+ hbox <- hBoxNew False 3
+ label <- labelNew (Just $ defaultTitle lambdaCatConf)
+ button <- buttonNew
+
+ widgetSetName button "tab-close-button"
+
+ fav <- imageNewFromStock stockJustifyCenter IconSizeMenu
+ img <- imageNewFromStock stockClose IconSizeMenu
+
+ set button
+ [ buttonRelief := ReliefNone
+ , buttonImage := img
+ ]
+
+ _ <- button `onClicked` closeCallback
+
+ boxPackStart hbox fav PackGrow 0
+ boxPackStart hbox label PackGrow 0
+ boxPackStart hbox button PackNatural 0
+
+ widgetShowAll hbox
+
+ return (hbox, img, label)
+
+-- | Update the visibility of the tabs in the given notebook.
+--
+-- The rule is: Display tabs only if there are at least two of them.
+tabVisibility :: Notebook -> IO ()
+tabVisibility notebook = do
+ pages <- notebookGetNPages notebook
+ set notebook [ notebookShowTabs := pages > 1 ]
+
+-- | Get the widget of the specified toolbutton.
+xmlGetToolButton
+ :: GladeXML -- ^ The Glade file's content.
+ -> String -- ^ Name of the toolbutton.
+ -> IO ToolButton -- ^ The toolbutton widget.
+xmlGetToolButton xml = xmlGetWidget xml castToToolButton
+
+-- | Call the given function with the specified tab.
+withNthNotebookTab
+ :: Notebook -- ^ Notebook that contains the tab.
+ -> MSession TabId TabMeta -- ^ The global session.
+ -> Int -- ^ Number of the tab.
+ -> (Tab TabMeta -> IO a) -- ^ The function.
+ -> IO a -- ^ The functions return value.
+withNthNotebookTab notebook msession page f = do
+ mContainer <- notebookGetNthPage notebook page
+
+ case mContainer of
+ Just container ->
+ withUnsafeContainerId (castToContainer container) $ \tabId ->
+ withMSession msession $ \session ->
+ case getTab tabId session of
+ Just tab ->
+ f tab
+
+ Nothing ->
+ error "no tab with such an id"
+
+ Nothing ->
+ error "no container in here"
+
+-- | Call the given function with the current tab. Also the identifier and
+-- session are passed to the function.
+withCurrentTab
+ :: GladeUI -- ^ UI to get the current tab from.
+ -> ( Tab TabMeta
+ -> TabId
+ -> Session TabId TabMeta
+ -> IO (Session TabId TabMeta, a)
+ ) -- ^ Function to call. Should return the modified session and
+ -- its real result.
+ -> IO a -- ^ The result of the function call.
+withCurrentTab ui f = do
+ let notebook = viewContainer ui
+ msession = gladeSession ui
+
+ pageId <- notebookGetCurrentPage notebook
+ mContainer <- notebookGetNthPage notebook pageId
+
+ case mContainer of
+ Just container ->
+ withUnsafeContainerId (castToContainer container) $ \tabId ->
+ updateMSession msession $ \session ->
+
+ case getTab tabId session of
+ Just tab ->
+ f tab tabId session
+
+ Nothing ->
+ error "Can't find current tab"
+
+ Nothing ->
+ error "there is no tab with the given ident in the notebook"
+
+-- | Replace the view in the given container by another one.
+replaceViewLocal
+ :: View -- ^ The new view.
+ -> Container -- ^ The container.
+ -> GladeUI -- ^ UI to replace in.
+ -> TabMeta -- ^ New metadata for the tab.
+ -> IO ()
+replaceViewLocal view container ui meta = do
+ cs <- containerGetChildren container
+ mapM_ (containerRemove container) cs
+
+ embed view (\w -> do
+ containerAdd container w
+ widgetShowAll w
+ widgetGrabFocus w
+ ) (update ui meta)
+
+ title <- getCurrentTitle view
+
+ set (tabMetaLabel meta)
+ [ labelLabel := if null title
+ then defaultTitle lambdaCatConf
+ else title
+ ]
+
+-- | Replace the view in the current tab.
+replaceViewCurrent
+ :: View -- ^ The new view.
+ -> GladeUI -- ^ The UI to replace in.
+ -> a -- TODO: Give a better name.
+ -> IO ()
+replaceViewCurrent view ui _ = do
+ let notebook = viewContainer ui
+
+ pageId <- notebookGetCurrentPage notebook
+ mContainer <- notebookGetNthPage notebook pageId
+
+ case mContainer of
+ Just container -> do
+ newURI <- getCurrentURI view
+ (meta, oldView) <- withUnsafeContainerId
+ (castToContainer container) $
+ \tabId ->
+
+ updateMSession (gladeSession ui) $ \session ->
+
+ case getTab tabId session of
+ Just tab -> do
+ let oldView = tabView tab
+ history = tabHistory tab
+ history' = insertAndForward newURI history
+ session' = updateTab
+ session
+ (tabMetaIdent $ tabMeta tab) $
+ \t -> Just $ t
+ { tabView = view
+ , tabHistory = history'
+ }
+
+ return ( session' { sessionTabActive = Just tabId }
+ , (tabMeta tab, oldView)
+ )
+
+ Nothing ->
+ return (session, error "there is no current tab")
+
+ destroy oldView
+ replaceViewLocal view (castToContainer container) ui meta
+
+ Nothing -> return ()
+
+-- | Update the URI displayed in the addressbar.
+updateAddressBar
+ :: GladeUI -- ^ The UI to update in.
+ -> URI -- ^ The URI to display.
+ -> IO ()
+updateAddressBar ui uri = do
+ let xml = gladeXML ui
+
+ pageURI <- xmlGetWidget xml castToEntry "addressEntry"
+ entrySetText pageURI $ show uri
+
+-- | Update the progress displayed in the statusbar.
+updateProgress
+ :: GladeUI -- ^ The UI to update in.
+ -> Int -- ^ The progress (@0 <= progress <= 100@).
+ -> IO ()
+updateProgress ui progress = do
+ let sb = gladeStatBar ui
+
+ cntx <- statusbarGetContextId sb "progress"
+ statusbarPop sb cntx
+ _ <- statusbarPush sb cntx $
+ if progress < 100
+ then show progress ++ "%"
+ else "Done"
+
+ return ()
+
diff --git a/LambdaCat/UI/Glade/PersistentTabId.hs b/LambdaCat/UI/Glade/PersistentTabId.hs
new file mode 100644
index 0000000..6c3b8a0
--- /dev/null
+++ b/LambdaCat/UI/Glade/PersistentTabId.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- |
+-- Module : LambdaCat.UI.Glade.PersistentTabId
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides tab identifiers that are globally unique.
+
+module LambdaCat.UI.Glade.PersistentTabId
+ (
+ -- * Datatype
+ TabId
+
+ -- * Container attribute
+ , containerTabId
+ , setContainerId
+
+ -- * Construction
+ , genNewId
+
+ -- * Access
+ , withContainerId
+ , withUnsafeContainerId
+ )
+where
+
+import Control.Concurrent.MVar
+ ( MVar
+ , modifyMVar
+ , newMVar
+ )
+import Data.Maybe
+ ( fromJust
+ )
+import System.IO.Unsafe
+ ( unsafePerformIO
+ )
+
+import Graphics.UI.Gtk
+
+-- | The type for unique tab identifiers.
+newtype TabId = TabId Int
+ deriving (Eq, Num, Show, Ord)
+
+-- | MVar holding the next identifier.
+nextTabId :: MVar TabId
+nextTabId = unsafePerformIO $ newMVar (TabId 0)
+
+-- | Generate a new unique identifier.
+genNewId :: IO TabId
+genNewId = modifyMVar nextTabId $ \t -> return (t + 1, t)
+
+-- | Attribute to store a unique tab identifier in a container.
+containerTabId :: Attr Container (Maybe TabId)
+containerTabId = unsafePerformIO objectCreateAttribute
+
+-- | Set a new identifier in the given container.
+--
+-- Same as @set container [ containerTabId := tabId ]@.
+setContainerId
+ :: ContainerClass container
+ => container -- ^ The container to set the identifier in.
+ -> TabId -- ^ The new tab identifier.
+ -> IO ()
+setContainerId container tabId =
+ set (castToContainer container) [ containerTabId := Just tabId ]
+
+-- | Call the given function with the tab identifier stored in the container.
+-- If no identifier is stored the function will return.
+withContainerId
+ :: (ContainerClass container)
+ => container
+ -> (TabId -> IO ())
+ -> IO ()
+withContainerId container f = do
+ maybeId <- get (castToContainer container) containerTabId
+
+ case maybeId of
+ Just cId ->
+ f cId
+
+ Nothing ->
+ return ()
+
+-- | Call the given function with the tab identifier stored in the container.
+-- If no identifier is stored the function will raise an exception.
+withUnsafeContainerId
+ :: (ContainerClass container)
+ => container
+ -> (TabId -> IO a)
+ -> IO a
+withUnsafeContainerId container f = do
+ mTabId <- get (castToContainer container) containerTabId
+ f $ fromJust mTabId
+
diff --git a/LambdaCat/Utils.hs b/LambdaCat/Utils.hs
new file mode 100644
index 0000000..33913ec
--- /dev/null
+++ b/LambdaCat/Utils.hs
@@ -0,0 +1,80 @@
+{-# OPTIONS_GHC -fno-warn-orphans
+ -fno-warn-unused-binds
+ #-}
+
+-- |
+-- Module : LambdaCat.Utils
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides a bunch of functions and instances that are pretty
+-- usefull.
+
+module LambdaCat.Utils
+ (
+ -- * URI
+ stringToURI
+ , showURI
+ )
+where
+
+import GHC.Exts
+ ( IsString (..)
+ )
+import Network.URI
+
+instance IsString URI where
+ fromString = stringToURI
+
+-- | This function tries hard on parsing a given String and converting it to
+-- an URI. In case of failure it returns 'nullURI'.
+--
+-- Use this function for parsing URIs where ever possible.
+stringToURI :: String -> URI
+stringToURI =
+ tryParsers
+ [ parseURI
+ , parseURIReference
+ , parseRelativeReference
+ , parseAbsoluteURI
+ ]
+ nullURI
+ where
+ tryParsers [] e _ = e
+ tryParsers (p : ps) e str =
+ case p str of
+ Just r -> r
+ Nothing -> tryParsers ps e str
+
+-- | Convert a given URI into a String representation.
+--
+-- This function is espacially usefull for debugging since it exposes the real
+-- structure of the URI datatype. The 'Show' instance for URI only pretty
+-- prints the URI.
+showURI :: URI -> String
+showURI URI
+ { uriScheme = uScheme
+ , uriAuthority = mAuth
+ , uriPath = uPath
+ , uriQuery = uQuery
+ , uriFragment = uFragment
+ } = "URI: scheme = " ++ uScheme
+ ++ ", auth = " ++ maybe "none" showAuth mAuth
+ ++ ", path = " ++ uPath
+ ++ ", query = " ++ uQuery
+ ++ ", fragment = " ++ uFragment
+
+-- | Helper function to show the auth part of an URI.
+showAuth :: URIAuth -> String
+showAuth URIAuth
+ { uriUserInfo = userInfo
+ , uriRegName = regName
+ , uriPort = port
+ } = "(userInfo = " ++ userInfo
+ ++ ", regName = " ++ regName
+ ++ ", port = " ++ port
+ ++ ")"
+
diff --git a/LambdaCat/View.hs b/LambdaCat/View.hs
new file mode 100644
index 0000000..a2a57b7
--- /dev/null
+++ b/LambdaCat/View.hs
@@ -0,0 +1,38 @@
+-- |
+-- Module : LambdaCat.View
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides view related classes, types and functions.
+
+module LambdaCat.View
+ (
+ -- * Class and wrapper
+ ViewClass (..)
+ , View (..)
+
+ -- * Construction
+ , createView
+
+ -- * Callback type
+ , Callback
+ )
+where
+
+import LambdaCat.Internal.Class
+
+-- | Create a view.
+--
+-- Its type is specified by the first parameter. This should be a view of the
+-- same type or one of the constants exported in the corresponding
+-- @LambdaCat.View.*@ modules.
+createView :: View -> IO View
+createView (View v) = return . View =<< createView_ v
+
+-- | Helper function that assures the view of the correct type is created.
+createView_ :: (ViewClass view) => view -> IO view
+createView_ _ = new
+
diff --git a/LambdaCat/View/Web.hs b/LambdaCat/View/Web.hs
new file mode 100644
index 0000000..1ee31d1
--- /dev/null
+++ b/LambdaCat/View/Web.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE FlexibleContexts
+ , FlexibleInstances
+ , MultiParamTypeClasses
+ #-}
+
+-- |
+-- Module : LambdaCat.View.Web
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This module provides the 'WebView'. Do confuse this with WebKit's WebView!
+
+module LambdaCat.View.Web
+ (
+ -- * The View
+ WebView
+ , webView
+
+ -- * Module exports
+ , module LambdaCat.View
+ )
+where
+
+import Data.Maybe
+import Network.URI
+-- import System.Directory
+-- import System.FilePath
+
+import Graphics.UI.Gtk hiding
+ ( populatePopup
+ , widgetDestroy
+ )
+import Graphics.UI.Gtk.Abstract.Widget
+-- import Graphics.UI.Gtk.WebKit.Download
+import qualified Graphics.UI.Gtk.WebKit.NetworkRequest as NR
+-- import Graphics.UI.Gtk.WebKit.WebFrame
+import qualified Graphics.UI.Gtk.WebKit.WebNavigationAction as NA
+-- import Graphics.UI.Gtk.WebKit.WebSettings
+import qualified Graphics.UI.Gtk.WebKit.WebView as WV
+-- import System.Glib.GError
+
+import LambdaCat.Configure
+import LambdaCat.Supplier
+import LambdaCat.UI
+import LambdaCat.Utils
+import LambdaCat.View
+
+-- | Data type representing the view. Do not confuse this with WebKit's
+-- WebView!
+newtype WebView = WebView
+ { webViewWidget :: WV.WebView -- ^ The widget for the view.
+ }
+
+-- | Type specification constant for use with 'createView'.
+webView :: View
+webView = View (WebView undefined)
+
+instance ViewClass WebView where
+ new = do
+ widget <- WV.webViewNew
+ return WebView { webViewWidget = widget }
+
+ embed wV@WebView { webViewWidget = widget } embedder callback = do
+ -- Setup signal handling
+ _ <- widget `on` WV.navigationPolicyDecisionRequested $
+ \_wf nr na _wpd -> do
+ muri <- NR.networkRequestGetUri nr
+ reason <- NA.webNavigationActionGetReason na
+
+ case (muri, reason) of
+ (Just _, NA.WebNavigationReasonFormResubmitted) ->
+ -- this is not handled because of the form data
+ return False
+
+ (Just uri, NA.WebNavigationReasonLinkClicked) -> do
+ supplyForView callback replaceView $ stringToURI uri
+ return True
+
+ _ ->
+ return False
+
+ _ <- widget `on` WV.newWindowPolicyDecisionRequested $
+ \_wf nr _na _wpd -> do
+ muri <- NR.networkRequestGetUri nr
+
+ case muri of
+ Just uri ->
+ supplyForView callback replaceView $ stringToURI uri
+
+ Nothing ->
+ return ()
+
+ return True
+
+ _ <- widget `on` WV.titleChanged $ \_wf _title ->
+ callback (changedTitle $ View wV)
+
+ _ <- widget `on` WV.loadStarted $ \_wf ->
+ callback (changedURI $ View wV)
+
+ _ <- widget `on` WV.loadCommitted $ \_wf ->
+ callback (changedURI $ View wV)
+
+ _ <- widget `on` WV.loadFinished $ \_wf ->
+ callback (changedURI $ View wV)
+
+ _ <- widget `on` WV.progressChanged $ \progress ->
+ callback (changedProgress progress)
+
+ -- Embed widget
+ embedder $ castToWidget widget
+
+ destroy WebView { webViewWidget = widget } = do
+ -- TODO: Unref WebKit's WebView.
+ -- WV.webViewLoadUri widget "about:blank"
+ WV.webViewStopLoading widget
+ widgetDestroy widget
+
+ load WebView { webViewWidget = widget } uri = do
+ -- TODO: Write module for URI conversion
+ WV.webViewLoadUri widget $ show uri
+ return True
+
+ getCurrentURI WebView { webViewWidget = widget } = do
+ mUriStr <- WV.webViewGetUri widget
+ return $ maybe nullURI stringToURI mUriStr
+
+ getCurrentTitle WebView { webViewWidget = widget } = do
+ mTitle <- WV.webViewGetTitle widget
+ return $ fromMaybe (defaultTitle lambdaCatConf) mTitle
+
+ getCurrentProgress WebView { webViewWidget = widget } = do
+ progress <- widget `get` WV.webViewProgress
+ status <- widget `get` WV.webViewLoadStatus
+
+ case status of
+ WV.LoadFinished -> return 100
+ WV.LoadFailed -> return 100
+ _ -> return $ round (progress * 100)
+
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..30a357b
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,21 @@
+-- |
+-- Module : Main
+-- Copyright : Andreas Baldeau, Daniel Ehlers
+-- License : BSD3
+-- Maintainer : Andreas Baldeau <andreas@baldeau.net>,
+-- Daniel Ehlers <danielehlers@mindeye.net>
+-- Stability : Alpha
+--
+-- This is the main module for lambdacat's global binary. Its purpose is
+-- (re-)compiling the config file (real main module) and running the
+-- generated binary.
+
+module Main
+ ( main
+ )
+where
+
+import LambdaCat
+
+main :: IO ()
+main = lambdacat defaultConfig
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..604d261
--- /dev/null
+++ b/README.md
@@ -0,0 +1,73 @@
+LambdaCat - the Haskell online cat viewer
+=========================================
+
+Driven by the frustration modern browsers caused us we started to think about
+how a browser should be.
+
+Table of Contents
+-----------------
+
+1. Mission Statement
+2. Release Notes
+3. Installation
+4. Configuration
+
+1. Mission Statement
+--------------------
+
+To us, a browser should be fast, configurable, extendable, secure and easy to
+use with keyboard only. The most important feature is the ability to
+comfortably display online cat-content.
+
+By extendable and configurable we mean that we like to easily change the
+behaviour of the application in sourcecode. It should be possible to engage in
+nearly every data flow by adopting the configuration.
+
+With security, we mean that every communication and interaction with the net
+should be controllable. Every communication should be deniable by default.
+
+We like to use keyboard only applications since the mouse to keyboard movement
+is time intensive and usually breaks the workflow. This is not acceptable.
+
+Till now the mission is _not_ yet accomplished.
+
+2. Release Notes
+----------------
+
+### 0.1.0 Haskell the Cat
+
+This is the first code release. Its main purpose is to demonstrate our
+software design. The API is currently not stable and is subject to change.
+
+For now we only provide a Glade base UI (GladeUI). In the future we plan to
+add further UIs which can be chosen in the configuration.
+
+This release is _not_ for production use. Please be aware of that.
+
+3. Installation
+---------------
+
+Lambdacat can be installed from [Hackage](http://hackage.haskell.org) using
+'cabal'.
+
+ > cabal update
+ > cabal install lambdacat
+
+You can also checkout the sources from github and compile them yourself.
+
+4. Configuration
+----------------
+
+A user configuration can be put in:
+
+ ~/.config/lambdacat/lambdacat.hs
+
+This file has to provide a 'main' function that then invokes the function
+'lambdacat'.
+
+A small example how this file might look like is the 'Main.hs'.
+For further information please have a look at the haddock generated API
+documentation.
+
+Meow.
+
diff --git a/STYLE.md b/STYLE.md
new file mode 100644
index 0000000..e52afe9
--- /dev/null
+++ b/STYLE.md
@@ -0,0 +1,275 @@
+LambdaCat Style Guide
+=====================
+
+This style guide is based on Johan Tibell's Haskell Style Guide at
+<https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md>.
+
+This is a short document describing the preferred coding style for
+this project. We've tried to cover the major areas of formatting and
+naming. When something isn't covered by this guide you should stay
+consistent with the code in the other modules.
+
+Table of Contents
+-----------------
+
+1. Formatting
+2. Imports
+3. Comments
+4. Naming
+5. Misc
+
+1. Formatting
+-------------
+
+### Line Length
+
+Maximum line length is *78 characters*.
+
+### Indentation
+
+Tabs are illegal. Use spaces for indenting. Indent your code blocks
+with *4 spaces*. Indent the `where` keyword two spaces to set it
+apart from the rest of the code and indent the definitions in a
+`where` clause 2 spaces. Some examples:
+
+ sayHello :: IO ()
+ sayHello = do
+ name <- getLine
+ putStrLn $ greeting name
+ where
+ greeting name = "Hello, " ++ name ++ "!"
+
+ filter :: (a -> Bool) -> [a] -> [a]
+ filter _ [] = []
+ filter p (x:xs)
+ | p x = x : filter p xs
+ | otherwise = filter p xs
+
+### Blank Lines
+
+One blank line between top-level definitions. No blank lines between
+type signatures and function definitions. Add one blank line between
+functions in a type class instance declaration if the functions bodies
+are large. Use your judgement.
+
+### Whitespace
+
+Surround binary operators with a single space on either side. Don't
+insert a space after a lambda.
+
+### Data Declarations
+
+Align the constructors in a data type definition. Indent deriving
+declarations with two spaces. Example:
+
+ data Tree a = Branch a (Tree a) (Tree a)
+ | Leaf
+ deriving (Eq, Show)
+
+For long type names the following formatting is also acceptable:
+
+ data HttpException
+ = InvalidStatusCode Int
+ | MissingContentHeader
+ deriving (Eq, Show)
+
+Format records as follows:
+
+ data Person = Person
+ { firstName :: String -- ^ First name
+ , lastName :: String -- ^ Last name
+ , age :: Int -- ^ Age
+ }
+ deriving (Eq, Show)
+
+### List Declarations
+
+Align the elements in the list. Example:
+
+ exceptions =
+ [ InvalidStatusCode
+ , MissingContentHeader
+ , InternalServerError
+ ]
+
+Optionally, you can skip the first newline. Use your judgement.
+
+ directions = [ North
+ , East
+ , South
+ , West
+ ]
+
+### Pragmas
+
+For language extensions use the LANGUAGE pragma. Keep the
+extensions in alphabetical order. Align the extensions. Indent
+the closing bracket with two spaces. Example:
+
+ {-# LANGUAGE ExistentialQuantification
+ , FunctionalDependencies
+ , MultiParamTypeClasses
+ #-}
+
+If you only have one extension put the closing bracket on the
+same line:
+
+ {-# LANGUAGE ExistentialQuantification #-}
+
+If you need to specify compiler options per file (e.g. you need
+to disable certain warnings) align the options and keep them in
+alphabetical order if reasonable. Example:
+
+ {-# OPTIONS_GHC -fno-warn-orphans
+ -fno-warn-unused-binds
+ #-}
+
+Again if there is only one option put the closing bracket on the
+same line.
+
+Put pragmas immediately following the function they apply to.
+Example:
+
+ id :: a -> a
+ id x = x
+ {-# INLINE id #-}
+
+In the case of data type definitions you must put the pragma before
+the type it applies to. Example:
+
+ data Array e = Array
+ {-# UNPACK #-} !Int
+ !ByteArray
+
+### Hanging Lambdas
+
+You may or may not indent the code following a "hanging" lambda. Use
+your judgement. Some examples:
+
+ bar :: IO ()
+ bar = forM_ [1, 2, 3] $ \n -> do
+ putStrLn "Here comes a number!"
+ print n
+
+ foo :: IO ()
+ foo = alloca 10 $ \a ->
+ alloca 20 $ \b ->
+ cFunction a b
+
+### Export Lists
+
+Format export lists as follows:
+
+ module Data.Set
+ (
+ -- * The @Set@ type
+ Set
+
+ , empty
+ , singleton
+
+ -- * Querying
+ , member
+ )
+ where
+
+2. Imports
+----------
+
+Imports should be grouped in the following order:
+
+1. standard library imports
+2. related third party imports
+3. local application/library specific imports
+
+Put a blank line between each group of imports. The imports in each
+group should be sorted alphabetically, by module name.
+
+It is recommended to use explicit import lists or `qualified` imports
+for standard and third party libraries. This makes the code more
+robust against changes in these libraries. Exception: The Prelude.
+Use your judgement.
+
+Format the imports as follows:
+
+ import Prelude hiding
+ ( lookup
+ , null
+ )
+ import qualified Data.Map as Map
+ import Data.Maybe
+ ( fromJust
+ )
+ import GHC.Exts ()
+
+3. Comments
+-----------
+
+### Punctuation
+
+Write proper sentences; start with a capital letter and use proper
+punctuation.
+
+### Top-Level Definitions
+
+Comment every top level function (particularly exported functions),
+and provide a type signature; use Haddock syntax in the comments.
+Comment every exported data type. Some examples:
+
+ -- | Send a message on a socket. The socket must be in a connected
+ -- state. Returns the number of bytes sent. Applications are
+ -- responsible for ensuring that all data has been sent.
+ send :: Socket -- ^ Connected socket
+ -> ByteString -- ^ Data to send
+ -> IO Int -- ^ Bytes sent
+
+ -- | Bla bla bla.
+ data Person = Person
+ { age :: Int -- ^ Age
+ , name :: String -- ^ First name
+ }
+
+For functions the documentation should give enough information to
+apply the function without looking at the function's definition.
+
+### End-of-Line Comments
+
+Separate end-of-line comments from the code using 2 spaces. Align
+comments for data type definitions. Some examples:
+
+ data Parser = Parser
+ Int -- Current position
+ ByteString -- Remaining input
+
+ foo :: Int -> Int
+ foo n = salt * 32 + 9
+ where
+ salt = 453645243 -- Magic hash salt.
+
+### Links
+
+Use in-line links economically. You are encouraged to add links for
+API names. It is not necessary to add links for all API names in a
+Haddock comment. We therefore recommend adding a link to an API name
+if:
+
+* The user might actually want to click on it for more information (in
+ your judgment), and
+
+* Only for the first occurrence of each API name in the comment (don't
+ bother repeating a link)
+
+4. Naming
+---------
+
+For readability reasons, don't capitalize all letters when using an
+abbreviation. For example, write `HttpServer` instead of
+`HTTPServer`. Exception: Two letter abbreviations, e.g. `IO`.
+
+5. Misc
+-------
+
+### Warnings ###
+
+Code should be compilable with `-Wall -Werror`. There should be no
+warnings.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..6479cb1
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main = defaultMain
+
diff --git a/lambdacat.cabal b/lambdacat.cabal
new file mode 100644
index 0000000..5c9913b
--- /dev/null
+++ b/lambdacat.cabal
@@ -0,0 +1,76 @@
+Name: lambdacat
+Version: 0.1.0
+Stability: Alpha
+Synopsis: Webkit Browser
+Description: A Browser based on WebKit, concepted to be easy to use and
+ extendable
+License: BSD3
+License-File: LICENSE
+Build-Type: Simple
+Author: Andreas Baldeau, Daniel Ehlers
+Maintainer: Andreas Baldeau <andreas@baldeau.net>,
+ Daniel Ehlers <danielehlers@mindeye.net>
+Category: User Interfaces
+Tested-With: GHC == 6.12.3
+Cabal-Version: >= 1.6
+
+Extra-Source-Files:
+ README.md
+ STYLE.md
+
+Data-Files:
+ lambdacat.glade
+ lambdacat.gtkrc
+
+Executable lambdacat
+ Main-is: Main.hs
+
+ Ghc-Options:
+ -Wall
+
+Library
+ Build-Depends:
+ base >= 4 && < 5,
+ mtl == 2.*,
+ gtk == 0.12.*,
+ glade == 0.12.*,
+ webkit >= 0.12.1 && < 0.13,
+ network == 2.2.*,
+ containers == 0.3.*,
+ dyre >= 0.8.5 && < 0.9,
+ cmdargs == 0.6.*
+
+ Ghc-Options:
+ -Wall
+
+ Exposed-Modules:
+ LambdaCat
+ LambdaCat.Configure
+ LambdaCat.Supplier
+ LambdaCat.Supplier.Web
+ LambdaCat.Utils
+ LambdaCat.View
+ LambdaCat.View.Web
+ LambdaCat.Session
+ LambdaCat.History
+ LambdaCat.UI
+ LambdaCat.UI.Glade
+ -- LambdaCat.UI.Vim
+
+ Other-Modules:
+ Paths_lambdacat
+ LambdaCat.Internal.Class
+ LambdaCat.UI.Glade.PersistentTabId
+ LambdaCat.CmdArgs
+
+ Extensions:
+ DeriveDataTypeable
+ ExistentialQuantification
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ MultiParamTypeClasses
+ OverloadedStrings
+ RankNTypes
+ TypeSynonymInstances
+
diff --git a/lambdacat.glade b/lambdacat.glade
new file mode 100644
index 0000000..4b246be
--- /dev/null
+++ b/lambdacat.glade
@@ -0,0 +1,179 @@
+<?xml version="1.0"?>
+<glade-interface>
+ <!-- interface-requires gtk+ 2.16 -->
+ <!-- interface-naming-policy project-wide -->
+ <widget class="GtkWindow" id="mainWindow">
+ <child>
+ <widget class="GtkVBox" id="verticalContainer">
+ <property name="visible">True</property>
+ <property name="orientation">vertical</property>
+ <child>
+ <widget class="GtkMenuBar" id="menubar">
+ <property name="visible">True</property>
+ <child>
+ <widget class="GtkMenuItem" id="fileItem">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_File</property>
+ <property name="use_underline">True</property>
+ <child>
+ <widget class="GtkMenu" id="fileMenu">
+ <property name="visible">True</property>
+ <child>
+ <widget class="GtkImageMenuItem" id="quitItem">
+ <property name="label">gtk-quit</property>
+ <property name="visible">True</property>
+ <property name="use_underline">True</property>
+ <property name="use_stock">True</property>
+ <accelerator key="q" signal="activate" modifiers="GDK_CONTROL_MASK"/>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ <child>
+ <widget class="GtkMenuItem" id="helpItem">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_Help</property>
+ <property name="use_underline">True</property>
+ <child>
+ <widget class="GtkMenu" id="helpMenu">
+ <property name="visible">True</property>
+ <child>
+ <widget class="GtkImageMenuItem" id="infoItem">
+ <property name="label">gtk-about</property>
+ <property name="visible">True</property>
+ <property name="use_underline">True</property>
+ <property name="use_stock">True</property>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ <property name="position">0</property>
+ </packing>
+ </child>
+ <child>
+ <widget class="GtkToolbar" id="toolbar">
+ <property name="visible">True</property>
+ <property name="toolbar_style">icons</property>
+ <child>
+ <widget class="GtkToolButton" id="backButton">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">back</property>
+ <property name="use_underline">True</property>
+ <property name="stock_id">gtk-go-back</property>
+ <accelerator key="XF86Back" signal="clicked"/>
+ <accelerator key="Left" signal="clicked" modifiers="GDK_MOD1_MASK"/>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ <property name="homogeneous">True</property>
+ </packing>
+ </child>
+ <child>
+ <widget class="GtkToolButton" id="forwardButton">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">forward</property>
+ <property name="use_underline">True</property>
+ <property name="stock_id">gtk-go-forward</property>
+ <accelerator key="XF86Forward" signal="clicked"/>
+ <accelerator key="Right" signal="clicked" modifiers="GDK_MOD1_MASK"/>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ <property name="homogeneous">True</property>
+ </packing>
+ </child>
+ <child>
+ <widget class="GtkToolButton" id="reloadButton">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">reload</property>
+ <property name="use_underline">True</property>
+ <property name="stock_id">gtk-refresh</property>
+ <accelerator key="r" signal="clicked" modifiers="GDK_CONTROL_MASK"/>
+ <accelerator key="F5" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ <property name="homogeneous">True</property>
+ </packing>
+ </child>
+ <child>
+ <widget class="GtkToolButton" id="homeButton">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">home</property>
+ <property name="use_underline">True</property>
+ <property name="stock_id">gtk-home</property>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ <property name="homogeneous">True</property>
+ </packing>
+ </child>
+ <child>
+ <widget class="GtkToolButton" id="addTabButton">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">add tab</property>
+ <property name="use_underline">True</property>
+ <property name="stock_id">gtk-add</property>
+ <accelerator key="t" signal="clicked" modifiers="GDK_CONTROL_MASK"/>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ <property name="homogeneous">True</property>
+ </packing>
+ </child>
+ <child>
+ <widget class="GtkToolItem" id="addressItem">
+ <property name="visible">True</property>
+ <child>
+ <widget class="GtkEntry" id="addressEntry">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="invisible_char">&#x25CF;</property>
+ <property name="primary_icon_stock">gtk-justify-center</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ </packing>
+ </child>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ <property name="position">1</property>
+ </packing>
+ </child>
+ <child>
+ <widget class="GtkNotebook" id="viewNotebook">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="scrollable">True</property>
+ <property name="tab_border">0</property>
+ <property name="tab_hborder">0</property>
+ <property name="tab_vborder">0</property>
+ </widget>
+ <packing>
+ <property name="position">2</property>
+ </packing>
+ </child>
+ <child>
+ <widget class="GtkStatusbar" id="statusbar">
+ <property name="visible">True</property>
+ <property name="spacing">2</property>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ <property name="position">3</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+ </widget>
+</glade-interface>
diff --git a/lambdacat.gtkrc b/lambdacat.gtkrc
new file mode 100644
index 0000000..12b5daf
--- /dev/null
+++ b/lambdacat.gtkrc
@@ -0,0 +1,8 @@
+style "tab-close-button-style"
+{
+ GtkWidget::focus-padding = 0
+ GtkWidget::focus-line-width = 0
+ xthickness = 0
+ ythickness = 0
+}
+widget "*.tab-close-button" style "tab-close-button-style"