{-# LANGUAGE RankNTypes #-}
-- | Screen overlays.
module Game.LambdaHack.Client.UI.Overlay
  ( -- * AttrString
    AttrString, blankAttrString, textToAS, textFgToAS, stringToAS
  , (<+:>), (<\:>)
    -- * AttrLine
  , AttrLine, attrLine, emptyAttrLine, attrStringToAL, firstParagraph, linesAttr
  , textToAL, textFgToAL, stringToAL, splitAttrString
  , indentSplitAttrString, indentSplitAttrString2
    -- * Overlay
  , Overlay, offsetOverlay, offsetOverlayX, updateLine
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , splitAttrPhrase
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Data.Char (isSpace)
import qualified Data.Text as T

import           Game.LambdaHack.Client.UI.PointUI
import qualified Game.LambdaHack.Definition.Color as Color

-- * AttrString

-- | String of colourful text. End of line characters permitted.
type AttrString = [Color.AttrCharW32]

blankAttrString :: Int -> AttrString
blankAttrString :: Int -> AttrString
blankAttrString w :: Int
w = Int -> AttrCharW32 -> AttrString
forall a. Int -> a -> [a]
replicate Int
w AttrCharW32
Color.spaceAttrW32

textToAS :: Text -> AttrString
textToAS :: Text -> AttrString
textToAS !Text
t =
  let f :: Char -> AttrString -> AttrString
f c :: Char
c l :: AttrString
l = let !ac :: AttrCharW32
ac = Char -> AttrCharW32
Color.attrChar1ToW32 Char
c
              in AttrCharW32
ac AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
l
  in (Char -> AttrString -> AttrString)
-> AttrString -> Text -> AttrString
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr Char -> AttrString -> AttrString
f [] Text
t

textFgToAS :: Color.Color -> Text -> AttrString
textFgToAS :: Color -> Text -> AttrString
textFgToAS !Color
fg !Text
t =
  let f :: Char -> AttrString -> AttrString
f ' ' l :: AttrString
l = AttrCharW32
Color.spaceAttrW32 AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
l
                  -- for speed and simplicity (testing if char is a space)
                  -- we always keep the space @White@
      f c :: Char
c l :: AttrString
l = let !ac :: AttrCharW32
ac = Color -> Char -> AttrCharW32
Color.attrChar2ToW32 Color
fg Char
c
              in AttrCharW32
ac AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
l
  in (Char -> AttrString -> AttrString)
-> AttrString -> Text -> AttrString
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr Char -> AttrString -> AttrString
f [] Text
t

stringToAS :: String -> AttrString
stringToAS :: String -> AttrString
stringToAS = (Char -> AttrCharW32) -> String -> AttrString
forall a b. (a -> b) -> [a] -> [b]
map Char -> AttrCharW32
Color.attrChar1ToW32

-- Follows minimorph.<+>.
infixr 6 <+:>  -- matches Monoid.<>
(<+:>) :: AttrString -> AttrString -> AttrString
<+:> :: AttrString -> AttrString -> AttrString
(<+:>) [] l2 :: AttrString
l2 = AttrString
l2
(<+:>) l1 :: AttrString
l1 [] = AttrString
l1
(<+:>) l1 :: AttrString
l1 l2 :: AttrString
l2@(c2 :: AttrCharW32
c2 : _) =
  if Char -> Bool
isSpace (AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
c2) Bool -> Bool -> Bool
|| Char -> Bool
isSpace (AttrCharW32 -> Char
Color.charFromW32 (AttrString -> AttrCharW32
forall a. [a] -> a
last AttrString
l1))
  then AttrString
l1 AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
l2
  else AttrString
l1 AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ [AttrCharW32
Color.spaceAttrW32] AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
l2

infixr 6 <\:>  -- matches Monoid.<>
(<\:>) :: AttrString -> AttrString -> AttrString
<\:> :: AttrString -> AttrString -> AttrString
(<\:>) [] l2 :: AttrString
l2 = AttrString
l2
(<\:>) l1 :: AttrString
l1 [] = AttrString
l1
(<\:>) l1 :: AttrString
l1 l2 :: AttrString
l2@(c2 :: AttrCharW32
c2 : _) =
  if AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
c2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' Bool -> Bool -> Bool
|| AttrCharW32 -> Char
Color.charFromW32 (AttrString -> AttrCharW32
forall a. [a] -> a
last AttrString
l1) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n'
  then AttrString
l1 AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
l2
  else AttrString
l1 AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ String -> AttrString
stringToAS "\n" AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
l2

-- We consider only these, because they are short and form a closed category.
nonbreakableRev :: [String]
nonbreakableRev :: [String]
nonbreakableRev = ["eht", "a", "na", "ehT", "A", "nA", "I"]

isPrefixOfNonbreakable :: AttrString -> Bool
isPrefixOfNonbreakable :: AttrString -> Bool
isPrefixOfNonbreakable s :: AttrString
s =
  let isPrefixOfNb :: String -> String -> Bool
isPrefixOfNb sRev :: String
sRev nbRev :: String
nbRev = case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
nbRev String
sRev of
        Nothing -> Bool
False
        Just [] -> Bool
True
        Just (c :: Char
c : _) -> Char -> Bool
isSpace Char
c
  in (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
isPrefixOfNb (String -> String -> Bool) -> String -> String -> Bool
forall a b. (a -> b) -> a -> b
$ (AttrCharW32 -> Char) -> AttrString -> String
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> Char
Color.charFromW32 AttrString
s) [String]
nonbreakableRev

breakAtSpace :: AttrString -> (AttrString, AttrString)
breakAtSpace :: AttrString -> (AttrString, AttrString)
breakAtSpace lRev :: AttrString
lRev =
  let (pre :: AttrString
pre, post :: AttrString
post) = (AttrCharW32 -> Bool) -> AttrString -> (AttrString, AttrString)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32) AttrString
lRev
  in case AttrString
post of
    c :: AttrCharW32
c : rest :: AttrString
rest | AttrCharW32
c AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32 ->
      if AttrString -> Bool
isPrefixOfNonbreakable AttrString
rest
      then let (pre2 :: AttrString
pre2, post2 :: AttrString
post2) = AttrString -> (AttrString, AttrString)
breakAtSpace AttrString
rest
           in (AttrString
pre AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrCharW32
c AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
pre2, AttrString
post2)
      else (AttrString
pre, AttrString
post)
    _ -> (AttrString
pre, AttrString
post)  -- no space found, give up

-- * AttrLine

-- | Line of colourful text. End of line characters forbidden.
newtype AttrLine = AttrLine {AttrLine -> AttrString
attrLine :: AttrString}
  deriving (Int -> AttrLine -> ShowS
[AttrLine] -> ShowS
AttrLine -> String
(Int -> AttrLine -> ShowS)
-> (AttrLine -> String) -> ([AttrLine] -> ShowS) -> Show AttrLine
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttrLine] -> ShowS
$cshowList :: [AttrLine] -> ShowS
show :: AttrLine -> String
$cshow :: AttrLine -> String
showsPrec :: Int -> AttrLine -> ShowS
$cshowsPrec :: Int -> AttrLine -> ShowS
Show, AttrLine -> AttrLine -> Bool
(AttrLine -> AttrLine -> Bool)
-> (AttrLine -> AttrLine -> Bool) -> Eq AttrLine
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttrLine -> AttrLine -> Bool
$c/= :: AttrLine -> AttrLine -> Bool
== :: AttrLine -> AttrLine -> Bool
$c== :: AttrLine -> AttrLine -> Bool
Eq)

