Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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...
commit 46079cf39d9370bf6b7c0e53627fc42ee9fb6dc8 1 parent 645cbb2
Daniel Ehlers authored January 10, 2011
18  LambdaCat.hs
@@ -38,8 +38,6 @@ import LambdaCat.Supplier.Web
38 38
 import LambdaCat.UI.Glade as UI
39 39
 import LambdaCat.Utils
40 40
 import LambdaCat.View.Web
41  
-    ( webView
42  
-    )
43 41
 
44 42
 -- | Lambdacat's default configuration.
45 43
 defaultConfig :: LambdaCatConf
@@ -52,14 +50,14 @@ defaultConfig = LambdaCatConf
52 50
                               ]
53 51
                             )
54 52
                           ]
55  
-    , viewList          = [ ( webView
56  
-                            , [ "about:"
57  
-                              , "http:"
58  
-                              , "https:"
59  
-                              , "file:"
60  
-                              ]
61  
-                            , []
62  
-                            )
  53
+    , viewList          = [ ViewSpec
  54
+                                webViewConf
  55
+                                [ "about:"
  56
+                                , "http:"
  57
+                                , "https:"
  58
+                                , "file:"
  59
+                                ]
  60
+                                []
63 61
                           ]
64 62
     , homeURI           = "http://www.haskell.org"
65 63
     , defaultURI        = "about:blank"
11  LambdaCat/Configure.hs
... ...
@@ -1,3 +1,4 @@
  1
+{-# LANGUAGE ExistentialQuantification #-}
1 2
 -- |
2 3
 -- Module      : LambdaCat.Configure
3 4
 -- Copyright   : Andreas Baldeau, Daniel Ehlers
@@ -14,6 +15,7 @@ module LambdaCat.Configure
14 15
     (
15 16
       -- * The configuration data structure
16 17
       LambdaCatConf (..)
  18
+    , ViewSpec (..)
17 19
     , Protocol
18 20
 
19 21
       -- * Global access
@@ -27,17 +29,21 @@ import Network.URI
27 29
 import System.IO.Unsafe
28 30
 
29 31
 import LambdaCat.Internal.Class
30  
-    ( View (..)
  32
+    ( ViewClass (..)
31 33
     , Supplier (..)
32 34
     )
33 35
 
  36
+-- | Encapsulate specification of a view.
  37
+data ViewSpec = forall view . ViewClass view
  38
+              => ViewSpec (ViewConf view) [Protocol] [String]
  39
+
34 40
 -- | Lambdacat's configuration datatype.
35 41
 data LambdaCatConf = LambdaCatConf
36 42
     { supplierList
37 43
         :: [(Supplier, [Protocol])]        -- ^ Suppliers with supported
38 44
                                            -- protocols.
39 45
     , viewList
40  
-        :: [(View, [Protocol], [String])]  -- ^ Views with supported
  46
+        :: [ViewSpec]  -- ^ Views with supported
41 47
                                            -- protocols.
42 48
     , homeURI
43 49
         :: URI                             -- ^ URI of the home page.
@@ -71,4 +77,3 @@ lambdaCatConf = unsafePerformIO $ readIORef cfgIORef
71 77
 -- function and is only for internal use.
72 78
 setLCC :: LambdaCatConf -> IO ()
73 79
 setLCC = writeIORef cfgIORef
74  
-
9  LambdaCat/Internal/Class.hs
... ...
@@ -1,6 +1,7 @@
1 1
 {-# LANGUAGE ExistentialQuantification
2 2
            , FunctionalDependencies
3 3
            , MultiParamTypeClasses
  4
+           , TypeFamilies
4 5
   #-}
5 6
 
6 7
 -- |
@@ -77,8 +78,11 @@ class UIClass ui meta | ui -> meta where
77 78
 
78 79
 -- | Class of viewers, that can render and handle content behind an 'URI'.
79 80
 class ViewClass view where
  81
+    -- | Configuration datatype.
  82
+    data ViewConf view :: *
  83
+
80 84
     -- | Creates a new view.
81  
-    new :: IO view
  85
+    new :: ViewConf view -> IO view
82 86
 
83 87
     -- | Ask the view to embed its widget by calling the given function.
84 88
     -- Also give the callback function to the widget.
@@ -116,7 +120,8 @@ class SupplierClass supplier where
116 120
 data View = forall view . ViewClass view => View view
117 121
 
118 122
 instance ViewClass View where
119  
-    new = return (error "Can't create existential quantificated datatype")
  123
+    data ViewConf View
  124
+    new _ = return (error "Can't create existential quantificated datatype")
120 125
 
121 126
     embed              (View view) = embed view
122 127
     destroy            (View view) = destroy view
5  LambdaCat/Supplier/Web.hs
@@ -43,10 +43,11 @@ instance SupplierClass WebSupplier where
43 43
         let viewers    = viewList lambdaCatConf
44 44
             protocol   = uriScheme uri
45 45
             mViewConst =
46  
-                find (\(_vc, ps, _) -> isJust $ find (== protocol) ps) viewers
  46
+               find (\(ViewSpec _ ps _) -> isJust $
  47
+                    find (== protocol) ps) viewers
47 48
 
48 49
         in  case mViewConst of
49  
-                Just (vc, _, _) -> do
  50
+                Just (ViewSpec vc _ _) -> do
50 51
                     view <- createView vc
51 52
 
52 53
                     _status <- load view uri
15  LambdaCat/View.hs
@@ -26,13 +26,8 @@ import LambdaCat.Internal.Class
26 26
 
27 27
 -- | Create a view.
28 28
 --
29  
--- Its type is specified by the first parameter. This should be a view of the
30  
--- same type or one of the constants exported in the corresponding
31  
--- @LambdaCat.View.*@ modules.
32  
-createView :: View -> IO View
33  
-createView (View v) = return . View =<< createView_ v
34  
-
35  
--- | Helper function that assures the view of the correct type is created.
36  
-createView_ :: (ViewClass view) => view -> IO view
37  
-createView_ _ = new
38  
-
  29
+-- Its type its specified by the configuration supplied.
  30
+createView :: ViewClass view => ViewConf view -> IO View
  31
+createView conf = do
  32
+    view <- new conf
  33
+    return $ View view
17  LambdaCat/View/Web.hs
... ...
@@ -1,6 +1,7 @@
1 1
 {-# LANGUAGE FlexibleContexts
2 2
            , FlexibleInstances
3 3
            , MultiParamTypeClasses
  4
+           , TypeFamilies
4 5
   #-}
5 6
 
6 7
 -- |
@@ -17,10 +18,7 @@ module LambdaCat.View.Web
17 18
     (
18 19
       -- * The View
19 20
       WebView
20  
-    , webView
21  
-
22  
-      -- * Module exports
23  
-    , module LambdaCat.View
  21
+    , webViewConf
24 22
     )
25 23
 where
26 24
 
@@ -48,18 +46,19 @@ import LambdaCat.UI
48 46
 import LambdaCat.Utils
49 47
 import LambdaCat.View
50 48
 
  49
+-- |  Default WebView configuration.
  50
+webViewConf :: ViewConf WebView
  51
+webViewConf = WebViewConf
  52
+
51 53
 -- | Data type representing the view. Do not confuse this with WebKit's
52 54
 -- WebView!
53 55
 newtype WebView = WebView
54 56
     { webViewWidget :: WV.WebView  -- ^ The widget for the view.
55 57
     }
56 58
 
57  
--- | Type specification constant for use with 'createView'.
58  
-webView :: View
59  
-webView = View (WebView undefined)
60  
-
61 59
 instance ViewClass WebView where
62  
-    new = do
  60
+    data ViewConf WebView = WebViewConf
  61
+    new _ = do
63 62
         widget <- WV.webViewNew
64 63
         return WebView { webViewWidget = widget }
65 64
 

0 notes on commit 46079cf

Please sign in to comment.
Something went wrong with that request. Please try again.