module System.Log.SLog.Format
(
FormatElem(..)
, Format
, format )
where
import Control.Applicative
import Language.Haskell.TH
import Language.Haskell.TH.Lift
import qualified Data.Text as T
import qualified Data.Attoparsec.Text as A
import Data.Time.Format
import Data.Time.LocalTime
import System.Locale
import Data.String
instance Lift T.Text where
lift t = let s = T.unpack t in [| fromString s :: T.Text |]
data FormatElemTH
= MessageElemTH
| SeverityElemTH
| StringElemTH T.Text
| DateTimeElemTH String
| ThreadElemTH
deriving (Show)
type FormatTH = [FormatElemTH]
data FormatElem
= MessageElem
| SeverityElem
| StringElem T.Text
| DateTimeElem (ZonedTime -> T.Text)
| ThreadElem
type Format = [FormatElem]
finaliseFormat :: FormatTH -> Format
finaliseFormat (StringElemTH s0 : StringElemTH s1 : rest) = finaliseFormat $ StringElemTH (T.append s0 s1) : rest
finaliseFormat fs = map for' fs
where
for' MessageElemTH = MessageElem
for' SeverityElemTH = SeverityElem
for' (StringElemTH s) = StringElem s
for' (DateTimeElemTH s) = DateTimeElem $ T.pack . formatTime defaultTimeLocale s
for' ThreadElemTH = ThreadElem
formatParser :: A.Parser [ExpQ]
formatParser
= A.endOfInput *> return [] <|> do
e <- A.choice [ A.takeWhile1 (/= '%') >>= \t -> return [|StringElemTH t|]
, A.char '%' *> elemParser
]
(e :) <$> formatParser
elemParser :: A.Parser ExpQ
elemParser = A.choice [ A.char '%' *> return [|StringElemTH "%"|]
, A.char 'm' *> return [|MessageElemTH|]
, A.char 's' *> return [|SeverityElemTH|]
, A.char 'd' *> datetimeParser >>= \f -> return [|DateTimeElemTH f|]
, A.char 't' *> return [|ThreadElemTH|]
]
datetimeParser :: A.Parser String
datetimeParser = fmap T.unpack $ A.char '(' *> datetimeParser' <* A.char ')'
where
datetimeParser' :: A.Parser T.Text
datetimeParser' = do
s <- A.takeWhile (\c -> c /= '\\' && c /= ')')
A.choice [ A.string "\\)" *> ((\r -> T.concat [s, ")", r]) <$> datetimeParser')
, liftA3
(\a b c -> a `T.cons` b `T.cons` c)
(A.char '\\')
A.anyChar
datetimeParser'
, return s
]
format :: String -> ExpQ
format s = [| finaliseFormat $(mat s) |]
mat :: String -> ExpQ
mat s = case A.parseOnly formatParser $ T.pack s of
Left err -> fail err
Right exps -> ListE <$> sequence exps