emptyAttrLine :: AttrLine
emptyAttrLine :: AttrLine
emptyAttrLine = AttrString -> AttrLine
AttrLine []

attrStringToAL :: AttrString -> AttrLine
attrStringToAL :: AttrString -> AttrLine
attrStringToAL s :: AttrString
s =
#ifdef WITH_EXPENSIVE_ASSERTIONS
  Bool -> AttrLine -> AttrLine
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((AttrCharW32 -> Bool) -> AttrString -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (\ac :: AttrCharW32
ac -> AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
ac Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n') AttrString
s) (AttrLine -> AttrLine) -> AttrLine -> AttrLine
forall a b. (a -> b) -> a -> b
$  -- expensive in menus
  Bool -> AttrLine -> AttrLine
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (AttrString -> Int
forall a. [a] -> Int
length AttrString
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| AttrString -> AttrCharW32
forall a. [a] -> a
last AttrString
s AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrCharW32
Color.spaceAttrW32
          Bool -> String -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (AttrCharW32 -> Char) -> AttrString -> String
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> Char
Color.charFromW32 AttrString
s) (AttrLine -> AttrLine) -> AttrLine -> AttrLine
forall a b. (a -> b) -> a -> b
$
    -- only expensive for menus, but often violated by code changes, so disabled
    -- outside test runs
#endif
    AttrString -> AttrLine
AttrLine AttrString
s

firstParagraph :: AttrString -> AttrLine
firstParagraph :: AttrString -> AttrLine
firstParagraph s :: AttrString
s = case AttrString -> [AttrLine]
linesAttr AttrString
s of
  [] -> AttrLine
emptyAttrLine
  l :: AttrLine
l : _ -> AttrLine
l

textToAL :: Text -> AttrLine
textToAL :: Text -> AttrLine
textToAL !Text
t =
  let f :: Char -> AttrString -> AttrString
f '\n' _ = String -> AttrString
forall a. (?callStack::CallStack) => String -> a
error (String -> AttrString) -> String -> AttrString
forall a b. (a -> b) -> a -> b
$ "illegal end of line in: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t
      f c :: Char
c l :: AttrString
l = let !ac :: AttrCharW32
ac = Char -> AttrCharW32
Color.attrChar1ToW32 Char
c
              in AttrCharW32
ac AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
l
      s :: AttrString
s = (Char -> AttrString -> AttrString)
-> AttrString -> Text -> AttrString
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr Char -> AttrString -> AttrString
f [] Text
t
  in AttrString -> AttrLine
AttrLine (AttrString -> AttrLine) -> AttrString -> AttrLine
forall a b. (a -> b) -> a -> b
$
#ifdef WITH_EXPENSIVE_ASSERTIONS
  Bool -> AttrString -> AttrString
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (AttrString -> Int
forall a. [a] -> Int
length AttrString
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| AttrString -> AttrCharW32
forall a. [a] -> a
last AttrString
s AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrCharW32
Color.spaceAttrW32 Bool -> Text -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` Text
t)
#endif
    AttrString
s

textFgToAL :: Color.Color -> Text -> AttrLine
textFgToAL :: Color -> Text -> AttrLine
textFgToAL !Color
fg !Text
t =
  let f :: Char -> AttrString -> AttrString
f '\n' _ = String -> AttrString
forall a. (?callStack::CallStack) => String -> a
error (String -> AttrString) -> String -> AttrString
forall a b. (a -> b) -> a -> b
$ "illegal end of line in: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t
      f ' ' l :: AttrString
l = AttrCharW32
Color.spaceAttrW32 AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
l
                  -- for speed and simplicity (testing if char is a space)
                  -- we always keep the space @White@
      f c :: Char
c l :: AttrString
l = let !ac :: AttrCharW32
ac = Color -> Char -> AttrCharW32
Color.attrChar2ToW32 Color
fg Char
c
              in AttrCharW32
ac AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
l
      s :: AttrString
s = (Char -> AttrString -> AttrString)
-> AttrString -> Text -> AttrString
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr Char -> AttrString -> AttrString
f [] Text
t
  in AttrString -> AttrLine
AttrLine (AttrString -> AttrLine) -> AttrString -> AttrLine
forall a b. (a -> b) -> a -> b
$
#ifdef WITH_EXPENSIVE_ASSERTIONS
  Bool -> AttrString -> AttrString
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (AttrString -> Int
forall a. [a] -> Int
length AttrString
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| AttrString -> AttrCharW32
forall a. [a] -> a
last AttrString
s AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrCharW32
Color.spaceAttrW32 Bool -> Text -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` Text
t)
#endif
    AttrString
s

stringToAL :: String -> AttrLine
stringToAL :: String -> AttrLine
stringToAL s :: String
s = AttrString -> AttrLine
attrStringToAL (AttrString -> AttrLine) -> AttrString -> AttrLine
forall a b. (a -> b) -> a -> b
$ (Char -> AttrCharW32) -> String -> AttrString
forall a b. (a -> b) -> [a] -> [b]
map Char -> AttrCharW32
Color.attrChar1ToW32 String
s

-- Mimics @lines@.
linesAttr :: AttrString -> [AttrLine]
linesAttr :: AttrString -> [AttrLine]
linesAttr [] = []
linesAttr l :: AttrString
l = (AttrLine, [AttrLine]) -> [AttrLine]
forall a. (a, [a]) -> [a]
cons (case (AttrCharW32 -> Bool) -> AttrString -> (AttrString, AttrString)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\ac :: AttrCharW32
ac -> AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
ac Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n') AttrString
l of
  (h :: AttrString
h, t :: AttrString
t) -> (AttrString -> AttrLine
attrStringToAL AttrString
h, case AttrString
t of
                                 [] -> []
                                 _ : tt :: AttrString
tt -> AttrString -> [AttrLine]
linesAttr AttrString
tt))
 where
  cons :: (a, [a]) -> [a]
cons ~(h :: a
h, t :: [a]
t) = a
h a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
t

-- | Split a string into lines. Avoids breaking the line at a character
-- other than space. Remove space characters from the starts and ends
-- of created lines. Newlines are respected.
--
-- Note that we only split wrt @White@ space, nothing else,
-- and the width, in the first argument, is calculated in characters,
-- not in UI (mono font) coordinates, so that taking and dropping characters
-- is performed correctly.
splitAttrString :: Int -> Int -> AttrString -> [AttrLine]
splitAttrString :: Int -> Int -> AttrString -> [AttrLine]
splitAttrString w0 :: Int
w0 w1 :: Int
w1 l :: AttrString
l = case AttrString -> [AttrLine]
linesAttr AttrString
l of
  [] -> []
  x :: AttrLine
x : xs :: [AttrLine]
xs ->
    (Int -> Int -> AttrLine -> [AttrLine]
splitAttrPhrase Int
w0 Int
w1
     (AttrLine -> [AttrLine])
-> (AttrLine -> AttrLine) -> AttrLine -> [AttrLine]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrString -> AttrLine
AttrLine (AttrString -> AttrLine)
-> (AttrLine -> AttrString) -> AttrLine -> AttrLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AttrCharW32 -> Bool) -> AttrString -> AttrString
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32) (AttrString -> AttrString)
-> (AttrLine -> AttrString) -> AttrLine -> AttrString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrLine -> AttrString
attrLine) AttrLine
x
    [AttrLine] -> [AttrLine] -> [AttrLine]
