diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for rio-orphans + +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 Michael Snoyman + +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +# rio-orphans + +Provides orphan instances for the `RIO` data type. Currently supports: + +* `MonadCatch` and `MonadMask` from `exceptions` +* `MonadBase` from `transformers-base` +* `MonadBaseControl` from `monad-control` +* `MonadResource` from `resourcet` 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/rio-orphans.cabal b/rio-orphans.cabal new file mode 100644 --- /dev/null +++ b/rio-orphans.cabal @@ -0,0 +1,62 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: a68a1341535748f5bf8f2fa1202835ba7a858683f5349848561893fd880e7824 + +name: rio-orphans +version: 0.1.0.0 +synopsis: Orphan instances for the RIO type in the rio package +description: See README and Haddocks at +category: Control +homepage: https://github.com/commercialhaskell/rio#readme +bug-reports: https://github.com/commercialhaskell/rio/issues +author: Michael Snoyman +maintainer: michael@snoyman.com +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/commercialhaskell/rio + +library + exposed-modules: + RIO.Orphans + other-modules: + Paths_rio_orphans + hs-source-dirs: + src + build-depends: + base >=4.9 && <10 + , exceptions + , monad-control + , resourcet + , rio + , transformers-base + default-language: Haskell2010 + +test-suite rio-orphans-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + RIO.OrphansSpec + Paths_rio_orphans + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.9 && <10 + , exceptions + , hspec + , monad-control + , resourcet + , rio + , rio-orphans + , transformers-base + default-language: Haskell2010 diff --git a/src/RIO/Orphans.hs b/src/RIO/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Orphans.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Orphan instances for the 'RIO' data type. +module RIO.Orphans + ( HasResourceMap (..) + , ResourceMap + , withResourceMap + ) where + +import RIO +import Control.Monad.Catch (MonadCatch, MonadMask) +import Control.Monad.Base (MonadBase) +import Control.Monad.Trans.Resource.Internal (MonadResource (..), ReleaseMap, ResourceT (..)) +import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Trans.Control (MonadBaseControl (..)) + +-- | @since 0.1.0.0 +deriving instance MonadCatch (RIO env) + +-- | @since 0.1.0.0 +deriving instance MonadMask (RIO env) + +-- | @since 0.1.0.0 +deriving instance MonadBase IO (RIO env) + +-- | @since 0.1.0.0 +instance MonadBaseControl IO (RIO env) where + type StM (RIO env) a = a + + liftBaseWith = withRunInIO + restoreM = return + +-- | A collection of all of the registered resource cleanup actions. +-- +-- @since 0.1.0.0 +type ResourceMap = IORef ReleaseMap + +-- | Perform an action with a 'ResourceMap' +-- +-- @since 0.1.0.0 +withResourceMap :: MonadUnliftIO m => (ResourceMap -> m a) -> m a +withResourceMap inner = + withRunInIO $ \run -> runResourceT $ ResourceT $ run . inner + +-- | An environment with a 'ResourceMap' +-- +-- @since 0.1.0.0 +class HasResourceMap env where + resourceMapL :: Lens' env ResourceMap +instance HasResourceMap (IORef ReleaseMap) where + resourceMapL = id +instance HasResourceMap env => MonadResource (RIO env) where + liftResourceT (ResourceT f) = view resourceMapL >>= liftIO . f + diff --git a/test/RIO/OrphansSpec.hs b/test/RIO/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/RIO/OrphansSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module RIO.OrphansSpec (spec) where + +import Test.Hspec +import RIO +import RIO.Orphans +import Control.Monad.Trans.Resource + +spec :: Spec +spec = do + it "success" $ do + ref <- newIORef False + withResourceMap $ \rm -> runRIO rm $ do + void $ register $ writeIORef ref True + readIORef ref `shouldReturn` True + it "exceptions" $ do + ref <- newIORef False + void $ tryAny $ withResourceMap $ \rm -> runRIO rm $ do + void $ register $ writeIORef ref True + throwString "ignored" + readIORef ref `shouldReturn` True + it "no release" $ do + ref <- newIORef False + void $ tryAny $ withResourceMap $ \rm -> runRIO rm $ do + () <- throwString "ignored" + writeIORef ref True + readIORef ref `shouldReturn` False diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}