content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TypeSynonymInstances #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  module Common.Logger
    ( 
      LogSource
    , LogLevel (..)
    , LogStr(..)
    , toLogStr
    , fromLogStr
    , liftLoc
    , defaultLoc
    , defaultLogStr
    ) where
  
  
  import Data.ByteString (ByteString)
  import qualified Data.ByteString as BS
  import Data.ByteString.Builder (Builder)
  import qualified Data.ByteString.Builder as B
  import qualified Data.ByteString.Char8 as S8
  import qualified Data.ByteString.Lazy as BL
  import qualified Data.ByteString.Short as SBS
  import Data.Monoid (mappend, mempty)
  #if MIN_VERSION_base(4,9,0)
  import qualified Data.Semigroup as Semi (Semigroup(..))
  #endif
  import Data.String (IsString(..))
  import qualified Data.Text as T
  import Data.Text (Text)
  import qualified Data.Text.Encoding as T
  import qualified Data.Text.Lazy as TL
  import qualified Data.Text.Lazy.Encoding as TL
  import Language.Haskell.TH.Syntax (Lift (lift), Q, Exp, Loc (..), qLocation)
  
  -- From the monad-logger package
  
  type LogSource = Text
  
  data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
      deriving (Eq, Prelude.Show, Prelude.Read, Ord)
  
  instance Lift LogLevel where
      lift LevelDebug = [|LevelDebug|]
      lift LevelInfo  = [|LevelInfo|]
      lift LevelWarn  = [|LevelWarn|]
      lift LevelError = [|LevelError|]
      lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|]
  
  liftLoc :: Loc -> Q Exp
  liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
      $(lift a)
      $(lift b)
      $(lift c)
      ($(lift d1), $(lift d2))
      ($(lift e1), $(lift e2))
      |]
  
  defaultLoc :: Loc
  defaultLoc = Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)
  
  defaultLogLevelStr :: LogLevel -> LogStr
  defaultLogLevelStr level = case level of
      LevelOther t -> toLogStr t
      _            -> toLogStr $ S8.pack $ drop 5 $ show level
  
  defaultLogStr :: Loc
                -> LogSource
                -> LogLevel
                -> LogStr
                -> LogStr
  defaultLogStr loc src level msg =
      "[" `mappend` defaultLogLevelStr level `mappend`
      (if T.null src
          then mempty
          else "#" `mappend` toLogStr src) `mappend`
      "] " `mappend`
      msg `mappend`
      (if isDefaultLoc loc
          then "\n"
          else
              " @(" `mappend`
              toLogStr (S8.pack fileLocStr) `mappend`
              ")\n")
    where
      -- taken from file-location package
      -- turn the TH Loc loaction information into a human readable string
      -- leaving out the loc_end parameter
      fileLocStr = (loc_package loc) ++ ':' : (loc_module loc) ++
        ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
        where
          line = show . fst . loc_start
          char = show . snd . loc_start
  
  isDefaultLoc :: Loc -> Bool
  isDefaultLoc (Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)) = True
  isDefaultLoc _ = False
  
  ----------------------------------------------------------------
  -- From the fast-logger package
  
  toBuilder :: ByteString -> Builder
  toBuilder = B.byteString
  
  fromBuilder :: Builder -> ByteString
  #if MIN_VERSION_bytestring(0,10,0)
  fromBuilder = BL.toStrict . B.toLazyByteString
  #else
  fromBuilder = BS.concat . BL.toChunks . B.toLazyByteString
  #endif
  
  -- | Log message builder. Use ('<>') to append two LogStr in O(1).
  data LogStr = LogStr !Int Builder
  
  #if MIN_VERSION_base(4,9,0)
  instance Semi.Semigroup LogStr where
      {-# INLINE (<>) #-}
      LogStr s1 b1 <> LogStr s2 b2 = LogStr (s1 + s2) (b1 <> b2)
  #endif
  
  instance Monoid LogStr where
      mempty = LogStr 0 (toBuilder BS.empty)
      {-# INLINE mappend #-}
      LogStr s1 b1 `mappend` LogStr s2 b2 = LogStr (s1 + s2) (b1 <> b2)
  
  instance IsString LogStr where
      {-# INLINE fromString #-}
      fromString = toLogStr . TL.pack
  
  -- | Types that can be converted to a 'LogStr'. Instances for
  -- types from the @text@ library use a UTF-8 encoding. Instances
  -- for numerical types use a decimal encoding.
  class ToLogStr msg where
      toLogStr :: msg -> LogStr
  
  instance ToLogStr LogStr where
      {-# INLINE toLogStr #-}
      toLogStr = id
  instance ToLogStr S8.ByteString where
      {-# INLINE toLogStr #-}
      toLogStr bs = LogStr (BS.length bs) (toBuilder bs)
  instance ToLogStr BL.ByteString where
      {-# INLINE toLogStr #-}
      toLogStr b = LogStr (fromIntegral (BL.length b)) (B.lazyByteString b)
  instance ToLogStr Builder where
      {-# INLINE toLogStr #-}
      toLogStr x = let b = B.toLazyByteString x in LogStr (fromIntegral (BL.length b)) (B.lazyByteString b)
  instance ToLogStr SBS.ShortByteString where
      {-# INLINE toLogStr #-}
      toLogStr b = LogStr (SBS.length b) (B.shortByteString b)
  
  instance ToLogStr String where
      {-# INLINE toLogStr #-}
      toLogStr = toLogStr . TL.pack
  
  instance ToLogStr T.Text where
      {-# INLINE toLogStr #-}
      toLogStr = toLogStr . T.encodeUtf8
  instance ToLogStr TL.Text where
      {-# INLINE toLogStr #-}
      toLogStr = toLogStr . TL.encodeUtf8
  
  instance Show LogStr where
    show = show . T.decodeUtf8 . fromLogStr
  
  instance Eq LogStr where
    a == b = fromLogStr a == fromLogStr b
  
  -- | Obtaining the length of 'LogStr'.
  logStrLength :: LogStr -> Int
  logStrLength (LogStr n _) = n
  
  -- | Converting 'LogStr' to 'ByteString'.
  fromLogStr :: LogStr -> ByteString
  fromLogStr (LogStr _ builder) = fromBuilder builder
  