forall a. [a] -> [a] -> [a]
++ (AttrLine -> [AttrLine]) -> [AttrLine] -> [AttrLine]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Int -> AttrLine -> [AttrLine]
splitAttrPhrase Int
w1 Int
w1
                  (AttrLine -> [AttrLine])
-> (AttrLine -> AttrLine) -> AttrLine -> [AttrLine]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrString -> AttrLine
AttrLine (AttrString -> AttrLine)
-> (AttrLine -> AttrString) -> AttrLine -> AttrLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AttrCharW32 -> Bool) -> AttrString -> AttrString
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32) (AttrString -> AttrString)
-> (AttrLine -> AttrString) -> AttrLine -> AttrString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrLine -> AttrString
attrLine) [AttrLine]
xs

indentSplitAttrString :: Int -> AttrString -> [AttrLine]
indentSplitAttrString :: Int -> AttrString -> [AttrLine]
indentSplitAttrString w :: Int
w l :: AttrString
l =
  let ts :: [AttrLine]
ts = Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
w (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) AttrString
l
  in case [AttrLine]
ts of
    [] -> []
    hd :: AttrLine
hd : tl :: [AttrLine]
tl -> AttrLine
hd AttrLine -> [AttrLine] -> [AttrLine]
forall a. a -> [a] -> [a]
: (AttrLine -> AttrLine) -> [AttrLine] -> [AttrLine]
forall a b. (a -> b) -> [a] -> [b]
map (AttrString -> AttrLine
AttrLine (AttrString -> AttrLine)
-> (AttrLine -> AttrString) -> AttrLine -> AttrLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([AttrCharW32
Color.spaceAttrW32] AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++) (AttrString -> AttrString)
-> (AttrLine -> AttrString) -> AttrLine -> AttrString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrLine -> AttrString
attrLine) [AttrLine]
tl

