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 |