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 :: ByteString -> ([ShadercWarning], [ShadercWarning])
processShadercMessages = (ShadercWarning -> ([ShadercWarning], [ShadercWarning]))
-> [ShadercWarning] -> ([ShadercWarning], [ShadercWarning])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ShadercWarning -> ([ShadercWarning], [ShadercWarning])
parseMsg ([ShadercWarning] -> ([ShadercWarning], [ShadercWarning]))
-> (ByteString -> [ShadercWarning])
-> ByteString
-> ([ShadercWarning], [ShadercWarning])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShadercWarning -> [ShadercWarning]
lines (ShadercWarning -> [ShadercWarning])
-> (ByteString -> ShadercWarning) -> ByteString -> [ShadercWarning]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShadercWarning
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 :: ShadercWarning -> ([ShadercWarning], [ShadercWarning])
parseMsg =
  ReadP ([ShadercWarning], [ShadercWarning])
-> ShadercWarning -> ([ShadercWarning], [ShadercWarning])
forall p. Monoid p => ReadP p -> ShadercWarning -> p
runParser (ReadP ([ShadercWarning], [ShadercWarning])
 -> ShadercWarning -> ([ShadercWarning], [ShadercWarning]))
-> ReadP ([ShadercWarning], [ShadercWarning])
-> ShadercWarning
-> ([ShadercWarning], [ShadercWarning])
forall a b. (a -> b) -> a -> b
$
    (ReadP ([ShadercWarning], [ShadercWarning])
 -> ReadP ([ShadercWarning], [ShadercWarning])
 -> ReadP ([ShadercWarning], [ShadercWarning]))
-> [ReadP ([ShadercWarning], [ShadercWarning])]
-> ReadP ([ShadercWarning], [ShadercWarning])
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1
      ReadP ([ShadercWarning], [ShadercWarning])
-> ReadP ([ShadercWarning], [ShadercWarning])
-> ReadP ([ShadercWarning], [ShadercWarning])
forall a. ReadP a -> ReadP a -> ReadP a
(<++)
      [ do
          f <- ReadP ShadercWarning
filename
          line <- between colon colon number
          skipSpaces
          t <- msgType
          msg <- manyTill get eof
          pure $ formatMsg t f line msg
      , do
          f <- ReadP ShadercWarning
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 <- ReadP ShadercWarning
filename
          colon *> skipSpaces
          _ <- string f
          line <- between (char '(') (char ')') number
          colon *> skipSpaces
          let t a
x = ([], [a
x])
          msg <- manyTill get eof
          pure $ formatMsg t f line msg
      , do
          _ <- ReadP Integer
number
          skipSpaces
          _ <- string "errors generated"
          eof
          pure ([], [])
      , do
          -- Unknown format
          msg <- ReadP Char -> ReadP () -> ReadP ShadercWarning
forall a end. ReadP a -> ReadP end -> ReadP [a]
manyTill ReadP Char
get ReadP ()
eof
          eof
          pure ([], [msg])
      ]
  where
    formatMsg :: (ShadercWarning -> t) -> ShadercWarning -> a -> ShadercWarning -> t
formatMsg ShadercWarning -> t
t ShadercWarning
f a
line ShadercWarning
msg = ShadercWarning -> t
t (ShadercWarning
f ShadercWarning -> ShadercWarning -> ShadercWarning
forall a. Semigroup a => a -> a -> a
<> ShadercWarning
":" ShadercWarning -> ShadercWarning -> ShadercWarning
forall a. Semigroup a => a -> a -> a
<> a -> ShadercWarning
forall a. Show a => a -> ShadercWarning
show a
line ShadercWarning -> ShadercWarning -> ShadercWarning
forall a. Semigroup a => a -> a -> a
<> ShadercWarning
": " ShadercWarning -> ShadercWarning -> ShadercWarning
forall a. Semigroup a => a -> a -> a
<> ShadercWarning
msg)
    filename :: ReadP ShadercWarning
filename = ReadP Char -> ReadP ShadercWarning
forall a. ReadP a -> ReadP [a]
many1 ReadP Char
get
    number :: ReadP Integer
number = ReadS Integer -> ReadP Integer
forall a. ReadS a -> ReadP a
readS_to_P (forall a. Read a => ReadS a
reads @Integer)
    colon :: ReadP ()
colon = ReadP Char -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP Char -> ReadP ()) -> ReadP Char -> ReadP ()
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char Char
':'
    msgType :: ReadP (a -> ([a], [a]))
msgType =
      [ReadP (a -> ([a], [a]))] -> ReadP (a -> ([a], [a]))
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ (\a
x -> ([], [a
x])) (a -> ([a], [a]))
-> ReadP ShadercWarning -> ReadP (a -> ([a], [a]))
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ShadercWarning -> ReadP ShadercWarning
string ShadercWarning
"error"
        , (\a
x -> ([a
x], [])) (a -> ([a], [a]))
-> ReadP ShadercWarning -> ReadP (a -> ([a], [a]))
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ShadercWarning -> ReadP ShadercWarning
string ShadercWarning
"warning"
        ]
        ReadP (a -> ([a], [a])) -> ReadP () -> ReadP (a -> ([a], [a]))
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
colon
        ReadP (a -> ([a], [a])) -> ReadP () -> ReadP (a -> ([a], [a]))
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces

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