-- 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]
_ = []