indentSplitAttrString2 :: Bool -> Int -> AttrString -> [AttrLine]
indentSplitAttrString2 :: Bool -> Int -> AttrString -> [AttrLine]
indentSplitAttrString2 isProp :: Bool
isProp w :: Int
w l :: AttrString
l =
  let nspaces :: Int
nspaces = if Bool
isProp then 4 else 2
      ts :: [AttrLine]
ts = Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
w (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nspaces) AttrString
l
      -- Proportional spaces are very narrow.
      spaces :: AttrString
spaces = Int -> AttrCharW32 -> AttrString
forall a. Int -> a -> [a]
replicate Int
nspaces AttrCharW32
Color.spaceAttrW32
  in case [AttrLine]
ts of
    [] -> []
    hd :: AttrLine
hd : tl :: [AttrLine]
tl -> AttrLine
hd AttrLine -> [AttrLine] -> [AttrLine]
forall a. a -> [a] -> [a]
: (AttrLine -> AttrLine) -> [AttrLine] -> [AttrLine]
forall a b. (a -> b) -> [a] -> [b]
map (AttrString -> AttrLine
AttrLine (AttrString -> AttrLine)
-> (AttrLine -> AttrString) -> AttrLine -> AttrLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AttrString
spaces AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++) (AttrString -> AttrString)
-> (AttrLine -> AttrString) -> AttrLine -> AttrString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrLine -> AttrString
attrLine) [AttrLine]
tl

