keera-hails-mvc-model-lightmodel (empty) → 0.0.3.4
raw patch · 12 files changed
+825/−0 lines, 12 filesdep +MissingKdep +basedep +containerssetup-changed
Dependencies added: MissingK, base, containers, keera-hails-reactivevalues, stm, template-haskell
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- keera-hails-mvc-model-lightmodel.cabal +75/−0
- src/Hails/MVC/Model/ProtectedModel.hs +138/−0
- src/Hails/MVC/Model/ProtectedModel/Initialisation.hs +11/−0
- src/Hails/MVC/Model/ProtectedModel/Reactive.hs +72/−0
- src/Hails/MVC/Model/ReactiveFields.hs +26/−0
- src/Hails/MVC/Model/ReactiveModel.hs +128/−0
- src/Hails/MVC/Model/ReactiveModel/Events.hs +16/−0
- src/Hails/MVC/Model/ReactiveModel/Initialisation.hs +11/−0
- src/Hails/MVC/Model/THAccessors.hs +158/−0
- src/Hails/MVC/Model/THFields.hs +158/−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-model-lightmodel.cabal view
@@ -0,0 +1,75 @@+-- 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-model-lightmodel++-- 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.4++-- A short (one-line) description of the package.+Synopsis: Rapid Gtk Application Development - Reactive Protected Light Models++-- A longer description of the package.+Description: Light Protected Models are Thread-safe (STM) Reactive Models+ with change propagation and notification. They are meant+ to enclose a whole (MVC) application's model, using field+ accessors to access every part of a Protected Model as a+ Reactive Value. Unline full Protected Models, Light models+ do not have an undo/redo queue.++-- 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+ , Hails.MVC.Model.ProtectedModel.Reactive+ , Hails.MVC.Model.ProtectedModel.Initialisation+ , Hails.MVC.Model.THAccessors+ , Hails.MVC.Model.THFields+ , Hails.MVC.Model.ReactiveFields+ , Hails.MVC.Model.ReactiveModel.Initialisation+ , Hails.MVC.Model.ReactiveModel+ , Hails.MVC.Model.ReactiveModel.Events+ + -- Packages needed in order to build this package.+ Build-depends: base >= 4 && < 5+ , template-haskell+ , containers+ , stm+ , keera-hails-reactivevalues+ , MissingK
+ src/Hails/MVC/Model/ProtectedModel.hs view
@@ -0,0 +1,138 @@+-- | Note: this is experimental code. It's what I'm using to build my+-- own Gtk apps. That being said, you may find IO more often than it's+-- really necessary. I'd be glad if you could point that out when you+-- see it. I'd like to make this code as generic and useful as+-- possible.+--+-- | This module holds the protected reactive program model. It holds+-- a reactive model, but includes an interface that is thread safe+-- (can be called concurrently). This makes it easier for different+-- threads to modify the model without having to worry about+-- concurrency. Note that using this interface can lead to deadlocks+-- in the program.+module Hails.MVC.Model.ProtectedModel+ ( ProtectedModel (reactiveModel)+ -- * Construction+ , startProtectedModel+ -- * Access+ , onReactiveModel+ , onEvent+ , onEvents+ , applyToReactiveModel+ , fromReactiveModel+ , waitFor+ )+ where++-- External libraries+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Data.Maybe+import Data.Foldable as F+import Data.Sequence as Seq++-- Internal libraries+import Hails.MVC.Model.ReactiveModel+ ( emptyRM+ , getPendingHandler+ , pendingEvents+ , pendingHandlers+ , Event+ , ReactiveModel+ )+import qualified Hails.MVC.Model.ReactiveModel as RM++-- A Protected model holds a reactive model and a thread that calls+-- the necessary event handlers as soon as the events are triggered.+-- Note that the hanlders are executed by this thread, which means+-- that, if you need the operation to be executed in another handlers,+-- you'll have to write explicit code for that.+--+-- Gtk (which is what I use this for) has specific functions for this+-- purpose.+data (Event b) => ProtectedModel a b = ProtectedModel+ { reactiveModel :: TVar (ReactiveModelIO a b)+ , dispatcher :: Maybe ThreadId+ }++type ReactiveModelIO a b = ReactiveModel a b (IO ())++-- | Start executing the a new protected model.+startProtectedModel :: Event b => a -> IO (ProtectedModel a b)+startProtectedModel emptyBM = do+ rm <- atomically $ newTVar $ emptyRM emptyBM+ i <- forkIO $ dispatcherThread rm+ return ProtectedModel+ { reactiveModel = rm+ , dispatcher = Just i+ }++-- | Lock the calling thread until the reactive model fulfills a+-- condition.+waitFor :: Event b => + ProtectedModel a b -> (ReactiveModelIO a b -> Bool) -> IO ()+waitFor p c = atomically $ void $ do+ rm <- readTVar $ reactiveModel p+ check (c rm)++-- | Run the thread that executes the event handlers.+-- This thread runs indefinitely.+--+-- TODO: would it be better to kill the thread in a clean way+-- (notifying that it has to die ASAP?)+dispatcherThread :: Event b => TVar (ReactiveModelIO a b) -> IO ()+dispatcherThread rmvar = forever $ do+ pa <- atomically $ do+ rm <- readTVar rmvar+ -- Check that there's something pending+ check (not (Seq.null (pendingEvents rm)) + || not (Seq.null (pendingHandlers rm)))+ -- Get the next handler+ let (rm', op) = getPendingHandler rm+ + -- Update the ReactiveModel+ writeTVar rmvar rm'+ + -- Return the next handler to execute+ return op++ -- Execute the handler+ when (isJust pa) $ fromJust pa + + -- Let other threads run+ yield++-- | Execute an event handler for a given Event.+onEvent :: Event b => ProtectedModel a b -> b -> IO () -> IO ()+onEvent pm ev f = applyToReactiveModel pm (\rm -> RM.onEvent rm ev f)++-- | Execute an event handler for a given Event.+onEvents :: (F.Foldable container, Event b) => ProtectedModel a b -> container b -> IO () -> IO ()+onEvents pm evs f = applyToReactiveModel pm (\rm -> RM.onEvents rm evs f)++-- | Perform a modification to the underlying reactive model.+applyToReactiveModel :: Event b + => ProtectedModel a b + -> (ReactiveModelIO a b -> ReactiveModelIO a b) + -> IO ()+applyToReactiveModel p f = atomically $ onTVar (reactiveModel p) f+ where onTVar v g = readTVar v >>= (writeTVar v . g)++-- | Calculate a value from the reactive model.+onReactiveModel :: Event b + => ProtectedModel a b + -> (ReactiveModelIO a b -> c) + -> IO c+onReactiveModel p f = fmap f $ atomically $ readTVar $ reactiveModel p++-- | Calculate a value from the reactive model and update it at the same time+fromReactiveModel :: Event b+ => ProtectedModel a b+ -> (ReactiveModelIO a b -> (ReactiveModelIO a b, c))+ -> IO c+fromReactiveModel p f = atomically $ do+ rm <- readTVar (reactiveModel p)+ let (rm', v) = f rm+ writeTVar (reactiveModel p) rm'+ return v
+ src/Hails/MVC/Model/ProtectedModel/Initialisation.hs view
@@ -0,0 +1,11 @@+-- | Contains only one operation to notify that the system's been+-- initialised.+--+module Hails.MVC.Model.ProtectedModel.Initialisation where++import qualified Hails.MVC.Model.ReactiveModel.Initialisation as RM+import Hails.MVC.Model.ReactiveModel.Events+import Hails.MVC.Model.ProtectedModel++initialiseSystem :: InitialisedEvent c => ProtectedModel a c -> IO ()+initialiseSystem = (`applyToReactiveModel` RM.initialiseSystem)
+ src/Hails/MVC/Model/ProtectedModel/Reactive.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+-- | Protected Reactive Fields+-- +-- This module defines several classes and operations that are used to+-- create reactive fields and to bind reactive fields in the view to+-- reactive fields in the model.+--+-- FIXME: Due to the restrictions in the type classes, the current+-- version uses Model.ProtectedModel.ProtectedModelInternals.ProtectedModel.++module Hails.MVC.Model.ProtectedModel.Reactive where++import Data.ReactiveValue+import Hails.MVC.Model.ProtectedModel+import Hails.MVC.Model.ReactiveModel hiding (onEvent, onEvents)+import Hails.MVC.Model.ReactiveModel.Events++type Setter a b c = ProtectedModel b c -> a -> IO()+type Getter a b c = ProtectedModel b c -> IO a+type Modifier a b c = ProtectedModel b c -> (a -> a) -> IO()+type ModifierIO a b c = ProtectedModel b c -> (a -> IO a) -> IO()++class ReactiveField a b c d | a -> b, a -> c, a -> d where+ events :: a -> [ d ]++onChanged :: (Event d, ReactiveField a b c d) => ProtectedModel c d -> a -> IO () -> IO ()+onChanged pm field p = mapM_ (\e -> onEvent pm e p) (events field)++class ReactiveField a b c d => ReactiveReadField a b c d where+ getter :: a -> Getter b c d++class ReactiveWriteField a b c d where+ setter :: a -> Setter b c d++class (ReactiveField a b c d, ReactiveReadField a b c d, ReactiveWriteField a b c d) => ReactiveReadWriteField a b c d where++ modifier :: a -> Modifier b c d+ modifier x pm f = do+ v <- getter x pm+ let v' = f v+ setter x pm v'++ modifierIO :: a -> ModifierIO b c d+ modifierIO x pm f = do+ v <- getter x pm+ v' <- f v+ setter x pm v'++data Event c => ReactiveElement a b c = ReactiveElement+ { reEvents :: [ c ]+ , reSetter :: Setter a b c+ , reGetter :: Getter a b c+ }++instance Event c => ReactiveField (ReactiveElement a b c) a b c where+ events = reEvents++instance Event c => ReactiveReadField (ReactiveElement a b c) a b c where+ getter = reGetter++instance Event c => ReactiveWriteField (ReactiveElement a b c) a b c where+ setter = reSetter++instance Event c => ReactiveReadWriteField (ReactiveElement a b c) a b c where++type FieldAccessor a b c = ProtectedModel b c -> ReactiveFieldReadWrite a++mkFieldAccessor :: (InitialisedEvent c, Event c) => ReactiveElement a b c -> ProtectedModel b c -> ReactiveFieldReadWrite a+mkFieldAccessor (ReactiveElement evs setter' getter') pm = ReactiveFieldReadWrite set get notify+ where set = setter' pm+ get = getter' pm+ notify p = onEvents pm (initialisedEvent : evs) p
+ src/Hails/MVC/Model/ReactiveFields.hs view
@@ -0,0 +1,26 @@+module Hails.MVC.Model.ReactiveFields where++import Hails.MVC.Model.ReactiveModel++-- TODO: With the new reactive lenses interface,+-- this should uses lenses instead. A 'Field' is+-- just a lens, augmented with an event and a+-- precondition checker. ++-- The following code presents a possibly simpler way of creating reactive+-- fields in a reactive model.+type Field a b c = (b -> a, a -> b -> Bool, a -> b -> b, c)++preTrue :: a -> b -> Bool+preTrue _ _ = True++fieldSetter :: (Eq a, Event c) => + Field a b c -> ReactiveModel b c d -> a -> ReactiveModel b c d+fieldSetter f@(_, pre, rSet, ev) rm newVal+ | fieldGetter f rm == newVal = rm+ | not $ pre newVal $ basicModel rm = triggerEvent rm ev+ | otherwise = triggerEvent rm' ev+ where rm' = rm `onBasicModel` rSet newVal++fieldGetter :: (Event c) => Field a b c -> ReactiveModel b c d -> a+fieldGetter (rGet,_,_,_) = rGet . basicModel
+ src/Hails/MVC/Model/ReactiveModel.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE ExistentialQuantification #-} +-- | This module holds a reactive program model. It holds a program model, but+-- includes events that other threads can listen to, so that a change in a part+-- of the model is notified to another part of the program. The reactive model+-- is not necessarily concurrent (it doesn't have its own thread), although a+-- facility is included to make it also concurrent (so that event handlers can+-- be called as soon as they are present).+--+-- This type includes operations to handle undoing-redoing and+-- tracking which notifications must be triggered in each+-- undo-redo step.+module Hails.MVC.Model.ReactiveModel+ ( ReactiveModel (basicModel)+ -- * Construction+ , Event+ , emptyRM+ -- * Access+ , pendingEvents+ , pendingHandlers+ -- * Modification+ , onBasicModel+ , onEvent+ , onEvents+ , getPendingHandler+ , eventHandlers+ , prepareEventHandlers+ , triggerEvent+ , triggerEvents++ )+ where++-- External imports+import qualified Data.Foldable as F+import qualified Data.Map as M+import Data.Sequence ((|>), (><), Seq, ViewL(..), viewl)+import qualified Data.Sequence as Seq++-- | A reactive model uses an event datatype with all the events that our model+-- must trigger. An heterogenous container cannot be used because we need an Eq+-- operation that is efficient (a string comparison is not).+--+-- Therefore, we can declare operations that require certain events,+-- as long as we create a typeclass for Event types that have a constructor+-- for the kind of events we require.+--+-- NOTE: This is experimental code.+--+class (Eq a, Ord a) => Event a where++-- data FullEvent = forall a . Event a => FullEvent a++-- instance Eq FullEvent where+-- (FullEvent a) == (FullEvent b) = typeOf a == typeOf b+-- && cast a == Just b+-- instance Ord FullEvent where +-- (FullEvent a) < (FullEvent b) = (typeOf a == typeOf b+-- && fromJust (cast a) < b)+-- || (show (typeOf a) < show (typeOf b))++-- instance Show FullEvent where+-- show (FullEvent x) = show x++-- | A model of kind a with a stack of events of kind b+data Event b => ReactiveModel a b c = ReactiveModel + { basicModel :: a+ , eventHandlers :: M.Map b (Seq c)+ , pendingEvents :: Seq b+ , pendingHandlers :: Seq c+ }++-- | Default constructor (with an empty model, no events and no handlers installed)+emptyRM :: Event b => a -> ReactiveModel a b c+emptyRM emptyBM = ReactiveModel+ { basicModel = emptyBM+ , eventHandlers = M.empty+ , pendingEvents = Seq.empty+ , pendingHandlers = Seq.empty+ }++-- | Apply a modification to the internal model (no events are triggered)+onBasicModel :: Event b => ReactiveModel a b c -> (a -> a) -> ReactiveModel a b c+onBasicModel rm f = rm { basicModel = f (basicModel rm) }++-- | Install a handler for an event+onEvent :: Event b => ReactiveModel a b c -> b -> c -> ReactiveModel a b c+onEvent rm ev f = rm { eventHandlers = m' }+ where ls = M.findWithDefault Seq.empty ev m+ ls' = ls |> f+ m = eventHandlers rm+ m' = M.insert ev ls' m++onEvents :: (F.Foldable container, Event b) => ReactiveModel a b c -> container b -> c -> ReactiveModel a b c+onEvents rm evs f = F.foldl (\rm' e' -> onEvent rm' e' f) rm evs++-- | Trigger an event (execute all handlers associated to it)+triggerEvent :: Event b => ReactiveModel a b c -> b -> ReactiveModel a b c+triggerEvent rm e = rm { pendingEvents = ps' }+ where ps = pendingEvents rm+ ps' = ps |> e++-- | Trigger many events in sequence (execute all handlers associated to them)+triggerEvents :: Event b => ReactiveModel a b c -> Seq b -> ReactiveModel a b c+triggerEvents = F.foldl triggerEvent++-- | If any pending handler exists or can be obtained, it is returned+-- and removed from the queue+getPendingHandler :: Event b => ReactiveModel a b c -> (ReactiveModel a b c, Maybe c)+getPendingHandler rm = (rm' { pendingHandlers = pt }, ph)+ where rm' = prepareEventHandlers rm+ ps = pendingHandlers rm'+ vw = viewl ps+ (ph, pt) = case vw of+ EmptyL -> (Nothing, ps)+ (h :< hs) -> (Just h, hs)+ -- if Seq.null ps then (Nothing,ps) else (Just (head ps), tail ps)++-- | Return a reactive model that has no pending events. All the pending events+-- have been looked up in the eventHandlers table and the handlers have been+-- added to the field pendingHandlers.+prepareEventHandlers :: Event b => ReactiveModel a b c -> ReactiveModel a b c+prepareEventHandlers rm =+ rm { pendingEvents = Seq.empty, pendingHandlers = hs1 >< hs2 }+ where evs = pendingEvents rm+ m = eventHandlers rm+ hs1 = pendingHandlers rm+ hs2 = F.foldl (><) Seq.empty $ + fmap (\e -> M.findWithDefault Seq.empty e m) evs
+ src/Hails/MVC/Model/ReactiveModel/Events.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | This module contains all the events in our program. +--+-- FIXME: Because we want events to be comparable, we need to use the+-- same datatype. It remains to be checked whether using an instance+-- of Typeable and an existential type will be enough to have a good+-- instance of Eq and therefore a heterogeneous model (wrt. events).+-- +module Hails.MVC.Model.ReactiveModel.Events+ where++-- import GenericModel.GenericModelEvent+import qualified Hails.MVC.Model.ReactiveModel as GRM++class GRM.Event a => InitialisedEvent a where+ initialisedEvent :: a
+ src/Hails/MVC/Model/ReactiveModel/Initialisation.hs view
@@ -0,0 +1,11 @@+-- | Contains only one operation to notify that the system's been+-- initialised.+--+module Hails.MVC.Model.ReactiveModel.Initialisation where++import Hails.MVC.Model.ReactiveModel+import Hails.MVC.Model.ReactiveModel.Events++initialiseSystem :: InitialisedEvent b+ => ReactiveModel a b c -> ReactiveModel a b c+initialiseSystem = (`triggerEvent` initialisedEvent)
+ src/Hails/MVC/Model/THAccessors.hs view
@@ -0,0 +1,158 @@+-- | This module uses Template Haskell to declare getters and setters+-- for a given field and type that access the ProtectedModel in the+-- IO Monad and the reactive model.++module Hails.MVC.Model.THAccessors where++-- External imports+import Data.Char+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib++-- Creates a setter and a getter at ProtectedModel level that works in the IO Monad+protectedModelAccessors :: String -> String -> Q [Dec]+protectedModelAccessors fname ftype = sequenceQ+ -- Declare plain setter+ [ sigD setterName setterType+ , funD setterName [clause [varP (mkName "pm"), varP (mkName "n")] + (normalB (appE (appE (varE (mkName "applyToReactiveModel"))+ (varE (mkName "pm"))+ )+ (infixE Nothing + (varE (mkName ("RM.set" ++ fname)))+ (Just (varE (mkName "n")))+ )+ )+ )+ []+ ]+ -- Declare plain getter+ , sigD getterName getterType+ , funD getterName [clause []+ (normalB (infixE Nothing + (varE (mkName "onReactiveModel")) + (Just (varE (mkName ("RM.get" ++ fname))))+ )+ )+ []+ ]+ ]+ where setterName = mkName ("set" ++ fname)+ getterName = mkName ("get" ++ fname)+ setterType = appT pmTo typeToIO+ getterType = appT pmTo ioType+ pmTo = appT arrowT (conT (mkName "ProtectedModel"))+ typeToIO = appT (appT arrowT (conT (mkName ftype))) ioNil+ ioNil = appT (conT (mkName "IO")) (conT (mkName "()"))+ ioType = appT (conT (mkName "IO")) (conT (mkName ftype))++-- | Creates a setter and a getter that works at ReactiveModel level.+reactiveModelAccessors :: String -> String -> Q [Dec]+reactiveModelAccessors fname ftype = sequenceQ+ -- Declare plain setter+ [ sigD setterName setterType+ , funD setterName + [clause + -- Setter args: rm (reactive model), n (value)+ [varP (mkName "rm"), varP (mkName "n")]+ -- Main result: triggerEvent rm' ev+ (normalB (appE (appE (varE (mkName "triggerEvent"))+ (varE (mkName "rm'"))+ )+ (varE (mkName "ev"))+ )+ )+ -- Where rm' = updated rm+ [valD (varP (mkName "rm'"))+ (normalB (infixE (Just (varE (mkName "rm")))+ (varE (mkName "onBasicModel"))+ (Just (lamE [varP (mkName "b")]+ (recUpdE (varE (mkName "b"))+ [fieldExp + (mkName fnamelc)+ (varE (mkName "n"))+ ]+ )+ )+ )+ )+ )+ []+ -- Where ev = Corresponding Event+ , valD (varP (mkName "ev"))+ (normalB (conE (mkName (fname ++ "Changed"))))+ []+ ]+ ] + -- Declare plain getter+ , sigD getterName getterType+ , funD getterName [clause []+ -- recordField . basicModel+ (normalB (infixE (Just (varE (mkName fnamelc)))+ (varE (mkName ".")) + (Just (varE (mkName "basicModel")))+ )+ )+ []+ ]+ ]+ where setterName = mkName ("set" ++ fname)+ getterName = mkName ("get" ++ fname)+ setterType = appT rmTo typeToRM+ getterType = appT rmTo (conT (mkName ftype))+ rmTo = appT arrowT (conT (mkName "ReactiveModel"))+ typeToRM = appT (appT arrowT (conT (mkName ftype))) (conT (mkName "ReactiveModel"))+ fnamelc = lcFst fname+ +-- | Creates a setter and a getter that works at ReactiveModel level.+nonReactiveModelAccessors :: String -> Q Type -> Q [Dec]+nonReactiveModelAccessors fname ftype = sequenceQ+ -- Declare plain setter+ [ sigD setterName setterType+ , funD setterName + [clause + -- Setter args: rm (reactive model), n (value)+ [varP (mkName "rm"), varP (mkName "n")]+ -- Main result: triggerEvent rm' ev+ (normalB (varE (mkName "rm'")))+ -- Where rm' = updated rm+ [valD (varP (mkName "rm'"))+ (normalB (infixE (Just (varE (mkName "rm")))+ (varE (mkName "onBasicModel"))+ (Just (lamE [varP (mkName "b")]+ (recUpdE (varE (mkName "b"))+ [fieldExp + (mkName fnamelc)+ (varE (mkName "n"))+ ]+ )+ )+ )+ )+ )+ []+ ]+ ] + -- Declare plain getter+ , sigD getterName getterType+ , funD getterName [clause []+ -- recordField . basicModel+ (normalB (infixE (Just (varE (mkName fnamelc)))+ (varE (mkName ".")) + (Just (varE (mkName "basicModel")))+ )+ )+ []+ ]+ ]+ where setterName = mkName ("set" ++ fname)+ getterName = mkName ("get" ++ fname)+ setterType = appT rmTo typeToRM+ getterType = appT rmTo ftype+ rmTo = appT arrowT (conT (mkName "ReactiveModel"))+ typeToRM = appT (appT arrowT ftype) (conT (mkName "ReactiveModel"))+ fnamelc = lcFst fname++lcFst :: String -> String +lcFst [] = []+lcFst (x:xs) = (toLower x) : xs
+ src/Hails/MVC/Model/THFields.hs view
@@ -0,0 +1,158 @@+-- | This module uses Template Haskell to declare reactive fields for+-- a given model field and type that access the ProtectedModel in+-- the IO Monad and the reactive model.++module Hails.MVC.Model.THFields where++-- External imports+import Data.Char+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib++-- | Creates a setter and a getter that works at ProtectedModel level+-- inside the IO Monad+protectedField :: String -> Q Type -> String -> String -> Q [Dec]+protectedField fname ftype pmodel event = sequenceQ+ -- Declare plain field+ [ sigD setterName setterType+ , funD setterName [clause []+ -- Main result: setter field+ (normalB (appE (varE (mkName "reSetter"))+ (varE fieldName)+ )+ )+ -- where+ []+ ] + -- Declare plain getter+ , sigD getterName getterType+ , funD getterName [clause []+ -- Main result: getter field+ (normalB (appE (varE (mkName "reGetter"))+ (varE fieldName)+ )+ )+ []+ ]+ -- Declare protected field+ , sigD fieldName fieldType+ , funD fieldName [clause []+ (normalB + (recConE (mkName "ReactiveElement")+ [fieldExp+ (mkName "reEvents")+ (listE [conE (mkName + ("RM." ++ fname ++ "Changed"))+ ]+ )+ , fieldExp+ (mkName "reSetter")+ (lamE [varP (mkName "pm")+ , varP (mkName "c")+ ] + (infixE + (Just (varE (mkName "pm")))+ (varE (mkName "applyToReactiveModel"))+ (Just (infixE Nothing+ (varE (mkName + ("RM." ++ "set" ++ fname)+ )+ )+ (Just (varE (mkName "c")))+ )+ )+ )+ )+ , fieldExp (mkName "reGetter")+ (infixE + Nothing+ (varE (mkName "onReactiveModel"))+ (Just (varE (mkName+ ("RM." ++ "get" ++ fname)))+ )+ )+ ]+ )+ )+ []+ ]+ ]+ where setterName = mkName ("set" ++ fname)+ getterName = mkName ("get" ++ fname)+ fieldName = mkName (fnamelc ++ "Field")+ setterType = appT pmTo typeToIO+ getterType = appT pmTo ioType+ fieldType = appT+ (appT+ (appT (conT (mkName "ReactiveElement")) + ftype+ )+ (conT (mkName pmodel))+ )+ (conT (mkName event))+ pmTo = appT arrowT (conT (mkName "ProtectedModel"))+ typeToIO = appT (appT arrowT ftype) ioNil+ ioNil = appT (conT (mkName "IO")) (conT (mkName "()"))+ ioType = appT (conT (mkName "IO")) ftype+ + fnamelc = lcFst fname++-- | Creates a setter and a getter that works at ReactiveModel level.+reactiveField :: String -> Q Type -> Q [Dec]+reactiveField fname ftype = sequenceQ+ -- Declare plain setter+ [ sigD setterName setterType+ , funD setterName [clause []+ -- Main result: just use the field's setter+ (normalB (appE (varE (mkName "fieldSetter"))+ (varE fieldName)+ )+ )+ -- where+ []+ ] + -- Declare plain getter+ , sigD getterName getterType+ , funD getterName [clause []+ -- Main result: just use the field's getter+ (normalB (appE (varE (mkName "fieldGetter"))+ (varE fieldName)+ )+ )+ []+ ]+ -- Declare field with 4 elements + , sigD fieldName fieldType+ , funD fieldName [clause []+ (normalB + (tupE+ [ varE (mkName fnamelc) -- function to read from model+ , varE (mkName "preTrue") -- precondition to update model+ , lamE [varP (mkName "v"), varP (mkName "b")] -- function to update model+ (recUpdE (varE (mkName "b"))+ [fieldExp + (mkName fnamelc)+ (varE (mkName "v"))+ ]+ )+ , (conE (mkName (fname ++ "Changed"))) -- Event to trigger when changed+ ]+ )+ )+ []+ ]+ ]+ where setterName = mkName ("set" ++ fname)+ getterName = mkName ("get" ++ fname)+ fieldName = mkName (fnamelc ++ "Field")+ setterType = appT rmTo typeToRM+ getterType = appT rmTo ftype+ fieldType = appT (conT (mkName "Field")) ftype+ rmTo = appT arrowT (conT (mkName "ReactiveModel"))+ typeToRM = appT (appT arrowT ftype) + (conT (mkName "ReactiveModel"))+ fnamelc = lcFst fname++lcFst :: String -> String +lcFst [] = []+lcFst (x:xs) = (toLower x) : xs