teardown (empty) → 0.0.0.1

raw patch · 11 files changed

+541/−0 lines, 11 filesdep +Globdep +QuickCheckdep +ansi-wl-pprintsetup-changed

Dependencies added: Glob, QuickCheck, ansi-wl-pprint, base, criterion, doctest, protolude, tasty, tasty-hspec, tasty-hunit, tasty-rerun, tasty-smallcheck, teardown, text, time

Files

• CHANGELOG.md +12/−0
• LICENSE +13/−0
• README.md +7/−0
• Setup.hs +2/−0
• benchmark/Main.hs +9/−0
• src/Control/Teardown.hs +17/−0
• src/Control/Teardown/Internal/Core.hs +160/−0
• src/Control/Teardown/Internal/Printer.hs +76/−0
• teardown.cabal +100/−0
• test/DocTest.hs +7/−0
• test/TestSuite.hs +138/−0

@@ -0,0 +1,12 @@+Change log+==========++teardown uses [Semantic Versioning][1].+The change log is available [on GitHub][2].++[1]: http://semver.org/spec/v2.0.0.html+[2]: https://github.com/roman/Haskell-teardown/libraries/teardown/CHANGELOG.md++## v0.0.0.1++* First release of teardown library

@@ -0,0 +1,13 @@+Copyright (c) 2017, TODO:<Author name here>++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

@@ -0,0 +1,7 @@+# teardow++`teardown` allows the creation of composable, idempotent and transparent+application cleanup sub-routines.++For more information about `teardown` API and how to use it, see+the [`teardown` homepage](https://github.com/roman/Haskell-teardown).

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

@@ -0,0 +1,9 @@+module Main where++import Criterion+import Criterion.Main++import Lib (inc)++main :: IO ()+main = defaultMain [bench "inc 41" (whnf inc (41 :: Int))]

@@ -0,0 +1,17 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Control.Teardown ( module X ) where++import Control.Teardown.Internal.Core    as X+    ( ITeardown (..)+    , Teardown+    , TeardownResult (..)+    , concatTeardown+    , didTeardownFail+    , emptyTeardown+    , failedToredownCount+    , newDynTeardown+    , newTeardown+    , toredownCount+    )+import Control.Teardown.Internal.Printer as X (renderTeardownReport)

