03ec51a · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

on develop help sign in

Haddocks and a slight refactor

03ec51aAli Abrar8 years ago

src/Reflex/Vty/Widget.hs+36−14

compare with develop

unifiedsplit

@@ -32,7 +32,6 @@ module Reflex.Vty.Widget

32 , tellShutdown

33 , splitV

34 , splitVDrag

35− , fractionSz

36 , box

35 , box

37 , text

36 , text

38 , display

37 , display

@@ -91,6 +90,7 @@ instance (Reflex t) => Monoid (VtyWidgetOut t) where

91 mempty = VtyWidgetOut mempty mempty

90 mempty = VtyWidgetOut mempty mempty

92 mappend wo wo' = wo <> wo'

91 mappend wo wo' = wo <> wo'

93+-- | A widget that can read its context and produce image output

94newtype VtyWidget t m a = VtyWidget

95 { unVtyWidget :: WriterT (VtyWidgetOut t) (ReaderT (VtyWidgetCtx t) m) a

96 }

@@ -136,42 +136,50 @@ mainWidget child = do

136 vty <- getDefaultVty

137 mainWidgetWithHandle vty child

138

139+-- | A class for things that know their own display size dimensions

139class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where

140class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where

140 displaySize :: m (Dynamic t (Int, Int))

141 displaySize :: m (Dynamic t (Int, Int))

141

142

142instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where

143instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where

143 displaySize = VtyWidget . lift $ asks _vtyWidgetCtx_size

144 displaySize = VtyWidget . lift $ asks _vtyWidgetCtx_size

144

145

146+-- | Retrieve the display width (columns)

145displayWidth :: HasDisplaySize t m => m (Dynamic t Int)

147displayWidth :: HasDisplaySize t m => m (Dynamic t Int)

146displayWidth = fmap fst <$> displaySize

148displayWidth = fmap fst <$> displaySize

147

149

150+-- | Retrieve the display height (rows)

148displayHeight :: HasDisplaySize t m => m (Dynamic t Int)

151displayHeight :: HasDisplaySize t m => m (Dynamic t Int)

149displayHeight = fmap snd <$> displaySize

152displayHeight = fmap snd <$> displaySize

150

153

154+-- | A class for things that can receive vty events as input

151class HasVtyInput t m | m -> t where

155class HasVtyInput t m | m -> t where

152 input :: m (Event t VtyEvent)

156 input :: m (Event t VtyEvent)

153

157

154instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where

158instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where

155 input = VtyWidget . lift $ asks _vtyWidgetCtx_input

159 input = VtyWidget . lift $ asks _vtyWidgetCtx_input

156

160

161+-- | A class for things that can dynamically gain and lose focus

157class HasFocus t m | m -> t where

162class HasFocus t m | m -> t where

158 focus :: m (Dynamic t Bool)

163 focus :: m (Dynamic t Bool)

159

164

160instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where

165instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where

161 focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus

166 focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus

162

167

168+-- | A class for widgets that can produce images to draw to the display

163class (Reflex t, Monad m) => ImageWriter t m | m -> t where

169class (Reflex t, Monad m) => ImageWriter t m | m -> t where

164 tellImages :: Behavior t [Image] -> m ()

170 tellImages :: Behavior t [Image] -> m ()

165

171

166instance (Reflex t, Monad m) => ImageWriter t (VtyWidget t m) where

172instance (Reflex t, Monad m) => ImageWriter t (VtyWidget t m) where

167 tellImages imgs = VtyWidget $ tell (mempty { _vtyWidgetOut_images = imgs })

173 tellImages imgs = VtyWidget $ tell (mempty { _vtyWidgetOut_images = imgs })

168

174

175+-- | A class for things that can shut down the vty application

169class (Reflex t, Monad m) => Shutdown t m where

176class (Reflex t, Monad m) => Shutdown t m where

170 tellShutdown :: Event t () -> m ()

177 tellShutdown :: Event t () -> m ()

171

178

172instance (Reflex t, Monad m) => Shutdown t (VtyWidget t m) where

179instance (Reflex t, Monad m) => Shutdown t (VtyWidget t m) where

