diff --git a/LICENSE b/LICENSE new file mode 100644 --- /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 --- /dev/null +++ b/LambdaCat.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : LambdaCat +-- Copyright : Andreas Baldeau, Daniel Ehlers +-- License : BSD3 +-- Maintainer : Andreas Baldeau , +-- Daniel Ehlers +-- 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 --- /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 , +-- Daniel Ehlers +-- 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 --- /dev/null +++ b/LambdaCat/Configure.hs @@ -0,0 +1,74 @@ +-- | +-- Module : LambdaCat.Configure +-- Copyright : Andreas Baldeau, Daniel Ehlers +-- License : BSD3 +-- Maintainer : Andreas Baldeau , +-- Daniel Ehlers +-- 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 ":" +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 --- /dev/null +++ b/LambdaCat/History.hs @@ -0,0 +1,160 @@ +-- | +-- Module : LambdaCat.History +-- Copyright : Andreas Baldeau, Daniel Ehlers +-- License : BSD3 +-- Maintainer : Andreas Baldeau , +-- Daniel Ehlers +-- 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 --- /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 , +-- Daniel Ehlers +-- 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 --- /dev/null +++ b/LambdaCat/Session.hs @@ -0,0 +1,159 @@ +-- | +-- Module : LambdaCat.Session +-- Copyright : Andreas Baldeau, Daniel Ehlers +-- License : BSD3 +-- Maintainer : Andreas Baldeau , +-- Daniel Ehlers +-- 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 --- /dev/null +++ b/LambdaCat/Supplier.hs @@ -0,0 +1,63 @@ +-- | +-- Module : LambdaCat.Supplier +-- Copyright : Andreas Baldeau, Daniel Ehlers +-- License : BSD3 +-- Maintainer : Andreas Baldeau , +-- Daniel Ehlers +-- 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 --- /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 , +-- Daniel Ehlers +-- 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 --- /dev/null +++ b/LambdaCat/UI.hs @@ -0,0 +1,26 @@ +-- | +-- Module : LambdaCat.UI +-- Copyright : Andreas Baldeau, Daniel Ehlers +-- License : BSD3 +-- Maintainer : Andreas Baldeau , +-- Daniel Ehlers +-- 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 --- /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 , +-- Daniel Ehlers +-- 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 --- /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 , +-- Daniel Ehlers +-- 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 --- /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 , +-- Daniel Ehlers +-- 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 --- /dev/null +++ b/LambdaCat/View.hs @@ -0,0 +1,38 @@ +-- | +-- Module : LambdaCat.View +-- Copyright : Andreas Baldeau, Daniel Ehlers +-- License : BSD3 +-- Maintainer : Andreas Baldeau , +-- Daniel Ehlers +-- 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 --- /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 , +-- Daniel Ehlers +-- 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 --- /dev/null +++ b/Main.hs @@ -0,0 +1,21 @@ +-- | +-- Module : Main +-- Copyright : Andreas Baldeau, Daniel Ehlers +-- License : BSD3 +-- Maintainer : Andreas Baldeau , +-- Daniel Ehlers +-- 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 --- /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 --- /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 +. + +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 --- /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 --- /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 , + Daniel Ehlers +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 --- /dev/null +++ b/lambdacat.glade @@ -0,0 +1,179 @@ + + + + + + + + True + vertical + + + True + + + True + _File + True + + + True + + + gtk-quit + True + True + True + + + + + + + + + + True + _Help + True + + + True + + + gtk-about + True + True + True + + + + + + + + + False + 0 + + + + + True + icons + + + True + back + True + gtk-go-back + + + + + False + True + + + + + True + forward + True + gtk-go-forward + + + + + False + True + + + + + True + reload + True + gtk-refresh + + + + + False + True + + + + + True + home + True + gtk-home + + + False + True + + + + + True + add tab + True + gtk-add + + + + False + True + + + + + True + + + True + True + ● + gtk-justify-center + + + + + False + + + + + False + 1 + + + + + True + True + True + 0 + 0 + 0 + + + 2 + + + + + True + 2 + + + False + 3 + + + + + + diff --git a/lambdacat.gtkrc b/lambdacat.gtkrc new file mode 100644 --- /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"