-- We pass empty line along for the case of appended buttons, which need
-- either space or new lines before them.
splitAttrPhrase :: Int -> Int -> AttrLine -> [AttrLine]
splitAttrPhrase :: Int -> Int -> AttrLine -> [AttrLine]
splitAttrPhrase w0 :: Int
w0 w1 :: Int
w1 (AttrLine xs :: AttrString
xs)
  | Int
w0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= AttrString -> Int
forall a. [a] -> Int
length AttrString
xs = [AttrString -> AttrLine
AttrLine AttrString
xs]  -- no problem, everything fits
  | Bool
otherwise =
      let (pre :: AttrString
pre, postRaw :: AttrString
postRaw) = Int -> AttrString -> (AttrString, AttrString)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
w0 AttrString
xs
          preRev :: AttrString
preRev = AttrString -> AttrString
forall a. [a] -> [a]
reverse AttrString
pre
          ((ppre :: AttrString
ppre, ppost :: AttrString
ppost), post :: AttrString
post) = case AttrString
postRaw of
            c :: AttrCharW32
c : rest :: AttrString
rest | AttrCharW32
c AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32
                       Bool -> Bool -> Bool
&& Bool -> Bool
not (AttrString -> Bool
isPrefixOfNonbreakable AttrString
preRev) ->
              (([], AttrString
preRev), AttrString
rest)
            _ -> (AttrString -> (AttrString, AttrString)
breakAtSpace AttrString
preRev, AttrString
postRaw)
      in if (AttrCharW32 -> Bool) -> AttrString -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32) AttrString
ppost
         then AttrString -> AttrLine
AttrLine (AttrString -> AttrString
forall a. [a] -> [a]
reverse (AttrString -> AttrString) -> AttrString -> AttrString
forall a b. (a -> b) -> a -> b
$ (AttrCharW32 -> Bool) -> AttrString -> AttrString
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32) AttrString
preRev) AttrLine -> [AttrLine] -> [AttrLine]
forall a. a -> [a] -> [a]
:
              Int -> Int -> AttrLine -> [AttrLine]
splitAttrPhrase Int
w1 Int
w1 (AttrString -> AttrLine
AttrLine AttrString
post)
         else AttrString -> AttrLine