@@ -0,0 +1,160 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Control.Teardown.Internal.Core where++import Protolude hiding (first)++import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)++import Data.IORef (atomicModifyIORef, newIORef, readIORef, writeIORef)++--------------------------------------------------------------------------------++type Description = Text++data TeardownResult+  = BranchResult+    {+      resultDescription :: !Description+    , resultElapsedTime :: !NominalDiffTime+    , resultDidFail     :: !Bool+    , resultListing     :: ![TeardownResult]+    }+  | LeafResult+    {+      resultDescription :: !Description+    , resultElapsedTime :: !NominalDiffTime+    , resultError       :: !(Maybe SomeException)+    }+  | EmptyResult+    {+      resultDescription :: !Description+    }+  deriving (Generic, Show)++newtype Teardown+  = Teardown (IO TeardownResult)+  deriving (Generic)++class ITeardown d where+  teardown :: d -> IO TeardownResult++--------------------------------------------------------------------------------++trackExecutionTime :: IO a -> IO (NominalDiffTime, a)+trackExecutionTime routine = do+  start <- getCurrentTime+  result <- routine+  end <- getCurrentTime+  return (diffUTCTime end start, result)++emptyTeardownResult :: Description -> TeardownResult+emptyTeardownResult = EmptyResult++didTeardownFail :: TeardownResult -> Bool+didTeardownFail result =+  case result of+    LeafResult {} ->+      isJust (resultError result)++    BranchResult {} ->+      resultDidFail result++    EmptyResult {} ->+      False++newTeardown :: Description -> IO () -> IO Teardown+newTeardown desc disposingAction = do+  teardownResultLock <- newIORef False+  teardownResultRef  <- newIORef Nothing+  return $ Teardown $ do+      shouldExecute <-+        atomicModifyIORef teardownResultLock+                          (\toredown ->+                             if toredown then+                               (True, False)+                             else+                               (True, True))++      if shouldExecute then do+          (elapsed, disposeResult0) <- trackExecutionTime (try disposingAction)+          let+            disposeResult =+              LeafResult desc elapsed (either Just (const Nothing) disposeResult0)++          writeIORef teardownResultRef (Just disposeResult)+          return disposeResult+      else+          fromMaybe (emptyTeardownResult desc) <$> readIORef teardownResultRef++concatTeardown :: Description -> [Teardown] -> Teardown+concatTeardown desc teardownChildren = Teardown $ do+  teardownResults <- mapM (\(Teardown action) -> action) teardownChildren++  let+    elapsed =+      sum $ map resultElapsedTime teardownResults++    teardownFailed =+      any didTeardownFail teardownResults++  return $ BranchResult desc elapsed teardownFailed teardownResults++newDynTeardown :: Description -> IO [TeardownResult] -> Teardown+newDynTeardown desc action = Teardown $ do+  teardownResults <- action++  let+    elapsed =+      sum $ map resultElapsedTime teardownResults++    teardownFailed =+      any didTeardownFail teardownResults++  return $ BranchResult desc elapsed teardownFailed teardownResults++emptyTeardown :: Description -> Teardown+emptyTeardown desc =+  Teardown (return $ emptyTeardownResult desc)++--------------------------------------------------------------------------------++foldTeardownResult+  :: (acc -> Description -> Maybe SomeException -> acc)+  -> ([acc] -> Description -> acc)+  -> acc+  -> TeardownResult+  -> acc+foldTeardownResult leafStep branchStep acc disposeResult =+  case disposeResult of+    EmptyResult desc ->+      leafStep acc desc Nothing++    LeafResult desc _ mErr ->+      leafStep acc desc mErr++    BranchResult desc _ _ results ->+      let+        result =+          map (foldTeardownResult leafStep branchStep acc) results+      in+        branchStep result desc++toredownCount :: TeardownResult -> Int+toredownCount =+  foldTeardownResult (\acc _ _ -> acc + 1)+                     (\results _ -> sum results)+                     0++failedToredownCount :: TeardownResult -> Int+failedToredownCount =+  foldTeardownResult (\acc _ mErr -> acc + maybe 0 (const 1) mErr)+                     (\results _ -> sum results)+                     0++--------------------------------------------------------------------------------++instance ITeardown Teardown where+  teardown (Teardown action) =+    action

@@ -0,0 +1,76 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Control.Teardown.Internal.Printer where++import Protolude hiding ((<>))++import qualified Data.Text     as Text+import           Data.Typeable (typeOf)++import Control.Teardown.Internal.Core+import Data.Monoid                    ((<>))+import Text.PrettyPrint.ANSI.Leijen   hiding ((<>))++treeTrunk :: Int -> Int -> Doc+treeTrunk start level =+  hcat (map (\_ -> text "    ") [1..start]) <>+  hcat (map (\_ -> text "   |") [start..pred level])++renderTeardownReport :: TeardownResult -> Doc+renderTeardownReport result =+    render 0 0 result <> hardline+  where+    renderError start level (SomeException err) =+      let+        (fstErrLine:errLines) =+          Text.lines (show err)++        errorReport =+          treeTrunk (pred start) (succ level)+           <> ">"+           <> indent 2 (text (show (typeOf err)) <> ":")+           <+> text (Text.unpack fstErrLine)+          : map (\l ->+                    treeTrunk (pred start) (succ level)+                    <> ">"+                    <> indent 2 (text $ Text.unpack l))+                 errLines+      in+        vcat errorReport++    renderTree start level disposeResults =+      case disposeResults of+        [] ->+          mempty+        [ lastResult ] ->+          treeTrunk start (succ level) <> render (succ start) (succ level) lastResult+        (r : results) ->+          treeTrunk start (succ level) <> render start (succ level) r <$$> renderTree start level results+    render start level disposeResult =+      case disposeResult of+        EmptyResult desc ->+            "`-"+             <+> "✓"+             <+> text (Text.unpack desc)+             <+> "(empty)"++        LeafResult desc elapsed Nothing ->+            "`-"+             <+> "✓"+             <+> text (Text.unpack desc)+             <+> text ("(" <> show elapsed <> ")")++        LeafResult desc elapsed (Just err) ->+            "`-"+             <+> "✘"+             <+> text (Text.unpack desc)+             <+> text ("(" <> show elapsed <> ")")+             <$$> renderError start level err++        BranchResult desc elapsed didFail results ->+          vcat [ "`-"+                 <+> (if didFail then "✘" else "✓")+                 <+> text (Text.unpack desc)+                 <+> text ("(" <> show elapsed <> ")")+               , renderTree start level results+               ]

