{-|
  The module implements text wrapping. The following example roughly outlines
  the functionality of the module. In the example, we try to wrap the text at
  spaces into lines of height 10 and width

  1. between 40 and 50, which is mostly successful, except the first line: because
  the word "gentlemen" is long. Therefore the word gentlemen is tried to be
  split at each two chars, so that the width of the first line is between 0 and
  50. Now the splitting is successful.

  2. between 0 and 2, which is unsuccessful (splitting at spaces such that @0 <
  length_of_the_first_line <= 2@ is not possible). Then it tries to split the
  text at each two chars, which is unsuccessful again (2 is just too little).
  Then the third splitter is applied, which is @const Nothing@, therefore the
  result is @Nothing@ (= unsuccessful split).

  > example :: (Maybe [String], Maybe [String])
  > example =
  >   ( wrapText def 10 splits1 text
  >   , wrapText def 10 splits2 text
  >   )
  >   where
  >     text = "mornin' gentlemen, how is the business going today?"
  >     splits1 =
  >       [ (splitAtSpaces, (40 :: Double, 50))
  >       , (splitEachTwoChars, (0, 50))
  >       , (const Nothing, (-1, 1/0))
  >       ]
  >
  >     splits2 =
  >       [ (splitAtSpaces, (0 :: Double, 2))
  >       , (splitEachTwoChars, (0, 2))
  >       , (const Nothing, (-1, 1/0))
  >       ]

  The result is

  > ( Just ["mornin' gentle-","men, how is the","business going","today?"]
  > , Nothing
  > )
-}

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}

module Graphics.SVGFonts.Wrap
  ( wrapTextLine
  , wrapText
  , splitAtSpaces
  , splitEachTwoChars
  ) where

import Diagrams.Prelude hiding (font, text)
import Graphics.SVGFonts.Text
import Graphics.SVGFonts.ReadFont (bbox_dy)

data Modification
  = Append Char
  | Erase
  deriving Int -> Modification -> ShowS
[Modification] -> ShowS
Modification -> String
(Int -> Modification -> ShowS)
-> (Modification -> String)
-> ([Modification] -> ShowS)
-> Show Modification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Modification] -> ShowS
$cshowList :: [Modification] -> ShowS
show :: Modification -> String
$cshow :: Modification -> String
showsPrec :: Int -> Modification -> ShowS
$cshowsPrec :: Int -> Modification -> ShowS
Show

data Split
  = Split String String [Modification]
  | TextEnd
  deriving Int -> Split -> ShowS
[Split] -> ShowS
Split -> String
(Int -> Split -> ShowS)
-> (Split -> String) -> ([Split] -> ShowS) -> Show Split
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Split] -> ShowS
$cshowList :: [Split] -> ShowS
show :: Split -> String
$cshow :: Split -> String
showsPrec :: Int -> Split -> ShowS
$cshowsPrec :: Int -> Split -> ShowS
Show

-- | Split the text to a first line and the rest. 
-- Given the invocation @wrapTextLine opts font_height [(first_split,
-- first_split_bounds), ...] text@, the longest modified first line is taken, which
-- holds the following vague specification:
--
-- * The @text@ is split using the @first_split@ function into a @prefix@ and
-- the @rest@. The first line is the @prefix@, possibly concatenated with the first
-- line of the @rest@. In addition, if the rest is not an empty string, the
-- first line is modified using the @first_split@'s elementary modifications.
--
-- * The first line's width is inside @first_split_bounds@ after applying the
-- modification of the @first_split@.
--
-- * If such line cannot be found, last split is undone and @second_split@ and
-- @second_split_bounds@ is considered.
--
-- * Edge case: If the @text@ is shorter than the bounds, @(text, "")@ is returned.
--
-- For better performance, this should be reimplemented using something other than
-- 'String's.
wrapTextLine :: forall n m. (TypeableFloat n, Monad m) =>
  TextOpts n -> n -> [(String -> m Split, (n, n))] -> String -> m (String, String)
wrapTextLine :: TextOpts n
-> n
-> [(String -> m Split, (n, n))]
-> String
-> m (String, String)
wrapTextLine TextOpts n
topts n
desired_height = n -> [(String -> m Split, (n, n))] -> String -> m (String, String)
forall (m :: * -> *).
Monad m =>
n -> [(String -> m Split, (n, n))] -> String -> m (String, String)
throughLevels n
0
  where
    throughLevels :: n -> [(String -> m Split, (n, n))] -> String -> m (String, String)
