------------------------------------------------------------------------------
-- |
-- Module      : Redact.Markdown
-- Description : Markdown redaction
-- Copyright   : Copyright (c) 2020-2023 Travis Cardwell
-- License     : MIT
--
-- Markdown inline code (text enclosed in backticks) is redacted.  This
-- redacted text may not span multiple lines.  Example:
--
-- @The word `hidden` is redacted.@
--
-- Markdown fenced code (text in between lines of three or more backticks is
-- redacted.  The number of backticks is not matched.  The backticks in the
-- beginning line may optionally be followed by addition text, which is
-- ignored.  Example:
--
-- @
-- ```
-- All lines of text between the backticks
-- are hidden.
-- ```
-- @
------------------------------------------------------------------------------

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

module Redact.Markdown
  ( -- * Types
    Line(..)
  , Part(..)
  , Error(..)
    -- * Pure API
  , redact
  , redact'
    -- * Terminal API
  , textToTerminal
  , textToTerminal'
  , handleToTerminal
  , handleToTerminal'
  , fileToTerminal
  , fileToTerminal'
    -- * Internal
  , redactLine
  , redactLine'
  ) where

-- https://hackage.haskell.org/package/ansi-terminal
import qualified System.Console.ANSI as Term

-- https://hackage.haskell.org/package/base
import Control.Monad (guard)
import Prelude hiding (lines)
import System.IO (Handle)

-- https://hackage.haskell.org/package/text
import qualified Data.Text as T
import Data.Text (Text)

-- (redact)
import qualified Redact.Internal as Internal
import qualified Redact.Monad.Handle as RMH
import Redact.Monad.Handle (MonadHandle)
import qualified Redact.Monad.Terminal as RMT
import Redact.Monad.Terminal (MonadTerminal)
import Redact.Types
  ( Error(IOError, RedactError), Line(NormalLine, RedactLine)
  , Part(Redact, Stet)
  )

------------------------------------------------------------------------------
-- $PureAPI

-- | Redact text strictly
--
-- This function fails if inline or fenced code is not closed.
--
-- @since 0.4.0.0
redact :: Text -> Either String [Line]
redact :: Text -> Either [Char] [Line]
redact = forall s.
(s -> Text -> Either [Char] (Line, s))
-> (s -> Maybe [Char]) -> s -> Text -> Either [Char] [Line]
Internal.redact StrictState -> Text -> Either [Char] (Line, StrictState)
strictStep StrictState -> Maybe [Char]
strictEnd StrictState
initialStrictState

------------------------------------------------------------------------------

-- | Redact text leniently
--
-- This function does not fail if inline or fenced code is not closed.
--
-- @since 0.4.0.0
redact' :: Text -> [Line]
redact' :: Text -> [Line]
redact' = forall s. (s -> Text -> (Line, s)) -> s -> Text -> [Line]
Internal.redact' LenientState -> Text -> (Line, LenientState)
lenientStep LenientState
initialLenientState

------------------------------------------------------------------------------
-- $TerminalAPI

-- | Redact text strictly, putting it to the terminal
--
-- @since 0.4.0.0
textToTerminal
  :: MonadTerminal m
  => [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> Text
  -> m (Either Error ())
textToTerminal :: forall (m :: * -> *).
MonadTerminal m =>
[SGR] -> Text -> m (Either Error ())
textToTerminal [SGR]
sgrs
    = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Error
RedactError) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadTerminal m => [SGR] -> [Line] -> m ()
RMT.putLines [SGR]
sgrs)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either [Char] [Line]
redact

------------------------------------------------------------------------------

-- | Redact text leniently, putting it to the terminal
--
-- @since 0.4.0.0
textToTerminal'
  :: MonadTerminal m
  => [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> Text
  -> m ()
textToTerminal' :: forall (m :: * -> *). MonadTerminal m => [SGR] -> Text -> m ()
textToTerminal' [SGR]
sgrs = forall (m :: * -> *). MonadTerminal m => [SGR] -> [Line] -> m ()
RMT.putLines [SGR]
sgrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Line]
redact'

------------------------------------------------------------------------------

