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

  , wrapTextToLines
  , wrapText
  )
where

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

-- | How should wrapped lines be filled (i.e. what kind of prefix
--   should be attached?)
data FillStrategy
  = NoFill             -- ^ Don't do any filling (default)
  | FillIndent Int     -- ^ Indent by this many spaces
  | FillPrefix T.Text  -- ^ Prepend this text
  deriving (FillStrategy -> FillStrategy -> Bool
(FillStrategy -> FillStrategy -> Bool)
-> (FillStrategy -> FillStrategy -> Bool) -> Eq FillStrategy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FillStrategy -> FillStrategy -> Bool
$c/= :: FillStrategy -> FillStrategy -> Bool
== :: FillStrategy -> FillStrategy -> Bool
$c== :: FillStrategy -> FillStrategy -> Bool
Eq, Int -> FillStrategy -> ShowS
[FillStrategy] -> ShowS
FillStrategy -> String
(Int -> FillStrategy -> ShowS)
-> (FillStrategy -> String)
-> ([FillStrategy] -> ShowS)
-> Show FillStrategy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FillStrategy] -> ShowS
$cshowList :: [FillStrategy] -> ShowS
show :: FillStrategy -> String
$cshow :: FillStrategy -> String
showsPrec :: Int -> FillStrategy -> ShowS
$cshowsPrec :: Int -> FillStrategy -> ShowS
Show, ReadPrec [FillStrategy]
ReadPrec FillStrategy
Int -> ReadS FillStrategy
ReadS [FillStrategy]
(Int -> ReadS FillStrategy)
-> ReadS [FillStrategy]
-> ReadPrec FillStrategy
-> ReadPrec [FillStrategy]
-> Read FillStrategy
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FillStrategy]
$creadListPrec :: ReadPrec [FillStrategy]
readPrec :: ReadPrec FillStrategy
$creadPrec :: ReadPrec FillStrategy
readList :: ReadS [FillStrategy]
$creadList :: ReadS [FillStrategy]
readsPrec :: Int -> ReadS FillStrategy
$creadsPrec :: Int -> ReadS FillStrategy
Read)

fillWidth :: FillStrategy -> Int
fillWidth :: FillStrategy -> Int
fillWidth FillStrategy
NoFill         = Int
0
fillWidth (FillIndent Int
n) = Int
n
fillWidth (FillPrefix Text
t) = Text -> Int
T.length Text
t

-- | To which lines should the fill strategy be applied?
data FillScope
  = FillAfterFirst     -- ^ Apply any fill prefix only to lines after
                       --   the first line (default)
  | FillAll            -- ^ Apply any fill prefix to all lines, even
                       --   if there is only one line
  deriving (FillScope -> FillScope -> Bool
(FillScope -> FillScope -> Bool)
-> (FillScope -> FillScope -> Bool) -> Eq FillScope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FillScope -> FillScope -> Bool
$c/= :: FillScope -> FillScope -> Bool
== :: FillScope -> FillScope -> Bool
$c== :: FillScope -> FillScope -> Bool
Eq, Int -> FillScope -> ShowS
[FillScope] -> ShowS
FillScope -> String
(Int -> FillScope -> ShowS)
-> (FillScope -> String)
-> ([FillScope] -> ShowS)
-> Show FillScope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FillScope] -> ShowS
$cshowList :: [FillScope] -> ShowS
show :: FillScope -> String
$cshow :: FillScope -> String
showsPrec :: Int -> FillScope -> ShowS
$cshowsPrec :: Int -> FillScope -> ShowS
Show, ReadPrec [FillScope]
ReadPrec FillScope
Int -> ReadS FillScope
ReadS [FillScope]
(Int -> ReadS FillScope)
-> ReadS [FillScope]
-> ReadPrec FillScope
-> ReadPrec [FillScope]
-> Read FillScope
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FillScope]
$creadListPrec :: ReadPrec [FillScope]
readPrec :: ReadPrec FillScope
$creadPrec :: ReadPrec FillScope
readList :: ReadS [FillScope]
$creadList :: ReadS [FillScope]
readsPrec :: Int -> ReadS FillScope
$creadsPrec :: Int -> ReadS FillScope
Read)

