supervisor 0.1.0.0 → 0.1.1.0

raw patch · 5 files changed

+312/−13 lines, 5 filesdep +containersdep +exceptionsdep −MonadCatchIO-transformersdep ~base

Dependencies added: containers, exceptions

Dependencies removed: MonadCatchIO-transformers

Dependency ranges changed: base

Files

Control/Monad/Supervisor.hs +107/−0
Control/Monad/Supervisor/Session.hs +73/−0
Control/Monad/Supervisor/Trace.hs +15/−9
Control/Monad/Supervisor/Transactions.hs +108/−0
supervisor.cabal +9/−4

+ Control/Monad/Supervisor.hs view

@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------+--+-- Module      :  Control.Monad.Supervisor+-- Copyright   :+-- License     :  BSD3+--+-- Maintainer  :  agocorona@gmail.com+-- Stability   :+-- Portability :+--+-- | A supervisor monad that explore the execution tree of an internal monad and define extra behaviours thanks to flexible instance definitions for each particular purpose.+-- It can inject new behaviours for backtracking, trace generation, testing, transaction rollbacks etc+-- The supervisor monad is used in the package MFlow to control the routing, tracing, state management, back button management and navigation in general++--+-----------------------------------------------------------------------------+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,+             UndecidableInstances, DeriveDataTypeable,+             FunctionalDependencies #-}++module Control.Monad.Supervisor where++import Control.Monad.Trans+import Control.Monad.State+import Data.Typeable++import Debug.Trace+(!>)= flip trace++--class  Monad m => MonadState1 s m where+--   get :: m s+--   put :: s -> m ()++-- | The internal computation can be reexecuted, proceed forward or backward+data Control a = Control a | Forward a | Backward deriving (Typeable, Read, Show)++-- | The supervisor add a Control wrapper that is interpreted by the monad instance+newtype Sup s m a = Sup { runSup :: m (Control a ) }++-- | The supervise class add two general modifiers that can be applied:+class  MonadState s m => Supervise s m  where
+   supBack :: s -> m ()          -- ^ Called before initiating backtracking in a control point+                                -- When the computation goes back, by default+                                -- the  state is kepth. This procedure can change+                                -- that behaviour. The state passed is the one before the+                                -- computation was executed.+   supBack = const $ return ()+   
+   supervise :: s ->  m (Control a) -> m (Control a)  -- ^ When the conputation has been executed+                                                    -- this method is an opportunity for modifying the result+                                                    -- By default: supervise _= id+   supervise= const $ id+++-- | Flag the computation that executes @breturn@ as a control point.+--+-- When the computation is going back, it will be re-executed (see the monad definition)+breturn :: Monad m => a -> Sup s m a+breturn = Sup . return . Control 
++--instance MonadState () IO where+--  get= return()+--  put= const $ return ()+  
+--instance MonadState s m => Supervise s m++++-- | The Supervisor Monad is in essence an Identity monad transformer when executing Forward.
+instance  Supervise s m => Monad (Sup s m) where
+    fail   _ = Sup . return $ Backward
+    return x = Sup . return $ Forward x
+    x >>= f    = Sup $ loop 
+     where
+     loop = do
+        s <- get+        -- execution as usual if supervise== id
+        v <-  supervise s $ runSup x                        
+        case v of+            --  a normal execution if supervise== id
+            Forward y  -> supervise s $ runSup (f y)++            --   Backward was returned, stop the branch of execution and propagate it back+            Backward  ->  return  Backward++            -- the computaton x was a control point. if the branch of execution goes Backward+            -- then x will be reexecuted. supBack will control the state backtracking, how much of+            -- the current state we want to keep and how much we want to backtrack  
+            Control y  -> do
+                 z <- supervise s $ runSup (f y)            
+                 case z of
+                  Backward  -> supBack s >> loop           -- re-execute x   
+                  other   -> return other
+
++instance MonadTrans (Sup s) where
+  lift f = Sup $  f >>= return . Forward++instance (MonadIO m,Supervise s m)=> MonadIO (Sup s m) where+  liftIO iof= Sup $ liftIO iof  >>= return . Forward
++instance Supervise s m => MonadState s (Sup s m) where
+   get= lift get
+   put = lift . put
+++

+ Control/Monad/Supervisor/Session.hs view