-- | Redact text from a 'Handle' strictly, putting it to the terminal
--
-- @since 0.4.0.0
handleToTerminal
  :: (MonadHandle m, MonadTerminal m)
  => [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> Handle
  -> m (Either Error ())
handleToTerminal :: forall (m :: * -> *).
(MonadHandle m, MonadTerminal m) =>
[SGR] -> Handle -> m (Either Error ())
handleToTerminal =
    forall (m :: * -> *) s.
(MonadHandle m, MonadTerminal m) =>
(s -> Text -> Either [Char] (Line, s))
-> (s -> Maybe [Char])
-> s
-> [SGR]
-> Handle
-> m (Either Error ())
RMH.handleToTerminal StrictState -> Text -> Either [Char] (Line, StrictState)
strictStep StrictState -> Maybe [Char]
strictEnd StrictState
initialStrictState

------------------------------------------------------------------------------

-- | Redact text from a 'Handle' leniently, putting it to the terminal
--
-- @since 0.4.0.0
handleToTerminal'
  :: (MonadHandle m, MonadTerminal m)
  => [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> Handle
  -> m ()
handleToTerminal' :: forall (m :: * -> *).
(MonadHandle m, MonadTerminal m) =>
[SGR] -> Handle -> m ()
handleToTerminal' = forall (m :: * -> *) s.
(MonadHandle m, MonadTerminal m) =>
(s -> Text -> (Line, s)) -> s -> [SGR] -> Handle -> m ()
RMH.handleToTerminal' LenientState -> Text -> (Line, LenientState)
lenientStep LenientState
initialLenientState

------------------------------------------------------------------------------

-- | Redact text from a file strictly, putting it to the terminal
--
-- @since 0.4.0.0
fileToTerminal
  :: (MonadHandle m, MonadTerminal m)
  => [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> FilePath
  -> m (Either Error ())
fileToTerminal :: forall (m :: * -> *).
(MonadHandle m, MonadTerminal m) =>
[SGR] -> [Char] -> m (Either Error ())
fileToTerminal = forall (m :: * -> *) s.
(MonadHandle m, MonadTerminal m) =>
(s -> Text -> Either [Char] (Line, s))
-> (s -> Maybe [Char])
-> s
-> [SGR]
-> [Char]
-> m (Either Error ())
RMH.fileToTerminal StrictState -> Text -> Either [Char] (Line, StrictState)
strictStep StrictState -> Maybe [Char]
strictEnd StrictState
initialStrictState

------------------------------------------------------------------------------

-- | Redact text from a file leniently, putting it to the terminal
--
-- @since 0.4.0.0
fileToTerminal'
  :: (MonadHandle m, MonadTerminal m)
  => [Term.SGR]  -- ^ 'Term.SGR's for redacted text
  -> FilePath
  -> m (Either Error ())
fileToTerminal' :: forall (m :: * -> *).
(MonadHandle m, MonadTerminal m) =>
[SGR] -> [Char] -> m (Either Error ())
fileToTerminal' = forall (m :: * -> *) s.
(MonadHandle m, MonadTerminal m) =>
(s -> Text -> (Line, s))
-> s -> [SGR] -> [Char] -> m (Either Error ())
RMH.fileToTerminal' LenientState -> Text -> (Line, LenientState)
lenientStep LenientState
initialLenientState

------------------------------------------------------------------------------
-- $Internal

-- | Redact a 'NormalLine' strictly
redactLine :: Text -> Maybe Line
redactLine :: Text -> Maybe Line
redactLine Text
line = do
    let ts :: [Text]
ts = Text -> Text -> [Text]
T.splitOn Text
"`" Text
line
    forall (f :: * -> *). Alternative f => LenientState -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ts forall a. Integral a => a -> a -> a
`mod` Int
2 forall a. Eq a => a -> a -> LenientState
== Int
1
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> Line
redactLineParts [Text]
ts

------------------------------------------------------------------------------

-- | Redact a 'NormalLine' leniently
redactLine' :: Text -> Line
redactLine' :: Text -> Line
redactLine' = [Text] -> Line
redactLineParts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"`"

------------------------------------------------------------------------------

-- | Construct a 'NormalLine' from parts of a line split on @`@
redactLineParts :: [Text] -> Line
redactLineParts :: [Text] -> Line
redactLineParts = [Part] -> Line
NormalLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Part]
go
  where
    go :: [Text] -> [Part]
    go :: [Text] -> [Part]
go (Text
tStet:[Text]
ts)
      | Text -> LenientState
T.null Text
tStet = [Text] -> [Text] -> [Part]
goR [] [Text]
ts
      | LenientState
otherwise = [Text] -> [Text] -> [Part]
goR [Text
tStet] [Text]
ts
    go [] = []

    goR :: [Text] -> [Text] -> [Part]
    goR :: [Text] -> [Text] -> [Part]
goR [Text]
acc (Text
tRedact:[Text]
ts)
      | Text -> LenientState
T.null Text
tRedact = [Text] -> [Text] -> [Part]
goS (Text
"`" forall a. a -> [a] -> [a]
: [Text]
acc) [Text]
ts
      | LenientState
otherwise
          = Text -> Part
Stet ([Text] -> Text
T.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ Text
"`" forall a. a -> [a] -> [a]
: [Text]
acc)
          forall a. a -> [a] -> [a]
: Text -> Part
Redact Text
tRedact
          forall a. a -> [a] -> [a]
: [Text] -> [Text] -> [Part]
goS [] [Text]
ts
    goR [Text]
acc []
      | forall (t :: * -> *) a. Foldable t => t a -> LenientState
null [Text]
acc = []
      | LenientState
otherwise = [Text -> Part
Stet forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Text]
acc]

    goS :: [Text] -> [Text] -> [Part]
    goS :: [Text] -> [Text] -> [Part]
goS [Text]
acc (Text
tStet:[Text]
ts)
      | Text -> LenientState
T.null Text
tStet = [Text] -> [Text] -> [Part]
goR (Text
"`" forall a. a -> [a] -> [a]
: [Text]
acc) [Text]
ts
      | LenientState
otherwise = [Text] -> [Text] -> [Part]
goR (Text
tStet forall a. a -> [a] -> [a]
: Text
"`" forall a. a -> [a] -> [a]
: [Text]
acc) [Text]
ts
    goS [Text]
acc []
      | forall (t :: * -> *) a. Foldable t => t a -> LenientState
null [Text]
acc = []
      | LenientState
otherwise = [Text -> Part
Stet forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Text]
acc]