-- | 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.
                 , WrapSettings -> FillStrategy
fillStrategy        :: FillStrategy
                 -- ^ What kind of prefix should be applied to lines
                 --   after wrapping? (default: none)
                 , WrapSettings -> FillScope
fillScope           :: FillScope
                 -- ^ To which lines should the fill strategy be applied?
                 --   (default: all but the first)
                 }
                 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 -> FillStrategy -> FillScope -> WrapSettings
WrapSettings { preserveIndentation :: Bool
preserveIndentation = Bool
False
                 , breakLongWords :: Bool
breakLongWords = Bool
False
                 , fillStrategy :: FillStrategy
fillStrategy = FillStrategy
NoFill
                 , fillScope :: FillScope
fillScope = FillScope
FillAfterFirst
                 }

-- | Apply a function to the portion of a list of lines indicated by
--   the 'FillScope'.
withScope :: FillScope -> (a -> a) -> [a] -> [a]
withScope :: FillScope -> (a -> a) -> [a] -> [a]
withScope FillScope
FillAfterFirst = (a -> a) -> [a] -> [a]
forall a. (a -> a) -> [a] -> [a]
onTail
withScope FillScope
FillAll        = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map

-- | Map a function over the tail of a list.
onTail :: (a -> a) -> [a] -> [a]
onTail :: (a -> a) -> [a] -> [a]
onTail a -> a
_ []     = []
onTail a -> a
f (a
a:[a]
as) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map a -> a
f [a]
as

-- | Apply the fill specified in the 'WrapSettings' to a list of lines.
applyFill :: WrapSettings -> [T.Text] -> [T.Text]
applyFill :: WrapSettings -> [Text] -> [Text]
applyFill WrapSettings
settings =
    let scope :: FillScope
scope = WrapSettings -> FillScope
fillScope WrapSettings
settings
    in case WrapSettings -> FillStrategy
fillStrategy WrapSettings
settings of
           FillStrategy
NoFill       -> [Text] -> [Text]
forall a. a -> a
id
           FillIndent Int
n -> FillScope -> (Text -> Text) -> [Text] -> [Text]
forall a. FillScope -> (a -> a) -> [a] -> [a]
withScope FillScope
scope (Text -> Text -> Text
T.append (Int -> Text -> Text
T.replicate Int
n (String -> Text
T.pack String
" ")))
           FillPrefix Text
t -> FillScope -> (Text -> Text) -> [Text] -> [Text]
forall a. FillScope -> (a -> a) -> [a] -> [a]
withScope FillScope
scope (Text -> Text -> Text
T.append Text
t)

-- | 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 prior to having any fill applied.  Preserved
-- indentation is always placed before any fill.
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 restFillWidth :: Int
restFillWidth      = FillStrategy -> Int
fillWidth (WrapSettings -> FillStrategy
fillStrategy WrapSettings
settings)
        firstLineFillWidth :: Int
firstLineFillWidth = if WrapSettings -> FillScope
fillScope WrapSettings
settings FillScope -> FillScope -> Bool
forall a. Eq a => a -> a -> Bool
== FillScope
FillAll then Int
restFillWidth else Int
0

        firstLineLimit :: Int
firstLineLimit = Int
limit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstLineFillWidth
        restLimit :: Int
restLimit      = Int
limit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
restFillWidth

        go :: Bool -> [Token] -> [Text]
go Bool
_ []     = [Text
T.empty]
        go Bool
_ [WS Text
_] = [Text
T.empty]
        go Bool
isFirstLine [Token]
ts =
            let lim :: Int
lim = if Bool
isFirstLine then Int
firstLineLimit else Int
restLimit
                ([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]
: Bool -> [Token] -> [Text]
go Bool
False [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 = Bool -> [Token] -> [Text]
go Bool
True (Text -> [Token]
tokenize Text
modifiedText)
    in (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
indent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapSettings -> [Text] -> [Text]
applyFill WrapSettings
settings ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> 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