------------------------------------------------------------------------------
-- |
-- Module      : Redact.Markdown
-- Description : Markdown redaction
-- Copyright   : Copyright (c) 2020-2022 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 String [Line]
redact = (StrictState -> Text -> Either String (Line, StrictState))
-> (StrictState -> Maybe String)
-> StrictState
-> Text
-> Either String [Line]
forall s.
(s -> Text -> Either String (Line, s))
-> (s -> Maybe String) -> s -> Text -> Either String [Line]
Internal.redact StrictState -> Text -> Either String (Line, StrictState)
strictStep StrictState -> Maybe String
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' = (LenientState -> Text -> (Line, LenientState))
-> LenientState -> Text -> [Line]
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 :: [SGR] -> Text -> m (Either Error ())
textToTerminal [SGR]
sgrs
    = (String -> m (Either Error ()))
-> ([Line] -> m (Either Error ()))
-> Either String [Line]
-> m (Either Error ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either Error () -> m (Either Error ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error () -> m (Either Error ()))
-> (String -> Either Error ()) -> String -> m (Either Error ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ())
-> (String -> Error) -> String -> Either Error ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Error
RedactError) ((() -> Either Error ()) -> m () -> m (Either Error ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Either Error ()
forall a b. b -> Either a b
Right (m () -> m (Either Error ()))
-> ([Line] -> m ()) -> [Line] -> m (Either Error ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SGR] -> [Line] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> [Line] -> m ()
RMT.putLines [SGR]
sgrs)
    (Either String [Line] -> m (Either Error ()))
-> (Text -> Either String [Line]) -> Text -> m (Either Error ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String [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' :: [SGR] -> Text -> m ()
textToTerminal' [SGR]
sgrs = [SGR] -> [Line] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> [Line] -> m ()
RMT.putLines [SGR]
sgrs ([Line] -> m ()) -> (Text -> [Line]) -> Text -> m ()
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 :: [SGR] -> Handle -> m (Either Error ())
handleToTerminal =
    (StrictState -> Text -> Either String (Line, StrictState))
-> (StrictState -> Maybe String)
-> StrictState
-> [SGR]
-> Handle
-> m (Either Error ())
forall (m :: * -> *) s.
(MonadHandle m, MonadTerminal m) =>
(s -> Text -> Either String (Line, s))
-> (s -> Maybe String)
-> s
-> [SGR]
-> Handle
-> m (Either Error ())
RMH.handleToTerminal StrictState -> Text -> Either String (Line, StrictState)
strictStep StrictState -> Maybe String
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' :: [SGR] -> Handle -> m ()
handleToTerminal' = (LenientState -> Text -> (Line, LenientState))
-> LenientState -> [SGR] -> Handle -> m ()
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 :: [SGR] -> String -> m (Either Error ())
fileToTerminal = (StrictState -> Text -> Either String (Line, StrictState))
-> (StrictState -> Maybe String)
-> StrictState
-> [SGR]
-> String
-> m (Either Error ())
forall (m :: * -> *) s.
(MonadHandle m, MonadTerminal m) =>
(s -> Text -> Either String (Line, s))
-> (s -> Maybe String)
-> s
-> [SGR]
-> String
-> m (Either Error ())
RMH.fileToTerminal StrictState -> Text -> Either String (Line, StrictState)
strictStep StrictState -> Maybe String
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' :: [SGR] -> String -> m (Either Error ())
fileToTerminal' = (LenientState -> Text -> (Line, LenientState))
-> LenientState -> [SGR] -> String -> m (Either Error ())
forall (m :: * -> *) s.
(MonadHandle m, MonadTerminal m) =>
(s -> Text -> (Line, s))
-> s -> [SGR] -> String -> 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
    LenientState -> Maybe ()
forall (f :: * -> *). Alternative f => LenientState -> f ()
guard (LenientState -> Maybe ()) -> LenientState -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ts Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> LenientState
forall a. Eq a => a -> a -> LenientState
== Int
1
    Line -> Maybe Line
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Line -> Maybe Line) -> Line -> Maybe Line
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 ([Text] -> Line) -> (Text -> [Text]) -> Text -> Line
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 ([Part] -> Line) -> ([Text] -> [Part]) -> [Text] -> Line
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
"`" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) [Text]
ts
      | LenientState
otherwise
          = Text -> Part
Stet ([Text] -> Text
T.concat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
"`" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
          Part -> [Part] -> [Part]
forall a. a -> [a] -> [a]
: Text -> Part
Redact Text
tRedact
          Part -> [Part] -> [Part]
forall a. a -> [a] -> [a]
: [Text] -> [Text] -> [Part]
goS [] [Text]
ts
    goR [Text]
acc []
      | [Text] -> LenientState
forall (t :: * -> *) a. Foldable t => t a -> LenientState
null [Text]
acc = []
      | LenientState
otherwise = [Text -> Part
Stet (Text -> Part) -> ([Text] -> Text) -> [Text] -> Part
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Part) -> [Text] -> Part
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
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
"`" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) [Text]
ts
      | LenientState
otherwise = [Text] -> [Text] -> [Part]
goR (Text
tStet Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"`" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) [Text]
ts
    goS [Text]
acc []
      | [Text] -> LenientState
forall (t :: * -> *) a. Foldable t => t a -> LenientState
null [Text]
acc = []
      | LenientState
otherwise = [Text -> Part
Stet (Text -> Part) -> ([Text] -> Text) -> [Text] -> Part
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Part) -> [Text] -> Part
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
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 = (Int -> Int -> LenientState
forall a. Ord a => a -> a -> LenientState
>= Int
3) (Int -> LenientState) -> (Text -> Int) -> Text -> LenientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length (Text -> Int) -> (Text -> Text) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> LenientState) -> Text -> Text
T.takeWhile (Char -> Char -> LenientState
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
(&&) (LenientState -> LenientState -> LenientState)
-> (Text -> LenientState) -> Text -> LenientState -> LenientState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> LenientState
T.null (Text -> LenientState) -> (Text -> Text) -> Text -> LenientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> LenientState) -> Text -> Text
T.dropWhile (Char -> Char -> LenientState
forall a. Eq a => a -> a -> LenientState
== Char
'`')) (Text -> LenientState -> LenientState)
-> (Text -> LenientState) -> Text -> LenientState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int -> Int -> LenientState
forall a. Ord a => a -> a -> LenientState
>= Int
3) (Int -> LenientState) -> (Text -> Int) -> Text -> LenientState
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 String (Line, StrictState)
strictStep (!Int
lineNum, LenientState
isFenced) Text
t
    | LenientState