@@ -0,0 +1,100 @@+-- This file has been generated from package.yaml by hpack version 0.15.0.+--+-- see: https://github.com/sol/hpack++name:           teardown+version:        0.0.0.1+synopsis:       Build composable, idempotent & transparent application cleanup sub-routines+description:    Please see README.md+category:       System+stability:      alpha (experimental)+homepage:       https://github.com/roman/Haskell-teardown#readme+bug-reports:    https://github.com/roman/Haskell-teardown/issues+author:         Roman Gonzalez+maintainer:     romanandreg@gmail.com+copyright:      © 2017 Roman Gonzalez+license:        MIT+license-file:   LICENSE+tested-with:    GHC==7.10.3 GHC==8.0.1 GHC==8.0.2+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    CHANGELOG.md+    README.md++source-repository head+  type: git+  location: https://github.com/roman/Haskell-teardown++library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.8 && <5+    , protolude >=0.1 && <0.2+    , text >=1.2 && <1.3+    , time >=1.5 && <1.7+    , ansi-wl-pprint >=0.6 && <0.7+  exposed-modules:+      Control.Teardown+  other-modules:+      Control.Teardown.Internal.Core+      Control.Teardown.Internal.Printer+  default-language: Haskell2010++test-suite teardown-doctest+  type: exitcode-stdio-1.0+  main-is: DocTest.hs+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.8 && <5+    , protolude >=0.1 && <0.2+    , text >=1.2 && <1.3+    , time >=1.5 && <1.7+    , doctest >=0.11 && <0.12+    , Glob >=0.7 && <0.8+    , QuickCheck >=2.8 && <2.10+    , teardown+  other-modules:+      TestSuite+  default-language: Haskell2010++test-suite teardown-test+  type: exitcode-stdio-1.0+  main-is: TestSuite.hs+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.8 && <5+    , protolude >=0.1 && <0.2+    , text >=1.2 && <1.3+    , time >=1.5 && <1.7+    , tasty >=0.11 && <0.12+    , tasty-hunit >=0.9 && <0.10+    , tasty-hspec >=1.1 && <1.2+    , tasty-smallcheck >=0.8 && <0.9+    , tasty-rerun >=1.1 && <1.2+    , teardown+  other-modules:+      DocTest+  default-language: Haskell2010++benchmark teardown-benchmark+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      benchmark+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.8 && <5+    , protolude >=0.1 && <0.2+    , text >=1.2 && <1.3+    , time >=1.5 && <1.7+    , criterion >=1.1 && <1.2+    , teardown+  default-language: Haskell2010

@@ -0,0 +1,7 @@+module Main where++import System.FilePath.Glob+import Test.DocTest++main :: IO ()+main = glob "src/**/*.hs" >>= doctest

