Add separate demo-setup-teardown

cabal.project

@@ -20,6 +20,7 @@ packages:
   demos/demo-landing
   demos/demo-paralleln
   demos/demo-quickcheck
+  demos/demo-setup-teardown
   demos/demo-slack
   demos/demo-timing
   demos/demo-timing-parallel

demos/demo-setup-teardown/.gitignore

@@ -0,0 +1,2 @@
+.stack-work/
+*~

demos/demo-setup-teardown/LICENSE

@@ -0,0 +1,30 @@
+Copyright Tom McLaughlin (c) 2023
+
+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 Tom McLaughlin 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.

demos/demo-setup-teardown/app/Main.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NumericUnderscores #-}
+
+module Main where
+
+import Control.Concurrent
+import Control.Exception.Lifted
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Data.String.Interpolate
+import Test.Sandwich
+
+data DatabaseContext = MySQLDatabaseContext | SqliteDatabaseContext
+  deriving Show
+
+database = Label :: Label "database" DatabaseContext
+
+setupDatabase :: MonadIO m => ExampleT context m DatabaseContext
+setupDatabase = debug "Spinning up DB..." >> p 3 >> return MySQLDatabaseContext
+
+teardownDatabase :: MonadIO m => DatabaseContext -> ExampleT context m ()
+teardownDatabase db = debug "Tearing down DB..." >> p 2 >> return ()
+
+introduceDatabase = introduceWith "introduceWith database" database $ \action ->
+  bracket setupDatabase teardownDatabase (void . action)
+
+basic :: TopSpec
+basic = describe "Simple tests" $ do
+  before "Pauses" (p 3) $ do
+    it "adds" $ (2 + 2) `shouldBe` 4
+
+  introduceDatabase $ do
+    it "Uses the database" $ do
+      db <- getContext database
+      info [i|Got database: '#{db}'|]
+
+  introduce "introduce database" database setupDatabase teardownDatabase $ do
+    it "Uses the database" $ do
+      db <- getContext database
+      info [i|Got database: '#{db}'|]
+
+
+p :: (MonadIO m) => Double -> m ()
+p = liftIO . threadDelay . round . (* 1000000.0)
+
+main :: IO ()
+main = runSandwichWithCommandLineArgs defaultOptions basic

demos/demo-setup-teardown/demo-setup-teardown.cabal

@@ -0,0 +1,35 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.36.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           demo-setup-teardown
+version:        0.1.0.0
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+
+executable demo-basic
+  main-is: Main.hs
+  other-modules:
+      Paths_demo_setup_teardown
+  hs-source-dirs:
+      app
+  default-extensions:
+      OverloadedStrings
+      QuasiQuotes
+      NamedFieldPuns
+      RecordWildCards
+      ScopedTypeVariables
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base
+    , lifted-base
+    , monad-logger
+    , sandwich
+    , string-interpolate
+  default-language: Haskell2010

demos/demo-setup-teardown/package.yaml

@@ -0,0 +1,30 @@
+name:                demo-setup-teardown
+version:             0.1.0.0
+license:             BSD3
+
+dependencies:
+- base
+- lifted-base
+- monad-logger
+- sandwich
+- string-interpolate
+
+default-extensions:
+- OverloadedStrings
+- QuasiQuotes
+- NamedFieldPuns
+- RecordWildCards
+- ScopedTypeVariables
+- FlexibleContexts
+- FlexibleInstances
+- LambdaCase
+
+ghc-options:
+- -threaded
+- -rtsopts
+- -with-rtsopts=-N
+
+executables:
+  demo-basic:
+    main: Main.hs
+    source-dirs: app

stack.yaml

@@ -28,6 +28,7 @@ packages:
 - ./demos/demo-landing
 - ./demos/demo-paralleln
 - ./demos/demo-quickcheck
+- ./demos/demo-setup-teardown
 - ./demos/demo-slack
 - ./demos/demo-stack-test
 - ./demos/demo-timing