throughLevels n
w0 ((String -> m Split
split, (n, n) -> (n, n)
scale_range -> (n
minw, n
maxw)):[(String -> m Split, (n, n))]
splits) String
text =
      String -> m Split
split String
text m Split -> (Split -> m (String, String)) -> m (String, String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= n -> n -> String -> Split -> m (String, String)
oneChunk n
w0 n
w0 String
text
      where
        oneChunk :: n -> n -> String -> Split -> m (String, String)
oneChunk n
w n
wmod String
full_text Split
TextEnd
          | n
w' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
maxw =
              if n
wmod n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
minw
                then (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"", String
full_text)
                else n -> [(String -> m Split, (n, n))] -> String -> m (String, String)
throughLevels n
w [(String -> m Split, (n, n))]
splits String
full_text
          | Bool
otherwise = (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
full_text, String
"")
          where ((n
wn -> n -> n
forall a. Num a => a -> a -> a
+) -> n
w', [(String, n)]
_) = String -> (n, [(String, n)])
fontInfoOf String
full_text

        oneChunk n
w n
wmod String
full_text (Split String
chunk String
rest [Modification]
modifs)
          | n
wmod' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
maxw =
              if n
wmod n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
minw
                then (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"", String
full_text)
                else n -> [(String -> m Split, (n, n))] -> String -> m (String, String)
throughLevels n
w [(String -> m Split, (n, n))]
splits String
full_text
          | Bool
otherwise = do
              (String
appendix, String
rest') <- String -> m Split
split String
rest m Split -> (Split -> m (String, String)) -> m (String, String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= n -> n -> String -> Split -> m (String, String)
oneChunk n
w' n
wmod' String
rest
              (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return((String, String) -> m (String, String))
-> (String, String) -> m (String, String)
forall a b. (a -> b) -> a -> b
$ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
appendix
                then (String
chunk', String
rest')
                else (String
chunk String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
appendix, String
rest')
          where
            ((n
wn -> n -> n
forall a. Num a => a -> a -> a
+) -> n
w', [(String, n)]
ligs) = String -> (n, [(String, n)])
fontInfoOf String
chunk
            (ShowS
forall a. [a] -> [a]
reverse -> String
chunk', n
wdiff) = [Modification] -> [(String, n)] -> (String, n)
applyMods [Modification]
modifs([(String, n)] -> (String, n)) -> [(String, n)] -> (String, n)
forall a b. (a -> b) -> a -> b
$ [(String, n)] -> [(String, n)]
forall a. [a] -> [a]
reverse([(String, n)] -> [(String, n)]) -> [(String, n)] -> [(String, n)]
forall a b. (a -> b) -> a -> b
$ [(String, n)]
ligs
            wmod' :: n
wmod' = n
w' n -> n -> n
forall a. Num a => a -> a -> a
+ n
wdiff

    throughLevels n
_ [(String -> m Split, (n, n))]
_ String
_ = String -> m (String, String)
forall a. HasCallStack => String -> a
error String
"split levels exhausted"

    (FontData n
fontD, OutlineMap n
_) = TextOpts n -> (FontData n, OutlineMap n)
forall n. TextOpts n -> PreparedFont n
textFont TextOpts n
topts
    isKern_ :: Bool
isKern_ = Spacing -> Bool
isKern (TextOpts n -> Spacing
forall n. TextOpts n -> Spacing
spacing TextOpts n
topts)

    font_height :: n
font_height = FontData n -> n
forall n. RealFloat n => FontData n -> n
bbox_dy FontData n
fontD
    font_scale :: n
font_scale = n
font_height n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
desired_height
    scale_range :: (n, n) -> (n, n)
scale_range (n
minw, n
maxw) = (n
minwn -> n -> n
forall a. Num a => a -> a -> a
*n
font_scale, n
maxwn -> n -> n
forall a. Num a => a -> a -> a
*n
font_scale)

    characterStrings_ :: String -> [String]
characterStrings_ = FontData n -> String -> [String]
forall n. FontData n -> String -> [String]
characterStrings' FontData n
fontD

    fontInfoOf :: String -> (n, [(String, n)])
fontInfoOf String
text = ([n] -> n
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [n]
hs, [String] -> [n] -> [(String, n)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
str [n]
hs)
      where
        hs :: [n]
hs = [String] -> FontData n -> Bool -> [n]
forall n. RealFloat n => [String] -> FontData n -> Bool -> [n]
horizontalAdvances [String]
str FontData n
fontD Bool
isKern_
        str :: [String]
str = String -> [String]
characterStrings_ String
text

    applyMods :: [Modification] -> [(String, n)] -> (String, n)
    applyMods :: [Modification] -> [(String, n)] -> (String, n)
applyMods [] [(String, n)]
text = (((String, n) -> String) -> [(String, n)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, n) -> String
forall a b. (a, b) -> a
fst [(String, n)]
text, n
0)
    applyMods (Modification
Erase:[Modification]
modifs) ((String
_, n
advance):[(String, n)]
text) = (String
text', n
wdiff n -> n -> n
forall a. Num a => a -> a -> a
- n
advance)
      where (String
text', n
wdiff) = [Modification] -> [(String, n)] -> (String, n)
applyMods [Modification]
modifs [(String, n)]
text
    applyMods (Append Char
c2 : [Modification]
modifs) [(String, n)]
text = (String
text', n
wdiff n -> n -> n
forall a. Num a => a -> a -> a
+ n
advance)
      where
        lastChars :: [String]
lastChars = case [(String, n)]
text of
          (String
c1, n
_):[(String, n)]
_ -> [String
c1, [Char
c2]]
          [(String, n)]
_ -> [[Char
c2]]
        advance :: n
advance = [n] -> n
forall a. [a] -> a
last([n] -> n) -> [n] -> n
forall a b. (a -> b) -> a -> b
$ [String] -> FontData n -> Bool -> [n]
forall n. RealFloat n => [String] -> FontData n -> Bool -> [n]
horizontalAdvances [String]
lastChars FontData n
fontD Bool
isKern_
        (String
text', n
wdiff) = [Modification] -> [(String, n)] -> (String, n)
applyMods [Modification]
modifs (([Char
c2], n
advance)(String, n) -> [(String, n)] -> [(String, n)]
forall a. a -> [a] -> [a]
:[(String, n)]
text)
    applyMods [Modification]
_ [(String, n)]
_ = String -> (String, n)
forall a. HasCallStack => String -> a
error String
"modification not applicable"


-- | Using 'wrapTextLine', split the text to a list of lines.
wrapText :: forall n m. (TypeableFloat n, Monad m) =>
  TextOpts n -> n -> [(String -> m Split, (n, n))] -> String -> m [String]
wrapText :: TextOpts n
-> n -> [(String -> m Split, (n, n))] -> String -> m [String]
wrapText TextOpts n
topts n
desired_height [(String -> m Split, (n, n))]
splits String
text = String -> m [String]
closure String
text
  where
    closure :: String -> m [String]
closure String
"" = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    closure String
text_ = do
      (String
line, String
rest) <- String -> m (String, String)
wrapTextLine' String
text_
      [String]
rest' <- String -> m [String]
closure String
rest
      [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ String
line String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rest'
    wrapTextLine' :: String -> m (String, String)
wrapTextLine' = TextOpts n
-> n
-> [(String -> m Split, (n, n))]
-> String
-> m (String, String)
forall n (m :: * -> *).
(TypeableFloat n, Monad m) =>
TextOpts n
-> n
-> [(String -> m Split, (n, n))]
-> String
-> m (String, String)
wrapTextLine TextOpts n
topts n
desired_height [(String -> m Split, (n, n))]
splits


-- | Quite useful argument for 'wrapTextLine'. Split the text at spaces, remove
-- the spaces at which we split.
splitAtSpaces :: Monad m => String -> m Split
splitAtSpaces :: String -> m Split
splitAtSpaces String
txt = Split -> m Split
forall (m :: * -> *) a. Monad m => a -> m a
return(Split -> m Split) -> Split -> m Split
forall a b. (a -> b) -> a -> b
$
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
txt of
    (String
_, String
"") -> Split
TextEnd
    (String
chunk, Char
_:String
rest) -> String -> String -> [Modification] -> Split
Split (String
chunk String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ") String
rest [Modification
Erase]


-- | Quite unuseful example argument for 'wrapTextLine'. Something more
-- sophisticated should be used in real world... something that would split
-- words at syllable boundaries. Split the text at each two characters,
-- interleaving the splits with a hyphen.
splitEachTwoChars :: Monad m => String -> m Split
splitEachTwoChars :: String -> m Split
splitEachTwoChars String
txt = Split -> m Split
forall (m :: * -> *) a. Monad m => a -> m a
return(Split -> m Split) -> Split -> m Split
forall a b. (a -> b) -> a -> b
$
  case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
2 String
txt of
    (String
_, String
"") -> Split
TextEnd
    (String
chunk, String
rest) -> String -> String -> [Modification] -> Split
Split (String
chunk) String
rest [Char -> Modification
Append Char
'-']