diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright John Ky (c) 2016-2021 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# hw-lazy + +Report dependency build errors: https://github.com/haskell-infra/hackage-trustees 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/doctest/DoctestDriver.hs b/doctest/DoctestDriver.hs new file mode 100644 --- /dev/null +++ b/doctest/DoctestDriver.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE CPP #-} + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,4,0) +{-# OPTIONS_GHC -F -pgmF doctest-discover #-} +#else +module Main where + +import qualified System.IO as IO + +main :: IO () +main = IO.putStrLn "WARNING: doctest will not run on GHC versions earlier than 8.4.4" +#endif diff --git a/hw-lazy.cabal b/hw-lazy.cabal new file mode 100644 --- /dev/null +++ b/hw-lazy.cabal @@ -0,0 +1,75 @@ +cabal-version: 2.2 + +name: hw-lazy +version: 0.0.0.1 +synopsis: Combinators for lazy IO +description: Combinators for lazy IO. +category: Data +stability: Experimental +homepage: http://github.com/haskell-works/hw-lazy#readme +bug-reports: https://github.com/haskell-works/hw-lazy/issues +author: John Ky +maintainer: newhoggy@gmail.com +copyright: 2016-2021 John Ky +license: BSD-3-Clause +license-file: LICENSE +tested-with: GHC == 9.2.2, GHC == 8.10.7, GHC == 8.8.4, GHC == 8.6.5 +build-type: Simple +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/haskell-works/hw-lazy + +common base { build-depends: base >= 4.11 && < 5 } + +common deepseq { build-depends: deepseq >= 1.4 && < 1.5 } +common doctest { build-depends: doctest >= 0.16.2 && < 0.21 } +common doctest-discover { build-depends: doctest-discover >= 0.2 && < 0.3 } +common hedgehog { build-depends: hedgehog >= 1.0 && < 1.2 } +common hspec { build-depends: hspec >= 2.4 && < 3 } +common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1 && < 0.2 } +common stm { build-depends: stm >= 2.5.0.2 && < 3 } +common unliftio-core { build-depends: unliftio-core >= 0.1.2.0 && < 0.3 } + +common hw-lazy + build-depends: hw-lazy + +common config + default-language: Haskell2010 + ghc-options: -Wall + +library + import: base, config, + deepseq, + unliftio-core, + exposed-modules: HaskellWorks.Control.Monad.Lazy + other-modules: Paths_hw_lazy + autogen-modules: Paths_hw_lazy + hs-source-dirs: src + +test-suite hw-lazy-test + import: base, config, + hedgehog, + hspec, + hw-hspec-hedgehog, + hw-lazy, + stm, + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: HaskellWorks.Control.Monad.LazySpec + hs-source-dirs: test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: hspec-discover:hspec-discover + +test-suite doctest + import: base, config, + doctest, + doctest-discover, + hw-lazy + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + main-is: DoctestDriver.hs + HS-Source-Dirs: doctest + build-tool-depends: doctest-discover:doctest-discover diff --git a/src/HaskellWorks/Control/Monad/Lazy.hs b/src/HaskellWorks/Control/Monad/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Control/Monad/Lazy.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BangPatterns #-} + +module HaskellWorks.Control.Monad.Lazy + ( replicateM + , sequenceM + , unfoldrM + , traverseM + , forM + , forceM + ) where + +import Control.DeepSeq +import Control.Monad ((<$!>)) +import Control.Monad.IO.Unlift + +import qualified System.IO.Unsafe as IO + +replicateM :: MonadUnliftIO m => Int -> m a -> m [a] +replicateM n f = sequenceM (replicate n f) + +sequenceM :: MonadUnliftIO m => [m a] -> m [a] +sequenceM as = do + f <- askUnliftIO + liftIO $ sequenceIO (fmap (unliftIO f) as) + +-- | Generates a lazy list of values that are produced by a given monadic function. +-- +-- This function is intended to be like the "standard" 'unfoldrM' except +-- that the list is generated lazily. +unfoldrM :: MonadUnliftIO m => (b -> m (Maybe (a, b))) -> b -> m [a] +unfoldrM f z = do + u <- askUnliftIO + liftIO $ IO.unsafeInterleaveIO (go u z) + where + go !u !b = do + m <- unliftIO u (f b) + case m of + Nothing -> pure [] + Just (!a, b') -> do + rest <- IO.unsafeInterleaveIO (go u b') + pure (a:rest) + +-- | Traverses the function over the list and produces a lazy list in a +-- monadic context. +-- +-- It is intended to be like the "standard" 'traverse' except +-- that the list is generated lazily. +traverseM :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b] +traverseM f as = do + u <- askUnliftIO + liftIO $ IO.unsafeInterleaveIO (go u as) + where + go _ [] = pure [] + go !u (v:vs) = do + !res <- unliftIO u (f v) + rest <- IO.unsafeInterleaveIO (go u vs) + pure (res:rest) + +forM :: MonadUnliftIO m => [a] -> (a -> m b) -> m [b] +forM = flip traverseM + +forceM :: (Monad m, NFData a) => m a -> m a +forceM = (force <$!>) + +-- Internal +sequenceIO :: [IO a] -> IO [a] +sequenceIO = IO.unsafeInterleaveIO . go + where go :: [IO a] -> IO [a] + go [] = return [] + go (fa:fas) = (:) <$> fa <*> IO.unsafeInterleaveIO (go fas) diff --git a/test/HaskellWorks/Control/Monad/LazySpec.hs b/test/HaskellWorks/Control/Monad/LazySpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Control/Monad/LazySpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BangPatterns #-} + +module HaskellWorks.Control.Monad.LazySpec (spec) where + +import Control.Monad.IO.Class +import Hedgehog +import Prelude hiding (log) +import Test.Hspec + +import qualified Control.Concurrent.STM as STM +import qualified HaskellWorks.Control.Monad.Lazy as LZ +import qualified HaskellWorks.Hspec.Hedgehog as H + +{- HLINT ignore "Redundant do" -} + +spec :: Spec +spec = describe "HaskellWorks.Control.Monad.LazySpec" $ do + it "Be able to load file into Vector" $ H.requireTest $ do + tvLog <- liftIO $ STM.newTVarIO [] + as <- liftIO $ LZ.replicateM 3 $ STM.atomically $ STM.modifyTVar tvLog (():) + liftIO (STM.atomically (STM.readTVar tvLog)) >>= do \log -> log === [] + let !(():_) = as + liftIO (STM.atomically (STM.readTVar tvLog)) >>= do \log -> log === [()] + let !(():():_) = as + liftIO (STM.atomically (STM.readTVar tvLog)) >>= do \log -> log === [(), ()] + let !(():():():_) = as + liftIO (STM.atomically (STM.readTVar tvLog)) >>= do \log -> log === [(), (), ()] + as === [(), (), ()] 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 #-}