diff --git a/Control/Monad/Supervisor/Trace.hs b/Control/Monad/Supervisor/Trace.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Supervisor/Trace.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-} + +-- | This module add a 'MonadLoc' instance to the 'Supervisor' monad. This instance generates a trace when a +-- uncaugh exception is raised. +-- +-- . See the MonadLoc package: +-- +-- The package control-monad-exception produces call stacks using @monadloc@, but the @Supervisor@ monad +-- produces execution traces thanks to the backtracking mechanism. +-- +-- The trace is produced after the exception is raised. So it does not generate +-- overhead in normal execution. +-- +-- For more finer control of exceptions, ej. for retrowing exceptions managed outside the Supervisor monad +-- , create your own instance +-- +-- Execute the example at @Demos/TraceExample.hs@ +-- +-- +-- > {-# OPTIONS -F -pgmF MonadLoc #-} +-- > module Demos.TraceExample ( +-- > +-- > ) where +-- > +-- > import Control.Monad.Loc +-- > import Control.Monad.Supervisor.Trace +-- > import Control.Monad.Trans +-- > +-- > main= runTrace $ do +-- > liftIO $ print "hello" +-- > +-- > example +-- > +-- > example= +-- > if True +-- > then do +-- > liftIO $ print "world" +-- > liftIO $ undefined +-- > +-- > else liftIO $ print "not there" +-- +-- Produce this trace: +-- +-- @ +-- \"hello\" +-- \"world\" +-- TraceExample.hs: TRACE (error in the last line): +-- . +-- main, Demos.TraceExample(Demos\TraceExample.hs): (23, 18) +-- main, Demos.TraceExample(Demos\TraceExample.hs): (26, 4) +-- example, Demos.TraceExample(Demos\TraceExample.hs): (30, 13) +-- example, Demos.TraceExample(Demos\TraceExample.hs): (32, 15) +-- exception: Prelude.undefined +-- @ + +-- TO DO: extend it for forward traces and test coverages + +module Control.Monad.Supervisor.Trace(runTrace) where + +import Control.Monad.Supervisor +import Control.Monad.Loc +import Control.Monad.State +import Control.Monad.CatchIO 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 + withLoc loc (Sup f) = Sup $ do + withLoc loc $ do + r <- f `CMC.catch` handler1 + trace <- get + case trace of + [] -> return r -- all ok + trace -> put (loc:trace) >> return r -- is going back with a trace, we add one more line + return r + + where + -- 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) [] + where + f1= printBackTrace >> f + printBackTrace= do + s <- get + case s of + [] -> breturn() + tr -> error (disp tr) + where + disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr) + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Alberto G. Corona + +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 Alberto G. Corona 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/supervisor.cabal b/supervisor.cabal new file mode 100644 --- /dev/null +++ b/supervisor.cabal @@ -0,0 +1,63 @@ +-- Initial supervisor.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: supervisor + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Control an internal monad execution for trace generation, backtrakcking, testing and other purposes + +-- A longer description of the package. +description: 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, state management, back button management and navigation in general. + . + Currently only the generation of an execution trace on case of error is developped. See @Control.Monad.Supervisor.Trace@ and the example at @Demos/TraceExample.hs@ + + +-- URL for the project homepage or repository. +homepage: http://github.com/agocorona/supervisor + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Alberto G. Corona + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: agocorona@gmail.com + +-- A copyright notice. +-- copyright: + +category: Control + +build-type: Simple + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.8 + + +library + -- Modules exported by the library. + exposed-modules: Control.Monad.Supervisor.Trace + + -- 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 +