isFenced = if Text -> LenientState
isFenceEnd Text
t
        then (Line, StrictState) -> Either String (Line, StrictState)
forall a b. b -> Either a b
Right ([Part] -> Line
NormalLine [Text -> Part
Stet Text
t], (Int
lineNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, LenientState
False))
        else (Line, StrictState) -> Either String (Line, StrictState)
forall a b. b -> Either a b
Right (Text -> Line
RedactLine Text
t, (Int
lineNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, LenientState
True))
    | LenientState
otherwise = if Text -> LenientState
isFenceBegin Text
t
        then (Line, StrictState) -> Either String (Line, StrictState)
forall a b. b -> Either a b
Right ([Part] -> Line
NormalLine [Text -> Part
Stet Text
t], (Int
lineNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, LenientState
True))
        else case Text -> Maybe Line
redactLine Text
t of
          Just Line
line -> (Line, StrictState) -> Either String (Line, StrictState)
forall a b. b -> Either a b
Right (Line
line, (Int
lineNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, LenientState
False))
          Maybe Line
Nothing -> String -> Either String (Line, StrictState)
forall a b. a -> Either a b
Left String
inlineError
  where
    inlineError :: String
    inlineError :: String
inlineError = String
"inline code not terminated (line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
lineNum String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

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

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

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

-- | 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)