content: -- 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 (Eq, Show, Functor, Foldable, Traversable)
  
  instance Pretty d => Pretty (LEvent d) where
      format = either Pretty.format format_log
  
  instance DeepSeq.NFData a => DeepSeq.NFData (LEvent a) where
      rnf = either DeepSeq.rnf DeepSeq.rnf
  
  -- | A variation on 'Log.format_msg', except this can format the stack nicely.
  format_log :: Log.Msg -> Pretty.Doc
  format_log msg =
      Pretty.text stars <+> Pretty.text caller <+> Pretty.format stack
          <> Pretty.indent_ (Pretty.text (Log.msg_text msg))
      where
      stars = Text.replicate (fromEnum (Log.msg_priority msg)) "*"
      caller = CallStack.showCaller (Log.msg_caller msg) <> ": "
      stack = case Log.msg_stack msg of
          Nothing -> Pretty.text "[]"
          Just stack -> Stack.format_ui stack
  
  event :: LEvent a -> Maybe a
  event (Event d) = Just d
  event _ = Nothing
  
  is_event :: LEvent a -> Bool
  is_event (Event {}) = True
  is_event _ = False
  
  is_log :: LEvent a -> Bool
  is_log (Log {}) = True
  is_log _ = False
  
  -- | Always true for logs.  Useful for take and drop on events.
  log_or :: (d -> Bool) -> LEvent d -> Bool
  log_or f = either f (const True)
  
  event_or :: (Log.Msg -> Bool) -> LEvent d -> Bool
  event_or = either (const True)
  
  -- | Drop while the predicate is true, but keep preceding logs.
  drop_while :: (a -> Bool) -> [LEvent a] -> [LEvent a]
  drop_while f = go []
      where
      go accum [] = reverse accum
      go accum es@(Event event : rest)
          | f event = go [] rest
          | otherwise = reverse accum ++ es
      go accum (log@(Log _) : rest) = go (log:accum) rest
  
  take_while :: (a -> Bool) -> [LEvent a] -> [LEvent a]
  take_while f = takeWhile (log_or f)
  
  either :: (d -> a) -> (Log.Msg -> a) -> LEvent d -> a
  either f1 _ (Event event) = f1 event
  either _ f2 (Log log) = f2 log
  
  map_log :: (Log.Msg -> Log.Msg) -> LEvent a -> LEvent a
  map_log f (Log log) = Log (f log)
  map_log _ event = event
  
  find_event :: (a -> Bool) -> [LEvent a] -> Maybe a
  find_event _ [] = Nothing
  find_event f (Log _ : rest) = find_event f rest
  find_event f (Event event : rest)
      | f event = Just event
      | otherwise = find_event f rest
  
  events_of :: [LEvent d] -> [d]
  events_of [] = []
  events_of (Event e : rest) = e : events_of rest
  events_of (Log _ : rest) = events_of rest
  
  logs_of :: [LEvent d] -> [Log.Msg]
  logs_of [] = []
  logs_of (Log log : rest) = log : logs_of rest
  logs_of (_ : rest) = logs_of rest
  
  write_logs :: Log.LogMonad m => [LEvent d] -> m [d]
  write_logs events = mapM_ Log.write logs >> return vals
      where (vals, logs) = partition events
  
  write_snd :: Log.LogMonad m => (a, [Log.Msg]) -> m a
  write_snd (result, logs) = mapM_ Log.write logs >> return result
  
  write_snd_prefix :: Log.LogMonad m => Text -> (a, [Log.Msg]) -> m a
  write_snd_prefix prefix (result, logs) =
      mapM_ Log.write (map (Log.add_prefix prefix) logs) >> return result
  
  partition :: [LEvent d] -> ([d], [Log.Msg])
  partition = Either.partitionEithers . map to_either
      where
      to_either (Event d) = Left d
      to_either (Log msg) = Right 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 f state events =
      List.mapAccumL process state (List.zip events (drop 1 (List.tails events)))
      where
      process st (Event event, future_events) =
          second (map Event) (f st event (events_of future_events))
      process st (Log log, _) = (st, [Log 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 f =
      snd . map_accum (\prev event next -> (event : prev, f prev event next)) []
  
  zip :: [a] -> [LEvent x] -> [LEvent (a, x)]
  zip as (Log x : xs) = Log x : zip as xs
  zip (a:as) (Event x : xs) = Event (a, x) : zip as xs
  zip _ _ = []
  
  zip3 :: [a] -> [b] -> [LEvent x] -> [LEvent (a, b, x)]
  zip3 as bs (Log x : xs) = Log x : zip3 as bs xs
  zip3 (a:as) (b:bs) (Event x : xs) = Event (a, b, x) : zip3 as bs xs
  zip3 _ _ _ = []
  
  zip4 :: [a] -> [b] -> [c] -> [LEvent x] -> [LEvent (a, b, c, x)]
  zip4 as bs cs (Log x : xs) = Log x : zip4 as bs cs xs
  zip4 (a:as) (b:bs) (c:cs) (Event x : xs) = Event (a, b, c, x) : zip4 as bs cs xs
  zip4 _ _ _ _ = []
  