module Text.Wrap
  ( WrapSettings(..)
  , defaultWrapSettings

  , wrapTextToLines
  , wrapText
  )
where

import Data.Monoid ((<>))
import Data.Char (isSpace)
import qualified Data.Text as T

-- | Settings to control how wrapping is performed.
data WrapSettings =
    WrapSettings { WrapSettings -> Bool
preserveIndentation :: Bool
                 -- ^ Whether to indent new lines created by wrapping
                 -- when their original line was indented.
                 , WrapSettings -> Bool
breakLongWords :: Bool
                 -- ^ Whether to break in the middle of the first word
                 -- on a line when that word exceeds the wrapping width.
                 }
                 deriving (WrapSettings -> WrapSettings -> Bool
(WrapSettings -> WrapSettings -> Bool)
-> (WrapSettings -> WrapSettings -> Bool) -> Eq WrapSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WrapSettings -> WrapSettings -> Bool
$c/= :: WrapSettings -> WrapSettings -> Bool
== :: WrapSettings -> WrapSettings -> Bool
$c== :: WrapSettings -> WrapSettings -> Bool
Eq, Int -> WrapSettings -> ShowS
[WrapSettings] -> ShowS
WrapSettings -> String
(Int -> WrapSettings -> ShowS)
-> (WrapSettings -> String)
-> ([WrapSettings] -> ShowS)
-> Show WrapSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WrapSettings] -> ShowS
$cshowList :: [WrapSettings] -> ShowS
show :: WrapSettings -> String
$cshow :: WrapSettings -> String
showsPrec :: Int -> WrapSettings -> ShowS
$cshowsPrec :: Int -> WrapSettings -> ShowS
Show, ReadPrec [WrapSettings]
ReadPrec WrapSettings
Int -> ReadS WrapSettings
ReadS [WrapSettings]
(Int -> ReadS WrapSettings)
-> ReadS [WrapSettings]
-> ReadPrec WrapSettings
-> ReadPrec [WrapSettings]
-> Read WrapSettings
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WrapSettings]
$creadListPrec :: ReadPrec [WrapSettings]
readPrec :: ReadPrec WrapSettings
$creadPrec :: ReadPrec WrapSettings
readList :: ReadS [WrapSettings]
$creadList :: ReadS [WrapSettings]
readsPrec :: Int -> ReadS WrapSettings
$creadsPrec :: Int -> ReadS WrapSettings
Read)

defaultWrapSettings :: WrapSettings
defaultWrapSettings :: WrapSettings
defaultWrapSettings =
    WrapSettings :: Bool -> Bool -> WrapSettings
WrapSettings { preserveIndentation :: Bool
preserveIndentation = Bool
False
                 , breakLongWords :: Bool
breakLongWords = Bool
False
                 }

-- | Wrap text at the specified width. Newlines and whitespace in the
-- input text are preserved. Returns the lines of text in wrapped form.
-- New lines introduced due to wrapping will have leading whitespace
-- stripped.
wrapTextToLines :: WrapSettings -> Int -> T.Text -> [T.Text]
wrapTextToLines :: WrapSettings -> Int -> Text -> [Text]
wrapTextToLines WrapSettings
settings Int
amt Text
s =
    [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> [Text]) -> [Text] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WrapSettings -> Int -> Text -> [Text]
wrapLine WrapSettings
settings Int
amt) ([Text] -> [[Text]]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
s

-- | Like 'wrapTextToLines', but returns the wrapped text reconstructed
-- with newlines inserted at wrap points.
wrapText :: WrapSettings -> Int -> T.Text -> T.Text
wrapText :: WrapSettings -> Int -> Text -> Text
wrapText WrapSettings
settings Int
amt Text
s =
    Text -> [Text] -> Text
T.intercalate (String -> Text
T.pack String
"\n") ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ WrapSettings -> Int -> Text -> [Text]
wrapTextToLines WrapSettings
settings Int
amt Text
s

data Token = WS T.Text | NonWS T.Text
           deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show)

tokenLength :: Token -> Int
tokenLength :: Token -> Int
tokenLength = Text -> Int
T.length (Text -> Int) -> (Token -> Text) -> Token -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Text
tokenContent

tokenContent :: Token -> T.Text
tokenContent :: Token -> Text
tokenContent (WS Text
t) = Text
t
tokenContent (NonWS Text
t) = Text
t

-- | Tokenize text into whitespace and non-whitespace chunks.
tokenize :: T.Text -> [Token]
tokenize :: Text -> [Token]
tokenize Text
t | Text -> Bool
T.null Text
t = []
tokenize Text
t =
    let leadingWs :: Text
