{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Redact.Markdown
(
Line(..)
, Part(..)
, Error(..)
, redact
, redact'
, textToTerminal
, textToTerminal'
, handleToTerminal
, handleToTerminal'
, fileToTerminal
, fileToTerminal'
, redactLine
, redactLine'
) where
import qualified System.Console.ANSI as Term
import Control.Monad (guard)
import Prelude hiding (lines)
import System.IO (Handle)
import qualified Data.Text as T
import Data.Text (Text)
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)
)
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 -> [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
textToTerminal
:: MonadTerminal m
=> [Term.SGR]
-> 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
textToTerminal'
:: MonadTerminal m
=> [Term.SGR]
-> 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'
handleToTerminal
:: (MonadHandle m, MonadTerminal m)
=> [Term.SGR]
-> 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
handleToTerminal'
:: (MonadHandle m, MonadTerminal m)
=> [Term.SGR]
-> 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
fileToTerminal
:: (MonadHandle m, MonadTerminal m)
=> [Term.SGR]
-> 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
fileToTerminal'
:: (MonadHandle m, MonadTerminal m)
=> [Term.SGR]
-> 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
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
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
"`"
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]
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
'`')
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)
type StrictState = (Int, Bool)
initialStrictState :: StrictState
initialStrictState :: StrictState
initialStrictState = (Int
1, LenientState
False)
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
")"
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
")"
type LenientState = Bool
initialLenientState :: LenientState
initialLenientState :: LenientState
initialLenientState = LenientState
False
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)