1 {-# LANGUAGE GeneralizedNewtypeDeriving, ViewPatterns #-} 2 -- | 3 -- FIXME: There is a lot of duplication of standard library tools in here. 4 module Databrary.Ops 5 ( useWhen -- (<?) 6 , thenUse -- (?>) 7 , unlessUse -- , (?!>) 8 -- , (?$>) 9 , thenReturn 10 , unlessReturn -- , (?!$>) 11 , rightJust 12 , fromMaybeM 13 , orElseM 14 , flatMapM 15 , groupTuplesBy 16 , mergeBy 17 ) where 18 19 import Control.Applicative 20 import qualified Data.Either.Combinators as EC 21 22 -- infixl 1 <? 23 -- infixr 1 ?!> 24 25 -- |@'($>)' . guard@ 26 thenUse :: Alternative f => Bool -> a -> f a 27 False `thenUse` _ = empty 28 True `thenUse` a = pure a 29 30 -- |@flip '(?>)'@ 31 useWhen :: Alternative f => a -> Bool -> f a 32 _ `useWhen` False = empty 33 a `useWhen` True = pure a 34 35 -- |@'(?>)' . not@ 36 unlessUse :: Alternative f => Bool -> a -> f a 37 True `unlessUse` _ = empty 38 False `unlessUse` a = pure a 39 40 {-# SPECIALIZE thenUse :: Bool -> a -> Maybe a #-} 41 {-# SPECIALIZE useWhen :: a -> Bool -> Maybe a #-} 42 {-# SPECIALIZE unlessUse :: Bool -> a -> Maybe a #-} 43 44 -- |@liftM . (?>)@ 45 thenReturn :: (Applicative m, Alternative f) => Bool -> m a -> m (f a) 46 False `thenReturn` _ = pure empty 47 True `thenReturn` f = pure <$> f 48 -- TODO: get rid of this 49 50 -- |@'(?$>)' . not@ 51 unlessReturn :: (Applicative m, Alternative f) => Bool -> m a -> m (f a) 52 True `unlessReturn` _ = pure empty 53 False `unlessReturn` f = pure <$> f 54 -- TODO: get rid of this 55 56 {-# SPECIALIZE thenReturn :: Applicative m => Bool -> m a -> m (Maybe a) #-} 57 {-# SPECIALIZE unlessReturn :: Applicative m => Bool -> m a -> m (Maybe a) #-} 58 59 rightJust :: Either a b -> Maybe b 60 rightJust = EC.rightToMaybe 61 62 -- TODO: get rid of this 63 fromMaybeM :: Monad m => m a -> Maybe a -> m a 64 fromMaybeM _ (Just a) = return a 65 fromMaybeM m Nothing = m 66 67 infixl 3 `orElseM` 68 69 -- TODO: get rid of this 70 orElseM :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) 71 orElseM Nothing m = m 72 orElseM m _ = return m 73 74 -- TODO: get rid of this 75 flatMapM :: Monad m => (a -> m (Maybe b)) -> Maybe a -> m (Maybe b) 76 flatMapM justAction mVal = maybe (return Nothing) justAction mVal 77 78 groupTuplesBy :: (a -> a -> Bool) -> [(a, b)] -> [(a, [b])] 79 groupTuplesBy _ [] = [] 80 groupTuplesBy p ((a,b):(span (p a . fst) -> (al, l))) = (a, b : map snd al) : groupTuplesBy p l 81 82 -- | 83 -- Merge two ordered lists using the given predicate, removing EQ "duplicates" 84 -- (left-biased) 85 mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] 86 mergeBy _ [] l = l 87 mergeBy _ l [] = l 88 mergeBy p al@(a:ar) bl@(b:br) = case p a b of 89 LT -> a : mergeBy p ar bl 90 EQ -> mergeBy p al br 91 GT -> b : mergeBy p al br