AttrLine (AttrString -> AttrString
forall a. [a] -> [a]
reverse (AttrString -> AttrString) -> AttrString -> AttrString
forall a b. (a -> b) -> a -> b
$ (AttrCharW32 -> Bool) -> AttrString -> AttrString
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32) AttrString
ppost)
              AttrLine -> [AttrLine] -> [AttrLine]
forall a. a -> [a] -> [a]
: Int -> Int -> AttrLine -> [AttrLine]
splitAttrPhrase Int
w1 Int
w1 (AttrString -> AttrLine
AttrLine (AttrString -> AttrLine) -> AttrString -> AttrLine
forall a b. (a -> b) -> a -> b
$ AttrString -> AttrString
forall a. [a] -> [a]
reverse AttrString
ppre AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
post)

-- * Overlay

-- | A series of screen lines with start positions at which they should
-- be overlayed over the base frame or a blank screen, depending on context.
-- The position point is represented as in integer that is an index into the
-- frame character array.
-- The lines either fit the width of the screen or are intended
-- for truncation when displayed. The start positions of lines may fall outside
-- the length of the screen, too, unlike in @SingleFrame@. Then they are
-- simply not shown.
type Overlay = [(PointUI, AttrLine)]

offsetOverlay :: [AttrLine] -> Overlay
offsetOverlay :: [AttrLine] -> Overlay
offsetOverlay l :: [AttrLine]
l = ((Int, AttrLine) -> (PointUI, AttrLine))
-> [(Int, AttrLine)] -> Overlay
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> PointUI) -> (Int, AttrLine) -> (PointUI, AttrLine)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Int -> PointUI) -> (Int, AttrLine) -> (PointUI, AttrLine))
-> (Int -> PointUI) -> (Int, AttrLine) -> (PointUI, AttrLine)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> PointUI
PointUI 0) ([(Int, AttrLine)] -> Overlay) -> [(Int, AttrLine)] -> Overlay
forall a b. (a -> b) -> a -> b
$ [Int] -> [AttrLine] -> [(Int, AttrLine)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [AttrLine]
l

offsetOverlayX :: [(Int, AttrLine)] -> Overlay
offsetOverlayX :: [(Int, AttrLine)] -> Overlay
offsetOverlayX l :: [(Int, AttrLine)]
l =
  ((Int, (Int, AttrLine)) -> (PointUI, AttrLine))
-> [(Int, (Int, AttrLine))] -> Overlay
forall a b. (a -> b) -> [a] -> [b]
map (\(y :: Int
y, (x :: Int
x, al :: AttrLine
al)) -> (Int -> Int -> PointUI
PointUI Int
x Int
y, AttrLine
al)) ([(Int, (Int, AttrLine))] -> Overlay)
-> [(Int, (Int, AttrLine))] -> Overlay
forall a b. (a -> b) -> a -> b
$ [Int] -> [(Int, AttrLine)] -> [(Int, (Int, AttrLine))]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [(Int, AttrLine)]
l

-- @f@ should not enlarge the line beyond screen width nor introduce linebreaks.
updateLine :: Int -> (Int -> AttrString -> AttrString) -> Overlay -> Overlay
updateLine :: Int -> (Int -> AttrString -> AttrString) -> Overlay -> Overlay
updateLine y :: Int
y f :: Int -> AttrString -> AttrString
f ov :: Overlay
ov =
  let upd :: (PointUI, AttrLine) -> (PointUI, AttrLine)
upd (p :: PointUI
p@(PointUI px :: Int
px py :: Int
py), AttrLine l :: AttrString
l) =
        if Int
py Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y then (PointUI
p, AttrString -> AttrLine
AttrLine (AttrString -> AttrLine) -> AttrString -> AttrLine
forall a b. (a -> b) -> a -> b
$ Int -> AttrString -> AttrString
f Int
px AttrString
l) else (PointUI
p, AttrString -> AttrLine
AttrLine AttrString
l)
  in ((PointUI, AttrLine) -> (PointUI, AttrLine)) -> Overlay -> Overlay
forall a b. (a -> b) -> [a] -> [b]
map (PointUI, AttrLine) -> (PointUI, AttrLine)
upd Overlay
ov