src/Control/Monad/Writer/Adjustable.hs · reflex-vty

git.iko.soy/reflex-vty

on ecc299a help sign in

35 lines 1.6 kB history raw

1{-|

2Module: Control.Monad.Writer.Adjustable

3Description: An Adjustable instance for WriterT

4-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE UndecidableInstances #-}

9{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO find a better home for this

10module Control.Monad.Writer.Adjustable where

12import Control.Monad.Trans

13import Control.Monad.Trans.Writer

14import qualified Data.Dependent.Map as DMap

15import Data.Foldable (fold)

16import Data.Functor.Compose

17import Reflex

18import Reflex.Patch.DMapWithMove

19import Reflex.Class.Switchable

21instance (Adjustable t m, MonadHold t m, Switchable t w, Monoid w) => Adjustable t (WriterT w m) where

22 runWithReplace a0 a' = do

23 (w, r) <- lift $ runWithReplace (runWriterT a0) $ fmap (runWriterT) a'

24 tell =<< switching (snd w) (snd <$> r)

25 return $ (fst w, fst <$> r)

26 traverseIntMapWithKeyWithAdjust f dm0 dm' = do

27 (w, r) <- lift $ traverseIntMapWithKeyWithAdjust (\k v -> runWriterT (f k v)) dm0 dm'

28 tell =<< switching (fold $ fmap snd w) (fmap (mconcat . patchIntMapNewElements . fmap snd) r)

29 return (fmap fst w, fmap (fmap fst) r)

30 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

31 (w, r) <- lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> fmap (\(x, w') -> Compose (w', x)) $ runWriterT (f k v)) dm0 dm'

32 let w' = runWriter $ DMap.traverseWithKey (\_ (Compose (w'', x)) -> tell w'' >> return x) w

33 r' = fmap (runWriter . traversePatchDMapWithMove (\(Compose (w'', x)) -> tell w'' >> return x)) r

34 tell =<< switching (snd w') (fmap snd r')

35 return (fst w', fmap fst r')