{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Graphics.Vty.Output.Interface
( Output(..)
, AssumedState(..)
, DisplayContext(..)
, Mode(..)
, displayContext
, outputPicture
, initialAssumedState
, limitAttrForDisplay
)
where
import Graphics.Vty.Attributes
import Graphics.Vty.Image (DisplayRegion, regionHeight)
import Graphics.Vty.Picture
import Graphics.Vty.PictureToSpans
import Graphics.Vty.Span
import Graphics.Vty.DisplayAttributes
import Blaze.ByteString.Builder (Write, writeToByteString)
import Blaze.ByteString.Builder.ByteString (writeByteString)
import qualified Data.ByteString as BS
import Data.IORef
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as Vector
data Mode = Mouse
| BracketedPaste
| Focus
| Hyperlink
deriving (Mode -> Mode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq, ReadPrec [Mode]
ReadPrec Mode
Int -> ReadS Mode
ReadS [Mode]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Mode]
$creadListPrec :: ReadPrec [Mode]
readPrec :: ReadPrec Mode
$creadPrec :: ReadPrec Mode
readList :: ReadS [Mode]
$creadList :: ReadS [Mode]
readsPrec :: Int -> ReadS Mode
$creadsPrec :: Int -> ReadS Mode
Read, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)
data Output = Output
{
Output -> String
terminalID :: String
, Output -> IO ()
releaseTerminal :: IO ()
, Output -> IO ()
reserveDisplay :: IO ()
, Output -> IO ()
releaseDisplay :: IO ()
, Output -> DisplayRegion -> IO ()
setDisplayBounds :: (Int, Int) -> IO ()
, Output -> IO DisplayRegion
displayBounds :: IO DisplayRegion
, Output -> ByteString -> IO ()
outputByteBuffer :: BS.ByteString -> IO ()
, Output -> Bool
supportsCursorVisibility :: Bool
, Output -> Mode -> Bool
supportsMode :: Mode -> Bool
, Output -> Mode -> Bool -> IO ()
setMode :: Mode -> Bool -> IO ()
, Output -> Mode -> IO Bool
getModeStatus :: Mode -> IO Bool
, Output -> IORef AssumedState
assumedStateRef :: IORef AssumedState
, Output -> Output -> DisplayRegion -> IO DisplayContext
mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
, Output -> IO ()
ringTerminalBell :: IO ()
, Output -> IO Bool
supportsBell :: IO Bool
, Output -> IO Bool
supportsItalics :: IO Bool
, Output -> IO Bool
supportsStrikethrough :: IO Bool
, Output -> ColorMode
outputColorMode :: ColorMode
}
displayContext :: Output -> DisplayRegion -> IO DisplayContext
displayContext :: Output -> DisplayRegion -> IO DisplayContext
displayContext Output
t = Output -> Output -> DisplayRegion -> IO DisplayContext
mkDisplayContext Output
t Output
t
data AssumedState = AssumedState
{ AssumedState -> Maybe FixedAttr
prevFattr :: Maybe FixedAttr
, AssumedState -> Maybe DisplayOps
prevOutputOps :: Maybe DisplayOps
}
initialAssumedState :: AssumedState
initialAssumedState :: AssumedState
initialAssumedState = Maybe FixedAttr -> Maybe DisplayOps -> AssumedState
AssumedState forall a. Maybe a
Nothing forall a. Maybe a
Nothing
data DisplayContext = DisplayContext
{ DisplayContext -> Output
contextDevice :: Output
, DisplayContext -> DisplayRegion
contextRegion :: DisplayRegion
, DisplayContext -> Int -> Int -> Write
writeMoveCursor :: Int -> Int -> Write
, DisplayContext -> Write
writeShowCursor :: Write
, DisplayContext -> Write
writeHideCursor :: Write
, DisplayContext
-> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
, DisplayContext -> Bool -> Write
writeDefaultAttr :: Bool -> Write
, DisplayContext -> Write
writeRowEnd :: Write
, DisplayContext -> IO ()
inlineHack :: IO ()
}
writeUtf8Text :: BS.ByteString -> Write
writeUtf8Text :: ByteString -> Write
writeUtf8Text = ByteString -> Write
writeByteString
outputPicture :: DisplayContext -> Picture -> IO ()
outputPicture :: DisplayContext -> Picture -> IO ()
outputPicture DisplayContext
dc Picture
pic = do
Bool
urlsEnabled <- Output -> Mode -> IO Bool
getModeStatus (DisplayContext -> Output
contextDevice DisplayContext
dc) Mode
Hyperlink
AssumedState
as <- forall a. IORef a -> IO a
readIORef (Output -> IORef AssumedState
assumedStateRef forall a b. (a -> b) -> a -> b
$ DisplayContext -> Output
contextDevice DisplayContext
dc)
let manipCursor :: Bool
manipCursor = Output -> Bool
supportsCursorVisibility (DisplayContext -> Output
contextDevice DisplayContext
dc)
r :: DisplayRegion
r = DisplayContext -> DisplayRegion
contextRegion DisplayContext
dc
ops :: DisplayOps
ops = Picture -> DisplayRegion -> DisplayOps
displayOpsForPic Picture
pic DisplayRegion
r
initialAttr :: FixedAttr
initialAttr = Style -> Maybe Color -> Maybe Color -> Maybe Text -> FixedAttr
FixedAttr Style
defaultStyleMask forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
[Bool]
diffs :: [Bool] = case AssumedState -> Maybe DisplayOps
prevOutputOps AssumedState
as of
Maybe DisplayOps
Nothing -> forall a. Int -> a -> [a]
replicate (forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ DisplayRegion -> Int
regionHeight forall a b. (a -> b) -> a -> b
$ DisplayOps -> DisplayRegion
affectedRegion DisplayOps
ops) Bool
True
Just DisplayOps
previousOps -> if DisplayOps -> DisplayRegion
affectedRegion DisplayOps
previousOps forall a. Eq a => a -> a -> Bool
/= DisplayOps -> DisplayRegion
affectedRegion DisplayOps
ops
then forall a. Int -> a -> [a]
replicate (DisplayOps -> Int
displayOpsRows DisplayOps
ops) Bool
True
else forall a. Vector a -> [a]
Vector.toList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
Vector.zipWith forall a. Eq a => a -> a -> Bool
(/=) DisplayOps
previousOps DisplayOps
ops
out :: Write
out = (if Bool
manipCursor then DisplayContext -> Write
writeHideCursor DisplayContext
dc else forall a. Monoid a => a
mempty)
forall a. Monoid a => a -> a -> a
`mappend` Bool
-> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
writeOutputOps Bool
urlsEnabled DisplayContext
dc FixedAttr
initialAttr [Bool]
diffs DisplayOps
ops
forall a. Monoid a => a -> a -> a
`mappend`
(let (Int
w,Int
h) = DisplayContext -> DisplayRegion
contextRegion DisplayContext
dc
clampX :: Int -> Int
clampX = forall a. Ord a => a -> a -> a
max Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min (Int
wforall a. Num a => a -> a -> a
-Int
1)
clampY :: Int -> Int
clampY = forall a. Ord a => a -> a -> a
max Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min (Int
hforall a. Num a => a -> a -> a
-Int
1) in
case Picture -> Cursor
picCursor Picture
pic of
Cursor
_ | Bool -> Bool
not Bool
manipCursor -> forall a. Monoid a => a
mempty
Cursor
NoCursor -> forall a. Monoid a => a
mempty
AbsoluteCursor Int
x Int
y ->
DisplayContext -> Write
writeShowCursor DisplayContext
dc forall a. Monoid a => a -> a -> a
`mappend`
DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc (Int -> Int
clampX Int
x) (Int -> Int
clampY Int
y)
PositionOnly Bool
isAbs Int
x Int
y ->
if Bool
isAbs
then DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc (Int -> Int
clampX Int
x) (Int -> Int
clampY Int
y)
else let (Int
ox, Int
oy) = CursorOutputMap -> DisplayRegion -> DisplayRegion
charToOutputPos CursorOutputMap
m (Int -> Int
clampX Int
x, Int -> Int
clampY Int
y)
m :: CursorOutputMap
m = DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap DisplayOps
ops forall a b. (a -> b) -> a -> b
$ Picture -> Cursor
picCursor Picture
pic
in DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc (Int -> Int
clampX Int
ox) (Int -> Int
clampY Int
oy)
Cursor Int
x Int
y ->
let m :: CursorOutputMap
m = DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap DisplayOps
ops forall a b. (a -> b) -> a -> b
$ Picture -> Cursor
picCursor Picture
pic
(Int
ox, Int
oy) = CursorOutputMap -> DisplayRegion -> DisplayRegion
charToOutputPos CursorOutputMap
m (Int -> Int
clampX Int
x, Int -> Int
clampY Int
y)
in DisplayContext -> Write
writeShowCursor DisplayContext
dc forall a. Monoid a => a -> a -> a
`mappend`
DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc (Int -> Int
clampX Int
ox) (Int -> Int
clampY Int
oy)
)
Output -> ByteString -> IO ()
outputByteBuffer (DisplayContext -> Output
contextDevice DisplayContext
dc) (Write -> ByteString
writeToByteString Write
out)
let as' :: AssumedState
as' = AssumedState
as { prevOutputOps :: Maybe DisplayOps
prevOutputOps = forall a. a -> Maybe a
Just DisplayOps
ops }
forall a. IORef a -> a -> IO ()
writeIORef (Output -> IORef AssumedState
assumedStateRef forall a b. (a -> b) -> a -> b
$ DisplayContext -> Output
contextDevice DisplayContext
dc) AssumedState
as'
writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
writeOutputOps :: Bool
-> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
writeOutputOps Bool
urlsEnabled DisplayContext
dc FixedAttr
initialAttr [Bool]
diffs DisplayOps
ops =
let (Int
_, Write
out, [Bool]
_) = forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (Int, Write, [Bool]) -> SpanOps -> (Int, Write, [Bool])
writeOutputOps'
(Int
0, forall a. Monoid a => a
mempty, [Bool]
diffs)
DisplayOps
ops
in Write
out
where
writeOutputOps' :: (Int, Write, [Bool]) -> SpanOps -> (Int, Write, [Bool])
writeOutputOps' (Int
y, Write
out, Bool
True : [Bool]
diffs') SpanOps
spanOps
= let spanOut :: Write
spanOut = Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
writeSpanOps Bool
urlsEnabled DisplayContext
dc Int
y FixedAttr
initialAttr SpanOps
spanOps
out' :: Write
out' = Write
out forall a. Monoid a => a -> a -> a
`mappend` Write
spanOut
in (Int
yforall a. Num a => a -> a -> a
+Int
1, Write
out', [Bool]
diffs')
writeOutputOps' (Int
y, Write
out, Bool
False : [Bool]
diffs') SpanOps
_spanOps
= (Int
y forall a. Num a => a -> a -> a
+ Int
1, Write
out, [Bool]
diffs')
writeOutputOps' (Int
_y, Write
_out, []) SpanOps
_spanOps
= forall a. HasCallStack => String -> a
error String
"vty - output spans without a corresponding diff."
writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
writeSpanOps Bool
urlsEnabled DisplayContext
dc Int
y FixedAttr
initialAttr SpanOps
spanOps =
let start :: Write
start = DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc Int
0 Int
y forall a. Monoid a => a -> a -> a
`mappend` DisplayContext -> Bool -> Write
writeDefaultAttr DisplayContext
dc Bool
urlsEnabled
in forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (\(Write
out, FixedAttr
fattr) SpanOp
op -> case Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
writeSpanOp Bool
urlsEnabled DisplayContext
dc SpanOp
op FixedAttr
fattr of
(Write
opOut, FixedAttr
fattr') -> (Write
out forall a. Monoid a => a -> a -> a
`mappend` Write
opOut, FixedAttr
fattr')
)
(Write
start, FixedAttr
initialAttr)
SpanOps
spanOps
writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
writeSpanOp Bool
urlsEnabled DisplayContext
dc (TextSpan Attr
attr Int
_ Int
_ DisplayText
str) FixedAttr
fattr =
let attr' :: Attr
attr' = Output -> Attr -> Attr
limitAttrForDisplay (DisplayContext -> Output
contextDevice DisplayContext
dc) Attr
attr
fattr' :: FixedAttr
fattr' = FixedAttr -> Attr -> FixedAttr
fixDisplayAttr FixedAttr
fattr Attr
attr'
diffs :: DisplayAttrDiff
diffs = FixedAttr -> FixedAttr -> DisplayAttrDiff
displayAttrDiffs FixedAttr
fattr FixedAttr
fattr'
out :: Write
out = DisplayContext
-> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
writeSetAttr DisplayContext
dc Bool
urlsEnabled FixedAttr
fattr Attr
attr' DisplayAttrDiff
diffs
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Write
writeUtf8Text (Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ DisplayText -> Text
TL.toStrict DisplayText
str)
in (Write
out, FixedAttr
fattr')
writeSpanOp Bool
_ DisplayContext
_ (Skip Int
_) FixedAttr
_fattr = forall a. HasCallStack => String -> a
error String
"writeSpanOp for Skip"
writeSpanOp Bool
urlsEnabled DisplayContext
dc (RowEnd Int
_) FixedAttr
fattr = (DisplayContext -> Bool -> Write
writeDefaultAttr DisplayContext
dc Bool
urlsEnabled forall a. Monoid a => a -> a -> a
`mappend` DisplayContext -> Write
writeRowEnd DisplayContext
dc, FixedAttr
fattr)
data CursorOutputMap = CursorOutputMap
{ CursorOutputMap -> DisplayRegion -> DisplayRegion
charToOutputPos :: (Int, Int) -> (Int, Int)
}
cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap DisplayOps
spanOps Cursor
_cursor = CursorOutputMap
{ charToOutputPos :: DisplayRegion -> DisplayRegion
charToOutputPos = \(Int
cx, Int
cy) -> (DisplayOps -> Int -> Int -> Int
cursorColumnOffset DisplayOps
spanOps Int
cx Int
cy, Int
cy)
}
cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
cursorColumnOffset DisplayOps
ops Int
cx Int
cy =
let cursorRowOps :: SpanOps
cursorRowOps = forall a. Vector a -> Int -> a
Vector.unsafeIndex DisplayOps
ops (forall a. Enum a => a -> Int
fromEnum Int
cy)
(Int
outOffset, Int
_, Bool
_)
= forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' ( \(Int
d, Int
currentCx, Bool
done) SpanOp
op ->
if Bool
done then (Int
d, Int
currentCx, Bool
done) else case SpanOp -> Maybe DisplayRegion
spanOpHasWidth SpanOp
op of
Maybe DisplayRegion
Nothing -> (Int
d, Int
currentCx, Bool
False)
Just (Int
cw, Int
ow) -> case forall a. Ord a => a -> a -> Ordering
compare Int
cx (Int
currentCx forall a. Num a => a -> a -> a
+ Int
cw) of
Ordering
GT -> ( Int
d forall a. Num a => a -> a -> a
+ Int
ow
, Int
currentCx forall a. Num a => a -> a -> a
+ Int
cw
, Bool
False
)
Ordering
EQ -> ( Int
d forall a. Num a => a -> a -> a
+ Int
ow
, Int
currentCx forall a. Num a => a -> a -> a
+ Int
cw
, Bool
True
)
Ordering
LT -> ( Int
d forall a. Num a => a -> a -> a
+ Int -> SpanOp -> Int
columnsToCharOffset (Int
cx forall a. Num a => a -> a -> a
- Int
currentCx) SpanOp
op
, Int
currentCx forall a. Num a => a -> a -> a
+ Int
cw
, Bool
True
)
)
(Int
0, Int
0, Bool
False)
SpanOps
cursorRowOps
in Int
outOffset
limitAttrForDisplay :: Output -> Attr -> Attr
limitAttrForDisplay :: Output -> Attr -> Attr
limitAttrForDisplay Output
t Attr
attr
= Attr
attr { attrForeColor :: MaybeDefault Color
attrForeColor = MaybeDefault Color -> MaybeDefault Color
clampColor forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrForeColor Attr
attr
, attrBackColor :: MaybeDefault Color
attrBackColor = MaybeDefault Color -> MaybeDefault Color
clampColor forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrBackColor Attr
attr
}
where
clampColor :: MaybeDefault Color -> MaybeDefault Color
clampColor MaybeDefault Color
Default = forall v. MaybeDefault v
Default
clampColor MaybeDefault Color
KeepCurrent = forall v. MaybeDefault v
KeepCurrent
clampColor (SetTo Color
c) = ColorMode -> Color -> MaybeDefault Color
clampColor' (Output -> ColorMode
outputColorMode Output
t) Color
c
clampColor' :: ColorMode -> Color -> MaybeDefault Color
clampColor' ColorMode
NoColor Color
_ = forall v. MaybeDefault v
Default
clampColor' ColorMode
ColorMode8 (ISOColor Style
v)
| Style
v forall a. Ord a => a -> a -> Bool
>= Style
8 = forall v. v -> MaybeDefault v
SetTo forall a b. (a -> b) -> a -> b
$ Style -> Color
ISOColor (Style
v forall a. Num a => a -> a -> a
- Style
8)
| Bool
otherwise = forall v. v -> MaybeDefault v
SetTo forall a b. (a -> b) -> a -> b
$ Style -> Color
ISOColor Style
v
clampColor' ColorMode
ColorMode8 Color
_ = forall v. MaybeDefault v
Default
clampColor' ColorMode
ColorMode16 c :: Color
c@(ISOColor Style
_) = forall v. v -> MaybeDefault v
SetTo Color
c
clampColor' ColorMode
ColorMode16 Color
_ = forall v. MaybeDefault v
Default
clampColor' (ColorMode240 Style
_) c :: Color
c@(ISOColor Style
_) = forall v. v -> MaybeDefault v
SetTo Color
c
clampColor' (ColorMode240 Style
colorCount) c :: Color
c@(Color240 Style
n)
| Style
n forall a. Ord a => a -> a -> Bool
<= Style
colorCount = forall v. v -> MaybeDefault v
SetTo Color
c
| Bool
otherwise = forall v. MaybeDefault v
Default
clampColor' colorMode :: ColorMode
colorMode@(ColorMode240 Style
_) (RGBColor Style
r Style
g Style
b) =
ColorMode -> Color -> MaybeDefault Color
clampColor' ColorMode
colorMode (forall i. Integral i => i -> i -> i -> Color
color240 Style
r Style
g Style
b)
clampColor' ColorMode
FullColor Color
c = forall v. v -> MaybeDefault v
SetTo Color
c