diff options
author | Gregor Kleen <pngwjpgh@users.noreply.github.com> | 2016-07-30 17:05:49 +0200 |
---|---|---|
committer | Gregor Kleen <pngwjpgh@users.noreply.github.com> | 2016-07-30 17:05:49 +0200 |
commit | e1c7ed58aacb46c8204461841d29cb790cdf76e7 (patch) | |
tree | 2cf23d3f8df2f8385dbc5cbf6c351f5405653ccc /events/src/Events/Types | |
parent | 9bffd435230514c00177a315bf65d9c13969f7dc (diff) | |
download | events-e1c7ed58aacb46c8204461841d29cb790cdf76e7.tar events-e1c7ed58aacb46c8204461841d29cb790cdf76e7.tar.gz events-e1c7ed58aacb46c8204461841d29cb790cdf76e7.tar.bz2 events-e1c7ed58aacb46c8204461841d29cb790cdf76e7.tar.xz events-e1c7ed58aacb46c8204461841d29cb790cdf76e7.zip |
code cleanup
Diffstat (limited to 'events/src/Events/Types')
-rw-r--r-- | events/src/Events/Types/NDT.hs | 21 |
1 files changed, 14 insertions, 7 deletions
diff --git a/events/src/Events/Types/NDT.hs b/events/src/Events/Types/NDT.hs index 8431f51..3f66953 100644 --- a/events/src/Events/Types/NDT.hs +++ b/events/src/Events/Types/NDT.hs | |||
@@ -2,6 +2,7 @@ | |||
2 | {-# LANGUAGE TupleSections #-} | 2 | {-# LANGUAGE TupleSections #-} |
3 | {-# LANGUAGE ViewPatterns #-} | 3 | {-# LANGUAGE ViewPatterns #-} |
4 | {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} | 4 | {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} |
5 | {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} | ||
5 | 6 | ||
6 | module Events.Types.NDT | 7 | module Events.Types.NDT |
7 | ( NDT | 8 | ( NDT |
@@ -21,6 +22,7 @@ import Control.Monad | |||
21 | import Control.Monad.Identity | 22 | import Control.Monad.Identity |
22 | 23 | ||
23 | import Control.Monad.Trans | 24 | import Control.Monad.Trans |
25 | import Control.Monad.Reader (MonadReader(..)) | ||
24 | import Control.Monad.Trans.Maybe | 26 | import Control.Monad.Trans.Maybe |
25 | 27 | ||
26 | import Debug.Trace | 28 | import Debug.Trace |
@@ -50,10 +52,10 @@ instance Applicative m => Monad (NDT m) where | |||
50 | 52 | ||
51 | instance Monad m => Monoid (NDT m a) where | 53 | instance Monad m => Monoid (NDT m a) where |
52 | mempty = empty | 54 | mempty = empty |
53 | mappend (NDTCons x) y'@(NDTCons y) = trace "(cons <> cons)" . NDTCons . trace "[cons <> cons]" $ maybe y (\(x, xs) -> return $ Just (x, xs <> y')) =<< x | 55 | mappend (NDTCons x) y'@(NDTCons y) = NDTCons $ maybe y (\(x, xs) -> return $ Just (x, xs <> y')) =<< x |
54 | mappend (NDTBind x f) (NDTBind y g) = trace "(bind <> bind)" $ NDTBind (fmap Left x <> fmap Right y) (either f g) | 56 | mappend (NDTBind x f) (NDTBind y g) = NDTBind (fmap Left x <> fmap Right y) (either f g) |
55 | mappend x@(NDTBind _ _) y = trace "(bind <>)" $ x <> NDTBind y return | 57 | mappend x@(NDTBind _ _) y = x <> NDTBind y return |
56 | mappend x y@(NDTBind _ _) = trace "(<> bind)" $ NDTBind x return <> y | 58 | mappend x y@(NDTBind _ _) = NDTBind x return <> y |
57 | 59 | ||
58 | instance MonadTrans NDT where | 60 | instance MonadTrans NDT where |
59 | lift = NDTCons . fmap Just . fmap (,empty) | 61 | lift = NDTCons . fmap Just . fmap (,empty) |
@@ -66,6 +68,11 @@ instance Monad m => MonadPlus (NDT m) where | |||
66 | mzero = mempty | 68 | mzero = mempty |
67 | mplus = mappend | 69 | mplus = mappend |
68 | 70 | ||
71 | instance MonadReader r m => MonadReader r (NDT m) where | ||
72 | reader = lift . reader | ||
73 | local f (NDTCons x) = NDTCons (local f x) | ||
74 | local f (NDTBind x g) = NDTBind (local f x) g | ||
75 | |||
69 | -- instance MonadFix m => MonadFix (NDT m) where | 76 | -- instance MonadFix m => MonadFix (NDT m) where |
70 | -- mfix f = NDTCons . runMaybeT $ do | 77 | -- mfix f = NDTCons . runMaybeT $ do |
71 | -- x <- mfix (head . f) | 78 | -- x <- mfix (head . f) |
@@ -100,10 +107,10 @@ foldNDT sel (NDTCons mx) = do | |||
100 | Nothing -> return mempty | 107 | Nothing -> return mempty |
101 | Just (x, mxs) -> do | 108 | Just (x, mxs) -> do |
102 | continue <- sel x | 109 | continue <- sel x |
103 | case trace ("(cons "++ show continue ++ ")") continue of | 110 | case continue of |
104 | False -> return mempty | 111 | False -> return mempty |
105 | True -> (pure x <>) <$> foldNDT sel mxs | 112 | True -> (pure x <>) <$> foldNDT sel mxs |
106 | foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do | 113 | foldNDT sel (NDTBind (NDTCons x) f) = do |
107 | x' <- x | 114 | x' <- x |
108 | case x' of | 115 | case x' of |
109 | Nothing -> return mempty | 116 | Nothing -> return mempty |
@@ -111,7 +118,7 @@ foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do | |||
111 | x3 <- foldNDT sel $ f x'' | 118 | x3 <- foldNDT sel $ f x'' |
112 | xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f) | 119 | xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f) |
113 | return $ x3 <> xs' | 120 | return $ x3 <> xs' |
114 | foldNDT sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT sel $ NDTBind x (f <=< g) | 121 | foldNDT sel (NDTBind (NDTBind x g) f) = foldNDT sel $ NDTBind x (f <=< g) |
115 | 122 | ||
116 | fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a | 123 | fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a |
117 | fromFoldable = foldr cons empty | 124 | fromFoldable = foldr cons empty |