{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

-- | Parse and combine a stream of tags.
--
module GhcTags.Stream
    ( tagParser
    , combineTagsPipe
    , runCombineTagsPipe
    ) where

import           Control.Monad.State.Strict
import           Data.ByteString (ByteString)
import           Data.Attoparsec.ByteString (Parser)
import qualified Data.ByteString as BS
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


-- | Parse a stream of tags, coming from a 'Text' producer.
--
tagParser :: MonadIO m
          => Parser (Maybe (Tag tk))
          -- ^ Parse a single tag.  For Vim this returns should parse a single
          -- line and return the tag, e.g  'parseTagLine'.
          -> Pipes.Producer ByteString m ()
          -> Pipes.Producer (Tag tk) m ()
tagParser :: Parser (Maybe (Tag tk))
-> Producer ByteString m () -> Producer (Tag tk) m ()
tagParser Parser (Maybe (Tag tk))
parser Producer ByteString m ()
producer = Proxy
  X
  ()
  ()
  (Tag tk)
  m
  (Either (ParsingError, Producer ByteString m ()) ())
-> Producer (Tag tk) m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Proxy
   X
   ()
   ()
   (Tag tk)
   m
   (Either (ParsingError, Producer ByteString m ()) ())
 -> Producer (Tag tk) m ())
-> Proxy
     X
     ()
     ()
     (Tag tk)
     m
     (Either (ParsingError, Producer ByteString m ()) ())
-> Producer (Tag tk) m ()
forall a b. (a -> b) -> a -> b
$
  Proxy
  X
  ()
  ()
  (Maybe (Tag tk))
  m
  (Either (ParsingError, Producer ByteString m ()) ())
-> (Maybe (Tag tk) -> Producer (Tag tk) m ())
-> Proxy
     X
     ()
     ()
     (Tag tk)
     m
     (Either (ParsingError, Producer ByteString m ()) ())
forall (m :: * -> *) x' x b' b a' c' c.
Functor m =>
Proxy x' x b' b m a'
-> (b -> Proxy x' x c' c m b') -> Proxy x' x c' c m a'
Pipes.for
    (Parser (Maybe (Tag tk))
-> Producer ByteString m ()
-> Proxy
     X
     ()
     ()
     (Maybe (Tag tk))
     m
     (Either (ParsingError, Producer ByteString m ()) ())
forall (m :: * -> *) a b r.
(Monad m, ParserInput a) =>
Parser a b
-> Producer a m r
-> Producer b m (Either (ParsingError, Producer a m r) r)
Pipes.AP.parsed Parser (Maybe (Tag tk))
parser Producer ByteString m ()
producer)
    ((Maybe (Tag tk) -> Producer (Tag tk) m ())
 -> Proxy
      X
      ()
      ()
      (Tag tk)
      m
      (Either (ParsingError, Producer ByteString m ()) ()))
-> (Maybe (Tag tk) -> Producer (Tag tk) m ())
-> Proxy
     X
     ()
     ()
     (Tag tk)
     m
     (Either (ParsingError, Producer ByteString m ()) ())
forall a b. (a -> b) -> a -> b
$ \case
      -- ignore header lines
      Just Tag tk
tag -> Tag tk -> Producer (Tag tk) m ()
forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
Pipes.yield Tag tk
tag
      Maybe (Tag tk)
Nothing  -> () -> Producer (Tag tk) m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Streaming version of 'GhcTags.Tag.combineTags'.
--
combineTagsPipe
    :: forall m (tk :: TAG_KIND).  Applicative m
    => (Tag tk -> Tag tk -> Ordering)
    -> RawFilePath -- ^ file path from which the new tags were obtained, it should be normalised
    -> Tag tk      -- ^ tag read from disc
    -> [Tag tk]    -- ^ new tags
    -> Pipes.Producer (Tag tk) m [Tag tk]
combineTagsPipe :: (Tag tk -> Tag tk -> Ordering)
-> ByteString -> Tag tk -> [Tag tk] -> Producer (Tag tk) m [Tag tk]
combineTagsPipe Tag tk -> Tag tk -> Ordering
compareFn ByteString
modPath = Tag tk -> [Tag tk] -> Producer (Tag tk) m [Tag tk]
go
  where
    go :: Tag tk -> [Tag tk]
       -> Pipes.Producer (Tag tk) m [Tag tk]

    -- omitt all the tags which point to 'modPath'
    --
    -- note: we check that 'tagFilePath' ends with 'modPath', which is
    -- a relative path from the corresponding cabal file.
    go :: Tag tk -> [Tag tk] -> Producer (Tag tk) m [Tag tk]
go Tag tk
tag [Tag tk]
as
      | ByteString
modPath ByteString -> ByteString -> Bool
`BS.isSuffixOf` Text -> ByteString
Text.encodeUtf8 (TagFilePath -> Text
getRawFilePath (Tag tk -> TagFilePath
forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath Tag tk
tag))
      = [Tag tk] -> Producer (Tag tk) m [Tag tk]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Tag tk]
