├── .github └── workflows │ ├── cd.yaml │ └── ci.yaml ├── LICENSE ├── cabal.project ├── htf-test └── Main.hs ├── library ├── ListT.hs └── ListT │ └── Prelude.hs └── list-t.cabal /.github/workflows/cd.yaml: -------------------------------------------------------------------------------- 1 | name: Release the lib to Hackage 2 | 3 | on: 4 | push: 5 | branches: 6 | - supermajor 7 | - major 8 | - minor 9 | - patch 10 | 11 | concurrency: 12 | group: cd 13 | cancel-in-progress: false 14 | 15 | jobs: 16 | 17 | ci: 18 | uses: ./.github/workflows/ci.yaml 19 | secrets: inherit 20 | 21 | cd: 22 | needs: 23 | - ci 24 | runs-on: ubuntu-latest 25 | steps: 26 | - uses: actions/checkout@v3 27 | 28 | - name: Release 29 | uses: nikita-volkov/release-haskell-package.github-action@v1.2.0 30 | with: 31 | hackage-token: ${{ secrets.HACKAGE_TOKEN }} 32 | version-bump-place: ${{ fromJSON('{"supermajor":0,"major":1,"minor":2,"patch":3}')[github.ref_name] }} 33 | main-branch: master 34 | prefix-tag-with-v: true 35 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: Compile, test and check the docs 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | workflow_call: 9 | 10 | jobs: 11 | 12 | format: 13 | 14 | runs-on: ubuntu-latest 15 | 16 | steps: 17 | - uses: actions/checkout@v3 18 | - uses: nikita-volkov/cabal-fmt.github-action@v1.0.0 19 | - uses: nikita-volkov/ormolu.github-action@v1.0.0 20 | - name: Commit the changes 21 | uses: stefanzweifel/git-auto-commit-action@v5 22 | with: 23 | commit_message: Format 24 | 25 | build-and-test: 26 | 27 | needs: 28 | - format 29 | 30 | strategy: 31 | fail-fast: false 32 | matrix: 33 | include: 34 | - ghc: '8.8.4' 35 | - ghc: '9.6.3' 36 | ghc-options: -Werror -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Wunused-packages -Wno-name-shadowing -Wno-unused-matches -Wno-unused-do-bind -Wno-type-defaults 37 | - ghc: '9.8.1' 38 | 39 | runs-on: ubuntu-latest 40 | 41 | steps: 42 | 43 | - uses: actions/checkout@v3 44 | 45 | - name: Setup Haskell 46 | uses: haskell-actions/setup@v2 47 | with: 48 | ghc-version: ${{ matrix.ghc }} 49 | cabal-version: 3.8 50 | 51 | - name: Generate cabal.project.freeze 52 | run: cabal freeze --enable-tests --enable-benchmarks 53 | 54 | - uses: actions/cache@v3 55 | with: 56 | path: | 57 | ~/.cabal/store 58 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 59 | restore-keys: | 60 | ${{ runner.os }}-${{ matrix.ghc }}- 61 | 62 | - name: Install HTF 63 | run: cabal install HTF --overwrite-policy=always 64 | 65 | - name: Install deps and compile 66 | run: cabal build --enable-tests -j +RTS -A128m -n2m -N -RTS --ghc-options="${{ matrix.ghc-options }}" 67 | 68 | - name: Test 69 | run: cabal test --test-show-details always 70 | 71 | - name: Run Haddock 72 | run: cabal haddock 73 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Nikita Volkov 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | if impl(ghc >= 9.8) 4 | constraints: 5 | , primitive >= 0.5 6 | , text >= 2.1 7 | 8 | allow-newer: 9 | , *:base 10 | , *:bytestring 11 | , *:deepseq 12 | , *:text 13 | -------------------------------------------------------------------------------- /htf-test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp -Wno-redundant-constraints #-} 2 | 3 | import BasePrelude hiding (toList) 4 | import Control.Monad.Morph 5 | import qualified ListT as L 6 | import MTLPrelude 7 | import Test.Framework 8 | 9 | main :: IO () 10 | main = htfMain htf_thisModulesTests 11 | 12 | -- * MMonad 13 | 14 | -- embed lift = id 15 | prop_mmonadLaw1 :: [Int] -> Bool 16 | prop_mmonadLaw1 (l :: [Int]) = 17 | let s = L.fromFoldable l 18 | in runIdentity $ streamsEqual s (embed lift s) 19 | 20 | -- embed f (lift m) = f m 21 | prop_mmonadLaw2 :: [Int] -> Bool 22 | prop_mmonadLaw2 l = 23 | let s = (L.fromFoldable :: [Int] -> L.ListT Identity Int) l 24 | f = MaybeT . fmap Just 25 | run = runIdentity . L.toList . runMaybeT 26 | in run (f s) 27 | == run (embed f (lift s)) 28 | 29 | -- * Applicative 30 | 31 | prop_applicativeIdentityLaw :: [Int] -> Bool 32 | prop_applicativeIdentityLaw (l :: [Int]) = 33 | runIdentity $ streamsEqual (pure id <*> s) s 34 | where 35 | s = L.fromFoldable l 36 | 37 | prop_applicativeBehavesLikeList :: [Int] -> Bool 38 | prop_applicativeBehavesLikeList = 39 | \(ns :: [Int]) -> 40 | let a = fs <*> ns 41 | b = runIdentity (toList $ L.fromFoldable fs <*> L.fromFoldable ns) 42 | in a == b 43 | where 44 | fs = [(+ 1), (+ 3), (+ 5)] 45 | 46 | -- * Monad 47 | 48 | test_monadLaw1 :: IO () 49 | test_monadLaw1 = 50 | assertBool =<< streamsEqual (return a >>= k) (k a) 51 | where 52 | a = 2 53 | k a = return $ chr a 54 | 55 | test_monadLaw2 :: IO () 56 | test_monadLaw2 = 57 | assertBool =<< streamsEqual (m >>= return) m 58 | where 59 | m = L.fromFoldable ['a' .. 'z'] 60 | 61 | test_monadLaw3 :: IO () 62 | test_monadLaw3 = 63 | assertBool =<< streamsEqual (m >>= (\x -> k x >>= h)) ((m >>= k) >>= h) 64 | where 65 | m = L.fromFoldable ['a' .. 'z'] 66 | k a = return $ ord a 67 | h a = return $ a + 1 68 | 69 | test_monadLaw4 :: IO () 70 | test_monadLaw4 = 71 | assertBool =<< streamsEqual (fmap f xs) (xs >>= return . f) 72 | where 73 | f = ord 74 | xs = L.fromFoldable ['a' .. 'z'] 75 | 76 | -- * Monoid 77 | 78 | test_mappend :: IO () 79 | test_mappend = 80 | assertBool 81 | =<< streamsEqual 82 | (L.fromFoldable [0 .. 7]) 83 | (L.fromFoldable [0 .. 3] <> L.fromFoldable [4 .. 7]) 84 | 85 | test_mappendAndTake :: IO () 86 | test_mappendAndTake = 87 | assertBool 88 | =<< streamsEqual 89 | (L.fromFoldable [0 .. 5]) 90 | (L.take 6 $ L.fromFoldable [0 .. 3] <> L.fromFoldable [4 .. 7]) 91 | 92 | test_mappendDoesntCauseTraversal :: IO () 93 | test_mappendDoesntCauseTraversal = 94 | do 95 | ref <- newIORef 0 96 | (flip runReaderT) ref (toList $ L.take 5 $ stream <> stream) 97 | assertEqual 5 =<< readIORef ref 98 | where 99 | stream = 100 | do 101 | ref <- lift $ ask 102 | x <- L.fromFoldable [0 .. 4] 103 | liftIO $ modifyIORef ref (+ 1) 104 | return x 105 | 106 | -- * Other 107 | 108 | test_repeat :: IO () 109 | test_repeat = 110 | assertEqual [2, 2, 2] =<< do 111 | toList $ L.take 3 $ L.repeat (2 :: Int) 112 | 113 | test_traverseDoesntCauseTraversal :: IO () 114 | test_traverseDoesntCauseTraversal = 115 | do 116 | ref <- newIORef 0 117 | (flip runReaderT) ref (toList stream3) 118 | assertEqual 3 =<< readIORef ref 119 | where 120 | stream1 = 121 | do 122 | ref <- lift $ ask 123 | x <- L.fromFoldable ['a' .. 'z'] 124 | liftIO $ modifyIORef ref (+ 1) 125 | return x 126 | stream2 = 127 | L.traverse (return . toUpper) stream1 128 | stream3 = 129 | L.take 3 stream2 130 | 131 | test_takeDoesntCauseTraversal :: IO () 132 | test_takeDoesntCauseTraversal = 133 | do 134 | ref <- newIORef 0 135 | (flip runReaderT) ref (toList $ L.take 3 $ L.take 7 $ stream) 136 | assertEqual 3 =<< readIORef ref 137 | where 138 | stream = 139 | do 140 | ref <- lift $ ask 141 | x <- L.fromFoldable [0 .. 10] 142 | liftIO $ modifyIORef ref (+ 1) 143 | return x 144 | 145 | test_drop :: IO () 146 | test_drop = 147 | assertEqual [3, 4] =<< do 148 | toList $ L.drop 2 $ L.fromFoldable [1 .. 4] 149 | 150 | test_slice :: IO () 151 | test_slice = 152 | assertEqual ["abc", "def", "gh"] =<< do 153 | toList $ L.slice 3 $ L.fromFoldable ("abcdefgh" :: [Char]) 154 | 155 | toList :: (Monad m) => L.ListT m a -> m [a] 156 | toList = L.toList 157 | 158 | streamsEqual :: (Applicative m, Monad m, Eq a) => L.ListT m a -> L.ListT m a -> m Bool 159 | streamsEqual a b = 160 | (==) <$> L.toList a <*> L.toList b 161 | -------------------------------------------------------------------------------- /library/ListT.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-dodgy-imports #-} 2 | 3 | module ListT 4 | ( ListT (..), 5 | 6 | -- * Execution utilities 7 | uncons, 8 | head, 9 | tail, 10 | null, 11 | alternate, 12 | alternateHoisting, 13 | fold, 14 | foldMaybe, 15 | applyFoldM, 16 | toList, 17 | toReverseList, 18 | traverse_, 19 | splitAt, 20 | 21 | -- * Construction utilities 22 | cons, 23 | fromFoldable, 24 | fromMVar, 25 | unfold, 26 | unfoldM, 27 | repeat, 28 | 29 | -- * Transformation utilities 30 | 31 | -- | 32 | -- These utilities only accumulate the transformations 33 | -- without actually traversing the stream. 34 | -- They only get applied in a single traversal, 35 | -- which only happens at the execution. 36 | traverse, 37 | take, 38 | drop, 39 | slice, 40 | ) 41 | where 42 | 43 | import ListT.Prelude hiding (drop, fold, head, null, repeat, splitAt, tail, take, toList, traverse, traverse_, uncons, yield) 44 | 45 | -- | 46 | -- A proper implementation of the list monad-transformer. 47 | -- Useful for streaming of monadic data structures. 48 | -- 49 | -- Since it has instances of 'MonadPlus' and 'Alternative', 50 | -- you can use general utilities packages like 51 | -- 52 | -- with it. 53 | newtype ListT m a 54 | = ListT (m (Maybe (a, ListT m a))) 55 | deriving (Foldable, Traversable, Generic) 56 | 57 | deriving instance (Show (m (Maybe (a, ListT m a)))) => Show (ListT m a) 58 | 59 | deriving instance (Read (m (Maybe (a, ListT m a)))) => Read (ListT m a) 60 | 61 | deriving instance (Eq (m (Maybe (a, ListT m a)))) => Eq (ListT m a) 62 | 63 | deriving instance (Ord (m (Maybe (a, ListT m a)))) => Ord (ListT m a) 64 | 65 | deriving instance (Typeable m, Typeable a, Data (m (Maybe (a, ListT m a)))) => Data (ListT m a) 66 | 67 | instance (Eq1 m) => Eq1 (ListT m) where 68 | liftEq eq = go 69 | where 70 | go (ListT m) (ListT n) = liftEq (liftEq (\(a, as) (b, bs) -> eq a b && go as bs)) m n 71 | 72 | instance (Ord1 m) => Ord1 (ListT m) where 73 | liftCompare cmp = go 74 | where 75 | go (ListT m) (ListT n) = liftCompare (liftCompare (\(a, as) (b, bs) -> cmp a b <> go as bs)) m n 76 | 77 | instance (Show1 m) => Show1 (ListT m) where 78 | -- I wish I were joking. 79 | liftShowsPrec sp (sl :: [a] -> ShowS) = mark 80 | where 81 | bob :: Int -> m (Maybe (a, ListT m a)) -> ShowS 82 | bob = liftShowsPrec jill edith 83 | 84 | edith :: [Maybe (a, ListT m a)] -> ShowS 85 | edith = liftShowList jack martha 86 | 87 | jill :: Int -> Maybe (a, ListT m a) -> ShowS 88 | jill = liftShowsPrec jack martha 89 | 90 | martha :: [(a, ListT m a)] -> ShowS 91 | martha = liftShowList2 sp sl mark juan 92 | 93 | mark :: Int -> ListT m a -> ShowS 94 | mark d (ListT m) = showsUnaryWith bob "ListT" d m 95 | 96 | juan :: [ListT m a] -> ShowS 97 | juan = liftShowList sp sl 98 | 99 | jack :: Int -> (a, ListT m a) -> ShowS 100 | jack = liftShowsPrec2 sp sl mark juan 101 | 102 | instance (Monad m) => Semigroup (ListT m a) where 103 | (<>) (ListT m1) (ListT m2) = 104 | ListT $ 105 | m1 106 | >>= \case 107 | Nothing -> 108 | m2 109 | Just (h1, s1') -> 110 | return (Just (h1, ((<>) s1' (ListT m2)))) 111 | 112 | instance (Monad m) => Monoid (ListT m a) where 113 | mempty = 114 | ListT $ 115 | return Nothing 116 | mappend = (<>) 117 | 118 | instance (Functor m) => Functor (ListT m) where 119 | fmap f = go 120 | where 121 | go = 122 | ListT . (fmap . fmap) (bimapPair' f go) . uncons 123 | 124 | instance (Monad m, Functor m) => Applicative (ListT m) where 125 | pure a = 126 | ListT $ return (Just (a, (ListT (return Nothing)))) 127 | (<*>) = 128 | ap 129 | 130 | -- This is just like liftM2, but it uses fmap over the second 131 | -- action. liftM2 can't do that, because it has to deal with 132 | -- the possibility that someone defines liftA2 = liftM2 and 133 | -- fmap f = (pure f <*>) (leaving (<*>) to the default). 134 | liftA2 f m1 m2 = do 135 | x1 <- m1 136 | fmap (f x1) m2 137 | 138 | instance (Monad m, Functor m) => Alternative (ListT m) where 139 | empty = 140 | inline mempty 141 | (<|>) = 142 | inline mappend 143 | 144 | instance (Monad m) => Monad (ListT m) where 145 | return = pure 146 | 147 | -- We use a go function so GHC can inline k2 148 | -- if it likes. 149 | (>>=) s10 k2 = go s10 150 | where 151 | go s1 = 152 | ListT $ 153 | uncons s1 154 | >>= \case 155 | Nothing -> 156 | return Nothing 157 | Just (h1, t1) -> 158 | uncons $ k2 h1 <> go t1 159 | 160 | instance (Monad m) => MonadFail (ListT m) where 161 | fail _ = 162 | inline mempty 163 | 164 | instance (Monad m) => MonadPlus (ListT m) where 165 | mzero = 166 | inline mempty 167 | mplus = 168 | inline mappend 169 | 170 | instance MonadTrans ListT where 171 | lift = 172 | ListT . fmap (\a -> Just (a, mempty)) 173 | 174 | instance (MonadIO m) => MonadIO (ListT m) where 175 | liftIO = 176 | lift . liftIO 177 | 178 | instance MFunctor ListT where 179 | hoist f = go 180 | where 181 | go (ListT run) = 182 | ListT . f $ 183 | run <&> \case 184 | Just (elem, next) -> Just (elem, go next) 185 | Nothing -> Nothing 186 | 187 | instance MMonad ListT where 188 | embed f (ListT m) = 189 | f m >>= \case 190 | Nothing -> mzero 191 | Just (h, t) -> ListT $ return $ Just $ (h, embed f t) 192 | 193 | instance (MonadBase b m) => MonadBase b (ListT m) where 194 | liftBase = 195 | lift . liftBase 196 | 197 | instance (MonadBaseControl b m) => MonadBaseControl b (ListT m) where 198 | type 199 | StM (ListT m) a = 200 | StM m (Maybe (a, ListT m a)) 201 | liftBaseWith runToBase = 202 | lift $ 203 | liftBaseWith $ \runInner -> 204 | runToBase $ runInner . uncons 205 | restoreM inner = 206 | lift (restoreM inner) >>= \case 207 | Nothing -> mzero 208 | Just (h, t) -> cons h t 209 | 210 | instance (MonadError e m) => MonadError e (ListT m) where 211 | throwError = ListT . throwError 212 | catchError m handler = ListT $ catchError (uncons m) $ uncons . handler 213 | 214 | instance (MonadReader e m) => MonadReader e (ListT m) where 215 | ask = lift ask 216 | reader = lift . reader 217 | local r = go 218 | where 219 | go (ListT m) = ListT $ local r (fmap (fmap (secondPair' go)) m) 220 | 221 | instance (MonadState e m) => MonadState e (ListT m) where 222 | get = lift get 223 | put = lift . put 224 | state = lift . state 225 | 226 | instance (Monad m) => MonadLogic (ListT m) where 227 | msplit (ListT m) = lift m 228 | 229 | interleave m1 m2 = 230 | ListT $ 231 | uncons m1 >>= \case 232 | Nothing -> uncons m2 233 | Just (a, m1') -> uncons $ cons a (interleave m2 m1') 234 | 235 | m >>- f = 236 | ListT $ 237 | uncons m >>= \case 238 | Nothing -> uncons empty 239 | Just (a, m') -> uncons $ interleave (f a) (m' >>- f) 240 | 241 | ifte t th el = 242 | ListT $ 243 | uncons t >>= \case 244 | Nothing -> uncons el 245 | Just (a, m) -> uncons $ th a <|> (m >>= th) 246 | 247 | once (ListT m) = 248 | ListT $ 249 | m >>= \case 250 | Nothing -> uncons empty 251 | Just (a, _) -> uncons (return a) 252 | 253 | lnot (ListT m) = 254 | ListT $ 255 | m >>= \case 256 | Nothing -> uncons (return ()) 257 | Just _ -> uncons empty 258 | 259 | instance (MonadZip m) => MonadZip (ListT m) where 260 | mzipWith f = go 261 | where 262 | go (ListT m1) (ListT m2) = 263 | ListT $ 264 | mzipWith 265 | ( mzipWith $ 266 | \(a, as) (b, bs) -> (f a b, go as bs) 267 | ) 268 | m1 269 | m2 270 | 271 | munzip (ListT m) 272 | | (l, r) <- munzip (fmap go m) = 273 | (ListT l, ListT r) 274 | where 275 | go Nothing = (Nothing, Nothing) 276 | go (Just ((a, b), listab)) = 277 | (Just (a, la), Just (b, lb)) 278 | where 279 | -- If the underlying munzip is careful not to leak memory, then we 280 | -- don't want to defeat it. We need to be sure that la and lb are 281 | -- realized as selector thunks. 282 | {-# NOINLINE remains #-} 283 | {-# NOINLINE la #-} 284 | {-# NOINLINE lb #-} 285 | remains = munzip listab 286 | (la, lb) = remains 287 | 288 | -- * Execution in the inner monad 289 | 290 | ------------------------- 291 | 292 | -- | 293 | -- Execute in the inner monad, 294 | -- getting the head and the tail. 295 | -- Returns nothing if it's empty. 296 | uncons :: ListT m a -> m (Maybe (a, ListT m a)) 297 | uncons (ListT m) = 298 | m 299 | 300 | -- | 301 | -- Execute, getting the head. Returns nothing if it's empty. 302 | {-# INLINEABLE head #-} 303 | head :: (Monad m) => ListT m a -> m (Maybe a) 304 | head = 305 | fmap (fmap fst) . uncons 306 | 307 | -- | 308 | -- Execute, getting the tail. Returns nothing if it's empty. 309 | {-# INLINEABLE tail #-} 310 | tail :: (Monad m) => ListT m a -> m (Maybe (ListT m a)) 311 | tail = 312 | fmap (fmap snd) . uncons 313 | 314 | -- | 315 | -- Execute, checking whether it's empty. 316 | {-# INLINEABLE null #-} 317 | null :: (Monad m) => ListT m a -> m Bool 318 | null = 319 | fmap (maybe True (const False)) . uncons 320 | 321 | -- | 322 | -- Execute in the inner monad, 323 | -- using its '(<|>)' function on each entry. 324 | {-# INLINEABLE alternate #-} 325 | alternate :: (Alternative m, Monad m) => ListT m a -> m a 326 | alternate (ListT m) = 327 | m >>= \case 328 | Nothing -> empty 329 | Just (a, as) -> pure a <|> alternate as 330 | 331 | -- | 332 | -- Use a monad morphism to convert a 'ListT' to a similar 333 | -- monad, such as '[]'. 334 | -- 335 | -- A more efficient alternative to @'alternate' . 'hoist' f@. 336 | {-# INLINEABLE alternateHoisting #-} 337 | alternateHoisting :: (Monad n, Alternative n) => (forall a. m a -> n a) -> ListT m a -> n a 338 | alternateHoisting f = go 339 | where 340 | go (ListT m) = 341 | f m >>= \case 342 | Nothing -> empty 343 | Just (a, as) -> pure a <|> go as 344 | 345 | -- | 346 | -- Execute, applying a strict left fold. 347 | {-# INLINEABLE fold #-} 348 | fold :: (Monad m) => (b -> a -> m b) -> b -> ListT m a -> m b 349 | fold step = go 350 | where 351 | go !acc (ListT run) = 352 | run >>= \case 353 | Just (element, next) -> do 354 | acc' <- step acc element 355 | go acc' next 356 | Nothing -> 357 | return acc 358 | 359 | -- | 360 | -- A version of 'fold', which allows early termination. 361 | {-# INLINEABLE foldMaybe #-} 362 | foldMaybe :: (Monad m) => (b -> a -> m (Maybe b)) -> b -> ListT m a -> m b 363 | foldMaybe s r l = 364 | fmap (maybe r id) $ 365 | runMaybeT $ do 366 | (h, t) <- MaybeT $ uncons l 367 | r' <- MaybeT $ s r h 368 | lift $ foldMaybe s r' t 369 | 370 | -- | 371 | -- Apply the left fold abstraction from the \"foldl\" package. 372 | applyFoldM :: (Monad m) => FoldM m i o -> ListT m i -> m o 373 | applyFoldM (FoldM step init extract) lt = do 374 | a <- init 375 | b <- fold step a lt 376 | extract b 377 | 378 | -- | 379 | -- Execute, folding to a list. 380 | {-# INLINEABLE toList #-} 381 | toList :: (Monad m) => ListT m a -> m [a] 382 | toList = 383 | fmap reverse . toReverseList 384 | 385 | -- | 386 | -- Execute, folding to a list in the reverse order. 387 | -- Performs more efficiently than 'toList'. 388 | {-# INLINEABLE toReverseList #-} 389 | toReverseList :: (Monad m) => ListT m a -> m [a] 390 | toReverseList = 391 | fold (\list element -> return (element : list)) [] 392 | 393 | -- | 394 | -- Execute, traversing the stream with a side effect in the inner monad. 395 | {-# INLINEABLE traverse_ #-} 396 | traverse_ :: (Monad m) => (a -> m ()) -> ListT m a -> m () 397 | traverse_ f = 398 | fold (const f) () 399 | 400 | -- | 401 | -- Execute, consuming a list of the specified length and returning the remainder stream. 402 | {-# INLINEABLE splitAt #-} 403 | splitAt :: (Monad m) => Int -> ListT m a -> m ([a], ListT m a) 404 | splitAt = 405 | \case 406 | n | n > 0 -> \l -> 407 | uncons l >>= \case 408 | Nothing -> return ([], mzero) 409 | Just (h, t) -> do 410 | (r1, r2) <- splitAt (pred n) t 411 | return (h : r1, r2) 412 | _ -> \l -> 413 | return ([], l) 414 | 415 | -- * Construction 416 | 417 | ------------------------- 418 | 419 | -- | 420 | -- Prepend an element. 421 | cons :: (Monad m) => a -> ListT m a -> ListT m a 422 | cons h t = 423 | ListT $ return (Just (h, t)) 424 | 425 | -- | 426 | -- Construct from any foldable. 427 | {-# INLINEABLE fromFoldable #-} 428 | fromFoldable :: (Monad m, Foldable f) => f a -> ListT m a 429 | fromFoldable = 430 | foldr cons mzero 431 | 432 | -- | 433 | -- Construct from an MVar, interpreting the value of Nothing as the end. 434 | fromMVar :: (MonadIO m) => MVar (Maybe a) -> ListT m a 435 | fromMVar v = 436 | fix $ \loop -> liftIO (takeMVar v) >>= maybe mzero (flip cons loop) 437 | 438 | -- | 439 | -- Construct by unfolding a pure data structure. 440 | {-# INLINEABLE unfold #-} 441 | unfold :: (Monad m) => (b -> Maybe (a, b)) -> b -> ListT m a 442 | unfold f s = 443 | maybe mzero (\(h, t) -> cons h (unfold f t)) (f s) 444 | 445 | -- | 446 | -- Construct by unfolding a monadic data structure 447 | -- 448 | -- This is the most memory-efficient way to construct ListT where 449 | -- the length depends on the inner monad. 450 | {-# INLINEABLE unfoldM #-} 451 | unfoldM :: (Monad m) => (b -> m (Maybe (a, b))) -> b -> ListT m a 452 | unfoldM f = go 453 | where 454 | go s = 455 | ListT $ 456 | f s >>= \case 457 | Nothing -> return Nothing 458 | Just (a, r) -> return (Just (a, go r)) 459 | 460 | -- | 461 | -- Produce an infinite stream. 462 | {-# INLINEABLE repeat #-} 463 | repeat :: (Monad m) => a -> ListT m a 464 | repeat = 465 | fix . cons 466 | 467 | -- * Transformation 468 | 469 | ------------------------- 470 | 471 | -- | 472 | -- A transformation, 473 | -- which traverses the stream with an action in the inner monad. 474 | {-# INLINEABLE traverse #-} 475 | traverse :: (Monad m) => (a -> m b) -> ListT m a -> ListT m b 476 | traverse f = 477 | go 478 | where 479 | go (ListT run) = 480 | ListT $ 481 | run >>= \case 482 | Nothing -> return Nothing 483 | Just (a, next) -> f a <&> \b -> Just (b, go next) 484 | 485 | -- | 486 | -- A transformation, 487 | -- reproducing the behaviour of @Data.List.'Data.List.take'@. 488 | {-# INLINEABLE take #-} 489 | take :: (Monad m) => Int -> ListT m a -> ListT m a 490 | take = 491 | \case 492 | n | n > 0 -> \t -> 493 | lift (uncons t) 494 | >>= \case 495 | Nothing -> t 496 | Just (h, t) -> cons h (take (pred n) t) 497 | _ -> 498 | const $ mzero 499 | 500 | -- | 501 | -- A transformation, 502 | -- reproducing the behaviour of @Data.List.'Data.List.drop'@. 503 | {-# INLINEABLE drop #-} 504 | drop :: (Monad m) => Int -> ListT m a -> ListT m a 505 | drop = 506 | \case 507 | n 508 | | n > 0 -> 509 | lift . uncons >=> maybe mzero (drop (pred n) . snd) 510 | _ -> 511 | id 512 | 513 | -- | 514 | -- A transformation, 515 | -- which slices a list into chunks of the specified length. 516 | {-# INLINEABLE slice #-} 517 | slice :: (Monad m) => Int -> ListT m a -> ListT m [a] 518 | slice n l = 519 | do 520 | (h, t) <- lift $ splitAt n l 521 | case h of 522 | [] -> mzero 523 | _ -> cons h (slice n t) 524 | -------------------------------------------------------------------------------- /library/ListT/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-dodgy-imports #-} 2 | 3 | module ListT.Prelude 4 | ( module Exports, 5 | bimapPair', 6 | secondPair', 7 | ) 8 | where 9 | 10 | import Control.Applicative as Exports 11 | import Control.Category as Exports 12 | import Control.Concurrent as Exports 13 | import Control.Exception as Exports 14 | import Control.Foldl as Exports (Fold (..), FoldM (..)) 15 | import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) 16 | import Control.Monad.Base as Exports 17 | import Control.Monad.Error.Class as Exports 18 | import Control.Monad.Fail as Exports 19 | import Control.Monad.Fix as Exports hiding (fix) 20 | import Control.Monad.IO.Class as Exports 21 | import Control.Monad.Logic.Class as Exports 22 | import Control.Monad.Morph as Exports hiding (MonadTrans (..)) 23 | import Control.Monad.Reader.Class as Exports 24 | import Control.Monad.ST as Exports 25 | import Control.Monad.State.Class as Exports 26 | import Control.Monad.Trans.Class as Exports 27 | import Control.Monad.Trans.Control as Exports hiding (embed, embed_) 28 | import Control.Monad.Trans.Maybe as Exports hiding (liftCallCC, liftCatch) 29 | import Control.Monad.Zip as Exports 30 | import Data.Bits as Exports 31 | import Data.Bool as Exports 32 | import Data.Char as Exports 33 | import Data.Coerce as Exports 34 | import Data.Complex as Exports 35 | import Data.Data as Exports 36 | import Data.Dynamic as Exports 37 | import Data.Either as Exports 38 | import Data.Fixed as Exports 39 | import Data.Foldable as Exports 40 | import Data.Function as Exports hiding (id, (.)) 41 | import Data.Functor as Exports hiding (unzip) 42 | import Data.Functor.Classes as Exports 43 | import Data.IORef as Exports 44 | import Data.Int as Exports 45 | import Data.Ix as Exports 46 | import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) 47 | import Data.Maybe as Exports 48 | import Data.Monoid as Exports hiding (First, Last, getFirst, getLast, (<>)) 49 | import Data.Ord as Exports 50 | import Data.Proxy as Exports 51 | import Data.Ratio as Exports 52 | import Data.STRef as Exports 53 | import Data.Semigroup as Exports 54 | import Data.String as Exports 55 | import Data.Traversable as Exports 56 | import Data.Tuple as Exports 57 | import Data.Unique as Exports 58 | import Data.Version as Exports 59 | import Data.Word as Exports 60 | import Debug.Trace as Exports 61 | import Foreign.ForeignPtr as Exports 62 | import Foreign.Ptr as Exports 63 | import Foreign.StablePtr as Exports 64 | import Foreign.Storable as Exports 65 | import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) 66 | import GHC.Exts as Exports (groupWith, inline, lazy, sortWith) 67 | import GHC.Generics as Exports (Generic) 68 | import GHC.IO.Exception as Exports 69 | import Numeric as Exports 70 | import System.Environment as Exports 71 | import System.Exit as Exports 72 | import System.IO as Exports (Handle, hClose) 73 | import System.IO.Error as Exports 74 | import System.IO.Unsafe as Exports 75 | import System.Mem as Exports 76 | import System.Mem.StableName as Exports 77 | import System.Timeout as Exports 78 | import Text.Printf as Exports (hPrintf, printf) 79 | import Text.Read as Exports (Read (..), readEither, readMaybe) 80 | import Unsafe.Coerce as Exports 81 | import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, unzip, (.)) 82 | 83 | -- | 84 | -- A slightly stricter version of Data.Bifunctor.bimap. 85 | -- There's no benefit to producing lazy pairs here. 86 | bimapPair' :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) 87 | bimapPair' f g = \(a, c) -> (f a, g c) 88 | 89 | -- | 90 | -- A slightly stricter version of Data.Bifunctor.second 91 | -- that doesn't produce gratuitous lazy pairs. 92 | secondPair' :: (b -> c) -> (a, b) -> (a, c) 93 | secondPair' f = \(a, b) -> (a, f b) 94 | -------------------------------------------------------------------------------- /list-t.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: list-t 3 | version: 1.0.5.7 4 | synopsis: ListT done right 5 | description: 6 | A correct implementation of the list monad-transformer. 7 | Useful for basic streaming. 8 | 9 | category: Streaming, Data Structures, Control 10 | homepage: https://github.com/nikita-volkov/list-t 11 | bug-reports: https://github.com/nikita-volkov/list-t/issues 12 | author: Nikita Volkov 13 | maintainer: Nikita Volkov 14 | copyright: (c) 2014, Nikita Volkov 15 | license: MIT 16 | license-file: LICENSE 17 | 18 | source-repository head 19 | type: git 20 | location: git://github.com/nikita-volkov/list-t.git 21 | 22 | common language-settings 23 | default-extensions: 24 | NoImplicitPrelude 25 | NoMonomorphismRestriction 26 | BangPatterns 27 | ConstraintKinds 28 | DataKinds 29 | DefaultSignatures 30 | DeriveDataTypeable 31 | DeriveFunctor 32 | DeriveGeneric 33 | DeriveTraversable 34 | EmptyDataDecls 35 | FlexibleContexts 36 | FlexibleInstances 37 | FunctionalDependencies 38 | GADTs 39 | GeneralizedNewtypeDeriving 40 | LambdaCase 41 | LiberalTypeSynonyms 42 | MagicHash 43 | MultiParamTypeClasses 44 | MultiWayIf 45 | OverloadedStrings 46 | ParallelListComp 47 | PatternGuards 48 | PolyKinds 49 | QuasiQuotes 50 | RankNTypes 51 | RecordWildCards 52 | ScopedTypeVariables 53 | StandaloneDeriving 54 | TemplateHaskell 55 | TupleSections 56 | TypeFamilies 57 | TypeOperators 58 | UnboxedTuples 59 | UndecidableInstances 60 | 61 | default-language: Haskell2010 62 | 63 | library 64 | import: language-settings 65 | hs-source-dirs: library 66 | exposed-modules: ListT 67 | other-modules: ListT.Prelude 68 | build-depends: 69 | , base >=4.11 && <5 70 | , foldl >=1.2 && <2 71 | , logict >=0.7 && <0.9 72 | , mmorph >=1 && <2 73 | , monad-control >=0.3 && <2 74 | , mtl >=2 && <3 75 | , transformers >=0.3 && <0.7 76 | , transformers-base ^>=0.4 77 | 78 | if impl(ghc <8.0) 79 | build-depends: semigroups >=0.11 && <0.21 80 | 81 | test-suite htf-test 82 | import: language-settings 83 | type: exitcode-stdio-1.0 84 | hs-source-dirs: htf-test 85 | main-is: Main.hs 86 | build-depends: 87 | , base-prelude 88 | , HTF ^>=0.15 89 | , list-t 90 | , mmorph 91 | , mtl-prelude <3 92 | --------------------------------------------------------------------------------