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 CPP #-}
  module LogView.Process (
      -- * state
      State(..), initial_state, add_msg, state_msgs
      , compile_filter
      -- * process_msg
      , process_msg
      , CatchPattern, global_status_pattern
      , render_status
      , StyledText(..)
  
      , match_pattern
  #ifdef TESTING
      , flatten_ranges, run_formatter, regex_style, style_plain
      , msg_text_regexes
  #endif
  ) where
  import qualified Control.Monad.Trans.State as State
  import qualified Control.Monad.Trans.Writer as Writer
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Builder as Builder
  import qualified Data.ByteString.Lazy as Lazy
  import qualified Data.Foldable as Foldable
  import qualified Data.Functor.Identity as Identity
  import qualified Data.List as List
  import qualified Data.Map as Map
  import qualified Data.Sequence as Sequence
  import qualified Data.Text as Text
  import qualified Data.Text.Encoding as Text.Encoding
  import qualified Data.Word as Word
  
  import qualified Util.CallStack as CallStack
  import qualified Util.Lists as Lists
  import qualified Util.Log as Log
  import qualified Util.Regex as Regex
  
  import qualified Derive.Stack as Stack
  
  import           Global
  
  
  -- * state
  
  data State = State {
      state_filter :: Filter
      -- | Msgs matching this regex have their matching groups put in the
      -- status line.
      , state_catch_patterns :: [CatchPattern]
      , state_status :: Status
      -- | A cache of the most recent msgs.  When the filter is changed they can
      -- be displayed.  This way memory use is bounded but you can display recent
      -- msgs you missed because of the filter.
      , state_cached_msgs :: Sequence.Seq Log.Msg
      -- | Last displayed msg, along with the number of times it has been seen.
      -- Used to suppress duplicate msgs.
      , state_last_displayed :: Maybe (Log.Msg, Int)
      } deriving (Show)
  
  initial_state :: Text -> State
  initial_state filt = State
      { state_filter = compile_filter filt
      , state_catch_patterns = []
      , state_status = Map.empty
      , state_cached_msgs = Sequence.empty
      , state_last_displayed = Nothing
      }
  
  add_msg :: Int -> Log.Msg -> State -> State
  add_msg history msg state = state { state_cached_msgs = seq }
      where seq = Sequence.take history (msg Sequence.<| state_cached_msgs state)
  
  state_msgs :: State -> [Log.Msg]
  state_msgs = Foldable.toList . state_cached_msgs
  
  -- ** catch
  
  -- | Transform the status line based on each msg.
  type Catch = Log.Msg -> Status -> Status
  
  -- | Extract text from a log msg and put it in 'state_status', via
  -- 'catch_regexes'.
  type CatchPattern = (Text, Regex.Regex)
  
  -- ** status
  
  type Status = Map Text Text
  
  render_status :: Status -> StyledText
  render_status status = run_formatter $
      sequence_ $ List.intersperse (with_style style_divider " || ")
          (map format_status (Map.assocs status))
  
  format_status :: (Text, Text) -> Formatter
  format_status (k, v) = do
      with_style style_emphasis k
      with_style style_plain ": "
      regex_style style_plain clickable_braces v
  
  clickable_braces :: [(Regex.Regex, Style)]
  clickable_braces =
      [ (Regex.compileUnsafe "\\{.*?\\}", style_clickable)
      ]
  
  data StyledText = StyledText {
      -- | UTF8-encoded text.
      style_text :: B.ByteString
      -- | 'Style' characters, same length as style_text.
      , style_style :: B.ByteString
      } deriving (Eq, Show)
  
  type ProcessM = State.StateT State Identity.Identity
  
  -- | Process an incoming log msg.  If the msg isn't filtered out, returned
  -- a colorized version.  Also possibly modify the app state for things like
  -- catch and timing.
  process_msg :: State -> Log.Msg -> (Maybe StyledText, State)
  process_msg state msg = run $ do -- suppress_last msg $ do
      filt <- State.gets state_filter
      process_catch
      let styled = format_msg msg
      -- I match the filter on the styled output so that the filter is on
      -- the msg as actually displayed.
      return $ if eval_filter filt msg $
              Text.Encoding.decodeUtf8 (style_text styled)
          then Just styled else Nothing
      where
      run = flip State.runState state
      process_catch = State.modify $ \st -> st
          { state_status = catch (state_status st) (state_catch_patterns st) }
      catch status patterns = foldl'
          (\status catch -> catch msg status) status (catches patterns)
  
  catches :: [CatchPattern] -> [Catch]
  catches patterns =
      [ catch_regexes patterns
      , catch_start
      ]
  
  -- | Return Nothing if the given msg is the same as the last one.
  suppress_last :: Log.Msg -> ProcessM (Maybe a) -> ProcessM (Maybe a)
  suppress_last msg process = do
      last_displayed <- State.gets state_last_displayed
      case last_displayed of
          Just (last_msg, times) | matches last_msg msg -> do
              State.modify $ \st ->
                  st { state_last_displayed = Just (msg, times+1) }
              return Nothing
          _ -> do
              result <- process
              whenJust result $ \_ -> State.modify $ \st ->
                  st { state_last_displayed = Just (msg, 0) }
              return result
      where matches m1 m2 = Log.msg_text m1 == Log.msg_text m2
  
  -- | This searches the log msg text for a regex and puts it in the status bar
  -- with the given key string.
  --
  -- If the regex has no groups, the entire match is used for the value.  If it
  -- has one group, that group is used.  If it has two groups, the first group
  -- will replace the key.  >2 groups is an error.
  --
  -- If the value is \"\", then the key is removed.
  catch_regexes :: [CatchPattern] -> Catch
  catch_regexes patterns msg = Map.filter (not . Text.null) . Map.union status
      where
      status = Map.unions $
          map (($ Log.msg_text msg) . match_pattern) patterns
  
  -- | The app sends this on startup, so I can clear out any status from the
  -- last session.
  catch_start :: Catch
  catch_start msg status
      | Log.msg_text msg == "app starting" = Map.empty
      | otherwise = status
  
  -- | This catches msgs emitted by 'Cmd.Cmd.set_global_status'.
  global_status_pattern :: CatchPattern
  global_status_pattern =
      ("_", Regex.compileUnsafe "^global status: (.*?) -- (.*)")
  
  match_pattern :: CatchPattern -> Text -> Map Text Text
  match_pattern (title, reg) = Map.fromList . map extract . Regex.groups reg
      where
      extract (_, [match]) = (title, match)
      extract (_, [match_title, match]) = (match_title, match)
      extract _ = error $ show reg ++ " has >2 groups"
  
  
  -- ** filter
  
  -- | Filter language, created by 'compile_filter'.
  data Filter = Filter Text (Log.Msg -> Text -> Bool)
  instance Show Filter where
      show (Filter src _) = "Process.compile_filter " ++ show src
  
  -- | Compile a simple filter language.  A log msg matches if all of the words
  -- in the filter occur within its 'Log.msg_text', and none of the words
  -- prefixed by @-@ occur.
  compile_filter :: Text -> Filter
  compile_filter s = Filter s pred
      where
      (not_has_, has) = List.partition ("-" `Text.isPrefixOf`) (Text.words s)
      not_has = map (Text.drop 1) not_has_
      pred _msg text = all (`Text.isInfixOf` text) has
          && not (any (`Text.isInfixOf` text) not_has)
  
  eval_filter :: Filter -> Log.Msg -> Text -> Bool
  eval_filter (Filter _ pred) msg text = pred msg text
  
  
  -- * format_msg
  
  -- | Format and colorize a single Log.Msg.
  format_msg :: Log.Msg -> StyledText
  format_msg msg = run_formatter $ do
      let width = fromEnum (maxBound :: Log.Priority)
      with_style style_fixed $ Text.justifyLeft width ' ' $
          prio_stars (Log.msg_priority msg)
      let style = if Log.msg_priority msg < Log.Warn
              then style_plain else style_warn
      case Log.msg_caller msg of
          CallStack.NoCaller -> return ()
          caller@(CallStack.Caller {}) ->
              with_style style_filename $ CallStack.showCaller caller <> " "
      whenJust (Log.msg_stack msg) $ \stack -> emit_stack stack >> with_plain " "
      regex_style style msg_text_regexes (Log.msg_text msg)
      with_plain "\n"
      where
      prio_stars Log.Timer = "-"
      prio_stars prio = Text.replicate (fromEnum prio) "*"
  
  -- | Pair together text along with the magic Style characters.  The Styles
  -- should be the same length as the string.
  type Formatter = Writer.Writer Builder ()
  
  data Builder = Builder !Builder.Builder !Builder.Builder
  
  instance Semigroup Builder where
      Builder a1 b1 <> Builder a2 b2 = Builder (a1 <> a2) (b1 <> b2)
  instance Monoid Builder where
      mempty = Builder mempty mempty
      mappend = (<>)
  
  run_formatter :: Formatter -> StyledText
  run_formatter = build . Writer.execWriter
      where
      build (Builder text styles) = StyledText (b text) (b styles)
      b = Lazy.toStrict . Builder.toLazyByteString
  
  emit_stack :: Stack.Stack -> Formatter
  emit_stack stack = do
      if stack == Stack.empty then return ()
          -- This likely means the global transform failed.
          else if null ui_stack then with_plain $
              "[" <> Text.intercalate " / " (map pretty (Stack.outermost stack))
              <> "]"
          else with_style style_clickable $
              Text.intercalate " / " (map Stack.log_ui_frame ui_stack)
      whenJust (last_call stack) $ \call ->
          with_plain $ " " <> call <> ":"
      where
      ui_stack = Stack.to_ui stack
      last_call = Lists.head . mapMaybe Stack.call_of . Stack.innermost
  
  msg_text_regexes :: [(Regex.Regex, Style)]
  msg_text_regexes =
      (Regex.compileUnsafe "\\([bvt]id \".*?\"\\)", style_emphasis)
      : clickable_braces
  
  regex_style :: Style -> [(Regex.Regex, Style)] -> Text -> Formatter
  regex_style default_style regex_styles text =
      sequence_ emits >> with_style default_style rest
      where
      (rest, emits) = List.mapAccumL emit text ranges
      emit text (i, style) = (post, with_style style pre)
          where (pre, post) = Text.splitAt i text
      ranges = flatten_ranges default_style
          [ (range, style)
          | (reg, style) <- regex_styles
          , (range, _) <- Regex.groupRanges reg text
          ]
  
  flatten_ranges :: a -> [((Int, Int), a)] -> [(Int, a)]
  flatten_ranges deflt = filter ((>0) . fst) . snd . go 0 . Lists.sortOn fst
      where
      go n [] = (n, [])
      go n (((s, e), style) : ranges) = (,) (max last_n e) $
          (s - n, deflt)
          : (min e next - s, style)
          : rest ++ if last_n < e then [(e - last_n, style)] else []
          where
          next = maybe e (fst . fst) (Lists.head ranges)
          (last_n, rest) = go e ranges
  
  with_plain :: Text -> Formatter
  with_plain = with_style style_plain
  
  with_style :: Style -> Text -> Formatter
  with_style _ text | Text.null text = return ()
  with_style style text = Writer.tell $
      Builder (Builder.byteString utf8)
          (Builder.byteString (B.replicate (B.length utf8) style))
      where utf8 = Text.Encoding.encodeUtf8 text
  
  type Style = Word.Word8
  
  style_plain, style_warn, style_clickable, style_emphasis, style_divider,
      style_filename :: Style
  style_plain = word 'A'
  style_warn = word 'B'
  style_clickable = word 'C'
  style_emphasis = word 'D'
  style_divider = word 'E'
  -- I lost calling function name when I switched from hspp to implicit call
  -- stacks.
  -- style_func_name = word 'F'
  style_filename = word 'F'
  style_fixed = word 'H'
  
  word :: Char -> Word.Word8
  word = toEnum . fromEnum
  