{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module GhcTags.Stream
( tagParser
, combineTagsPipe
, runCombineTagsPipe
) where
import Control.Monad.State.Strict
import Data.ByteString (ByteString)
import Data.Attoparsec.ByteString (Parser)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BS
import Data.Functor (($>))
import qualified Data.Text.Encoding as Text
import System.IO
import System.FilePath.ByteString (RawFilePath)
import Pipes ((>->), (~>))
import qualified Pipes as Pipes
import qualified Pipes.Lift as Pipes
import qualified Pipes.Attoparsec as Pipes.AP
import qualified Pipes.ByteString as Pipes.BS
import GhcTags.Tag
tagParser :: MonadIO m
=> Parser (Maybe (Tag tk))
-> Pipes.Producer ByteString m ()
-> Pipes.Producer (Tag tk) m ()
tagParser parser producer = void $
Pipes.for
(Pipes.AP.parsed parser producer)
$ \case
Just tag -> Pipes.yield tag
Nothing -> pure ()
combineTagsPipe
:: forall m (tk :: TAG_KIND). Applicative m
=> (Tag tk -> Tag tk -> Ordering)
-> RawFilePath
-> Tag tk
-> [Tag tk]
-> Pipes.Producer (Tag tk) m [Tag tk]
combineTagsPipe compareFn modPath = go
where
modPathText = Text.decodeUtf8 modPath
go :: Tag tk -> [Tag tk]
-> Pipes.Producer (Tag tk) m [Tag tk]
go tag as
| getRawFilePath (tagFilePath tag) == modPathText = pure as
go tag as@(a : as')
| otherwise = case a `compareFn` tag of
LT -> Pipes.yield a >> go tag as'
EQ -> Pipes.yield a $> as'
GT -> Pipes.yield tag $> as
go tag [] = Pipes.yield tag $> []
runCombineTagsPipe
:: MonadIO m
=> Handle
-> (Tag tk -> Tag tk -> Ordering)
-> (Tag tk -> Builder)
-> RawFilePath
-> Tag tk
-> Pipes.Effect (StateT [Tag tk] m) ()
runCombineTagsPipe writeHandle compareFn formatTag modPath =
(\tag -> Pipes.stateP $ fmap ((),) . combineTagsPipe compareFn modPath tag)
~> Pipes.yield . BS.toLazyByteString . formatTag
~> Pipes.BS.fromLazy
~> \bs -> Pipes.yield bs >-> Pipes.BS.toHandle writeHandle