173 tellShutdown sd = VtyWidget $ tell (mempty { _vtyWidgetOut_shutdown = sd })

180 tellShutdown sd = VtyWidget $ tell (mempty { _vtyWidgetOut_shutdown = sd })

174

181

182+-- | A chunk of the display area

175data Region = Region

183data Region = Region

176 { _region_left :: Int

184 { _region_left :: Int

177 , _region_top :: Int

185 , _region_top :: Int

@@ -180,9 +188,17 @@ data Region = Region

180 }

188 }

181 deriving (Show, Read, Eq, Ord)

189 deriving (Show, Read, Eq, Ord)

182

190

191+-- | The width and height of a 'Region'

183regionSize :: Region -> (Int, Int)

192regionSize :: Region -> (Int, Int)

184regionSize (Region _ _ w h) = (w, h)

193regionSize (Region _ _ w h) = (w, h)

185

194

195+-- | Low-level widget combinator that runs a child 'VtyWidget' within

196+-- a given region and context. This widget filters and modifies the input

197+-- that the child widget receives such that:

198+-- * unfocused widgets receive no key events

199+-- * mouse inputs outside the region are ignored

200+-- * mouse inputs inside the region have their coordinates translated such

201+-- that (0,0) is the top-left corner of the region

186pane

202pane

187 :: (Reflex t, Monad m)

203 :: (Reflex t, Monad m)

188 => Dynamic t Region -- ^ Region into which we should draw the widget (in coordinates relative to our own)

204 => Dynamic t Region -- ^ Region into which we should draw the widget (in coordinates relative to our own)

@@ -207,11 +223,6 @@ pane reg foc child = VtyWidget $ do

207 tell wo'

223 tell wo'

208 return result

224 return result

209 where

225 where

210− -- Filters input such that:

211− -- * unfocused widgets receive no key events

212− -- * mouse inputs outside the region are ignored

213− -- * mouse inputs inside the region have their coordinates translated

214− -- such that (0,0) is the top-left corner of the region

215 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent

226 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent

216 filterInput (Region l t w h) focused e = case e of

227 filterInput (Region l t w h) focused e = case e of

217 V.EvKey _ _ | not focused -> Nothing

228 V.EvKey _ _ | not focused -> Nothing

@@ -227,6 +238,7 @@ pane reg foc child = VtyWidget $ do

227 | otherwise =

238 | otherwise =

228 Just (con (x - l) (y - t))

239 Just (con (x - l) (y - t))

229

240

241+-- | Information about a drag operation

230data Drag = Drag

242data Drag = Drag

231 { _drag_from :: (Int, Int) -- ^ Where the drag began

243 { _drag_from :: (Int, Int) -- ^ Where the drag began

232 , _drag_to :: (Int, Int) -- ^ Where the mouse currently is

244 , _drag_to :: (Int, Int) -- ^ Where the mouse currently is

@@ -236,14 +248,16 @@ data Drag = Drag

236 }

248 }

237 deriving (Eq, Ord, Show)

249 deriving (Eq, Ord, Show)

238

250

251+-- | Converts raw vty mouse drag events into an event stream of 'Drag's

239drag

252drag

240 :: (Reflex t, MonadFix m, MonadHold t m)

253 :: (Reflex t, MonadFix m, MonadHold t m)

241 => V.Button

254 => V.Button

242 -> VtyWidget t m (Event t Drag)

255 -> VtyWidget t m (Event t Drag)

243drag btn = do

256drag btn = do

244 inp <- input

257 inp <- input

245− let f :: Drag -> V.Event -> Maybe Drag

258+ let f :: Maybe Drag -> V.Event -> Maybe Drag

259+ f Nothing = const Nothing

246− f (Drag from _ _ mods end) = \case

260+ f (Just (Drag from _ _ mods end)) = \case

247 V.EvMouseDown x y btn' mods'

261 V.EvMouseDown x y btn' mods'

248 | end -> Just $ Drag (x,y) (x,y) btn' mods' False

262 | end -> Just $ Drag (x,y) (x,y) btn' mods' False

249 | btn == btn' -> Just $ Drag from (x,y) btn mods' False

263 | btn == btn' -> Just $ Drag from (x,y) btn mods' False

