diff options
| -rw-r--r-- | events/src/Events/Types/NDT.hs | 12 |
1 files changed, 4 insertions, 8 deletions
diff --git a/events/src/Events/Types/NDT.hs b/events/src/Events/Types/NDT.hs index 848ad39..a417029 100644 --- a/events/src/Events/Types/NDT.hs +++ b/events/src/Events/Types/NDT.hs | |||
| @@ -1,6 +1,5 @@ | |||
| 1 | {-# LANGUAGE GADTs #-} | 1 | {-# LANGUAGE GADTs #-} |
| 2 | {-# LANGUAGE TupleSections #-} | 2 | {-# LANGUAGE TupleSections #-} |
| 3 | {-# LANGUAGE ViewPatterns #-} | ||
| 4 | {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} | 3 | {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} |
| 5 | {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} | 4 | {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} |
| 6 | 5 | ||
| @@ -15,6 +14,7 @@ import Data.Monoid | |||
| 15 | import Data.Foldable (foldr) | 14 | import Data.Foldable (foldr) |
| 16 | import Data.Maybe | 15 | import Data.Maybe |
| 17 | import Data.Either | 16 | import Data.Either |
| 17 | import Data.Bool (bool) | ||
| 18 | 18 | ||
| 19 | import Control.Applicative (Alternative) | 19 | import Control.Applicative (Alternative) |
| 20 | import qualified Control.Applicative as Alt (Alternative(..)) | 20 | import qualified Control.Applicative as Alt (Alternative(..)) |
| @@ -41,7 +41,7 @@ instance Functor m => Functor (NDT m) where | |||
| 41 | 41 | ||
| 42 | instance Applicative m => Applicative (NDT m) where | 42 | instance Applicative m => Applicative (NDT m) where |
| 43 | pure x = NDTCons . pure $ Just (x, empty) | 43 | pure x = NDTCons . pure $ Just (x, empty) |
| 44 | fs <*> xs = fs >>= (\f -> xs >>= pure . (f $)) | 44 | fs <*> xs = fs >>= (\f -> xs >>= pure . f) |
| 45 | 45 | ||
| 46 | instance Applicative m => Monad (NDT m) where | 46 | instance Applicative m => Monad (NDT m) where |
| 47 | return = pure | 47 | return = pure |
| @@ -55,7 +55,7 @@ instance Monad m => Monoid (NDT m a) where | |||
| 55 | mappend x y@(NDTBind _ _) = NDTBind x return <> y | 55 | mappend x y@(NDTBind _ _) = NDTBind x return <> y |
| 56 | 56 | ||
| 57 | instance MonadTrans NDT where | 57 | instance MonadTrans NDT where |
| 58 | lift = NDTCons . fmap Just . fmap (,empty) | 58 | lift = NDTCons . fmap (Just . (, empty)) |
| 59 | 59 | ||
| 60 | instance Monad m => Alternative (NDT m) where | 60 | instance Monad m => Alternative (NDT m) where |
| 61 | empty = mempty | 61 | empty = mempty |
| @@ -88,11 +88,7 @@ foldNDT sel (NDTCons mx) = do | |||
| 88 | mx' <- mx | 88 | mx' <- mx |
| 89 | case mx' of | 89 | case mx' of |
| 90 | Nothing -> return mempty | 90 | Nothing -> return mempty |
| 91 | Just (x, mxs) -> do | 91 | Just (x, mxs) -> bool (return mempty) ((pure x <>) <$> foldNDT sel mxs) =<< sel x |
| 92 | continue <- sel x | ||
| 93 | case continue of | ||
| 94 | False -> return mempty | ||
| 95 | True -> (pure x <>) <$> foldNDT sel mxs | ||
| 96 | foldNDT sel (NDTBind (NDTCons x) f) = do | 92 | foldNDT sel (NDTBind (NDTCons x) f) = do |
| 97 | x' <- x | 93 | x' <- x |
| 98 | case x' of | 94 | case x' of |