as

    go Tag tk
tag as :: [Tag tk]
as@(Tag tk
a : [Tag tk]
as')
      | Bool
otherwise = case Tag tk
a Tag tk -> Tag tk -> Ordering
`compareFn` Tag tk
tag of
          Ordering
LT -> Tag tk -> Proxy X () () (Tag tk) m ()
forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
Pipes.yield Tag tk
a Proxy X () () (Tag tk) m ()
-> Producer (Tag tk) m [Tag tk] -> Producer (Tag tk) m [Tag tk]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tag tk -> [Tag tk] -> Producer (Tag tk) m [Tag tk]
go Tag tk
tag [Tag tk]
as'
          Ordering
EQ -> Tag tk -> Proxy X () () (Tag tk) m ()
forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
Pipes.yield Tag tk
a Proxy X () () (Tag tk) m ()
-> [Tag tk] -> Producer (Tag tk) m [Tag tk]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Tag tk]
as'
          Ordering
GT -> Tag tk -> Proxy X () () (Tag tk) m ()
forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
Pipes.yield Tag tk
tag Proxy X () () (Tag tk) m ()
-> [Tag tk] -> Producer (Tag tk) m [Tag tk]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Tag tk]
as

    go Tag tk
tag [] = Tag tk -> Proxy X () () (Tag tk) m ()
forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
Pipes.yield Tag tk
tag Proxy X () () (Tag tk) m ()
-> [Tag tk] -> Producer (Tag tk) m [Tag tk]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []


-- | run 'combineTagsPipe' taking care of the state.
--
runCombineTagsPipe
    :: MonadIO m
    => Handle
    -> (Tag tk -> Tag tk -> Ordering)
    -> (Tag tk -> Builder)
    -> RawFilePath
    -> Tag tk
    -> Pipes.Effect (StateT [Tag tk] m) ()