@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------+--+-- Module      :  Control.Monad.Supervisor.Session+-- Copyright   :+-- License     :  BSD3+--+-- Maintainer  :  agocorona@gmail.com+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+{-# LANGUAGE TypeSynonymInstances,+             FlexibleInstances,+             MultiParamTypeClasses,+             FlexibleContexts,+             UndecidableInstances #-}+module Control.Monad.Supervisor.Session where+import Control.Monad.State+--import Control.Monad.Supervisor+import Data.Map as M+import Data.Typeable+import Data.Dynamic+++onNothing m exc= do+   r <- m+   case r of+     Nothing -> exc+     Just r  -> return r+++-- | Set user-defined data in the context of the session.
+--
+-- The data is indexed by  type in a map. So the user can insert-retrieve different kinds of data
+-- in the session context to add different behaviours to the supervisor monad.
+--
+
++++type SessionData= M.Map TypeRep Dynamic++emptySessionData= M.empty+
+setSessionData :: ( MonadState SessionData m, Typeable a) => a -> m ()  
+setSessionData  x=
+  modify $ \session ->  M.insert  (typeOf x ) (toDyn x)  session
++delSessionData :: ( MonadState SessionData m, Typeable a) => a -> m ()+delSessionData x=+ modify $ \session ->  M.delete  (typeOf x )  (session :: M.Map TypeRep Dynamic)+  
+-- | Get the session data of the desired type if there is any.
+getSessionData ::  (Typeable a, MonadState SessionData m) =>  m (Maybe a)
+getSessionData =  resp where
+ resp= get  >>= \list  ->
+    case M.lookup ( typeOf $ typeResp resp) list :: Maybe Dynamic of
+      Just x  -> return $ cast x
+      Nothing -> return Nothing
+ typeResp :: m (Maybe x) -> x
+ typeResp= undefined
++++runs= flip evalStateT++main= do+   r <- runs emptySessionData  $ do+            setSessionData  True+            getSessionData+   print (r :: Maybe Bool)

Control/Monad/Supervisor/Trace.hs view

@@ -1,4 +1,6 @@-{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances,+    MultiParamTypeClasses, FlexibleInstances+    ,FlexibleContexts, UndecidableInstances #-}  -- | This module add a 'MonadLoc' instance to the 'Supervisor' monad. This instance generates a trace when a -- uncaugh exception is raised.@@ -56,18 +58,19 @@ -- TO DO:  extend it for forward traces and test coverages  module Control.Monad.Supervisor.Trace(runTrace) where-
+import Control.Monad.State
 import Control.Monad.Supervisor import Control.Monad.Loc-import Control.Monad.State-import Control.Monad.CatchIO as CMC+import Control.Monad.Catch as CMC import Control.Exception (SomeException) import Data.List(intersperse)   type Trace= [String] -instance (MonadLoc m, Supervise Trace m, MonadCatchIO m)=> MonadLoc (Sup m) where+++instance (MonadLoc m, Supervise Trace m, MonadCatch m)=> MonadLoc (Sup Trace m) where     withLoc loc (Sup f) =  Sup $ do        withLoc loc $ do              r <- f `CMC.catch` handler1@@ -81,14 +84,14 @@        -- detected failure, add the first line of trace with the error, init execution back
        handler1 (e :: SomeException)=    put ["exception: " ++show e]  >> return Backward -type WState  m = StateT [String] m + -- | Execute an Supervisor computation and raise an error with a trace when an uncaugh exception -- is raised. It is necessary to preprocess the file with the monadloc-pp preprocessor. -- -- Otherwise, it produces the same error with no trace.-runTrace :: Sup (WState IO) () -> IO (Control ())-runTrace  f=  evalStateT (runSup f1) []+runTrace :: Supervise [String] m => Sup [String] m a -> m (Control a)+runTrace  f=  runSup f1   where   f1= printBackTrace >> f   printBackTrace= do@@ -99,5 +102,8 @@      where      disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr)
 -+---- A less polimorphic version of runTrace. It assumes a state monad for the sole purpose+---- of capturing traces+--runTraceState  :: Monad m => Sup (StateT [String] m) a -> m (Control a)+--runTraceState f= evalStateT (runTrace f) []

+ Control/Monad/Supervisor/Transactions.hs view

@@ -0,0 +1,108 @@+-----------------------------------------------------------------------------+--+-- Module      :  Control.Monad.Supervisor.Transactions+-- Copyright   :+-- License     :  BSD3+--+-- Maintainer  :  agocorona@gmail.com+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+{-#LANGUAGE FlexibleInstances, MultiParamTypeClasses,+            GeneralizedNewtypeDeriving, FlexibleContexts+            ,UndecidableInstances, DeriveDataTypeable #-}+module Control.Monad.Supervisor.Transactions (++) where+import Control.Monad.State+import Control.Monad.Supervisor hiding (breturn)+import qualified Control.Monad.Supervisor as Sup(breturn)+import Data.Monoid+import Control.Monad.Trans+import Control.Monad.Supervisor.Session hiding (runs)+import Data.Typeable+++++breturn x= setSessionData (BackTracking False) >> Sup.breturn x++instance MonadState SessionData m => Supervise  SessionData m where+     supBack s= setSessionData (BackTracking True) !> "supBack"++--     supervise _ mx= setSessionData (BackTracking False) >> mx !> "supervise"++--instance (MonadState a m ,MonadState b m)=> MonadState (a,b) m where+--  get= do+--    x <- get+--    y <- get+--    return (x,y)+--+--  put (x,y)= put x >> put y++class  Monad m => BackTrackingStatus m where+   isGoingBack :: m Bool+++class Monoid t => HasInverse t where+  cancel :: t -> t+  -- property: forall w, w => v <> t <> w <> cancel t === v <> w++newtype BackTracking= BackTracking Bool deriving Typeable++processReversibleEvent :: (Supervise SessionData m, HasInverse a)=> a -> a -> (a -> Sup SessionData m()) -> Sup SessionData m ()+processReversibleEvent resource event update =  do+   now <- isGoingBack+   if  now  !> ("back="++ show now) then  update (resource <> cancel event) >> fail ""+           else  update (resource <> event) >> breturn ()++--processIrreversibleEvent :: (BackTrackingStatus m, Monoid a)=> a -> a -> Sup m a -> Sup m a+--processIrreversibleEvent resource event failAction= do
+--   now <- lift $ isGoingBack
+--   if not now+--    then breturn $ resource <> event+--    else do
+--         breturn()  -- will not go back beyond this
+--         failAction++instance Monoid Int where mempty=0; mappend =(+)+newtype Potatoes= Potatoes Int deriving (Num, Monoid, Typeable)++instance HasInverse Potatoes where cancel = negate++++instance Supervise SessionData m => BackTrackingStatus  m where+   isGoingBack= do+     BackTracking b <- getSessionData `onNothing` (return (BackTracking False) !> "backtracking not set" ) !> "isgoingback"+     return b++runs= flip evalStateT+++main= do+  print "hi"+  runs emptySessionData $ runSup $ do+      setSessionData (BackTracking True)+      getSessionData `onNothing` error "not set" >>= \(BackTracking b) -> liftIO (print b)++      Potatoes potatoes <- getSessionData `onNothing` return (Potatoes 0)+      liftIO . print $ " Now you have"++ show potatoes ++ " in your shopping cart"+      liftIO . print $ "press enter for more potatoes"+      liftIO $ getLine+      liftIO . print $ " you want to add potatoes to the shopping cart"+      processReversibleEvent (Potatoes potatoes) (Potatoes 5) setSessionData+++      liftIO . print $  "but wait!. you do not need potatoes, you need oranges!. "+      liftIO . print $  "No problem. press enter to drop the potatoes from the cart"+      liftIO $ getLine+      fail ""+++++

supervisor.cabal view

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.1.0.0
+version:             0.1.1.0
 
 -- A short (one-line) description of the package.
 synopsis:   Control an internal monad execution for trace generation, backtrakcking, testing and other purposes
@@ -53,11 +53,16 @@ 
 library
   -- Modules exported by the library.
-  exposed-modules:     Control.Monad.Supervisor.Trace
-  
+  exposed-modules:     Control.Monad.Supervisor+                       Control.Monad.Supervisor.Trace+                       Control.Monad.Supervisor.Session
+                       Control.Monad.Supervisor.Transactions+                       
   -- Modules included in this library but not exported.
   -- other-modules:       
   
   -- Other library packages from which modules are imported.
-  build-depends:       base ==4.5.*, mtl -any, monadloc -any, MonadCatchIO-transformers -any
+  build-depends:       base >=4 && <5, mtl -any, monadloc -any+                       , exceptions -any+                       , containers -any