Shaderc.hs

module Vulkan.Utils.ShaderQQ.Backend.Shaderc
  ( ShadercError
  , ShadercWarning
  , processShadercMessages
  ) where

import           Control.Monad                  ( void )
import qualified Data.ByteString.Lazy.Char8    as BSL
import           Data.Foldable                  ( asum )
import           Text.ParserCombinators.ReadP

type ShadercError = String
type ShadercWarning = String

processShadercMessages :: BSL.ByteString -> ([ShadercWarning], [ShadercError])
processShadercMessages = foldMap parseMsg . lines . BSL.unpack

-- >>> parseMsg "blah"
-- ([],[])
--
-- >>> parseMsg "blah"
-- ([],["blah"])
--
-- >>> parseMsg "foo:2: error: unknown var"
-- ([],["foo:2: unknown var"])
--
-- >>> parseMsg "foo:2: warning: unknown var"
-- (["foo:2: unknown var"],[])
--
-- >>> parseMsg "bar:2: error: 'a' : unknown variable"
-- ([],["bar:2: 'a' : unknown variable"])
--
-- >>> parseMsg "f:o: error: f:o:2: 'a' : unknown variable"
-- ([],["f:o:2: 'a' : unknown variable"])
--
-- >>> parseMsg "f:o: error: f:o:2: 'return' : type does not match, or is not convertible to, the function's return type"
-- ([],["f:o:2: 'return' : type does not match, or is not convertible to, the function's return type"])
--
-- >>> parseMsg "foo: foo(1): error at column 3, HLSL parsing failed."
-- ([],["foo:1: error at column 3, HLSL parsing failed."])
parseMsg :: String -> ([ShadercWarning], [ShadercError])
parseMsg = runParser $ foldl1
  (<++)
  [ do
    f    <- filename
    line <- between colon colon number
    skipSpaces
    t   <- msgType
    msg <- manyTill get eof
    pure $ formatMsg t f line msg
  , do
    f <- filename
    colon *> skipSpaces
    t    <- msgType
    _    <- string f
    line <- between (char ':') (char ':') number
    skipSpaces
    msg <- manyTill get eof
    pure $ formatMsg t f line msg
  , do
    f <- filename
    colon *> skipSpaces
    _    <- string f
    line <- between (char '(') (char ')') number
    colon *> skipSpaces
    let t x = ([], [x])
    msg <- manyTill get eof
    pure $ formatMsg t f line msg
  , do
    _ <- number
    skipSpaces
    _ <- string "errors generated"
    eof
    pure ([], [])
  , do
    -- Unknown format
    msg <- manyTill get eof
    eof
    pure ([], [msg])
  ]
 where
  formatMsg t f line msg = t (f <> ":" <> show line <> ": " <> msg)
  filename = many1 get
  number   = readS_to_P (reads @Integer)
  colon    = void $ char ':'
  msgType =
    asum
        [ (\x -> ([], [x])) <$ string "error"
        , (\x -> ([x], [])) <$ string "warning"
        ]
      <* colon
      <* skipSpaces

runParser :: Monoid p => ReadP p -> String -> p
runParser p s = case readP_to_S p s of
  [(r, "")] -> r
  _         -> mempty