mirror of
https://github.com/jtdaugherty/brick.git
synced 2025-01-05 21:03:07 +03:00
Implement cursor handling
This commit is contained in:
Jonathan Daugherty
parent
c47109dc13
commit
195e20419b
121
programs/Main.hs
121
programs/Main.hs
@ -3,15 +3,23 @@ module Main where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Data.String
|
||||
import Data.Maybe
|
||||
import Graphics.Vty
|
||||
import System.Exit
|
||||
|
||||
newtype Location = Location (Int, Int)
|
||||
|
||||
offset :: Location -> Location -> Location
|
||||
offset (Location (w1, h1)) (Location (w2, h2)) = Location (w1+w2, h1+h2)
|
||||
|
||||
data Widget =
|
||||
Widget { render :: DisplayRegion -> Attr -> Image
|
||||
Widget { render :: Location -> DisplayRegion -> Attr -> (Image, [Location])
|
||||
}
|
||||
|
||||
txt :: String -> Widget
|
||||
txt s = Widget { render = const $ flip string s
|
||||
txt s = Widget { render = \_ _ a -> ( string a s
|
||||
, []
|
||||
)
|
||||
}
|
||||
|
||||
instance IsString Widget where
|
||||
@ -19,62 +27,85 @@ instance IsString Widget where
|
||||
|
||||
hBorder :: Char -> Widget
|
||||
hBorder ch =
|
||||
Widget { render = \(width, _) attr -> charFill attr ch width 1
|
||||
Widget { render = \_ (width, _) attr -> ( charFill attr ch width 1
|
||||
, []
|
||||
)
|
||||
}
|
||||
|
||||
vBorder :: Char -> Widget
|
||||
vBorder ch =
|
||||
Widget { render = \(_, height) attr -> charFill attr ch 1 height
|
||||
Widget { render = \_ (_, height) attr -> ( charFill attr ch 1 height
|
||||
, []
|
||||
)
|
||||
}
|
||||
|
||||
vBox :: [Widget] -> Widget
|
||||
vBox ws =
|
||||
vBox widgets =
|
||||
Widget { render = renderVBox
|
||||
}
|
||||
where
|
||||
renderVBox (width, height) attr =
|
||||
vertCat $ snd $ foldr (doIt attr width) (height, []) ws
|
||||
renderVBox loc (width, height) attr =
|
||||
let (imgs, curs) = doIt attr width widgets height loc
|
||||
in (vertCat imgs, curs)
|
||||
|
||||
doIt attr width w (hRemaining, imgs)
|
||||
| hRemaining <= 0 = (0, imgs)
|
||||
doIt _ _ [] _ _ = ([], [])
|
||||
doIt attr width (w:ws) hRemaining loc
|
||||
| hRemaining <= 0 = ([], [])
|
||||
| otherwise =
|
||||
let newHeight = hRemaining - imageHeight img
|
||||
img = render w (width, hRemaining) attr
|
||||
in (newHeight, img : imgs)
|
||||
(img, curs') = render w loc (width, hRemaining) attr
|
||||
newLoc = loc `offset` Location (0, imageHeight img)
|
||||
(restImgs, restCurs) = doIt attr width ws newHeight newLoc
|
||||
in (img:restImgs, curs'++restCurs)
|
||||
|
||||
hBox :: [Widget] -> Widget
|
||||
hBox ws =
|
||||
hBox widgets =
|
||||
Widget { render = renderHBox
|
||||
}
|
||||
where
|
||||
renderHBox (width, height) attr =
|
||||
horizCat $ snd $ foldr (doIt attr height) (width, []) ws
|
||||
renderHBox loc (width, height) attr =
|
||||
let (imgs, curs) = doIt attr height widgets width loc
|
||||
in (horizCat imgs, curs)
|
||||
|
||||
doIt attr height w (wRemaining, imgs)
|
||||
| wRemaining <= 0 = (0, imgs)
|
||||
doIt _ _ [] _ _ = ([], [])
|
||||
doIt attr height (w:ws) wRemaining loc
|
||||
| wRemaining <= 0 = ([], [])
|
||||
| otherwise =
|
||||
let newWidth = wRemaining - imageWidth img
|
||||
img = render w (wRemaining, height) attr
|
||||
in (newWidth, img : imgs)
|
||||
(img, curs') = render w loc (wRemaining, height) attr
|
||||
newLoc = loc `offset` Location (imageWidth img, 0)
|
||||
(restImgs, restCurs) = doIt attr height ws newWidth newLoc
|
||||
in (img:restImgs, curs'++restCurs)
|
||||
|
||||
hLimit :: Int -> Widget -> Widget
|
||||
hLimit width w =
|
||||
Widget { render = \(_, height) attr -> render_ w (width, height) attr
|
||||
Widget { render = \loc (_, height) attr -> render_ w loc (width, height) attr
|
||||
}
|
||||
|
||||
vLimit :: Int -> Widget -> Widget
|
||||
vLimit height w =
|
||||
Widget { render = \(width, _) attr -> render_ w (width, height) attr
|
||||
Widget { render = \loc (width, _) attr -> render_ w loc (width, height) attr
|
||||
}
|
||||
|
||||
render_ :: Widget -> DisplayRegion -> Attr -> Image
|
||||
render_ w sz attr = uncurry crop sz $ render w sz attr
|
||||
render_ :: Widget -> Location -> DisplayRegion -> Attr -> (Image, [Location])
|
||||
render_ w loc sz attr = (uncurry crop sz img, curs)
|
||||
where
|
||||
(img, curs) = render w loc sz attr
|
||||
|
||||
renderFinal :: Widget -> DisplayRegion -> Picture
|
||||
renderFinal w sz = picForImage $ uncurry resize sz $ render_ w sz defAttr
|
||||
renderFinal :: Widget -> DisplayRegion -> ([Location] -> Maybe Location) -> Picture
|
||||
renderFinal widget sz chooseCursor = pic
|
||||
where
|
||||
pic = basePic { picCursor = cursor }
|
||||
basePic = picForImage $ uncurry resize sz img
|
||||
cursor = case chooseCursor curs of
|
||||
Nothing -> NoCursor
|
||||
Just (Location (w, h)) -> Cursor w h
|
||||
(img, curs) = render_ widget (Location (0, 0)) sz defAttr
|
||||
|
||||
liftVty :: Image -> Widget
|
||||
liftVty = Widget . const . const
|
||||
liftVty img =
|
||||
Widget { render = const $ const $ const (img, [])
|
||||
}
|
||||
|
||||
on :: Color -> Color -> Attr
|
||||
on f b = defAttr `withForeColor` f
|
||||
@ -88,19 +119,22 @@ bg = (defAttr `withBackColor`)
|
||||
|
||||
withAttr :: Widget -> Attr -> Widget
|
||||
withAttr w attr =
|
||||
Widget { render = \sz _ -> render_ w sz attr
|
||||
Widget { render = \loc sz _ -> render_ w loc sz attr
|
||||
}
|
||||
|
||||
withCursor :: Widget -> Location -> Widget
|
||||
withCursor w cursorLoc =
|
||||
w { render = \loc sz a -> let (img, _) = render_ w loc sz a
|
||||
in (img, [loc `offset` cursorLoc])
|
||||
}
|
||||
|
||||
drawUI :: () -> Widget
|
||||
drawUI _ =
|
||||
vBox [ "-- header --" `withAttr` (fg red)
|
||||
, vLimit 25 $ hBox [ hLimit 25 $ vBox [ "foo bar stuff things!"
|
||||
, hBorder '-'
|
||||
, "more things"
|
||||
]
|
||||
, vBorder '|' `withAttr` (yellow `on` black)
|
||||
, liftVty $ string (fg green) "on the right"
|
||||
]
|
||||
hBox [ vBox [ "-- header 1 --"
|
||||
, "-- header 2 --"
|
||||
] `withAttr` (fg red)
|
||||
, vBorder '|'
|
||||
, "stuff things" `withCursor` (Location (0, 0))
|
||||
]
|
||||
|
||||
handleEvent :: Event -> () -> Either ExitCode ()
|
||||
@ -109,19 +143,28 @@ handleEvent e _ =
|
||||
EvKey (KChar 'q') [] -> Left ExitSuccess
|
||||
_ -> Right ()
|
||||
|
||||
runVty :: (MonadIO m) => (a -> Widget) -> (Event -> a -> Either ExitCode a) -> a -> Vty -> m ()
|
||||
runVty draw handleEv state vty = do
|
||||
runVty :: (MonadIO m)
|
||||
=> (a -> Widget)
|
||||
-> (a -> [Location] -> Maybe Location)
|
||||
-> (Event -> a -> Either ExitCode a)
|
||||
-> a
|
||||
-> Vty
|
||||
-> m ()
|
||||
runVty draw chooseCursor handleEv state vty = do
|
||||
e <- liftIO $ do
|
||||
sz <- displayBounds $ outputIface vty
|
||||
update vty $ renderFinal (draw state) sz
|
||||
update vty $ renderFinal (draw state) sz (chooseCursor state)
|
||||
nextEvent vty
|
||||
case handleEv e state of
|
||||
Left status -> liftIO $ do
|
||||
shutdown vty
|
||||
exitWith status
|
||||
Right newState -> runVty draw handleEv newState vty
|
||||
Right newState -> runVty draw chooseCursor handleEv newState vty
|
||||
|
||||
pickCursor :: () -> [Location] -> Maybe Location
|
||||
pickCursor = const $ listToMaybe
|
||||
|
||||
main :: IO ()
|
||||
main = standardIOConfig
|
||||
>>= mkVty
|
||||
>>= runVty drawUI handleEvent ()
|
||||
>>= runVty drawUI pickCursor handleEvent ()
|
||||
|
||||
Loading…
Reference in New Issue
Block a user