{-# LANGUAGE RankNTypes, TupleSections #-}
-- | Screen overlays.
module Game.LambdaHack.Client.UI.Overlay
  ( -- * DisplayFont
    DisplayFont, isPropFont, isSquareFont, isMonoFont, textSize
  , -- * FontSetup
    FontSetup(..), multiFontSetup, singleFontSetup
  , -- * AttrString
    AttrString, blankAttrString, textToAS, textFgToAS, stringToAS
  , attrStringToString
  , (<+:>), (<\:>)
    -- * AttrLine
  , AttrLine, attrLine, emptyAttrLine, attrStringToAL, firstParagraph
  , textToAL, textFgToAL, stringToAL, linesAttr
  , splitAttrString, indentSplitAttrString
    -- * Overlay
  , Overlay, xytranslateOverlay, xtranslateOverlay, ytranslateOverlay
  , offsetOverlay, offsetOverlayX, typesetXY
  , updateLine, rectangleOfSpaces, maxYofOverlay, labDescOverlay
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , nonbreakableRev, isPrefixOfNonbreakable, breakAtSpace, 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

-- * DisplayFont

-- | Three types of fonts used in the UI. Overlays (layers, more or less)
-- in proportional font are overwritten by layers in square font,
-- which are overwritten by layers in mono font.
-- All overlays overwrite the rendering of the game map, which is
-- the underlying basic UI frame, comprised of square font glyps.
--
-- This type needs to be kept abstract to ensure that frontend-enforced
-- or user config-enforced font assignments in 'FontSetup'
-- (e.g., stating that the supposedly proportional font is overriden
-- to be the square font) can't be ignored. Otherwise a programmer
-- could use arbirary @DisplayFont@, instead of the one taken from 'FontSetup',
-- and so, e.g., calculating the width of an overlay so constructed
-- in order to decide where another overlay can start would be inconsistent
-- what what font is really eventually used when rendering.
--
-- Note that the order of constructors has limited effect,
-- but it illustrates how overwriting is explicitly implemented
-- in frontends that support all fonts.
data DisplayFont = PropFont | SquareFont | MonoFont
  deriving (Int -> DisplayFont -> ShowS
[DisplayFont] -> ShowS
DisplayFont -> [Char]
(Int -> DisplayFont -> ShowS)
-> (DisplayFont -> [Char])
-> ([DisplayFont] -> ShowS)
-> Show DisplayFont
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DisplayFont -> ShowS
showsPrec :: Int -> DisplayFont -> ShowS
$cshow :: DisplayFont -> [Char]
show :: DisplayFont -> [Char]
$cshowList :: [DisplayFont] -> ShowS
showList :: [DisplayFont] -> ShowS
Show, DisplayFont -> DisplayFont -> Bool
(DisplayFont -> DisplayFont -> Bool)
-> (DisplayFont -> DisplayFont -> Bool) -> Eq DisplayFont
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DisplayFont -> DisplayFont -> Bool
== :: DisplayFont -> DisplayFont -> Bool
$c/= :: DisplayFont -> DisplayFont -> Bool
/= :: DisplayFont -> DisplayFont -> Bool
Eq, Int -> DisplayFont
DisplayFont -> Int
DisplayFont -> [DisplayFont]
DisplayFont -> DisplayFont
DisplayFont -> DisplayFont -> [DisplayFont]
DisplayFont -> DisplayFont -> DisplayFont -> [DisplayFont]
(DisplayFont -> DisplayFont)
-> (DisplayFont -> DisplayFont)
-> (Int -> DisplayFont)
-> (DisplayFont -> Int)
-> (DisplayFont -> [DisplayFont])
-> (DisplayFont -> DisplayFont -> [DisplayFont])
-> (DisplayFont -> DisplayFont -> [DisplayFont])
-> (DisplayFont -> DisplayFont -> DisplayFont -> [DisplayFont])
-> Enum DisplayFont
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: DisplayFont -> DisplayFont
succ :: DisplayFont -> DisplayFont
$cpred :: DisplayFont -> DisplayFont
pred :: DisplayFont -> DisplayFont
$ctoEnum :: Int -> DisplayFont
toEnum :: Int -> DisplayFont
$cfromEnum :: DisplayFont -> Int
fromEnum :: DisplayFont -> Int
$cenumFrom :: DisplayFont -> [DisplayFont]
enumFrom :: DisplayFont -> [DisplayFont]
$cenumFromThen :: DisplayFont -> DisplayFont -> [DisplayFont]
enumFromThen :: DisplayFont -> DisplayFont -> [DisplayFont]
$cenumFromTo :: DisplayFont -> DisplayFont -> [DisplayFont]
enumFromTo :: DisplayFont -> DisplayFont -> [DisplayFont]
$cenumFromThenTo :: DisplayFont -> DisplayFont -> DisplayFont -> [DisplayFont]
enumFromThenTo :: DisplayFont -> DisplayFont -> DisplayFont -> [DisplayFont]
Enum)

isPropFont, isSquareFont, isMonoFont :: DisplayFont -> Bool
isPropFont :: DisplayFont -> Bool
isPropFont = (DisplayFont -> DisplayFont -> Bool
forall a. Eq a => a -> a -> Bool
== DisplayFont
PropFont)
isSquareFont :: DisplayFont -> Bool
isSquareFont = (DisplayFont -> DisplayFont -> Bool
forall a. Eq a => a -> a -> Bool
== DisplayFont
SquareFont)
isMonoFont :: DisplayFont -> Bool
isMonoFont = (DisplayFont -> DisplayFont -> Bool
forall a. Eq a => a -> a -> Bool
== DisplayFont
MonoFont)

textSize :: DisplayFont -> [a] -> Int
textSize :: forall a. DisplayFont -> [a] -> Int
textSize DisplayFont
SquareFont [a]
l = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [a] -> Int
forall a. [a] -> Int
length [a]
l
textSize DisplayFont
MonoFont [a]
l = [a] -> Int
forall a. [a] -> Int
length [a]
l
textSize DisplayFont
PropFont [a]
_ = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"size of proportional font texts is not defined"

-- * FontSetup

data FontSetup = FontSetup
  { FontSetup -> DisplayFont
squareFont :: DisplayFont
  , FontSetup -> DisplayFont
monoFont   :: DisplayFont
  , FontSetup -> DisplayFont
propFont   :: DisplayFont
  }
  deriving (FontSetup -> FontSetup -> Bool
(FontSetup -> FontSetup -> Bool)
-> (FontSetup -> FontSetup -> Bool) -> Eq FontSetup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FontSetup -> FontSetup -> Bool
== :: FontSetup -> FontSetup -> Bool
$c/= :: FontSetup -> FontSetup -> Bool
/= :: FontSetup -> FontSetup -> Bool
Eq, Int -> FontSetup -> ShowS
[FontSetup] -> ShowS
FontSetup -> [Char]
(Int -> FontSetup -> ShowS)
-> (FontSetup -> [Char])
-> ([FontSetup] -> ShowS)
-> Show FontSetup
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FontSetup -> ShowS
showsPrec :: Int -> FontSetup -> ShowS
$cshow :: FontSetup -> [Char]
show :: FontSetup -> [Char]
$cshowList :: [FontSetup] -> ShowS
showList :: [FontSetup] -> ShowS
Show)  -- for unit tests

multiFontSetup :: FontSetup
multiFontSetup :: FontSetup
multiFontSetup = DisplayFont -> DisplayFont -> DisplayFont -> FontSetup
FontSetup DisplayFont
SquareFont DisplayFont
MonoFont DisplayFont
PropFont

singleFontSetup :: FontSetup
singleFontSetup :: FontSetup
singleFontSetup = DisplayFont -> DisplayFont -> DisplayFont -> FontSetup
FontSetup DisplayFont
SquareFont DisplayFont
SquareFont DisplayFont
SquareFont

-- * AttrString

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

blankAttrString :: Int -> AttrString
blankAttrString :: Int -> AttrString
blankAttrString 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 Char
c 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 Char
' ' 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 Char
c 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 :: [Char] -> AttrString
stringToAS = (Char -> AttrCharW32) -> [Char] -> AttrString
forall a b. (a -> b) -> [a] -> [b]
map Char -> AttrCharW32
Color.attrChar1ToW32

-- | Transform 'AttrString' type to 'String'.
attrStringToString :: AttrString -> String
attrStringToString :: AttrString -> [Char]
attrStringToString = (AttrCharW32 -> Char) -> AttrString -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> Char
Color.charFromW32

-- Follows minimorph.<+>.
infixr 6 <+:>  -- matches Monoid.<>
(<+:>) :: AttrString -> AttrString -> AttrString
<+:> :: AttrString -> AttrString -> AttrString
(<+:>) [] AttrString
l2 = AttrString
l2
(<+:>) AttrString
l1 [] = AttrString
l1
(<+:>) AttrString
l1 l2 :: AttrString
l2@(AttrCharW32
c2 : AttrString
_) =
  if Char -> Bool
isSpace (AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
c2) Bool -> Bool -> Bool
|| Char -> Bool
isSpace (AttrCharW32 -> Char
Color.charFromW32 (AttrString -> AttrCharW32
forall a. HasCallStack => [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
(<\:>) [] AttrString
l2 = AttrString
l2
(<\:>) AttrString
l1 [] = AttrString
l1
(<\:>) AttrString
l1 l2 :: AttrString
l2@(AttrCharW32
c2 : AttrString
_) =
  if AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
c2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| AttrCharW32 -> Char
Color.charFromW32 (AttrString -> AttrCharW32
forall a. HasCallStack => [a] -> a
last AttrString
l1) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\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]
++ [Char] -> AttrString
stringToAS [Char]
"\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 :: [[Char]]
nonbreakableRev = [[Char]
"eht", [Char]
"a", [Char]
"na", [Char]
"ehT", [Char]
"A", [Char]
"nA", [Char]
"I"]

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

breakAtSpace :: AttrString -> (AttrString, AttrString)
breakAtSpace :: AttrString -> (AttrString, AttrString)
breakAtSpace AttrString
lRev =
  let (AttrString
pre, 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
    AttrCharW32
c : 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 (AttrString
pre2, 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
_ -> (AttrString
pre, AttrString
post)  -- no space found, give up

-- * AttrLine

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

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

attrStringToAL :: AttrString -> AttrLine
attrStringToAL :: AttrString -> AttrLine
attrStringToAL AttrString
s =
#ifdef WITH_EXPENSIVE_ASSERTIONS
  Bool -> AttrLine -> AttrLine
forall a. HasCallStack => Bool -> a -> a
assert ((AttrCharW32 -> Bool) -> AttrString -> Bool
forall v. Show v => (v -> Bool) -> [v] -> Bool
allB (\AttrCharW32
ac -> AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
ac Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') AttrString
s) (AttrLine -> AttrLine) -> AttrLine -> AttrLine
forall a b. (a -> b) -> a -> b
$  -- expensive in menus
  Bool -> AttrLine -> AttrLine
forall a. HasCallStack => Bool -> a -> a
assert (AttrString -> Bool
forall a. [a] -> Bool
null AttrString
s Bool -> Bool -> Bool
|| AttrString -> AttrCharW32
forall a. HasCallStack => [a] -> a
last AttrString
s AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrCharW32
Color.spaceAttrW32
          Bool -> [Char] -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` AttrString -> [Char]
attrStringToString 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 AttrString
s = case AttrString -> [AttrLine]
linesAttr AttrString
s of
  [] -> AttrLine
emptyAttrLine
  AttrLine
l : [AttrLine]
_ -> AttrLine
l

textToAL :: Text -> AttrLine
textToAL :: Text -> AttrLine
textToAL !Text
t =
  let f :: Char -> AttrString -> AttrString
f Char
'\n' AttrString
_ = [Char] -> AttrString
forall a. HasCallStack => [Char] -> a
error ([Char] -> AttrString) -> [Char] -> AttrString
forall a b. (a -> b) -> a -> b
$ [Char]
"illegal end of line in: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
      f Char
c 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. HasCallStack => Bool -> a -> a
assert (AttrString -> Bool
forall a. [a] -> Bool
null AttrString
s Bool -> Bool -> Bool
|| AttrString -> AttrCharW32
forall a. HasCallStack => [a] -> a
last AttrString
s AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrCharW32
Color.spaceAttrW32 Bool -> Text -> Bool
forall v. Show v => Bool -> v -> 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 Char
'\n' AttrString
_ = [Char] -> AttrString
forall a. HasCallStack => [Char] -> a
error ([Char] -> AttrString) -> [Char] -> AttrString
forall a b. (a -> b) -> a -> b
$ [Char]
"illegal end of line in: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
      f Char
' ' 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 Char
c 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. HasCallStack => Bool -> a -> a
assert (AttrString -> Bool
forall a. [a] -> Bool
null AttrString
s Bool -> Bool -> Bool
|| AttrString -> AttrCharW32
forall a. HasCallStack => [a] -> a
last AttrString
s AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrCharW32
Color.spaceAttrW32 Bool -> Text -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` Text
t)
#endif
    AttrString
s

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

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

-- | Split a string into lines. Avoid breaking the line at a character
-- other than space. Remove the spaces on which lines are broken,
-- keep other spaces. In expensive assertions mode (dev debug mode)
-- fail at trailing spaces, but keep leading spaces, e.g., to make
-- distance from a text in another font. 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 Int
w0 Int
w1 AttrString
l = case AttrString -> [AttrLine]
linesAttr AttrString
l of
  [] -> []
  AttrLine
x : [AttrLine]
xs -> Int -> Int -> AttrLine -> [AttrLine]
splitAttrPhrase Int
w0 Int
w1 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]
xs

indentSplitAttrString :: DisplayFont -> Int -> AttrString -> [AttrLine]
indentSplitAttrString :: DisplayFont -> Int -> AttrString -> [AttrLine]
indentSplitAttrString DisplayFont
font Int
w AttrString
l = Bool -> [AttrLine] -> [AttrLine]
forall a. HasCallStack => Bool -> a -> a
assert (Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4) ([AttrLine] -> [AttrLine]) -> [AttrLine] -> [AttrLine]
forall a b. (a -> b) -> a -> b
$
  -- Sadly this depends on how wide the space is in propotional font,
  -- which varies wildly, so we err on the side of larger indent.
  let nspaces :: Int
nspaces = case DisplayFont
font of
        DisplayFont
SquareFont -> Int
1
        DisplayFont
MonoFont -> Int
2
        DisplayFont
PropFont -> Int
4
      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
    [] -> []
    AttrLine
hd : [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 Int
w0 Int
w1 (AttrLine 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 (AttrString
pre, 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
          ((AttrString
ppre, AttrString
ppost), AttrString
post) = case AttrString
postRaw of
            AttrCharW32
c : 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, 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)]

xytranslateOverlay :: Int -> Int -> Overlay -> Overlay
xytranslateOverlay :: Int -> Int -> Overlay -> Overlay
xytranslateOverlay Int
dx Int
dy =
  ((PointUI, AttrLine) -> (PointUI, AttrLine)) -> Overlay -> Overlay
forall a b. (a -> b) -> [a] -> [b]
map (\(PointUI Int
x Int
y, AttrLine
al) -> (Int -> Int -> PointUI
PointUI (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dx) (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dy), AttrLine
al))

xtranslateOverlay :: Int -> Overlay -> Overlay
xtranslateOverlay :: Int -> Overlay -> Overlay
xtranslateOverlay Int
dx = Int -> Int -> Overlay -> Overlay
xytranslateOverlay Int
dx Int
0

ytranslateOverlay :: Int -> Overlay -> Overlay
ytranslateOverlay :: Int -> Overlay -> Overlay
ytranslateOverlay = Int -> Int -> Overlay -> Overlay
xytranslateOverlay Int
0

offsetOverlay :: [AttrLine] -> Overlay
offsetOverlay :: [AttrLine] -> Overlay
offsetOverlay = (Int -> AttrLine -> (PointUI, AttrLine))
-> [Int] -> [AttrLine] -> Overlay
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((Int, AttrLine) -> (PointUI, AttrLine))
-> Int -> AttrLine -> (PointUI, AttrLine)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry ((Int -> PointUI) -> (Int, AttrLine) -> (PointUI, AttrLine)
forall b c d. (b -> c) -> (b, d) -> (c, d)
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 Int
0)) [Int
0..]

offsetOverlayX :: [(Int, AttrLine)] -> Overlay
offsetOverlayX :: [(Int, AttrLine)] -> Overlay
offsetOverlayX = (Int -> (Int, AttrLine) -> (PointUI, AttrLine))
-> [Int] -> [(Int, AttrLine)] -> Overlay
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
y (Int
x, AttrLine
al) -> (Int -> Int -> PointUI
PointUI Int
x Int
y, AttrLine
al)) [Int
0..]

typesetXY :: (Int, Int) -> [AttrLine] -> Overlay
typesetXY :: (Int, Int) -> [AttrLine] -> Overlay
typesetXY (Int
xoffset, Int
yoffset) =
  (Int -> AttrLine -> (PointUI, AttrLine))
-> [Int] -> [AttrLine] -> Overlay
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
y AttrLine
al -> (Int -> Int -> PointUI
PointUI Int
xoffset (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yoffset), AttrLine
al)) [Int
0..]

-- @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 Int
y Int -> AttrString -> AttrString
f Overlay
ov =
  let upd :: (PointUI, AttrLine) -> (PointUI, AttrLine)
upd (p :: PointUI
p@(PointUI Int
px Int
py), AttrLine 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

rectangleOfSpaces :: Int -> Int -> Overlay
rectangleOfSpaces :: Int -> Int -> Overlay
rectangleOfSpaces Int
x Int
y =
  let blankAttrLine :: AttrLine
blankAttrLine = AttrString -> AttrLine
AttrLine (AttrString -> AttrLine) -> AttrString -> AttrLine
forall a b. (a -> b) -> a -> b
$ Int -> AttrCharW32 -> AttrString
forall a. Int -> a -> [a]
replicate Int
x AttrCharW32
Color.nbspAttrW32
  in [AttrLine] -> Overlay
offsetOverlay ([AttrLine] -> Overlay) -> [AttrLine] -> Overlay
forall a b. (a -> b) -> a -> b
$ Int -> AttrLine -> [AttrLine]
forall a. Int -> a -> [a]
replicate Int
y AttrLine
blankAttrLine

maxYofOverlay :: Overlay -> Int
maxYofOverlay :: Overlay -> Int
maxYofOverlay Overlay
ov = let yOfOverlay :: (PointUI, b) -> Int
yOfOverlay (PointUI Int
_ Int
y, b
_) = Int
y
                   in [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((PointUI, AttrLine) -> Int) -> Overlay -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (PointUI, AttrLine) -> Int
forall {b}. (PointUI, b) -> Int
yOfOverlay Overlay
ov

labDescOverlay :: DisplayFont -> Int -> AttrString -> (Overlay, Overlay)
labDescOverlay :: DisplayFont -> Int -> AttrString -> (Overlay, Overlay)
labDescOverlay DisplayFont
labFont Int
width AttrString
as =
  let (AttrString
tLab, AttrString
tDesc) = (AttrCharW32 -> Bool) -> AttrString -> (AttrString, AttrString)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrCharW32
Color.spaceAttrW32) AttrString
as
      labLen :: Int
labLen = DisplayFont -> AttrString -> Int
forall a. DisplayFont -> [a] -> Int
textSize DisplayFont
labFont AttrString
tLab
      len :: Int
len = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- AttrString -> Int
forall a. [a] -> Int
length AttrString
tLab  -- not labLen; TODO: type more strictly
      ovLab :: Overlay
ovLab = [AttrLine] -> Overlay
offsetOverlay [AttrString -> AttrLine
attrStringToAL AttrString
tLab]
      ovDesc :: Overlay
ovDesc = [(Int, AttrLine)] -> Overlay
offsetOverlayX ([(Int, AttrLine)] -> Overlay) -> [(Int, AttrLine)] -> Overlay
forall a b. (a -> b) -> a -> b
$
        case Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
len Int
width AttrString
tDesc of
          [] -> []
          AttrLine
l : [AttrLine]
ls -> (Int
labLen, AttrLine
l) (Int, AttrLine) -> [(Int, AttrLine)] -> [(Int, AttrLine)]
forall a. a -> [a] -> [a]
: (AttrLine -> (Int, AttrLine)) -> [AttrLine] -> [(Int, AttrLine)]
forall a b. (a -> b) -> [a] -> [b]
map (Int
0,) [AttrLine]
ls
  in (Overlay
ovLab, Overlay
ovDesc)