@@ -258,10 +272,10 @@ drag btn = do

258 | otherwise -> Just $ Drag from (x,y) btn mods True

272 | otherwise -> Just $ Drag from (x,y) btn mods True

259 _ -> Nothing

273 _ -> Nothing

260 rec let newDrag = attachWithMaybe f (current dragD) inp

274 rec let newDrag = attachWithMaybe f (current dragD) inp

261− dragD <- holdDyn (Drag (0,0) (0,0) btn [] True) -- gross, but ok because it'll never be produced.

275+ dragD <- holdDyn Nothing $ Just <$> newDrag

262− newDrag

263− return (updated dragD)

276+ return (fmapMaybe id $ updated dragD)

264

277

278+-- | Mouse down events for a particular mouse button

265mouseDown

279mouseDown

266 :: (Reflex t, Monad m)

280 :: (Reflex t, Monad m)

267 => V.Button

281 => V.Button

@@ -342,9 +356,7 @@ fill c = do

342hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()

356hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()

343hRule boxStyle = fill (_boxStyle_s boxStyle)

357hRule boxStyle = fill (_boxStyle_s boxStyle)

344

358

345−fractionSz :: Double -> Int -> Int

359+-- | Transform the images produces by a widget

346−fractionSz x h = round (fromIntegral h * x)

347−

348modifyImages

360modifyImages

349 :: (Reflex t, MonadHold t m, MonadFix m)

361 :: (Reflex t, MonadHold t m, MonadFix m)

350 => Behavior t ([Image] -> [Image])

362 => Behavior t ([Image] -> [Image])

@@ -353,6 +365,8 @@ modifyImages

353modifyImages f (VtyWidget w) = VtyWidget $ flip censor w $ \wo ->

365modifyImages f (VtyWidget w) = VtyWidget $ flip censor w $ \wo ->

354 wo { _vtyWidgetOut_images = f <*> (_vtyWidgetOut_images wo) }

366 wo { _vtyWidgetOut_images = f <*> (_vtyWidgetOut_images wo) }

355

367

368+-- | Defines a set of symbols to use to draw the outlines of boxes

369+-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character

356data BoxStyle = BoxStyle

370data BoxStyle = BoxStyle

357 { _boxStyle_nw :: Char

371 { _boxStyle_nw :: Char

358 , _boxStyle_n :: Char

372 , _boxStyle_n :: Char

@@ -367,21 +381,28 @@ data BoxStyle = BoxStyle

367instance Default BoxStyle where

381instance Default BoxStyle where

368 def = singleBoxStyle

382 def = singleBoxStyle

369

383

384+-- | A box style that uses hyphens and pipe characters. Doesn't handle

385+-- corners very well.

370hyphenBoxStyle :: BoxStyle

386hyphenBoxStyle :: BoxStyle

371hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'

387hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'

372

388

389+-- | A single line box style

373singleBoxStyle :: BoxStyle

390singleBoxStyle :: BoxStyle

374singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'

391singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'

375

392

393+-- | A thick single line box style

376thickBoxStyle :: BoxStyle

394thickBoxStyle :: BoxStyle

377thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'

395thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'

378

396

397+-- | A double line box style

379doubleBoxStyle :: BoxStyle

398doubleBoxStyle :: BoxStyle

380doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'

399doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'

381

400

401+-- | A single line box style with rounded corners

382roundedBoxStyle :: BoxStyle

402roundedBoxStyle :: BoxStyle

383roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'

403roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'

384

404

405+-- | Draws a box in the provided style and a child widget inside of that box

385box :: (Monad m, Reflex t)

406box :: (Monad m, Reflex t)

386 => BoxStyle

407 => BoxStyle

387 -> VtyWidget t m a

408 -> VtyWidget t m a

@@ -420,6 +441,7 @@ box style child = do

420 ]

441 ]

421 in sides ++ if width > 1 && height > 1 then corners else []

442 in sides ++ if width > 1 && height > 1 then corners else []

422

443

444+-- | Renders text, wrapped to the container width

423text

445text

424 :: (Reflex t, Monad m)

446 :: (Reflex t, Monad m)

425 => Behavior t Text

447 => Behavior t Text