{-# 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 [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 -> [Line]
redact' :: Text -> [Line]
redact' = 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 :: 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
textToTerminal'
:: MonadTerminal m
=> [Term.SGR]
-> 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'
handleToTerminal
:: (MonadHandle m, MonadTerminal m)
=> [Term.SGR]
-> 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
handleToTerminal'
:: (MonadHandle m, MonadTerminal m)
=> [Term.SGR]
-> 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
fileToTerminal
:: (MonadHandle m, MonadTerminal m)
=> [Term.SGR]
-> 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
fileToTerminal'
:: (MonadHandle m, MonadTerminal m)
=> [Term.SGR]
-> 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
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
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
"`"
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]
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
'`')
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)
type StrictState = (Int, Bool)
initialStrictState :: StrictState
initialStrictState :: StrictState
initialStrictState = (Int
1, LenientState
False)
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]
")"
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]
")"
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)