------------------------------------------------------------------------------

-- | Does a line begin a fenced code block?
--
-- A line that begins a fenced code block beings with three or more backticks.
isFenceBegin :: Text -> Bool
isFenceBegin :: Text -> LenientState
isFenceBegin = (forall a. Ord a => a -> a -> LenientState
>= Int
3) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> LenientState) -> Text -> Text
T.takeWhile (forall a. Eq a => a -> a -> LenientState
== Char
'`')

------------------------------------------------------------------------------

-- | Does a line end a fence code block?
--
-- A line that ends a fenced code block consists of three or more backticks.
isFenceEnd :: Text -> Bool
isFenceEnd :: Text -> LenientState
isFenceEnd = LenientState -> LenientState -> LenientState
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> LenientState
T.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> LenientState) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> LenientState
== Char
'`')) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall a. Ord a => a -> a -> LenientState
>= Int
3) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length)

------------------------------------------------------------------------------

-- | State for strict parsing
type StrictState = (Int, Bool)  -- (lineNum, isFenced)

------------------------------------------------------------------------------

-- | Initial 'StrictState'
initialStrictState :: StrictState
initialStrictState :: StrictState
initialStrictState = (Int
1, LenientState
False)

------------------------------------------------------------------------------

-- | Parse the next line strictly
strictStep
  :: StrictState
  -> Text
  -> Either String (Line, StrictState)
strictStep :: StrictState -> Text -> Either [Char] (Line, StrictState)
strictStep (!Int
lineNum, LenientState
isFenced) Text
t
    | LenientState
isFenced = if Text -> LenientState
isFenceEnd Text
t
        then forall a b. b -> Either a b
Right ([Part] -> Line
NormalLine [Text -> Part
Stet Text
t], (Int
lineNum forall a. Num a => a -> a -> a
+ Int
1, LenientState
False))
        else forall a b. b -> Either a b
Right (Text -> Line
RedactLine Text
t, (Int
lineNum forall a. Num a => a -> a -> a
+ Int
1, LenientState
True))
    | LenientState
otherwise = if Text -> LenientState
isFenceBegin Text
t
        then forall a b. b -> Either a b
Right ([Part] -> Line
NormalLine [Text -> Part
Stet Text
t], (Int
lineNum forall a. Num a => a -> a -> a
+ Int
1, LenientState
True))
        else case Text -> Maybe Line
redactLine Text
t of
          Just Line
line -> forall a b. b -> Either a b
Right (Line
line, (Int
lineNum forall a. Num a => a -> a -> a
+ Int
1, LenientState
False))
          Maybe Line
Nothing -> forall a b. a -> Either a b
Left [Char]
inlineError
  where
    inlineError :: String
    inlineError :: [Char]
inlineError = [Char]
"inline code not terminated (line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
lineNum forall a. [a] -> [a] -> [a]
++ [Char]
")"

------------------------------------------------------------------------------

-- | Process the end of the input strictly
strictEnd :: StrictState -> Maybe String
strictEnd :: StrictState -> Maybe [Char]
strictEnd (!Int
lineNum, LenientState
isFenced)
    | LenientState
isFenced = forall a. a -> Maybe a
Just [Char]
fencedError
    | LenientState
otherwise = forall a. Maybe a
Nothing
  where
    fencedError :: String
    fencedError :: [Char]
fencedError = [Char]
"fenced code not terminated (line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
lineNum forall a. [a] -> [a] -> [a]
++ [Char]
")"

------------------------------------------------------------------------------

-- | State for lenient parsing
type LenientState = Bool  -- isFenced

------------------------------------------------------------------------------

-- Initial 'LenientState'
initialLenientState :: LenientState
initialLenientState :: LenientState
initialLenientState = LenientState
False

------------------------------------------------------------------------------

-- | Parse the next line leniently
lenientStep
  :: LenientState
  -> Text
  -> (Line, LenientState)
lenientStep :: LenientState -> Text -> (Line, LenientState)
lenientStep LenientState
isFenced Text
t
    | LenientState
isFenced = if Text -> LenientState
isFenceEnd Text
t
        then ([Part] -> Line
NormalLine [Text -> Part
Stet Text
t], LenientState
False)
        else (Text -> Line
RedactLine Text
t, LenientState
True)
    | LenientState
otherwise = if Text -> LenientState
isFenceBegin Text
t
        then ([Part] -> Line
NormalLine [Text -> Part
Stet Text
t], LenientState
True)
        else (Text -> Line
redactLine' Text
t, LenientState
False)