lambdacat (empty) → 0.1.0
raw patch · 22 files changed
+2488/−0 lines, 22 filesdep +basedep +cmdargsdep +containerssetup-changed
Dependencies added: base, cmdargs, containers, dyre, glade, gtk, mtl, network, webkit
Files
- LICENSE +32/−0
- LambdaCat.hs +149/−0
- LambdaCat/CmdArgs.hs +99/−0
- LambdaCat/Configure.hs +74/−0
- LambdaCat/History.hs +160/−0
- LambdaCat/Internal/Class.hs +136/−0
- LambdaCat/Session.hs +159/−0
- LambdaCat/Supplier.hs +63/−0
- LambdaCat/Supplier/Web.hs +57/−0
- LambdaCat/UI.hs +26/−0
- LambdaCat/UI/Glade.hs +537/−0
- LambdaCat/UI/Glade/PersistentTabId.hs +99/−0
- LambdaCat/Utils.hs +80/−0
- LambdaCat/View.hs +38/−0
- LambdaCat/View/Web.hs +143/−0
- Main.hs +21/−0
- README.md +73/−0
- STYLE.md +275/−0
- Setup.hs +4/−0
- lambdacat.cabal +76/−0
- lambdacat.glade +179/−0
- lambdacat.gtkrc +8/−0
+ LICENSE view
@@ -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.+
+ LambdaCat.hs view
@@ -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"] }+
+ LambdaCat/CmdArgs.hs view
@@ -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+
+ LambdaCat/Configure.hs view
@@ -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+
+ LambdaCat/History.hs view
@@ -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)+
+ LambdaCat/Internal/Class.hs view
@@ -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+
+ LambdaCat/Session.hs view
@@ -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)+
+ LambdaCat/Supplier.hs view
@@ -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+
+ LambdaCat/Supplier/Web.hs view
@@ -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+
+ LambdaCat/UI.hs view
@@ -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 (..)+ )+
+ LambdaCat/UI/Glade.hs view
@@ -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 ()+
+ LambdaCat/UI/Glade/PersistentTabId.hs view
@@ -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+
+ LambdaCat/Utils.hs view
@@ -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+ ++ ")"+
+ LambdaCat/View.hs view
@@ -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+
+ LambdaCat/View/Web.hs view
@@ -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)+
+ Main.hs view
@@ -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
+ README.md view
@@ -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.+
+ STYLE.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main = defaultMain+
+ lambdacat.cabal view
@@ -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+
+ lambdacat.glade view
@@ -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">●</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>
+ lambdacat.gtkrc view
@@ -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"