{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Df1.Html.Parse (log) where
import Control.Applicative
import qualified Data.Attoparsec.ByteString as AB
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Df1 as D
import qualified Df1.Parse
import qualified Xmlbf as X
import Prelude hiding (log)
log :: X.Parser D.Log
log = X.pElement "div" $ do
attrClass "df1-log"
t <- parseTime
p <- parsePaths
l <- parseLevel
m <- parseMessage
let raw = BL.toStrict $ TLE.encodeUtf8 $ TL.intercalate " " [t, p, l, m]
case AB.parseOnly Df1.Parse.log raw of
Left _ -> fail "Could not parse Log."
Right a -> pure a
attrClass :: T.Text -> X.Parser ()
attrClass t = do
attrs <- X.pAttr "class"
case elem t (T.words attrs) of
False -> fail ("Expected \"class\" value to contain " <> show t <> ".")
True -> pure ()
parseTime :: X.Parser TL.Text
parseTime = X.pElement "span" $ do
attrClass "df1-time"
X.pText
parseLevel :: X.Parser TL.Text
parseLevel = X.pElement "span" $ do
attrClass "df1-level"
X.pText
parsePaths :: X.Parser TL.Text
parsePaths = X.pElement "span" $ do
attrClass "df1-path"
TL.intercalate " " <$> many (parsePush <|> parseAttr)
parsePush :: X.Parser TL.Text
parsePush = X.pElement "span" $ do
attrClass "df1-push"
t <- X.pText
s <- parseSeg
pure (t <> s)
parseSeg :: X.Parser TL.Text
parseSeg = X.pElement "span" $ do
attrClass "df1-seg"
X.pText <|> pure ""
parseAttr :: X.Parser TL.Text
parseAttr = X.pElement "span" $ do
attrClass "df1-attr"
k <- parseKey
eq <- X.pText
v <- parseValue
pure (k <> eq <> v)
parseKey :: X.Parser TL.Text
parseKey = X.pElement "span" $ do
attrClass "df1-key"
X.pText <|> pure ""
parseValue :: X.Parser TL.Text
parseValue = X.pElement "span" $ do
attrClass "df1-value"
X.pText <|> pure ""
parseMessage :: X.Parser TL.Text
parseMessage = X.pElement "span" $ do
attrClass "df1-msg"
X.pText <|> pure ""