keera-hails-mvc-solutions-gtk (empty) → 0.0.3.3
raw patch · 13 files changed
+589/−0 lines, 13 filesdep +HTTPdep +MissingKdep +basesetup-changed
Dependencies added: HTTP, MissingK, base, gtk, hslogger, keera-hails-mvc-environment-gtk, keera-hails-mvc-model-protectedmodel, keera-hails-mvc-view, keera-hails-mvc-view-gtk, keera-hails-reactivevalues, mtl, network, network-uri, template-haskell
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- keera-hails-mvc-solutions-gtk.cabal +82/−0
- src/Hails/Graphics/UI/Gtk/Simplify/AboutDialog.hs +46/−0
- src/Hails/Graphics/UI/Gtk/Simplify/Logger.hs +97/−0
- src/Hails/Graphics/UI/Gtk/Simplify/NameAndVersionTitleBar.hs +36/−0
- src/Hails/Graphics/UI/Gtk/Simplify/ProgramMainWindow.hs +26/−0
- src/Hails/Graphics/UI/Gtk/Simplify/RootLogger.hs +93/−0
- src/Hails/Graphics/UI/Gtk/Simplify/VersionNumberTitleBar.hs +64/−0
- src/Hails/MVC/Model/ProtectedModel/LoggedModel.hs +27/−0
- src/Hails/MVC/Model/ProtectedModel/NamedModel.hs +26/−0
- src/Hails/MVC/Model/ProtectedModel/UpdatableModel.hs +32/−0
- src/Hails/MVC/Model/ProtectedModel/VersionedModel.hs +28/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Ivan Perez++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Ivan Perez nor the names of other+ 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 COPYRIGHT+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ keera-hails-mvc-solutions-gtk.cabal view
@@ -0,0 +1,82 @@+-- hails.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: keera-hails-mvc-solutions-gtk++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.0.3.3++-- A short (one-line) description of the package.+Synopsis: Haskell on Gtk rails - Common solutions to recurrent problems in Gtk applications++-- A longer description of the package.+-- Description: ++-- URL for the project homepage or repository.+Homepage: http://www.keera.es/blog/community/++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Ivan Perez++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: ivan.perez@keera.es++-- A copyright notice.+-- Copyright: ++Category: Development++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.2+++Library+ hs-source-dirs: src/+ + ghc-options: -Wall -fno-warn-unused-do-bind -O2++ -- Modules exported by the library.+ Exposed-modules: Hails.MVC.Model.ProtectedModel.VersionedModel+ , Hails.MVC.Model.ProtectedModel.LoggedModel+ , Hails.MVC.Model.ProtectedModel.NamedModel+ , Hails.MVC.Model.ProtectedModel.UpdatableModel+ , Hails.Graphics.UI.Gtk.Simplify.VersionNumberTitleBar+ , Hails.Graphics.UI.Gtk.Simplify.NameAndVersionTitleBar+ , Hails.Graphics.UI.Gtk.Simplify.ProgramMainWindow+ , Hails.Graphics.UI.Gtk.Simplify.AboutDialog+ , Hails.Graphics.UI.Gtk.Simplify.Logger+ , Hails.Graphics.UI.Gtk.Simplify.RootLogger+ -- , Hails.Graphics.UI.Gtk.Simplify.UpdateCheck+ + -- Packages needed in order to build this package.+ Build-depends: base >= 4 && < 5+ , template-haskell+ , gtk+ , hslogger+ , HTTP+ , network+ , network-uri+ , mtl++ , keera-hails-mvc-environment-gtk+ , keera-hails-mvc-view+ , keera-hails-mvc-view-gtk+ , keera-hails-mvc-model-protectedmodel+ , keera-hails-reactivevalues+ , MissingK
+ src/Hails/Graphics/UI/Gtk/Simplify/AboutDialog.hs view
@@ -0,0 +1,46 @@+-- | Condition: The page of the main notebook visible at each moment+-- is the that corresponds to the selected branch in the category+-- tree.++module Hails.Graphics.UI.Gtk.Simplify.AboutDialog+ (installHandlers)+ where++import Control.Arrow+import Control.Monad+import Control.Monad.Reader (liftIO)+import Data.ExtraVersion+import Graphics.UI.Gtk+import Hails.MVC.View.GtkView+import Hails.MVC.View+-- import Graphics.UI.Gtk.GenericView+import Hails.MVC.GenericCombinedEnvironment+import Hails.MVC.Model.ReactiveModel (Event)+import Hails.MVC.Model.ProtectedModel.VersionedModel+import Hails.MVC.Model.ProtectedModel.NamedModel++installHandlers :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b,+ Event c, MenuItemClass d)+ => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) d)+ -> (ViewElementAccessorIO (GtkView a) AboutDialog)+ -> IO ()+installHandlers cenv mF dF = void $ do+ let vw = view cenv+ mn <- mF vw+ mn `on` menuItemActivate $ liftIO (onViewAsync vw (condition cenv dF))++condition :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b, Event c)+ => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) AboutDialog)+ -> IO ()+condition cenv dF = do+ let (vw, pm) = (view &&& model) cenv+ dg <- dF vw+ vn <- fmap versionToString $ getVersion pm+ pr <- getName pm+ set dg [ aboutDialogVersion := vn ]+ set dg [ aboutDialogProgramName := pr ]+ set dg [ aboutDialogName := pr ]+ _ <- dialogRun dg+ widgetHide dg
+ src/Hails/Graphics/UI/Gtk/Simplify/Logger.hs view
@@ -0,0 +1,97 @@+module Hails.Graphics.UI.Gtk.Simplify.Logger+ (installHandlers, installHandlersUnique)+ where++import Control.Arrow+import Control.Monad+import Hails.MVC.Model.ReactiveModel (Event)+import Control.Monad.Reader (liftIO)+import Data.Maybe+import Hails.MVC.GenericCombinedEnvironment+import Graphics.UI.Gtk+-- import Graphics.UI.Gtk.GenericView+import Hails.MVC.View.GtkView+import Hails.MVC.View+import System.Log as Log+import System.Log.Formatter+import System.Log.Handler+import System.Log.Logger++import Hails.MVC.Model.ProtectedModel.LoggedModel++installHandlersUnique :: (GtkGUI a, LoggedBasicModel b,+ Event c, MenuItemClass d)+ => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) d)+ -> IO ()+installHandlersUnique cenv mF = void $ do+ rl <- getRootLogger+ let lhs = [] :: [ ListStoreLogHandler ]+ let rl' = setHandlers lhs rl+ saveGlobalLogger rl'+ installHandlers cenv mF++installHandlers :: (GtkGUI a, LoggedBasicModel b,+ Event c, MenuItemClass d)+ => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) d)+ -> IO ()+installHandlers cenv mF = void $ do+ let (vw, pm) = (view &&& model) cenv++ lsLogHandler <- listStoreLogHandlerNew+ log <- getLog pm+ -- let nl = setHandlers [lsLogHandler] log+ let nl = addHandler lsLogHandler log+ saveGlobalLogger nl++ w <- createLogWindow $ lslhStore lsLogHandler+ mn <- mF vw+ mn `on` menuItemActivate $ liftIO (widgetShowAll w)++createLogWindow :: ListStore String -> IO Window+createLogWindow ls = do+ w <- windowNew+ set w [ windowTitle := "Log" ]+ windowSetDefaultSize w 400 300+ s <- scrolledWindowNew Nothing Nothing+ containerAdd w s+ tv <- treeViewNewWithModel ls+ treeViewSetHeadersVisible tv False+ addTextColumn tv ls Just+ containerAdd s tv+ w `on` deleteEvent $ liftIO $ widgetHide w >> return True+ return w -- , ls)++addTextColumn :: (TreeModelClass (model row), TypedTreeModelClass model)+ => TreeView -> model row -> (row -> Maybe String) -> IO()+addTextColumn tv st f = do+ col <- treeViewColumnNew+ renderer <- cellRendererTextNew+ cellLayoutPackStart col renderer True+ cellLayoutSetAttributes col renderer st $ map (cellText :=).maybeToList.f+ _ <- treeViewAppendColumn tv col+ return ()++data ListStoreLogHandler = ListStoreLogHandler+ { lslhStore :: ListStore String+ , lslhLevel :: Log.Priority+ , lslhFormatter :: LogFormatter ListStoreLogHandler+ }++instance LogHandler ListStoreLogHandler where+ getLevel = lslhLevel+ setLevel x l = x { lslhLevel = l }+ getFormatter = lslhFormatter+ setFormatter x f = x { lslhFormatter = f }+ emit x l _ = listStoreAppend (lslhStore x) (snd l) >> return ()+ close _ = return ()++listStoreLogHandlerNew :: IO ListStoreLogHandler+listStoreLogHandlerNew = do+ ls <- listStoreNew []+ return ListStoreLogHandler+ { lslhStore = ls+ , lslhLevel = DEBUG+ , lslhFormatter = nullFormatter+ }
+ src/Hails/Graphics/UI/Gtk/Simplify/NameAndVersionTitleBar.hs view
@@ -0,0 +1,36 @@+module Hails.Graphics.UI.Gtk.Simplify.NameAndVersionTitleBar where++import Control.Arrow+import Control.Monad+import Control.Monad.Reader (liftIO)+import Data.ExtraVersion+-- import Graphics.UI.Gtk.GenericView+import Graphics.UI.Gtk+import Hails.MVC.View+import Hails.MVC.View.GtkView+import Hails.MVC.GenericCombinedEnvironment+import Hails.MVC.Model.ReactiveModel (Event)+import Hails.MVC.Model.ProtectedModel.VersionedModel+import Hails.MVC.Model.ProtectedModel.NamedModel++installHandlers :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b, Event c)+ => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) Window)+ -> IO ()+installHandlers cenv wF = void $ do+ let vw = view cenv+ w <- wF vw+ w `on` mapEvent $ liftIO (onViewAsync vw (condition cenv wF)) >> return False++condition :: (GtkGUI a, VersionedBasicModel b, NamedBasicModel b, Event c)+ => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) Window)+ -> IO ()+condition cenv wF = do+ let (vw, pm) = (view &&& model) cenv+ w <- wF vw+ pn <- getName pm+ vn <- fmap versionToString $ getVersion pm+ t <- windowGetTitle w+ let titleMust = pn ++ " " ++ vn+ when (t /= titleMust) $ windowSetTitle w titleMust
+ src/Hails/Graphics/UI/Gtk/Simplify/ProgramMainWindow.hs view
@@ -0,0 +1,26 @@+module Hails.Graphics.UI.Gtk.Simplify.ProgramMainWindow where++import Control.Monad.Reader (liftIO)+import Hails.MVC.Model.ReactiveModel (Event)+import Hails.MVC.GenericCombinedEnvironment+import Graphics.UI.Gtk+import Hails.MVC.View+import Hails.MVC.View.GtkView++installHandlers :: (GtkGUI a, Event c)+ => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) Window)+ -> IO ()+installHandlers cenv wF = do+ let vw = view cenv+ w <- wF vw+ _ <- w `on` deleteEvent $ liftIO $ condition cenv+ return ()++condition :: (GtkGUI a, Event c)+ => CEnv a b c+ -> IO Bool+condition cenv = do+ let vw = view cenv+ onViewAsync vw $ destroyView vw+ return False
+ src/Hails/Graphics/UI/Gtk/Simplify/RootLogger.hs view
@@ -0,0 +1,93 @@+module Hails.Graphics.UI.Gtk.Simplify.RootLogger+ (installHandlers, installHandlersUnique)+ where++import Control.Monad.Reader (liftIO)+import Data.Maybe+-- import GenericCombinedEnvironment+import Graphics.UI.Gtk+-- import Graphics.UI.Gtk.GenericView+import Hails.MVC.GenericCombinedEnvironment+import Hails.MVC.View.GtkView+import Hails.MVC.View+import Hails.MVC.Model.ReactiveModel (Event)+import System.Log as Log+import System.Log.Formatter+import System.Log.Handler+import System.Log.Logger++installHandlersUnique :: (GtkGUI a,+ Event c, MenuItemClass d)+ => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) d)+ -> IO ()+installHandlersUnique cenv mF = fmap (const ()) $ do+ rl <- getRootLogger+ let lhs = [] :: [ListStoreLogHandler]+ let rl' = setHandlers lhs rl+ saveGlobalLogger rl'+ installHandlers cenv mF++installHandlers :: (GtkGUI a,+ Event c, MenuItemClass d)+ => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) d)+ -> IO ()+installHandlers cenv mF = fmap (const ()) $ do+ let vw = view cenv++ lsLogHandler <- listStoreLogHandlerNew+ rl <- getRootLogger+ let nl = addHandler lsLogHandler rl+ saveGlobalLogger nl++ w <- createLogWindow $ lslhStore lsLogHandler+ mn <- mF vw+ mn `on` menuItemActivate $ liftIO (widgetShowAll w)++createLogWindow :: ListStore String -> IO Window+createLogWindow ls = do+ w <- windowNew+ set w [ windowTitle := "Log" ]+ windowSetDefaultSize w 400 300+ s <- scrolledWindowNew Nothing Nothing+ containerAdd w s+ tv <- treeViewNewWithModel ls+ treeViewSetHeadersVisible tv False+ addTextColumn tv ls Just+ containerAdd s tv+ w `on` deleteEvent $ liftIO $ widgetHide w >> return True+ return w -- , ls)++addTextColumn :: (TreeModelClass (model row), TypedTreeModelClass model)+ => TreeView -> model row -> (row -> Maybe String) -> IO()+addTextColumn tv st f = do+ col <- treeViewColumnNew+ renderer <- cellRendererTextNew+ cellLayoutPackStart col renderer True+ cellLayoutSetAttributes col renderer st $ map (cellText :=).maybeToList.f+ _ <- treeViewAppendColumn tv col+ return ()++data ListStoreLogHandler = ListStoreLogHandler+ { lslhStore :: ListStore String+ , lslhLevel :: Log.Priority+ , lslhFormatter :: LogFormatter ListStoreLogHandler+ }++instance LogHandler ListStoreLogHandler where+ getLevel = lslhLevel+ setLevel x l = x { lslhLevel = l }+ getFormatter = lslhFormatter+ setFormatter x f = x { lslhFormatter = f }+ emit x l _ = listStoreAppend (lslhStore x) (snd l) >> return ()+ close _ = return ()++listStoreLogHandlerNew :: IO ListStoreLogHandler+listStoreLogHandlerNew = do+ ls <- listStoreNew []+ return ListStoreLogHandler+ { lslhStore = ls+ , lslhLevel = DEBUG+ , lslhFormatter = nullFormatter+ }
+ src/Hails/Graphics/UI/Gtk/Simplify/VersionNumberTitleBar.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-}+module Hails.Graphics.UI.Gtk.Simplify.VersionNumberTitleBar where++-- External imports+import Control.Arrow+import Control.Monad+import Control.Monad.Reader (liftIO)+import Data.ExtraVersion+import Graphics.UI.Gtk+-- import Graphics.UI.Gtk.GenericView ()+import Hails.MVC.View+import Hails.MVC.View.GtkView+import Hails.MVC.GenericCombinedEnvironment+import Hails.MVC.Model.ReactiveModel (Event)+import Hails.MVC.Model.ProtectedModel++-- Internal imports+import Data.ReactiveValue+import Hails.MVC.Model.ProtectedModel.VersionedModel++installHandlers :: (GtkGUI a, VersionedBasicModel b, Event c) => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) Window)+ -> IO ()+installHandlers cenv wF = void $ do+ let (vw, pm) = (view &&& model) cenv+ w <- wF vw+ w `on` mapEvent $ liftIO (condition cenv wF) >> return False++ -- -- let l f = do _ <- w `on` mapEvent $ liftIO f >> return False+ -- -- return ()+ -- let -- v1 :: (GtkGUI a, VersionedBasicModel b) => TypedReactiveValue (ProtectedModelVersion a b) String+ -- v1 = TypedReactiveValue (ProtectedModelVersion pm w) (undefined :: String)+ -- -- v2 :: TypedReactiveValue Window String+ -- v2 = TypedReactiveValue w (undefined :: String)+ -- v1 =:> v2++-- type WindowTitle = TypedReactiveValue Window String+-- +-- instance ReactiveValueWrite Window String where+-- reactiveValueWrite w v = do+-- t <- windowGetTitle w+-- when (t /= v) $ windowSetTitle w v+-- +-- data ProtectedModelVersion a b =+-- ProtectedModelVersion (ProtectedModel a b) Window+-- +-- type ProgramVersion a b = TypedReactiveValue (ProtectedModelVersion a b) String+-- +-- instance (VersionedBasicModel b, Event c) => ReactiveValueRead (ProtectedModelVersion b c) String where+-- reactiveValueOnCanRead (ProtectedModelVersion _ w) _ op = do+-- _ <- do w `on` mapEvent $ liftIO op >> return False+-- return ()+-- reactiveValueRead (ProtectedModelVersion pm _) = do+-- fmap versionToString $ getVersion pm++condition :: (GtkGUI a, VersionedBasicModel b, Event c) => CEnv a b c+ -> (ViewElementAccessorIO (GtkView a) Window)+ -> IO ()+condition cenv wF = do+ let (vw, pm) = (view &&& model) cenv+ w <- wF vw+ vn <- fmap versionToString $ getVersion pm+ t <- windowGetTitle w+ when (t /= vn) $ windowSetTitle w vn
+ src/Hails/MVC/Model/ProtectedModel/LoggedModel.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleInstances #-}+module Hails.MVC.Model.ProtectedModel.LoggedModel where++import Hails.MVC.Model.ProtectedModel+import Hails.MVC.Model.ReactiveModel+import Control.Monad+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.DeriveField+import System.Log.Logger++class LoggedBasicModel a where+ getBMLogName :: a -> String++class LoggedProtectedModel a where+ getLogName :: a -> IO String+ getLog :: a -> IO Logger++instance (Event b, LoggedBasicModel a) => LoggedProtectedModel (ProtectedModel a b) where++ getLogName = (`onReactiveModel` getRMLogName)+ where getRMLogName = getBMLogName . basicModel++ getLog = getLogName >=> getLogger++deriveLogged :: Name -> Q [Dec]+deriveLogged =+ deriveField "LoggedBasicModel" "getBMLogName" "logName"
+ src/Hails/MVC/Model/ProtectedModel/NamedModel.hs view
@@ -0,0 +1,26 @@+module Hails.MVC.Model.ProtectedModel.NamedModel where++import Hails.MVC.Model.ProtectedModel+import Hails.MVC.Model.ReactiveModel+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.DeriveField++class NamedBasicModel a where+ getBMName :: a -> String++class NamedProtectedModel a where+ getName :: a -> IO String++-- class NamedReactiveModel a where+-- getRMName :: a -> String+-- +-- instance NamedBasicModel a => NamedReactiveModel (ReactiveModel a) where+-- getRMName = getBMName . basicModel++instance (Event b, NamedBasicModel a) => NamedProtectedModel (ProtectedModel a b) where+ getName = (`onReactiveModel` getRMName)+ where getRMName = getBMName . basicModel++deriveNamed :: Name -> Q [Dec]+deriveNamed =+ deriveField "NamedBasicModel" "getBMName" "name"
+ src/Hails/MVC/Model/ProtectedModel/UpdatableModel.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE PackageImports, FlexibleInstances #-}++module Hails.MVC.Model.ProtectedModel.UpdatableModel where++import Hails.MVC.Model.ReactiveModel+import Hails.MVC.Model.ProtectedModel++import Data.ExtraVersion++import Hails.MVC.Model.ProtectedModel.VersionedModel++class VersionedBasicModel a => UpdatableBasicModel a where+ getBMUpdateURI :: a -> String+ getBMMaxVersionAvail :: a -> Maybe Version+ setBMMaxVersionAvail :: a -> Version -> a++class VersionedProtectedModel a => UpdatableProtectedModel a where+ getUpdateURI :: a -> IO String+ getMaxVersionAvail :: a -> IO (Maybe Version)+ setMaxVersionAvail :: a -> Version -> IO ()+ +class Event a => UpdateNotifiableEvent a where+ updateNotificationEvent :: a++instance (UpdatableBasicModel a, UpdateNotifiableEvent b) => UpdatableProtectedModel (ProtectedModel a b) where+ getUpdateURI = (`onReactiveModel` getRMUpdateURI)+ where getRMUpdateURI = getBMUpdateURI . basicModel+ getMaxVersionAvail = (`onReactiveModel` getRMMaxVersionAvail)+ where getRMMaxVersionAvail = getBMMaxVersionAvail . basicModel+ setMaxVersionAvail pm v = pm `applyToReactiveModel` setRMMaxVersionAvail+ where setRMMaxVersionAvail rm = let rm' = rm `onBasicModel` (`setBMMaxVersionAvail` v)+ in triggerEvent rm' updateNotificationEvent
+ src/Hails/MVC/Model/ProtectedModel/VersionedModel.hs view
@@ -0,0 +1,28 @@+module Hails.MVC.Model.ProtectedModel.VersionedModel where++import Data.ExtraVersion++import Hails.MVC.Model.ProtectedModel+import Hails.MVC.Model.ReactiveModel+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.DeriveField++class VersionedBasicModel a where+ getBMVersion :: a -> Version++class VersionedProtectedModel a where+ getVersion :: a -> IO Version++-- class VersionedReactiveModel a where+-- getRMVersion :: a -> String+-- +-- instance VersionedBasicModel a => VersionedReactiveModel (ReactiveModel a) where+-- getRMVersion = getBMVersion . basicModel++instance (Event b, VersionedBasicModel a) => VersionedProtectedModel (ProtectedModel a b) where+ getVersion = (`onReactiveModel` getRMVersion)+ where getRMVersion = getBMVersion . basicModel++deriveVersioned :: Name -> Q [Dec]+deriveVersioned =+ deriveField "VersionedBasicModel" "getBMVersion" "version"