Dangerous (empty) → 0.1

raw patch · 4 files changed

+200/−0 lines, 4 filesdep +basedep +mtlsetup-changed

Dependencies added: base, mtl

Files

Dangerous.cabal +27/−0
LICENSE +19/−0
Setup.hs +2/−0
src/Control/Dangerous.hs +152/−0

+ Dangerous.cabal view

@@ -0,0 +1,27 @@+Name:          Dangerous+Version:       0.1+License:       MIT+License-file:  LICENSE+Category:      Error Handling+Synopsis:      Monads for operations that can exit early and produce warnings+Description:   Dangerous monads result in (Either Exit a, [Warning]), where+               Exit can denote either ending computation early (Stop) or+               the computation failing (Exit, Failure). Monads, Monad+               Transformers, and helper functions are included.+Author:        Nate Soares+Maintainer:    nate@natesoares.com+Build-Type:    Simple+Cabal-Version: >=1.6++source-repository this+    type: git+    location: git://github.com/Soares/Dangerous.git+    tag: v1.0++Library+    Hs-Source-Dirs:   src+    Build-Depends:    base >= 4 && < 5,+                      mtl >= 1.0+    Exposed-modules:  Control.Dangerous+    Ghc-Options:      -Wall+    Ghc-Prof-Options: -auto-all

+ LICENSE view

@@ -0,0 +1,19 @@+Copyright © 2011 Nathaniel Soares++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ src/Control/Dangerous.hs view

@@ -0,0 +1,152 @@+module Control.Dangerous+    ( Exit(..)+    , Warning(..)+    , Dangerous(..)+    , DangerousT(..)+    , warn+    , throw+    , throw_+    , stop+    , stop_+    , succeeded+    , failed+    , stopped+    , exited+    , warnings+    , result+    , execute+    ) where+++import Prelude hiding ( log )+import Control.Arrow+import Control.Monad.Trans+import System.Exit+import System.IO+import Text.Printf+++-- A signal that computation should exit.+data Exit = Stop String     -- The computation was succesful+          | Failure String  -- The computation failed+          | Exit Int String -- The computation failed with an error code++instance Show Exit where+    show (Stop s) = printf "Stop: %s" s+    show (Exit n s) = printf "Error(%d): %s" n s+    show (Failure s) = printf "Error: %s" s+++-- A wrapped warning message+data Warning = Warning String++instance Show Warning where+    show (Warning w) = printf "Warning: %s" w+++-- A class of computation that can both log warnings and exit early+class (Monad m) => Errorable m where+    -- Log warnings+    log :: Warning -> m ()+    warn :: (Show w) => w -> m ()+    warn = log . Warning . show++    -- Stop the computation+    exit :: Exit -> m a+    exit_ :: Exit -> m ()+    exit_ x = exit x >> return ()++    -- Exit with a showable error and an error code+    die :: (Show s) => Int -> s -> m a+    die_ :: (Show s) => Int -> s -> m ()+    die n = exit . Exit n . show+    die_ n = (>> return ()) . die_ n++    -- Exit with a showable error+    throw :: (Show s) => s -> m a+    throw_ :: (Show s) => s -> m ()+    throw = exit . Failure . show+    throw_ = (>> return ()) . throw_++    -- Exit successfully with a showable message+    stop :: (Show s) => s -> m a+    stop_ :: (Show s) => s -> m ()+    stop = exit . Stop . show+    stop_ = (>> return ()) . stop_+++-- The Dangerous Monad+-- Preforms computations that can be exited early and result in warnings+data Dangerous a = Dangerous { runDangerous :: (Either Exit a, [Warning]) }++instance Functor Dangerous where+    fmap f (Dangerous (Right v, ws)) = Dangerous (Right (f v), ws)+    fmap _ (Dangerous (Left e, ws)) = Dangerous (Left e, ws)++instance Monad Dangerous where+    fail s = Dangerous (Left $ Failure s, [])+    return x = Dangerous (Right x, [])+    (Dangerous (Left e, ws)) >>= _ = Dangerous (Left e, ws)+    (Dangerous (Right v, ws)) >>= f = Dangerous $ case f v of+        Dangerous (Right v', ws') -> (Right v', ws ++ ws')+        Dangerous (Left e, ws') -> (Left e, ws ++ ws')++instance Errorable Dangerous where+    log w = Dangerous (Right (), [w])+    exit x = Dangerous (Left x, [])+++-- The Dangerous Monad Transformer+data DangerousT m a = DangerousT {+    runDangerousT :: m (Either Exit a, [Warning]) }++instance (Functor m) => Functor (DangerousT m) where+    fmap f (DangerousT mapable) = DangerousT (fmap (first apply) mapable) where+        apply (Right v) = Right $ f v+        apply (Left e) = Left e++instance (Monad m) => Monad (DangerousT m) where+    fail s = DangerousT (return (Left $ Failure s, []))+    return = lift . return+    (DangerousT m) >>= f = DangerousT $ m >>= \(r, ws) -> case r of+        Right x -> runDangerousT (f x) >>= return . second (ws ++)+        Left e -> return (Left e, ws)++instance MonadTrans DangerousT where+    lift x = DangerousT $ x >>= (\v -> return (Right v, []))++instance (MonadIO m) => MonadIO (DangerousT m) where+  liftIO = lift . liftIO++instance (Monad m) => Errorable (DangerousT m) where+    log w = DangerousT $ return (Right (), [w])+    exit x = DangerousT $ return (Left x, [])+++-- Functions that work on dangerous results+succeeded :: (Either Exit a, [Warning]) -> Bool+succeeded (Right _, _) = True+succeeded _ = False++exited :: (Either Exit a, [Warning]) -> Bool+exited (Left _, _) = True+exited _ = False++stopped :: (Either Exit a, [Warning]) -> Bool+stopped (Left (Stop _), _) = True+stopped _ = False++failed :: (Either Exit a, [Warning]) -> Bool+failed e = exited e && not (stopped e)++warnings :: (Either Exit a, [Warning]) -> [Warning]+warnings = snd++result :: (Either Exit a, [Warning]) -> Either Exit a+result = fst++execute :: Either Exit a -> IO a+execute (Left (Stop s)) = putStrLn s >> exitSuccess+execute (Left (Failure s)) = hPutStrLn stderr s >> exitFailure+execute (Left (Exit n s)) = hPutStrLn stderr s >> exitWith (ExitFailure n)+execute (Right a) = return a