diff --git a/programs/Main.hs b/programs/Main.hs index 10a39e2..f13dafb 100644 --- a/programs/Main.hs +++ b/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 ()