runCombineTagsPipe :: Handle
-> (Tag tk -> Tag tk -> Ordering)
-> (Tag tk -> Builder)
-> ByteString
-> Tag tk
-> Effect (StateT [Tag tk] m) ()
runCombineTagsPipe Handle
writeHandle Tag tk -> Tag tk -> Ordering
compareFn Tag tk -> Builder
formatTag ByteString
modPath =
       (\Tag tk
tag -> ([Tag tk] -> Proxy X () () (Tag tk) m ((), [Tag tk]))
-> Proxy X () () (Tag tk) (StateT [Tag tk] m) ()
forall (m :: * -> *) s a' a b' b r.
Monad m =>
(s -> Proxy a' a b' b m (r, s)) -> Proxy a' a b' b (StateT s m) r
Pipes.stateP (([Tag tk] -> Proxy X () () (Tag tk) m ((), [Tag tk]))
 -> Proxy X () () (Tag tk) (StateT [Tag tk] m) ())
-> ([Tag tk] -> Proxy X () () (Tag tk) m ((), [Tag tk]))
-> Proxy X () () (Tag tk) (StateT [Tag tk] m) ()
forall a b. (a -> b) -> a -> b
$ ([Tag tk] -> ((), [Tag tk]))
-> Proxy X () () (Tag tk) m [Tag tk]
-> Proxy X () () (Tag tk) m ((), [Tag tk])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((),) (Proxy X () () (Tag tk) m [Tag tk]
 -> Proxy X () () (Tag tk) m ((), [Tag tk]))
-> ([Tag tk] -> Proxy X () () (Tag tk) m [Tag tk])
-> [Tag tk]
-> Proxy X () () (Tag tk) m ((), [Tag tk])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag tk -> Tag tk -> Ordering)
-> ByteString
-> Tag tk
-> [Tag tk]
-> Proxy X () () (Tag tk) m [Tag tk]
forall (m :: * -> *) (tk :: TAG_KIND).
Applicative m =>
(Tag tk -> Tag tk -> Ordering)
-> ByteString -> Tag tk -> [Tag tk] -> Producer (Tag tk) m [Tag tk]
combineTagsPipe Tag tk -> Tag tk -> Ordering
compareFn ByteString
modPath Tag tk
tag)
    (Tag tk -> Proxy X () () (Tag tk) (StateT [Tag tk] m) ())
-> (Tag tk -> Effect (StateT [Tag tk] m) ())
-> Tag tk
-> Effect (StateT [Tag tk] m) ()
forall (m :: * -> *) a x' x b' b a' c' c.
Functor m =>
(a -> Proxy x' x b' b m a')
-> (b -> Proxy x' x c' c m b') -> a -> Proxy x' x c' c m a'
~> ByteString -> Proxy X () () ByteString (StateT [Tag tk] m) ()
forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
Pipes.yield (ByteString -> Proxy X () () ByteString (StateT [Tag tk] m) ())
-> (Tag tk -> ByteString)
-> Tag tk
-> Proxy X () () ByteString (StateT [Tag tk] m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BS.toLazyByteString (Builder -> ByteString)
-> (Tag tk -> Builder) -> Tag tk -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag tk -> Builder
formatTag
    (Tag tk -> Proxy X () () ByteString (StateT [Tag tk] m) ())
-> (ByteString -> Effect (StateT [Tag tk] m) ())
-> Tag tk
-> Effect (StateT [Tag tk] m) ()
forall (m :: * -> *) a x' x b' b a' c' c.
Functor m =>
(a -> Proxy x' x b' b m a')
-> (b -> Proxy x' x c' c m b') -> a -> Proxy x' x c' c m a'
~> (\ByteString
bs -> ByteString -> Producer' ByteString (StateT [Tag tk] m) ()
forall (m :: * -> *).
Monad m =>
ByteString -> Producer' ByteString m ()
Pipes.BS.fromLazy ByteString
bs)
    (ByteString -> Proxy X () () ByteString (StateT [Tag tk] m) ())
-> (ByteString -> Effect (StateT [Tag tk] m) ())
-> ByteString
-> Effect (StateT [Tag tk] m) ()
forall (m :: * -> *) a x' x b' b a' c' c.
Functor m =>
(a -> Proxy x' x b' b m a')
-> (b -> Proxy x' x c' c m b') -> a -> Proxy x' x c' c m a'
~> (\ByteString
bs -> ByteString -> Proxy X () () ByteString (StateT [Tag tk] m) ()
forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
Pipes.yield ByteString
bs Proxy X () () ByteString (StateT [Tag tk] m) ()
-> Proxy () ByteString () X (StateT [Tag tk] m) ()
-> Effect (StateT [Tag tk] m) ()
forall (m :: * -> *) a' a b r c' c.
Functor m =>
Proxy a' a () b m r -> Proxy () b c' c m r -> Proxy a' a c' c m r
>-> Handle -> Consumer' ByteString (StateT [Tag tk] m) ()
forall (m :: * -> *) r.
MonadIO m =>
Handle -> Consumer' ByteString m r
Pipes.BS.toHandle Handle
writeHandle)