-- Copyright 2013 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Derive.LEvent where import Prelude hiding (length, either, log, zip, zip3) import qualified Control.DeepSeq as DeepSeq import qualified Data.Either as Either import qualified Data.List as List import qualified Data.Text as Text import qualified Util.CallStack as CallStack import qualified Util.Log as Log import qualified Util.Pretty as Pretty import Util.Pretty ((<+>)) import qualified Derive.Stack as Stack import Global -- * LEvent data LEvent a = Event !a | Log !Log.Msg deriving (LEvent a -> LEvent a -> Bool forall a. Eq a => LEvent a -> LEvent a -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: LEvent a -> LEvent a -> Bool $c/= :: forall a. Eq a => LEvent a -> LEvent a -> Bool == :: LEvent a -> LEvent a -> Bool $c== :: forall a. Eq a => LEvent a -> LEvent a -> Bool Eq, Int -> LEvent a -> ShowS forall a. Show a => Int -> LEvent a -> ShowS forall a. Show a => [LEvent a] -> ShowS forall a. Show a => LEvent a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [LEvent a] -> ShowS $cshowList :: forall a. Show a => [LEvent a] -> ShowS show :: LEvent a -> String $cshow :: forall a. Show a => LEvent a -> String showsPrec :: Int -> LEvent a -> ShowS $cshowsPrec :: forall a. Show a => Int -> LEvent a -> ShowS Show, forall a b. a -> LEvent b -> LEvent a forall a b. (a -> b) -> LEvent a -> LEvent b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: forall a b. a -> LEvent b -> LEvent a $c<$ :: forall a b. a -> LEvent b -> LEvent a fmap :: forall a b. (a -> b) -> LEvent a -> LEvent b $cfmap :: forall a b. (a -> b) -> LEvent a -> LEvent b Functor, forall a. Eq a => a -> LEvent a -> Bool forall a. Num a => LEvent a -> a forall a. Ord a => LEvent a -> a forall m. Monoid m => LEvent m -> m forall a. LEvent a -> Bool forall a. LEvent a -> Int forall a. LEvent a -> [a] forall a. (a -> a -> a) -> LEvent a -> a forall m a. Monoid m => (a -> m) -> LEvent a -> m forall b a. (b -> a -> b) -> b -> LEvent a -> b forall a b. (a -> b -> b) -> b -> LEvent a -> b forall (t :: * -> *). (forall m. Monoid m => t m -> m) -> (forall m a. Monoid m => (a -> m) -> t a -> m) -> (forall m a. Monoid m => (a -> m) -> t a -> m) -> (forall a b. (a -> b -> b) -> b -> t a -> b) -> (forall a b. (a -> b -> b) -> b -> t a -> b) -> (forall b a. (b -> a -> b) -> b -> t a -> b) -> (forall b a. (b -> a -> b) -> b -> t a -> b) -> (forall a. (a -> a -> a) -> t a -> a) -> (forall a. (a -> a -> a) -> t a -> a) -> (forall a. t a -> [a]) -> (forall a. t a -> Bool) -> (forall a. t a -> Int) -> (forall a. Eq a => a -> t a -> Bool) -> (forall a. Ord a => t a -> a) -> (forall a. Ord a => t a -> a) -> (forall a. Num a => t a -> a) -> (forall a. Num a => t a -> a) -> Foldable t product :: forall a. Num a => LEvent a -> a $cproduct :: forall a. Num a => LEvent a -> a sum :: forall a. Num a => LEvent a -> a $csum :: forall a. Num a => LEvent a -> a minimum :: forall a. Ord a => LEvent a -> a $cminimum :: forall a. Ord a => LEvent a -> a maximum :: forall a. Ord a => LEvent a -> a $cmaximum :: forall a. Ord a => LEvent a -> a elem :: forall a. Eq a => a -> LEvent a -> Bool $celem :: forall a. Eq a => a -> LEvent a -> Bool length :: forall a. LEvent a -> Int $clength :: forall a. LEvent a -> Int null :: forall a. LEvent a -> Bool $cnull :: forall a. LEvent a -> Bool toList :: forall a. LEvent a -> [a] $ctoList :: forall a. LEvent a -> [a] foldl1 :: forall a. (a -> a -> a) -> LEvent a -> a $cfoldl1 :: forall a. (a -> a -> a) -> LEvent a -> a foldr1 :: forall a. (a -> a -> a) -> LEvent a -> a $cfoldr1 :: forall a. (a -> a -> a) -> LEvent a -> a foldl' :: forall b a. (b -> a -> b) -> b -> LEvent a -> b $cfoldl' :: forall b a. (b -> a -> b) -> b -> LEvent a -> b foldl :: forall b a. (b -> a -> b) -> b -> LEvent a -> b $cfoldl :: forall b a. (b -> a -> b) -> b -> LEvent a -> b foldr' :: forall a b. (a -> b -> b) -> b -> LEvent a -> b $cfoldr' :: forall a b. (a -> b -> b) -> b -> LEvent a -> b foldr :: forall a b. (a -> b -> b) -> b -> LEvent a -> b $cfoldr :: forall a b. (a -> b -> b) -> b -> LEvent a -> b foldMap' :: forall m a. Monoid m => (a -> m) -> LEvent a -> m $cfoldMap' :: forall m a. Monoid m => (a -> m) -> LEvent a -> m foldMap :: forall m a. Monoid m => (a -> m) -> LEvent a -> m $cfoldMap :: forall m a. Monoid m => (a -> m) -> LEvent a -> m fold :: forall m. Monoid m => LEvent m -> m $cfold :: forall m. Monoid m => LEvent m -> m Foldable, Functor LEvent Foldable LEvent forall (t :: * -> *). Functor t -> Foldable t -> (forall (f :: * -> *) a b. Applicative f => (a -> f b) -> t a -> f (t b)) -> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)) -> (forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)) -> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a)) -> Traversable t forall (m :: * -> *) a. Monad m => LEvent (m a) -> m (LEvent a) forall (f :: * -> *) a. Applicative f => LEvent (f a) -> f (LEvent a) forall (m :: * -> *) a b. Monad m => (a -> m b) -> LEvent a -> m (LEvent b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> LEvent a -> f (LEvent b) sequence :: forall (m :: * -> *) a. Monad m => LEvent (m a) -> m (LEvent a) $csequence :: forall (m :: * -> *) a. Monad m => LEvent (m a) -> m (LEvent a) mapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> LEvent a -> m (LEvent b) $cmapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> LEvent a -> m (LEvent b) sequenceA :: forall (f :: * -> *) a. Applicative f => LEvent (f a) -> f (LEvent a) $csequenceA :: forall (f :: * -> *) a. Applicative f => LEvent (f a) -> f (LEvent a) traverse :: forall (f :: * -> *) a b. Applicative f => (a -> f b) -> LEvent a -> f (LEvent b) $ctraverse :: forall (f :: * -> *) a b. Applicative f => (a -> f b) -> LEvent a -> f (LEvent b) Traversable) instance Pretty d => Pretty (LEvent d) where format :: LEvent d -> Doc format = forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a either forall a. Pretty a => a -> Doc Pretty.format Msg -> Doc format_log instance DeepSeq.NFData a => DeepSeq.NFData (LEvent a) where rnf :: LEvent a -> () rnf = forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a either forall a. NFData a => a -> () DeepSeq.rnf forall a. NFData a => a -> () DeepSeq.rnf -- | A variation on 'Log.format_msg', except this can format the stack nicely. format_log :: Log.Msg -> Pretty.Doc format_log :: Msg -> Doc format_log Msg msg = Text -> Doc Pretty.text Text stars Doc -> Doc -> Doc <+> Text -> Doc Pretty.text Text caller Doc -> Doc -> Doc <+> forall a. Pretty a => a -> Doc Pretty.format Doc stack forall a. Semigroup a => a -> a -> a <> Doc -> Doc Pretty.indent_ (Text -> Doc Pretty.text (Msg -> Text Log.msg_text Msg msg)) where stars :: Text stars = Int -> Text -> Text Text.replicate (forall a. Enum a => a -> Int fromEnum (Msg -> Priority Log.msg_priority Msg msg)) Text "*" caller :: Text caller = Caller -> Text CallStack.showCaller (Msg -> Caller Log.msg_caller Msg msg) forall a. Semigroup a => a -> a -> a <> Text ": " stack :: Doc stack = case Msg -> Maybe Stack Log.msg_stack Msg msg of Maybe Stack Nothing -> Text -> Doc Pretty.text Text "[]" Just Stack stack -> Stack -> Doc Stack.format_ui Stack stack event :: LEvent a -> Maybe a event :: forall a. LEvent a -> Maybe a event (Event a d) = forall a. a -> Maybe a Just a d event LEvent a _ = forall a. Maybe a Nothing is_event :: LEvent a -> Bool is_event :: forall a. LEvent a -> Bool is_event (Event {}) = Bool True is_event LEvent a _ = Bool False is_log :: LEvent a -> Bool is_log :: forall a. LEvent a -> Bool is_log (Log {}) = Bool True is_log LEvent a _ = Bool False -- | Always true for logs. Useful for take and drop on events. log_or :: (d -> Bool) -> LEvent d -> Bool log_or :: forall d. (d -> Bool) -> LEvent d -> Bool log_or d -> Bool f = forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a either d -> Bool f (forall a b. a -> b -> a const Bool True) event_or :: (Log.Msg -> Bool) -> LEvent d -> Bool event_or :: forall d. (Msg -> Bool) -> LEvent d -> Bool event_or = forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a either (forall a b. a -> b -> a const Bool True) -- | Drop while the predicate is true, but keep preceding logs. drop_while :: (a -> Bool) -> [LEvent a] -> [LEvent a] drop_while :: forall a. (a -> Bool) -> [LEvent a] -> [LEvent a] drop_while a -> Bool f = [LEvent a] -> [LEvent a] -> [LEvent a] go [] where go :: [LEvent a] -> [LEvent a] -> [LEvent a] go [LEvent a] accum [] = forall a. [a] -> [a] reverse [LEvent a] accum go [LEvent a] accum es :: [LEvent a] es@(Event a event : [LEvent a] rest) | a -> Bool f a event = [LEvent a] -> [LEvent a] -> [LEvent a] go [] [LEvent a] rest | Bool otherwise = forall a. [a] -> [a] reverse [LEvent a] accum forall a. [a] -> [a] -> [a] ++ [LEvent a] es go [LEvent a] accum (log :: LEvent a log@(Log Msg _) : [LEvent a] rest) = [LEvent a] -> [LEvent a] -> [LEvent a] go (LEvent a logforall a. a -> [a] -> [a] :[LEvent a] accum) [LEvent a] rest take_while :: (a -> Bool) -> [LEvent a] -> [LEvent a] take_while :: forall a. (a -> Bool) -> [LEvent a] -> [LEvent a] take_while a -> Bool f = forall a. (a -> Bool) -> [a] -> [a] takeWhile (forall d. (d -> Bool) -> LEvent d -> Bool log_or a -> Bool f) either :: (d -> a) -> (Log.Msg -> a) -> LEvent d -> a either :: forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a either d -> a f1 Msg -> a _ (Event d event) = d -> a f1 d event either d -> a _ Msg -> a f2 (Log Msg log) = Msg -> a f2 Msg log map_log :: (Log.Msg -> Log.Msg) -> LEvent a -> LEvent a map_log :: forall a. (Msg -> Msg) -> LEvent a -> LEvent a map_log Msg -> Msg f (Log Msg log) = forall a. Msg -> LEvent a Log (Msg -> Msg f Msg log) map_log Msg -> Msg _ LEvent a event = LEvent a event find_event :: (a -> Bool) -> [LEvent a] -> Maybe a find_event :: forall a. (a -> Bool) -> [LEvent a] -> Maybe a find_event a -> Bool _ [] = forall a. Maybe a Nothing find_event a -> Bool f (Log Msg _ : [LEvent a] rest) = forall a. (a -> Bool) -> [LEvent a] -> Maybe a find_event a -> Bool f [LEvent a] rest find_event a -> Bool f (Event a event : [LEvent a] rest) | a -> Bool f a event = forall a. a -> Maybe a Just a event | Bool otherwise = forall a. (a -> Bool) -> [LEvent a] -> Maybe a find_event a -> Bool f [LEvent a] rest events_of :: [LEvent d] -> [d] events_of :: forall d. [LEvent d] -> [d] events_of [] = [] events_of (Event d e : [LEvent d] rest) = d e forall a. a -> [a] -> [a] : forall d. [LEvent d] -> [d] events_of [LEvent d] rest events_of (Log Msg _ : [LEvent d] rest) = forall d. [LEvent d] -> [d] events_of [LEvent d] rest logs_of :: [LEvent d] -> [Log.Msg] logs_of :: forall d. [LEvent d] -> [Msg] logs_of [] = [] logs_of (Log Msg log : [LEvent d] rest) = Msg log forall a. a -> [a] -> [a] : forall d. [LEvent d] -> [Msg] logs_of [LEvent d] rest logs_of (LEvent d _ : [LEvent d] rest) = forall d. [LEvent d] -> [Msg] logs_of [LEvent d] rest write_logs :: Log.LogMonad m => [LEvent d] -> m [d] write_logs :: forall (m :: * -> *) d. LogMonad m => [LEvent d] -> m [d] write_logs [LEvent d] events = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall (m :: * -> *). LogMonad m => Msg -> m () Log.write [Msg] logs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> forall (m :: * -> *) a. Monad m => a -> m a return [d] vals where ([d] vals, [Msg] logs) = forall d. [LEvent d] -> ([d], [Msg]) partition [LEvent d] events write_snd :: Log.LogMonad m => (a, [Log.Msg]) -> m a write_snd :: forall (m :: * -> *) a. LogMonad m => (a, [Msg]) -> m a write_snd (a result, [Msg] logs) = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall (m :: * -> *). LogMonad m => Msg -> m () Log.write [Msg] logs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> forall (m :: * -> *) a. Monad m => a -> m a return a result write_snd_prefix :: Log.LogMonad m => Text -> (a, [Log.Msg]) -> m a write_snd_prefix :: forall (m :: * -> *) a. LogMonad m => Text -> (a, [Msg]) -> m a write_snd_prefix Text prefix (a result, [Msg] logs) = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall (m :: * -> *). LogMonad m => Msg -> m () Log.write (forall a b. (a -> b) -> [a] -> [b] map (Text -> Msg -> Msg Log.add_prefix Text prefix) [Msg] logs) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> forall (m :: * -> *) a. Monad m => a -> m a return a result partition :: [LEvent d] -> ([d], [Log.Msg]) partition :: forall d. [LEvent d] -> ([d], [Msg]) partition = forall a b. [Either a b] -> ([a], [b]) Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall {a}. LEvent a -> Either a Msg to_either where to_either :: LEvent a -> Either a Msg to_either (Event a d) = forall a b. a -> Either a b Left a d to_either (Log Msg msg) = forall a b. b -> Either a b Right Msg msg -- | This is similar to 'List.mapAccumL', but lifted into LEvents. It also -- passes future events to the function. map_accum :: (state -> a -> [a] -> (state, [b])) -> state -> [LEvent a] -> (state, [[LEvent b]]) map_accum :: forall state a b. (state -> a -> [a] -> (state, [b])) -> state -> [LEvent a] -> (state, [[LEvent b]]) map_accum state -> a -> [a] -> (state, [b]) f state state [LEvent a] events = forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) List.mapAccumL state -> (LEvent a, [LEvent a]) -> (state, [LEvent b]) process state state (forall a b. [a] -> [b] -> [(a, b)] List.zip [LEvent a] events (forall a. Int -> [a] -> [a] drop Int 1 (forall a. [a] -> [[a]] List.tails [LEvent a] events))) where process :: state -> (LEvent a, [LEvent a]) -> (state, [LEvent b]) process state st (Event a event, [LEvent a] future_events) = forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (forall a b. (a -> b) -> [a] -> [b] map forall a. a -> LEvent a Event) (state -> a -> [a] -> (state, [b]) f state st a event (forall d. [LEvent d] -> [d] events_of [LEvent a] future_events)) process state st (Log Msg log, [LEvent a] _) = (state st, [forall a. Msg -> LEvent a Log Msg log]) -- | Like 'map_accum', but provide past and future events to the function. map_around :: ([a] -> a -> [a] -> [b]) -> [LEvent a] -> [[LEvent b]] map_around :: forall a b. ([a] -> a -> [a] -> [b]) -> [LEvent a] -> [[LEvent b]] map_around [a] -> a -> [a] -> [b] f = forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . forall state a b. (state -> a -> [a] -> (state, [b])) -> state -> [LEvent a] -> (state, [[LEvent b]]) map_accum (\[a] prev a event [a] next -> (a event forall a. a -> [a] -> [a] : [a] prev, [a] -> a -> [a] -> [b] f [a] prev a event [a] next)) [] zip :: [a] -> [LEvent x] -> [LEvent (a, x)] zip :: forall a x. [a] -> [LEvent x] -> [LEvent (a, x)] zip [a] as (Log Msg x : [LEvent x] xs) = forall a. Msg -> LEvent a Log Msg x forall a. a -> [a] -> [a] : forall a x. [a] -> [LEvent x] -> [LEvent (a, x)] zip [a] as [LEvent x] xs zip (a a:[a] as) (Event x x : [LEvent x] xs) = forall a. a -> LEvent a Event (a a, x x) forall a. a -> [a] -> [a] : forall a x. [a] -> [LEvent x] -> [LEvent (a, x)] zip [a] as [LEvent x] xs zip [a] _ [LEvent x] _ = [] zip3 :: [a] -> [b] -> [LEvent x] -> [LEvent (a, b, x)] zip3 :: forall a b x. [a] -> [b] -> [LEvent x] -> [LEvent (a, b, x)] zip3 [a] as [b] bs (Log Msg x : [LEvent x] xs) = forall a. Msg -> LEvent a Log Msg x forall a. a -> [a] -> [a] : forall a b x. [a] -> [b] -> [LEvent x] -> [LEvent (a, b, x)] zip3 [a] as [b] bs [LEvent x] xs zip3 (a a:[a] as) (b b:[b] bs) (Event x x : [LEvent x] xs) = forall a. a -> LEvent a Event (a a, b b, x x) forall a. a -> [a] -> [a] : forall a b x. [a] -> [b] -> [LEvent x] -> [LEvent (a, b, x)] zip3 [a] as [b] bs [LEvent x] xs zip3 [a] _ [b] _ [LEvent x] _ = [] zip4 :: [a] -> [b] -> [c] -> [LEvent x] -> [LEvent (a, b, c, x)] zip4 :: forall a b c x. [a] -> [b] -> [c] -> [LEvent x] -> [LEvent (a, b, c, x)] zip4 [a] as [b] bs [c] cs (Log Msg x : [LEvent x] xs) = forall a. Msg -> LEvent a Log Msg x forall a. a -> [a] -> [a] : forall a b c x. [a] -> [b] -> [c] -> [LEvent x] -> [LEvent (a, b, c, x)] zip4 [a] as [b] bs [c] cs [LEvent x] xs zip4 (a a:[a] as) (b b:[b] bs) (c c:[c] cs) (Event x x : [LEvent x] xs) = forall a. a -> LEvent a Event (a a, b b, c c, x x) forall a. a -> [a] -> [a] : forall a b c x. [a] -> [b] -> [c] -> [LEvent x] -> [LEvent (a, b, c, x)] zip4 [a] as [b] bs [c] cs [LEvent x] xs zip4 [a] _ [b] _ [c] _ [LEvent x] _ = []