leadingWs = (Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isSpace Text
t
        leadingNonWs :: Text
leadingNonWs = (Char -> Bool) -> Text -> Text
T.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
t
        tok :: Token
tok = if Text -> Bool
T.null Text
leadingWs
              then Text -> Token
NonWS Text
leadingNonWs
              else Text -> Token
WS Text
leadingWs
    in Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize (Int -> Text -> Text
T.drop (Token -> Int
tokenLength Token
tok) Text
t)

-- | Wrap a single line of text into a list of lines that all satisfy
-- the wrapping width.
wrapLine :: WrapSettings
         -- ^ Settings.
         -> Int
         -- ^ The wrapping width.
         -> T.Text
         -- ^ A single line of text.
         -> [T.Text]
wrapLine :: WrapSettings -> Int -> Text -> [Text]
wrapLine WrapSettings
settings Int
limit Text
t =
    let go :: Int -> [Token] -> [Text]
go Int
_ []     = [Text
T.empty]
        go Int
_ [WS Text
_] = [Text
T.empty]
        go Int
lim [Token]
ts =
            let ([Token]
firstLine, Maybe [Token]
maybeRest) = WrapSettings -> Int -> [Token] -> ([Token], Maybe [Token])
breakTokens WrapSettings
settings Int
lim [Token]
ts
                firstLineText :: Text
firstLineText = Text -> Text
T.stripEnd (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Token -> Text) -> [Token] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> Text
tokenContent [Token]
firstLine
            in case Maybe [Token]
maybeRest of
                Maybe [Token]
Nothing -> [Text
firstLineText]
                Just [Token]
rest -> Text
firstLineText Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Text]
go Int
lim [Token]
rest
        (Text
indent, Text
modifiedText) = if WrapSettings -> Bool
preserveIndentation WrapSettings
settings
                                 then let i :: Text
i = (Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isSpace Text
t
                                      in (Int -> Text -> Text
T.take (Int
limit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
i, Int -> Text -> Text
T.drop (Text -> Int
T.length Text
i) Text
t)
                                 else (Text
T.empty, Text
t)
        result :: [Text]
result = Int -> [Token] -> [Text]
go (Int
limit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
indent) (Text -> [Token]
tokenize Text
modifiedText)
    in (Text
indent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
result

-- | Break a token sequence so that all tokens up to but not exceeding
-- a length limit are included on the left, and if any remain on the
-- right, return Just those too (or Nothing if there weren't any). If
-- this breaks a sequence at at point where the next token after the
-- break point is whitespace, that whitespace token is removed.
breakTokens :: WrapSettings -> Int -> [Token] -> ([Token], Maybe [Token])
breakTokens :: WrapSettings -> Int -> [Token] -> ([Token], Maybe [Token])
breakTokens WrapSettings
_ Int
_ [] = ([], Maybe [Token]
forall a. Maybe a
Nothing)
breakTokens WrapSettings
settings Int
limit [Token]
ts =
    -- Take enough tokens until we reach the point where taking more
    -- would exceed the line length.
    let go :: Int -> [Token] -> ([Token], [Token])
go Int
_ []     = ([], [])
        -- Check to see whether the next token exceeds the limit. If so, bump
        -- it to the next line and terminate. Otherwise keep it and continue to
        -- the next token.
        go Int
acc (Token
tok:[Token]
toks) =
            if Token -> Int
tokenLength Token
tok Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
            then let ([Token]
nextAllowed, [Token]
nextDisallowed) = Int -> [Token] -> ([Token], [Token])
go (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Token -> Int
tokenLength Token
tok) [Token]
toks
                 in (Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
nextAllowed, [Token]
nextDisallowed)
            else case Token
tok of
                     WS Text
_ -> ([], [Token]
toks)
                     NonWS Text
_ ->
                         if Int
acc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& WrapSettings -> Bool
breakLongWords WrapSettings
settings
                         then let (Text
h, Text
tl) = Int -> Text -> (Text, Text)
T.splitAt Int
limit (Token -> Text
tokenContent Token
tok)
                              in ([Text -> Token
NonWS Text
h], Text -> Token
NonWS Text
tl Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
toks)
                         else if Int
acc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ([Token
tok], [Token]
toks)
                         else ([], Token
tokToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
toks)

        -- Allowed tokens are the ones we keep on this line. The rest go
        -- on the next line, to be wrapped again.
        ([Token]
allowed, [Token]
disallowed') = Int -> [Token] -> ([Token], [Token])
go Int
0 [Token]
ts
        disallowed :: [Token]
disallowed = [Token] -> [Token]
maybeTrim [Token]
disallowed'

        -- Trim leading whitespace on wrapped lines.
        maybeTrim :: [Token] -> [Token]
maybeTrim [] = []
        maybeTrim (WS Text
_:[Token]
toks) = [Token]
toks
        maybeTrim [Token]
toks = [Token]
toks

        result :: ([Token], Maybe [Token])
result = if [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
disallowed
                 then ([Token]
allowed, Maybe [Token]
forall a. Maybe a
Nothing)
                 else ([Token]
allowed, [Token] -> Maybe [Token]
forall a. a -> Maybe a
Just [Token]
disallowed)
    in ([Token], Maybe [Token])
result