exitcode (empty) → 0.1.0.0
raw patch · 6 files changed
+502/−0 lines, 6 filesdep +QuickCheckdep +basedep +checkerssetup-changed
Dependencies added: QuickCheck, base, checkers, exitcode, lens, mtl, semigroupoids, semigroups, tasty, tasty-hunit, tasty-quickcheck, transformers
Files
- LICENSE +31/−0
- Setup.hs +2/−0
- changelog.md +5/−0
- exitcode.cabal +53/−0
- src/Control/Exitcode.hs +288/−0
- test/Tests.hs +123/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation+(CSIRO) ABN 41 687 119 230.++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 QFPL 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
+ changelog.md view
@@ -0,0 +1,5 @@+0.1.0.0++* This change log starts.+* The initial version of exitcode.+
+ exitcode.cabal view
@@ -0,0 +1,53 @@+-- documentation, see http://haskell.org/cabal/users-guide/++name: exitcode+version: 0.1.0.0+synopsis: Monad transformer for exit codes+description: + <<http://i.imgur.com/uZnp9ke.png>>+ .+ Monad transformer for exit codes+homepage: https://github.com/qfpl/exitcode+license: BSD3+license-file: LICENSE+author: Queensland Functional Programming Lab <oᴉ˙ldɟb@llǝʞsɐɥ>+maintainer: Queensland Functional Programming Lab <oᴉ˙ldɟb@llǝʞsɐɥ>+copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO)+category: Control+build-type: Simple+extra-source-files: changelog.md+cabal-version: >=1.10+homepage: https://github.com/qfpl/exitcode+bug-reports: https://github.com/qfpl/exitcode/issues++source-repository head+ type: git+ location: git@github.com:qfpl/exitcode.git++library+ exposed-modules: Control.Exitcode+ build-depends: base >=4.8 && <4.10+ , lens >=4.15 && <4.16+ , mtl >=2.2 && <2.3+ , semigroupoids >=5.1 && <5.3+ , semigroups >=0.18 && <0.19+ , transformers >=0.4.1 && <5.5+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++test-suite tests+ build-depends: QuickCheck >=2.9.2 && <2.11+ , base >=4.8 && <4.10+ , checkers >=0.4.6 && <0.5+ , exitcode+ , lens >=4.15 && <4.16+ , tasty >=0.11 && <0.12+ , tasty-hunit >=0.9 && <0.10+ , tasty-quickcheck >=0.8.4 && <0.10+ , transformers >=0.4.1 && <5.5+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -Wall
+ src/Control/Exitcode.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}++module Control.Exitcode (+ -- * Types+ ExitcodeT+ , Exitcode+ , ExitcodeT0+ , Exitcode0+ -- * Construction+ , exitsuccess+ , exitsuccess0+ , exitfailure0+ , fromExitCode+ -- * Extraction+ , runExitcode+ -- * Optics+ , exitCode+ , _ExitFailure+ , _ExitSuccess+ ) where++# if MIN_VERSION_base(4,9,0)+import Control.Applicative (Applicative, liftA2)+# else+import Control.Applicative (liftA2)+# endif+import Control.Lens (Iso, Prism', iso, prism', view,+ (^?), _Left, _Right)+import Control.Monad.Cont.Class (MonadCont (..))+import Control.Monad.Error.Class (MonadError (..))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Reader (MonadReader (ask, local))+import Control.Monad.RWS.Class (MonadRWS)+import Control.Monad.State.Lazy (MonadState (get, put))+import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Maybe (MaybeT (MaybeT))+import Control.Monad.Writer.Class (MonadWriter (listen, pass, tell, writer))+import Data.Functor.Alt (Alt, (<!>))+import Data.Functor.Apply (Apply, liftF2, (<.>))+import Data.Functor.Bind (Bind, (>>-))+# if MIN_VERSION_base(4,9,0)+import Data.Functor.Classes (Eq1, Ord1, Show1, compare1, eq1,+ liftCompare, liftEq, liftShowList,+ liftShowsPrec, showsPrec1,+ showsUnaryWith)+# else+import Data.Functor.Classes (Eq1, Ord1, Show1, compare1, eq1,+ showsPrec1, showsUnary1)+# endif+import Data.Functor.Extend (Extend, duplicated)+import Data.Functor.Identity (Identity (Identity))+import Data.Maybe (fromMaybe)+import Data.Semigroup (Semigroup, (<>))+import Data.Semigroup.Foldable (Foldable1)+import System.Exit (ExitCode (ExitFailure, ExitSuccess))++-- hide the constructor, `Left 0` is an invalid state+data ExitcodeT f a =+ ExitcodeT (f (Either Int a))++type Exitcode a =+ ExitcodeT Identity a++type ExitcodeT0 f =+ ExitcodeT f ()++type Exitcode0 =+ Exitcode ()++exitsuccess ::+ Applicative f =>+ a+ -> ExitcodeT f a+exitsuccess =+ ExitcodeT . pure . Right++exitsuccess0 ::+ Applicative f =>+ ExitcodeT0 f+exitsuccess0 =+ exitsuccess ()++exitfailure0 ::+ Applicative f =>+ Int+ -> ExitcodeT0 f+exitfailure0 n =+ if n == 0+ then+ exitsuccess0+ else+ ExitcodeT . pure . Left $ n++fromExitCode ::+ Functor f =>+ f ExitCode+ -> ExitcodeT0 f+fromExitCode x =+ let ExitcodeT (MaybeT r) = view exitCode x+ in ExitcodeT (fromMaybe (Right ()) <$> r)++exitCode ::+ (Functor f, Functor g) =>+ Iso+ (f ExitCode)+ (g ExitCode)+ (ExitcodeT0 (MaybeT f))+ (ExitcodeT0 (MaybeT g))+exitCode =+ iso+ (\x -> ExitcodeT (MaybeT ((\e -> case e of+ ExitSuccess ->+ Just (Right ())+ ExitFailure 0 ->+ Nothing+ ExitFailure n ->+ Just (Left n)) <$> x)))+ (\(ExitcodeT (MaybeT x)) -> (\e -> case e of+ Just (Right ()) ->+ ExitSuccess+ Nothing ->+ ExitFailure 0+ Just (Left n) ->+ ExitFailure n) <$> x)++runExitcode ::+ ExitcodeT f a+ -> f (Either Int a)+runExitcode (ExitcodeT x) =+ x++_ExitFailure ::+ Prism'+ Exitcode0+ Int+_ExitFailure =+ prism'+ exitfailure0+ (\(ExitcodeT (Identity x)) -> x ^? _Left)++_ExitSuccess ::+ Prism'+ Exitcode0+ ()+_ExitSuccess =+ prism'+ (\() -> exitsuccess0)+ (\(ExitcodeT (Identity x)) -> x ^? _Right)++instance Functor f => Functor (ExitcodeT f) where+ fmap f (ExitcodeT x) =+ ExitcodeT (fmap (fmap f) x)++instance Apply f => Apply (ExitcodeT f) where+ ExitcodeT f <.> ExitcodeT a =+ ExitcodeT (liftF2 (<.>) f a)++instance Applicative f => Applicative (ExitcodeT f) where+ pure =+ ExitcodeT . pure . pure+ ExitcodeT f <*> ExitcodeT a =+ ExitcodeT (liftA2 (<*>) f a)++instance (Bind f, Monad f) => Bind (ExitcodeT f) where+ (>>-) =+ (>>=)++instance Monad f => Monad (ExitcodeT f) where+ return =+ ExitcodeT . return . return+ ExitcodeT x >>= f =+ ExitcodeT+ (x >>= either (pure . Left) (\a -> let ExitcodeT y = f a in y))++instance Monad f => Alt (ExitcodeT f) where+ ExitcodeT a <!> ExitcodeT b =+ ExitcodeT (a >>= either (const b) (pure a))++instance Monad f => Semigroup (ExitcodeT f a) where+ ExitcodeT a <> ExitcodeT b =+ ExitcodeT (a >>= either (const b) (pure a))++instance Applicative f => Extend (ExitcodeT f) where+ duplicated (ExitcodeT x) =+ ExitcodeT ((pure <$>) <$> x )++instance (Eq1 f, Eq a) => Eq (ExitcodeT f a) where+ ExitcodeT a == ExitcodeT b =+ a `eq1` b++instance Eq1 f => Eq1 (ExitcodeT f) where+# if MIN_VERSION_base(4,9,0)+ liftEq f (ExitcodeT a) (ExitcodeT b) =+ liftEq (liftEq f) a b+# else+ eq1 (ExitcodeT a) (ExitcodeT b) =+ eq1 a b+# endif++instance (Ord1 f, Ord a) => Ord (ExitcodeT f a) where+ ExitcodeT a `compare` ExitcodeT b =+ a `compare1` b++instance (Ord1 f) => Ord1 (ExitcodeT f) where+# if MIN_VERSION_base(4,9,0)+ liftCompare f (ExitcodeT a) (ExitcodeT b) =+ liftCompare (liftCompare f) a b+# else+ compare1 (ExitcodeT a) (ExitcodeT b) =+ compare1 a b+# endif++instance (Show1 f, Show a) => Show (ExitcodeT f a) where+ showsPrec d (ExitcodeT m) =+# if MIN_VERSION_base(4,9,0)+ showsUnaryWith showsPrec1 "ExitcodeT" d m+# else+ showsUnary1 "ExitcodeT" d m+# endif++instance Show1 f => Show1 (ExitcodeT f) where+# if MIN_VERSION_base(4,9,0)+ liftShowsPrec sp sl d (ExitcodeT fa) =+ let showsPrecF = liftA2 liftShowsPrec (uncurry liftShowsPrec) (uncurry liftShowList) (sp, sl)+ in showsUnaryWith showsPrecF "ExitcodeT" d fa+# else+ showsPrec1 d (ExitcodeT fa) =+ showsUnary1 "ExitcodeT" d fa+# endif++instance Foldable f => Foldable (ExitcodeT f) where+ foldr f z (ExitcodeT x) =+ foldr (flip (foldr f)) z x++instance Foldable1 f => Foldable1 (ExitcodeT f)++instance Traversable f => Traversable (ExitcodeT f) where+ traverse f (ExitcodeT x) =+ ExitcodeT <$> traverse (traverse f) x++instance MonadIO f => MonadIO (ExitcodeT f) where+ liftIO io =+ ExitcodeT (Right <$> liftIO io)++instance MonadTrans ExitcodeT where+ lift = ExitcodeT . (>>= pure . pure)++instance MonadReader r f => MonadReader r (ExitcodeT f) where+ ask = lift ask+ local f (ExitcodeT m) = ExitcodeT $ local f m++instance MonadWriter w f => MonadWriter w (ExitcodeT f) where+ writer t = ExitcodeT . fmap pure $ writer t+ listen (ExitcodeT m) =+ ExitcodeT ((\(e, w) -> (,w) <$> e) <$> listen m)+ tell = ExitcodeT . fmap Right . tell+ pass e = do+ ((a, f), w) <- listen e+ tell (f w)+ pure a++instance MonadState s f => MonadState s (ExitcodeT f) where+ get = ExitcodeT (fmap Right get)+ put = ExitcodeT . fmap Right . put++instance MonadError e f => MonadError e (ExitcodeT f) where+ throwError = ExitcodeT . fmap Right . throwError+ catchError (ExitcodeT f) h =+ ExitcodeT $ flip catchError (runExitcode . h) f++instance MonadRWS r w s f => MonadRWS r w s (ExitcodeT f)++-- Given the embedded `Either` we can only handle computations that use `Either`.+-- This code taken from the ExceptT instance:+-- https://hackage.haskell.org/package/transformers-0.5.4.0/docs/src/Control.Monad.Trans.Except.html#line-237+instance MonadCont f => MonadCont (ExitcodeT f) where+ callCC = liftCallCC callCC++liftCallCC :: Functor f => (((Either Int a -> f (Either Int b)) -> f (Either Int a)) -> f (Either Int a))+ -> ((a -> ExitcodeT f b) -> ExitcodeT f a)+ -> ExitcodeT f a+liftCallCC callCC' f =+ ExitcodeT . callCC' $+ \c -> runExitcode (f (\a -> ExitcodeT (c (Right a))))
+ test/Tests.hs view
@@ -0,0 +1,123 @@+import Control.Lens (review, (^.), (^?))+import Control.Monad.Trans.Maybe (MaybeT (MaybeT))+import Data.Functor.Classes (Eq1)+import Data.Functor.Identity (Identity (..), runIdentity)+import Data.Monoid ((<>))++import Test.QuickCheck (Arbitrary (..), suchThat)+import Test.QuickCheck.Checkers (EqProp (..), Test, TestBatch, eq)+import Test.QuickCheck.Classes (applicative, functor)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck (testProperty)++import Control.Exitcode (Exitcode, ExitcodeT, exitCode,+ exitfailure0, exitsuccess,+ exitsuccess0, runExitcode,+ _ExitFailure, _ExitSuccess)++import System.Exit (ExitCode (..))++newtype EW f a = EW { unEW :: ExitcodeT f a } deriving (Eq, Show)++instance (Applicative f, Arbitrary a) => Arbitrary (EW f a) where+ arbitrary = fmap (EW . pure) arbitrary++instance Functor f => Functor (EW f) where+ fmap f = EW . fmap f . unEW++instance Applicative f => Applicative (EW f) where+ pure = EW . pure+ EW f <*> EW a = EW (f <*> a)++instance (Eq1 f, Eq a) => EqProp (EW f a) where+ (=-=) = eq++type CheckMe = EW [] (Integer, Integer, Integer)++newtype NonZero = NonZero Int deriving Show++instance Arbitrary NonZero where+ arbitrary = NonZero <$> suchThat arbitrary (/= 0)++main :: IO ()+main = defaultMain test_Exitcode++test_Exitcode :: TestTree+test_Exitcode =+ testGroup "Exitcode" [+ tastyCheckersBatch $ functor (undefined :: CheckMe)+ , tastyCheckersBatch $ applicative (undefined :: CheckMe)+ , applicativeTest+ , exitFailurePrismTest+ , exitSuccessPrismTest+ , exitfailure0Test+ , exitCodePrismTest+ ]++applicativeTest :: TestTree+applicativeTest =+ testGroup "Applicative" [+ testCase "Sticks to the Right" $+ pure (<> "bar") <*> pure "foo" @?= (exitsuccess "foobar" :: Exitcode String)+ ]++exitFailurePrismTest :: TestTree+exitFailurePrismTest =+ testGroup "_ExitFailure Prism" [+ testProperty "review non-zero input" $+ \(NonZero n) -> review _ExitFailure n == exitfailure0 n+ , testCase "review 0" $+ review _ExitFailure 0 @?= exitsuccess0+ , testProperty "view non-zero input" $+ \(NonZero n) -> exitfailure0 n ^? _ExitFailure == Just n+ , testCase "view 0" $+ exitfailure0 0 ^? _ExitFailure @?= Nothing+ ]++exitSuccessPrismTest :: TestTree+exitSuccessPrismTest =+ testGroup "_ExitSuccess Prism" [+ testCase "review" $+ review _ExitSuccess () @?= exitsuccess0+ , testCase "view exitsuccess0" $+ exitsuccess0 ^? _ExitSuccess @?= Just ()+ , testProperty "view exitfailure0 non-zero" $+ \(NonZero n) -> exitfailure0 n ^? _ExitSuccess == Nothing+ , testCase "view exitfailure0 0" $+ exitfailure0 0 ^? _ExitSuccess @?= Just ()+ ]++exitfailure0Test :: TestTree+exitfailure0Test =+ testGroup "exitfailure0" [+ testProperty "non-zero input" $+ \(NonZero n) -> (runIdentity . runExitcode) (exitfailure0 n) == Left n+ , testCase "0" $+ (runIdentity . runExitcode) (exitfailure0 0) @?= Right ()+ ]++exitCodePrismTest :: TestTree+exitCodePrismTest =+ testGroup "exitCode Prism" [+ testProperty "`exitfailure0 n`, where n is non-zero" $+ \(NonZero n) -> (review exitCode (exitfailure0 n)) == Identity (ExitFailure n)+ , testCase "review `exitfailure 0`" $+ runIdentity (review exitCode (exitfailure0 0)) @?= ExitSuccess+ , testCase "review `exitsuccess0`" $+ runIdentity (review exitCode exitsuccess0) @?= ExitSuccess+ , testProperty "view ExitFailure n, where n is non-zero" $+ \(NonZero n) -> Identity (ExitFailure n) ^? exitCode == Just (exitfailure0 n)+ , testCase "view ExitFailure 0" $+ runExitcode (Identity (ExitFailure 0) ^. exitCode) @?= (MaybeT (Identity Nothing))+ , testCase "view ExitSuccess" $+ Identity ExitSuccess ^? exitCode @?= Just exitsuccess0+ ]++tastyCheckersBatch :: TestBatch -> TestTree+tastyCheckersBatch (name, tests) =+ testGroup (name <> " laws") (tastyCheckersProperty <$> tests)++tastyCheckersProperty :: Test -> TestTree+tastyCheckersProperty =+ uncurry testProperty