@@ -0,0 +1,138 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Protolude++import Test.Tasty                   (TestTree, defaultMainWithIngredients, testGroup)+import Test.Tasty.HUnit+import Test.Tasty.Ingredients.Rerun (rerunningTests)+import Test.Tasty.Runners           (consoleTestReporter, listingTests)++import Control.Teardown+import Data.IORef       (atomicModifyIORef, newIORef, readIORef)++main :: IO ()+main =+  defaultMainWithIngredients+    [ rerunningTests [listingTests, consoleTestReporter] ]+    tests++tests :: TestTree+tests =+  testGroup "teardown"+  [+    testCase "idempotent execution of teardown action" $ do+      callCountRef <- newIORef (0 :: Int)+      teardownAction <- newTeardown "test cleanup" $+        atomicModifyIORef callCountRef (\a -> (succ a, ()))++      replicateM_ 10 (teardown teardownAction)+      callCount <- readIORef callCountRef+      assertEqual "teardown action got called more than once"+                  1 callCount++  , testCase "failing teardown action does not stop execution" $ do+      teardownAction <- newTeardown "failing teardown" $+        panic "failing teardown"++      result <- teardown teardownAction+      replicateM_ 9 (teardown teardownAction)++      assertBool "result should report an error"+                 (didTeardownFail result)++  , testCase "thread safe idempotent execution of teardown action" $ do+      callCountRef <- newIORef (0 :: Int)+      teardownAction <- newTeardown "test cleanup" $+        atomicModifyIORef callCountRef (\a -> (succ a, ()))++      asyncList <-+        replicateM 10 (async+                        -- each async executes teardown 3 times+                        $ replicateM_ 3+                        $ void $ teardown teardownAction)++      mapM_ wait asyncList+      callCount <- readIORef callCountRef+      assertEqual "teardown action must not be called more than once"+                  1 callCount++  , testCase "concatenated teardown actions keep idempotent guarantees" $ do+      callCountRefs <- replicateM 10 $ newIORef (0 :: Int)+      teardownActions <- forM callCountRefs $ \callCountRef ->+        newTeardown "test cleanup"+                    (atomicModifyIORef callCountRef (\a -> (succ a, ())))++      let+        teardownAction =+          concatTeardown "bigger system" teardownActions++      replicateM_ 10 (teardown teardownAction)++      countRefs <- mapM readIORef callCountRefs+      assertEqual "teardown action must not be called more than once"+                  (replicate 10 1)+                  countRefs++  , testCase "concatenated teardown actions return correct count" $ do+      teardownActions <-+        replicateM 10 (newTeardown "test cleanup" (return ()))++      let+        teardownAction =+          concatTeardown "bigger system" teardownActions++      toredownResult <- teardown teardownAction+      replicateM_ 9 (teardown teardownAction)++      assertEqual "teardown action must not be called more than once"+                  10 (toredownCount toredownResult)++  , testCase "concatenated failed teardown actions return correct count" $ do+      failedTeardownActions <-+        replicateM 5 (newTeardown "test cleanup with failures" (panic "nope"))++      teardownActions <-+        replicateM 5 (newTeardown "test cleanup" (return ()))++      let+        teardownAction =+          concatTeardown "bigger system"+                         (failedTeardownActions <> teardownActions)++      toredownResult <- teardown teardownAction+      replicateM_ 9 (teardown teardownAction)++      assertEqual "teardown action count must be correct"+                  10 (toredownCount toredownResult)++      assertEqual "failed teardown action must be correct"+                  5 (failedToredownCount toredownResult)++  , testCase "dynamic teardown behave similar to vanilla teardown" $ do+      callCountRef <- newIORef (0 :: Int)+      failedTeardownActions <-+        replicateM 5 (newTeardown "test cleanup with failures" (panic "nope"))++      teardownActions <-+        replicateM 5 (newTeardown "test cleanup"+                      (atomicModifyIORef callCountRef (\a -> (succ a, ()))))++      let+        teardownAction =+          newDynTeardown "bigger system" $+            mapM teardown (failedTeardownActions <> teardownActions)++      teardownResult <- teardown teardownAction+      replicateM_ 9 (teardown teardownAction)++      teardownSuccessCount <- readIORef callCountRef++      assertEqual "teardown action count must be correct"+                  10 (toredownCount teardownResult)++      assertEqual "teardown action must be idempotent"+                  5 teardownSuccessCount++  ]