Substring.hs

module Text.Parser.Substring
  ( matchAll
  , replaceFileOnceWithParser
  , replaceOnceWithParser
  , onceReplacify
  , takeMatch
  ) where

import           Control.Applicative ((<|>), optional)
import qualified Data.Attoparsec.Text as AT
import qualified Data.DList as DList
import           Data.Maybe (isJust)
import           Data.Monoid ((<>))
import           Data.Text (Text)
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Builder as TextBuilder
import           Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.IO as Text
import           Text.Parser.Char (CharParsing, anyChar)
import           Text.Parser.Combinators (eof)

import           Debug.NoTrace (trace, traceM)


replaceFileOnceWithParser :: AT.Parser Text -> FilePath -> IO ()
replaceFileOnceWithParser p filePath =
  Text.writeFile filePath =<< replaceOnceWithParser p <$> Text.readFile filePath


replaceOnceWithParser :: AT.Parser Text -> Text -> Text
replaceOnceWithParser p t =
  maybe t (Text.toStrict . TextBuilder.toLazyText)
    $ AT.maybeResult
    $ traceId "fed"
    $ flip AT.feed ""
    $ traceId "parsed"
    $ AT.parse (onceReplacify p) t


-- | ref: https://stackoverflow.com/questions/29549435/parsec-how-to-find-matches-within-a-string
{-# INLINE matchAll #-}
matchAll :: (Monad m, CharParsing m) => m a -> m [a]
matchAll p = DList.toList <$> loop DList.empty
  where
    loop xs = do
      mMatched <- optional p
      case mMatched of
          Just matched ->
            loop (xs `DList.snoc` matched)
          _ ->
            (anyChar *> loop xs) <|> pure xs


onceReplacify :: (Monad m, CharParsing m) => m Text -> m Builder
onceReplacify p =
  let firstToMatched =
        (TextBuilder.fromText <$> p)
          <|> ((<>) <$> (TextBuilder.singleton <$> anyChar) <*> firstToMatched)
  in
    (<>) <$> firstToMatched <*> takeBuilder


{-# INLINE takeBuilder #-}
takeBuilder :: (Monad m, CharParsing m) => m Builder
takeBuilder = loop mempty
 where
  loop b = (eof *> pure b) <|> ( do
      c <- anyChar
      loop (b <> TextBuilder.singleton c)
    )


{-# INLINE takeMatch #-}
takeMatch :: (Monad m, CharParsing m) => m a -> m (Text, a)
takeMatch p = loop mempty
  where
    loop taken = do
      mMatched <- optional p
      traceM $ "isJust mMatched: " ++ show (isJust mMatched)
      case mMatched of
          Just matched ->
            return (Text.toStrict $ TextBuilder.toLazyText taken, matched)
          _ -> do
            newChar <- (TextBuilder.singleton <$> anyChar) <|> pure mempty
            traceM $ "newChar: " ++ show newChar
            loop (taken <> newChar)


{-# INLINE traceIdVia #-}
traceIdVia :: Show b => (a -> b) -> String -> a -> a
traceIdVia via prefix x = trace (prefix ++ ": " ++ show (via x)) x


{-# INLINE traceId #-}
traceId :: Show a => String -> a -> a
traceId = traceIdVia id