content: {-# LANGUAGE NoMonomorphismRestriction #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE OverlappingInstances #-}
  {-# LANGUAGE TypeFamilies #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  System.Log.Format
  -- Copyright   :  (C) 2015 Flowbox
  -- License     :  Apache-2.0
  -- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>
  -- Stability   :  stable
  -- Portability :  portable
  -----------------------------------------------------------------------------
  
  module System.Log.Format where
  
  import System.Log.Log               (Log)
  import System.Log.Data              (Lvl(Lvl), Msg(Msg), Loc(Loc), Time(Time), LocData(LocData), LevelData(LevelData), readData, DataOf, Lookup)
  import Data.Time.Clock              (UTCTime)
  import Data.Time.Format             (formatTime)
  import Data.Time.Locale.Compat      (defaultTimeLocale)
  import Text.PrettyPrint.ANSI.Leijen
  
  
  
  ----------------------------------------------------------------------
  -- Formatter
  ----------------------------------------------------------------------
  
  newtype Formatter a = Formatter { runFormatter :: Log a -> Doc }
  
  mapFormatter f (Formatter a) = Formatter (f a)
  
  
  instance Show (Formatter a) where
      show _ = "Formatter"
  
  
  ----------------------------------------------------------------------
  -- FormatBuilder
  ----------------------------------------------------------------------
  
  class FormatterBuilder a b where
      buildFormatter :: a -> Formatter b
  
  
  (<:>) :: (FormatterBuilder a c, FormatterBuilder b c) => a -> b -> Formatter c
  (<:>) a b = concatFormatters (buildFormatter a) (buildFormatter b)
  
  concatFormatters :: Formatter a -> Formatter a -> Formatter a
  concatFormatters (Formatter f) (Formatter g) = Formatter (\s -> f s <> g s)
  
  -- === Instances ===
  
  instance (PPrint (DataOf seg), Lookup seg (Log a)) => FormatterBuilder seg a where
      buildFormatter a = Formatter $ pprint . readData a
  
  instance (a~b) => FormatterBuilder (Formatter a) b where
      buildFormatter = id
  
  instance FormatterBuilder String a where
      buildFormatter a = Formatter $ const (text a)
  
  instance FormatterBuilder Doc a where
      buildFormatter a = Formatter $ const a
  
  ----------------------------------------------------------------------
  -- Pretty printing
  ----------------------------------------------------------------------
  
  class PPrint a where
      pprint :: a -> Doc
  
  instance PPrint String where
      pprint = text
  
  instance Pretty a => PPrint a where
      pprint = pretty
  
  instance Pretty LevelData where
      pretty (LevelData _ name) = text name
  
  instance Pretty LocData where
      pretty (LocData _ _ m (l,_) _) = text (m ++ ":" ++ show l)
  
  instance Pretty UTCTime where
      pretty = text . formatTime defaultTimeLocale "%c"
  
  ----------------------------------------------------------------------
  -- Basic formatters
  ----------------------------------------------------------------------
  
  defaultFormatter     = colorLvlFormatter ("[" <:> Lvl <:> "] ") <:> Msg
  defaultTimeFormatter = colorLvlFormatter ("[" <:> Lvl <:> "] ") <:> Time <:> ": " <:> Msg
  defaultFormatterTH   = colorLvlFormatter ("[" <:> Lvl <:> "] ") <:> Loc <:> ": " <:> Msg
  
  -- Color formatter
  
  colorLvlFormatter f = Formatter (\s -> let (LevelData pr _) = readData Lvl s in lvlColor pr $ runFormatter f s)
  
  lvlColor lvl
      | lvl == 0  = id
      | lvl <= 2  = green
      | lvl == 3  = yellow
      | otherwise = red
  
  