git.iko.soy/reflex-vty
on fa4990f help sign in
reflex-vty/src-bin/example.hs
83 lines 3.0 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE ScopedTypeVariables #-}
8import Control.Monad.IO.Class
9import Control.Monad.Trans.Reader
10import Data.Time
11import Graphics.Vty as V
12import Reflex
13import Reflex.Vty
15data Region = Region
16 { _region_left :: Int
17 , _region_top :: Int
18 , _region_width :: Int
19 , _region_height :: Int
20 }
21 deriving (Show, Read, Eq, Ord)
23regionToDisplayRegion :: Region -> DisplayRegion
24regionToDisplayRegion (Region _ _ w h) = (w, h)
26region :: Region -> (DisplayRegion -> Image) -> [Image]
27region r@(Region left top width height) i =
28 [ within r $ resize width height $ i (width, height)
29 , within r $ wrapString width defAttr $ replicate (width * height) ' '
30 ]
32within :: Region -> Image -> Image
33within (Region left top width height) =
34 translate left top . V.crop width height
36wrapString :: Int -> Attr -> String -> Image
37wrapString maxWidth attrs = vertCat . concatMap (fmap (string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth)) . lines
39box :: Region -> (DisplayRegion -> Image) -> [Image]
40box r@(Region left top width height) i =
41 let hBorder = string mempty $ replicate width '-'
42 vBorder = wrapString 1 mempty $ replicate (height - 2) '|'
43 internal = Region
44 { _region_left = left + 1
45 , _region_top = top + 1
46 , _region_width = width - 2
47 , _region_height = height - 2
48 }
49 in [ within (r { _region_height = 1 }) hBorder
50 , within (Region left (top + 1) 1 (height - 2)) vBorder
51 , within (Region (left + width - 1) (top + 1) 1 (height - 2)) vBorder
52 , within (r { _region_top = top + height - 1 }) hBorder
53 ] ++ region internal i
55guest :: forall t m. VtyApp t m
56guest e = do
57 dr0@(w, h) <- displayRegion
58 dr <- holdDyn dr0 $ fforMaybe e $ \case
59 V.EvResize w h -> Just (w, h)
60 _ -> Nothing
61 let region = fmap (\(w,h) -> Region 0 0 w h) dr
62 region1 = fmap (\(w,h) -> Region (w `div` 5) (h `div` 5) (w `div` 2) (h `div` 2)) dr
63 region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) dr
64 debugRegion = fmap (\(w, _) -> Region 0 0 w 3) dr
65 events <- holdDyn "" $ show <$> e
66 let debugOut = ffor (zipDyn events debugRegion) $ \(ev, r) ->
67 box r $ \(w, _) -> wrapString w mempty ev
69 let shutdown = fforMaybe e $ \case
70 V.EvKey V.KEsc _ -> Just ()
71 _ -> Nothing
72 output = fmap V.picForLayers $
73 current $ ffor ((,,) <$> region1 <*> region2 <*> debugOut) $ \(r1, r2, d) ->
74 let b1 = box r1 (\(w, _) -> wrapString w mempty $ take 500 $ cycle ('\n' : ['a'..'z']))
75 b2 = box r2 (\(w, _) -> wrapString w mempty $ take 500 $ cycle ('\n' : ['a'..'z']))
76 in d ++ b2 ++ b1
77 return $ VtyResult
78 { _vtyResult_picture = output
79 , _vtyResult_shutdown = shutdown
80 }
82main :: IO ()
83main = runVtyApp guest