Permalink
Browse files

configuration: extend view class with type family configuration datat…

…ype.

This way we also get rid of the undefineds in the views.
  • Loading branch information...
sargon committed Jan 10, 2011
1 parent 645cbb2 commit 46079cf39d9370bf6b7c0e53627fc42ee9fb6dc8
Showing with 39 additions and 36 deletions.
  1. +8 −10 LambdaCat.hs
  2. +8 −3 LambdaCat/Configure.hs
  3. +7 −2 LambdaCat/Internal/Class.hs
  4. +3 −2 LambdaCat/Supplier/Web.hs
  5. +5 −10 LambdaCat/View.hs
  6. +8 −9 LambdaCat/View/Web.hs
View
@@ -38,8 +38,6 @@ import LambdaCat.Supplier.Web
import LambdaCat.UI.Glade as UI
import LambdaCat.Utils
import LambdaCat.View.Web
- ( webView
- )
-- | Lambdacat's default configuration.
defaultConfig :: LambdaCatConf
@@ -52,14 +50,14 @@ defaultConfig = LambdaCatConf
]
)
]
- , viewList = [ ( webView
- , [ "about:"
- , "http:"
- , "https:"
- , "file:"
- ]
- , []
- )
+ , viewList = [ ViewSpec
+ webViewConf
+ [ "about:"
+ , "http:"
+ , "https:"
+ , "file:"
+ ]
+ []
]
, homeURI = "http://www.haskell.org"
, defaultURI = "about:blank"
View
@@ -1,3 +1,4 @@
+{-# LANGUAGE ExistentialQuantification #-}
-- |
-- Module : LambdaCat.Configure
-- Copyright : Andreas Baldeau, Daniel Ehlers
@@ -14,6 +15,7 @@ module LambdaCat.Configure
(
-- * The configuration data structure
LambdaCatConf (..)
+ , ViewSpec (..)
, Protocol
-- * Global access
@@ -27,17 +29,21 @@ import Network.URI
import System.IO.Unsafe
import LambdaCat.Internal.Class
- ( View (..)
+ ( ViewClass (..)
, Supplier (..)
)
+-- | Encapsulate specification of a view.
+data ViewSpec = forall view . ViewClass view
+ => ViewSpec (ViewConf view) [Protocol] [String]
+
-- | Lambdacat's configuration datatype.
data LambdaCatConf = LambdaCatConf
{ supplierList
:: [(Supplier, [Protocol])] -- ^ Suppliers with supported
-- protocols.
, viewList
- :: [(View, [Protocol], [String])] -- ^ Views with supported
+ :: [ViewSpec] -- ^ Views with supported
-- protocols.
, homeURI
:: URI -- ^ URI of the home page.
@@ -71,4 +77,3 @@ lambdaCatConf = unsafePerformIO $ readIORef cfgIORef
-- function and is only for internal use.
setLCC :: LambdaCatConf -> IO ()
setLCC = writeIORef cfgIORef
-
@@ -1,6 +1,7 @@
{-# LANGUAGE ExistentialQuantification
, FunctionalDependencies
, MultiParamTypeClasses
+ , TypeFamilies
#-}
-- |
@@ -77,8 +78,11 @@ class UIClass ui meta | ui -> meta where
-- | Class of viewers, that can render and handle content behind an 'URI'.
class ViewClass view where
+ -- | Configuration datatype.
+ data ViewConf view :: *
+
-- | Creates a new view.
- new :: IO view
+ new :: ViewConf view -> IO view
-- | Ask the view to embed its widget by calling the given function.
-- Also give the callback function to the widget.
@@ -116,7 +120,8 @@ class SupplierClass supplier where
data View = forall view . ViewClass view => View view
instance ViewClass View where
- new = return (error "Can't create existential quantificated datatype")
+ data ViewConf View
+ new _ = return (error "Can't create existential quantificated datatype")
embed (View view) = embed view
destroy (View view) = destroy view
@@ -43,10 +43,11 @@ instance SupplierClass WebSupplier where
let viewers = viewList lambdaCatConf
protocol = uriScheme uri
mViewConst =
- find (\(_vc, ps, _) -> isJust $ find (== protocol) ps) viewers
+ find (\(ViewSpec _ ps _) -> isJust $
+ find (== protocol) ps) viewers
in case mViewConst of
- Just (vc, _, _) -> do
+ Just (ViewSpec vc _ _) -> do
view <- createView vc
_status <- load view uri
View
@@ -26,13 +26,8 @@ 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
-
+-- Its type its specified by the configuration supplied.
+createView :: ViewClass view => ViewConf view -> IO View
+createView conf = do
+ view <- new conf
+ return $ View view
View
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts
, FlexibleInstances
, MultiParamTypeClasses
+ , TypeFamilies
#-}
-- |
@@ -17,10 +18,7 @@ module LambdaCat.View.Web
(
-- * The View
WebView
- , webView
-
- -- * Module exports
- , module LambdaCat.View
+ , webViewConf
)
where
@@ -48,18 +46,19 @@ import LambdaCat.UI
import LambdaCat.Utils
import LambdaCat.View
+-- | Default WebView configuration.
+webViewConf :: ViewConf WebView
+webViewConf = WebViewConf
+
-- | 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
+ data ViewConf WebView = WebViewConf
+ new _ = do
widget <- WV.webViewNew
return WebView { webViewWidget = widget }

0 comments on commit 46079cf

Please sign in to comment.