{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Trace.Hpc.Codecov.Parser
( readTix'
, readMix'
) where
import Control.Applicative (Alternative (..))
import Data.Functor (($>))
import Prelude hiding (takeWhile)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import System.FilePath ((<.>), (</>))
import Trace.Hpc.Mix (BoxLabel (..),
CondBox (..), Mix (..),
MixEntry)
import Trace.Hpc.Tix (Tix (..), TixModule (..),
tixModuleName)
import Trace.Hpc.Util (HpcHash (..), HpcPos,
catchIO, toHpcPos)
import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
import Data.Time.Clock (UTCTime (..))
readTix' :: FilePath -> IO (Maybe Tix)
readTix' :: FilePath -> IO (Maybe Tix)
readTix' FilePath
path =
(forall a. P a -> ByteString -> Maybe a
runMaybeP P Tix
parseTix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BS.readFile FilePath
path) forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
readMix'
:: [String]
-> Either String TixModule
-> IO Mix
readMix' :: [FilePath] -> Either FilePath TixModule -> IO Mix
readMix' [FilePath]
dirs Either FilePath TixModule
et_tm = [FilePath] -> IO Mix
go [FilePath]
dirs
where
mixname :: FilePath
mixname = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id TixModule -> FilePath
tixModuleName Either FilePath TixModule
et_tm FilePath -> FilePath -> FilePath
<.> FilePath
"mix"
handler :: p -> f (Either a b)
handler p
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left a
"err ...")
parse :: FilePath -> IO (Either FilePath Mix)
parse FilePath
path = forall a. P a -> ByteString -> Either FilePath a
runEitherP P Mix
parseMix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BS.readFile FilePath
path
go :: [FilePath] -> IO Mix
go [] = forall a. HasCallStack => FilePath -> a
error FilePath
"Cannot find mix file"
go (FilePath
d:[FilePath]
ds) = do
Either FilePath Mix
et_mix <- FilePath -> IO (Either FilePath Mix)
parse (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
mixname) forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` forall {f :: * -> *} {a} {p} {b}.
(Applicative f, IsString a) =>
p -> f (Either a b)
handler
case Either FilePath Mix
et_mix of
Right Mix
mix -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Mix
mix
Left FilePath
_err -> [FilePath] -> IO Mix
go [FilePath]
ds
newtype P a =
P {forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP :: forall r. (String -> r)
-> (a -> ByteString -> r)
-> ByteString
-> r}
instance Functor P where
fmap :: forall a b. (a -> b) -> P a -> P b
fmap a -> b
f P a
p = forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
err b -> ByteString -> r
ok -> forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP P a
p FilePath -> r
err (b -> ByteString -> r
ok forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
{-# INLINE fmap #-}
instance Applicative P where
pure :: forall a. a -> P a
pure a
x = forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
_ a -> ByteString -> r
ok -> a -> ByteString -> r
ok a
x)
{-# INLINE pure #-}
P (a -> b)
pf <*> :: forall a b. P (a -> b) -> P a -> P b
<*> P a
pa = forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
err b -> ByteString -> r
ok -> forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP P (a -> b)
pf FilePath -> r
err (\a -> b
f -> forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f P a
pa) FilePath -> r
err b -> ByteString -> r
ok))
{-# INLINE (<*>) #-}
instance Monad P where
P a
m >>= :: forall a b. P a -> (a -> P b) -> P b
>>= a -> P b
k = forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
err b -> ByteString -> r
ok -> forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP P a
m FilePath -> r
err (\a
x -> forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP (a -> P b
k a
x) FilePath -> r
err b -> ByteString -> r
ok))
{-# INLINE (>>=) #-}
instance Alternative P where
empty :: forall a. P a
empty = forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
err a -> ByteString -> r
_ ByteString
_ -> FilePath -> r
err FilePath
"Alternative.empty")
{-# INLINE empty #-}
P a
p1 <|> :: forall a. P a -> P a -> P a
<|> P a
p2 = forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
err a -> ByteString -> r
go ByteString
bs -> forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP P a
p1 (\FilePath
_ -> forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP P a
p2 FilePath -> r
err a -> ByteString -> r
go ByteString
bs) a -> ByteString -> r
go ByteString
bs)
{-# INLINE (<|>) #-}
runEitherP :: P a -> ByteString -> Either String a
runEitherP :: forall a. P a -> ByteString -> Either FilePath a
runEitherP P a
p = forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP P a
p forall a b. a -> Either a b
Left (\a
a ByteString
_ -> forall a b. b -> Either a b
Right a
a)
runMaybeP :: P a -> ByteString -> Maybe a
runMaybeP :: forall a. P a -> ByteString -> Maybe a
runMaybeP P a
p = forall a.
P a
-> forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r
runP P a
p (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (\a
a ByteString
_ -> forall a. a -> Maybe a
Just a
a)
char :: Char -> P ()
char :: Char -> P ()
char Char
c =
forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
err () -> ByteString -> r
ok ByteString
bs ->
case ByteString -> Maybe (Char, ByteString)
BS.uncons ByteString
bs of
Just (Char
c', ByteString
bs') | Char
c forall a. Eq a => a -> a -> Bool
== Char
c' -> () -> ByteString -> r
ok () ByteString
bs'
Maybe (Char, ByteString)
_ -> FilePath -> r
err (FilePath
"char: failed to get " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Char
c))
{-# INLINABLE char #-}
bytes :: ByteString -> P ()
bytes :: ByteString -> P ()
bytes ByteString
target =
forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
err () -> ByteString -> r
ok ByteString
bs ->
case Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (ByteString -> Int
BS.length ByteString
target) ByteString
bs of
(ByteString
pre, ByteString
post) | ByteString
pre forall a. Eq a => a -> a -> Bool
== ByteString
target -> () -> ByteString -> r
ok () ByteString
post
(ByteString, ByteString)
_ -> FilePath -> r
err (FilePath
"bytes: failed to parse `" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show ByteString
target forall a. Semigroup a => a -> a -> a
<> FilePath
"'"))
{-# INLINABLE bytes #-}
int :: P Int
int :: P Int
int =
forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
err Int -> ByteString -> r
ok ByteString
bs ->
case ByteString -> Maybe (Int, ByteString)
BS.readInt ByteString
bs of
Just (Int
n, ByteString
bs') -> Int -> ByteString -> r
ok Int
n ByteString
bs'
Maybe (Int, ByteString)
_ -> FilePath -> r
err FilePath
"int: failed")
{-# INLINABLE int #-}
integer :: P Integer
integer :: P Integer
integer = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral P Int
int
{-# INLINEABLE integer #-}
spaces :: P ()
spaces :: P ()
spaces = forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
_ () -> ByteString -> r
ok ByteString
bs -> () -> ByteString -> r
ok () (ByteString -> ByteString
BS.dropSpace ByteString
bs))
{-# INLINABLE spaces #-}
takeWhile :: (Char -> Bool) -> P ByteString
takeWhile :: (Char -> Bool) -> P ByteString
takeWhile Char -> Bool
test =
forall a.
(forall r.
(FilePath -> r) -> (a -> ByteString -> r) -> ByteString -> r)
-> P a
P (\FilePath -> r
_ ByteString -> ByteString -> r
ok ByteString
bs -> case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span Char -> Bool
test ByteString
bs of (ByteString
pre, ByteString
post) -> ByteString -> ByteString -> r
ok ByteString
pre ByteString
post)
{-# INLINABLE takeWhile #-}
sepBy :: Alternative f => f a -> f s -> f [a]
sepBy :: forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy f a
a f s
s = forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy1 f a
a f s
s forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
{-# INLINEABLE sepBy #-}
sepBy1 :: Alternative f => f a -> f s -> f [a]
sepBy1 :: forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy1 f a
a f s
s = f [a]
go
where
go :: f [a]
go = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((f s
s forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f [a]
go) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
{-# INLINABLE sepBy1 #-}
doubleQuoted :: P a -> P a
doubleQuoted :: forall a. P a -> P a
doubleQuoted P a
p = Char -> P ()
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
char Char
'"'
{-# INLINEABLE doubleQuoted #-}
bracketed :: P a -> P a
bracketed :: forall a. P a -> P a
bracketed P a
p = Char -> P ()
char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
char Char
']'
{-# INLINABLE bracketed #-}
parenthesized :: P a -> P a
parenthesized :: forall a. P a -> P a
parenthesized P a
p = Char -> P ()
char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
char Char
')'
{-# INLINABLE parenthesized #-}
comma :: P ()
comma :: P ()
comma = Char -> P ()
char Char
','
{-# INLINABLE comma #-}
bool :: P Bool
bool :: P Bool
bool = P Bool
true forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Bool
false
where
true :: P Bool
true = ByteString -> P ()
bytes ByteString
"True" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
false :: P Bool
false = ByteString -> P ()
bytes ByteString
"False" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
{-# INLINABLE bool #-}
string :: P String
string :: P FilePath
string = ByteString -> FilePath
BS.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. P a -> P a
doubleQuoted ((Char -> Bool) -> P ByteString
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'"'))
{-# INLINABLE string #-}
parseTix :: P Tix
parseTix :: P Tix
parseTix = do
ByteString -> P ()
bytes ByteString
"Tix" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
spaces
[TixModule]
tix_modules <- forall a. P a -> P a
bracketed (forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy P TixModule
tixModule P ()
comma)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TixModule] -> Tix
Tix [TixModule]
tix_modules)
tixModule :: P TixModule
tixModule :: P TixModule
tixModule = do
P ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> P ()
bytes ByteString
"TixModule" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
spaces
FilePath
name <- P FilePath
string forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces
Hash
hash <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HpcHash a => a -> Hash
toHash P Int
int forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces
Int
size <- P Int
int forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces
[Integer]
ticks <- forall a. P a -> P a
bracketed (forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy P Integer
integer P ()
comma)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> Hash -> Int -> [Integer] -> TixModule
TixModule FilePath
name Hash
hash Int
size [Integer]
ticks)
parseMix :: P Mix
parseMix :: P Mix
parseMix = do
ByteString -> P ()
bytes ByteString
"Mix" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
spaces
FilePath
path <- P FilePath
string forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces
ByteString
_year <- (Char -> Bool) -> P ByteString
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
' ') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces
ByteString
_time <- (Char -> Bool) -> P ByteString
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
' ') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces
ByteString
_zone <- (Char -> Bool) -> P ByteString
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
' ') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces
Hash
hash <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HpcHash a => a -> Hash
toHash P Int
int forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces
Int
tabstop <- P Int
int forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces
let dummy_date :: UTCTime
dummy_date = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Day
fromOrdinalDate Integer
1900 Int
1) DiffTime
0
FilePath -> UTCTime -> Hash -> Int -> [MixEntry] -> Mix
Mix FilePath
path UTCTime
dummy_date Hash
hash Int
tabstop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P [MixEntry]
mixEntries
mixEntries :: P [MixEntry]
mixEntries :: P [MixEntry]
mixEntries = forall a. P a -> P a
bracketed (forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy P MixEntry
mixEntry P ()
comma)
{-# INLINABLE mixEntries #-}
mixEntry :: P MixEntry
mixEntry :: P MixEntry
mixEntry = forall a. P a -> P a
parenthesized forall a b. (a -> b) -> a -> b
$ do
HpcPos
pos <- P HpcPos
hpcPos
P ()
comma
BoxLabel
box <- P BoxLabel
boxLabel
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HpcPos
pos, BoxLabel
box)
{-# INLINABLE mixEntry #-}
hpcPos :: P HpcPos
hpcPos :: P HpcPos
hpcPos = do
Int
sl <- P Int
int
Char -> P ()
char Char
':'
Int
sc <- P Int
int
Char -> P ()
char Char
'-'
Int
el <- P Int
int
Char -> P ()
char Char
':'
Int
ec <- P Int
int
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Int, Int, Int) -> HpcPos
toHpcPos (Int
sl, Int
sc, Int
el, Int
ec))
{-# INLINABLE hpcPos #-}
boxLabel :: P BoxLabel
boxLabel :: P BoxLabel
boxLabel = P BoxLabel
expBox forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P BoxLabel
topLevelBox forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P BoxLabel
localBox forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P BoxLabel
binBox
where
expBox :: P BoxLabel
expBox = ByteString -> P ()
bytes ByteString
"ExpBox" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> BoxLabel
ExpBox P Bool
bool
topLevelBox :: P BoxLabel
topLevelBox = ByteString -> P ()
bytes ByteString
"TopLevelBox" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> BoxLabel
TopLevelBox P [FilePath]
names
localBox :: P BoxLabel
localBox = ByteString -> P ()
bytes ByteString
"LocalBox" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> BoxLabel
LocalBox P [FilePath]
names
binBox :: P BoxLabel
binBox = ByteString -> P ()
bytes ByteString
"BinBox" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
(CondBox -> Bool -> BoxLabel
BinBox forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P CondBox
condBox forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
spaces) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P Bool
bool)
{-# INLINABLE boxLabel #-}
names :: P [String]
names :: P [FilePath]
names = forall a. P a -> P a
bracketed (forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy P FilePath
string P ()
comma)
{-# INLINABLE names #-}
condBox :: P CondBox
condBox :: P CondBox
condBox = P CondBox
guard forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P CondBox
cond forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P CondBox
qual
where
guard :: P CondBox
guard = ByteString -> P ()
bytes ByteString
"GuardBinBox" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CondBox
GuardBinBox
cond :: P CondBox
cond = ByteString -> P ()
bytes ByteString
"CondBinBox" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CondBox
CondBinBox
qual :: P CondBox
qual = ByteString -> P ()
bytes ByteString
"QualBinBox" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CondBox
QualBinBox
{-# INLINABLE condBox #-}