2016-07-01 05:10:44 +03:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Main where
|
|
|
|
|
|
|
|
import Lens.Micro ((^.), (&), (%~), (.~))
|
|
|
|
import Lens.Micro.TH (makeLenses)
|
|
|
|
import Control.Monad (void)
|
|
|
|
import Data.Monoid ((<>))
|
|
|
|
import qualified Graphics.Vty as V
|
|
|
|
|
|
|
|
import qualified Brick.Types as T
|
2016-07-01 05:25:16 +03:00
|
|
|
import Brick.AttrMap
|
|
|
|
import Brick.Util
|
|
|
|
import Brick.Types (Widget)
|
2016-07-01 05:10:44 +03:00
|
|
|
import qualified Brick.Main as M
|
|
|
|
import qualified Brick.Widgets.Border as B
|
|
|
|
import qualified Brick.Widgets.Center as C
|
|
|
|
import Brick.Widgets.Core
|
|
|
|
|
|
|
|
data DragState =
|
|
|
|
NotDragging
|
|
|
|
| LastLocation T.Location Bool
|
|
|
|
deriving (Show)
|
|
|
|
|
|
|
|
data St =
|
2016-07-01 05:25:16 +03:00
|
|
|
St { _draggableLayerLocation :: T.Location
|
2016-07-01 05:10:44 +03:00
|
|
|
, _lastDragLoc :: DragState
|
|
|
|
}
|
|
|
|
|
|
|
|
makeLenses ''St
|
|
|
|
|
|
|
|
drawUi :: St -> [Widget ()]
|
|
|
|
drawUi st =
|
2016-07-01 05:25:16 +03:00
|
|
|
[ draggableLayer st
|
|
|
|
, infoLayer st
|
2016-07-01 05:10:44 +03:00
|
|
|
]
|
|
|
|
|
2016-07-01 05:25:16 +03:00
|
|
|
infoLayer :: St -> Widget ()
|
|
|
|
infoLayer st = fill ' ' <=> dragInfo st
|
2016-07-01 05:10:44 +03:00
|
|
|
|
2016-07-01 05:25:16 +03:00
|
|
|
dragInfo :: St -> Widget ()
|
|
|
|
dragInfo st =
|
|
|
|
let infoStr = case st^.lastDragLoc of
|
|
|
|
NotDragging -> str "Not dragging"
|
|
|
|
LastLocation (T.Location (c,r)) b ->
|
|
|
|
str $ "Dragging at column " <> show c <> ", row " <> show r <> " " <>
|
|
|
|
if b
|
|
|
|
then "(dragging layer)"
|
|
|
|
else "(dragging outside of layer)"
|
|
|
|
in withDefAttr "info" $ C.hCenter infoStr
|
|
|
|
|
|
|
|
draggableLayer :: St -> Widget ()
|
|
|
|
draggableLayer st =
|
|
|
|
let highlight = case st^.lastDragLoc of
|
|
|
|
LastLocation _ True -> withDefAttr "dragging"
|
|
|
|
_ -> id
|
|
|
|
in translateBy (st^.draggableLayerLocation) $
|
|
|
|
reportExtent () $
|
|
|
|
highlight $
|
|
|
|
B.border $ str $ "This layer can be dragged by\n" <>
|
|
|
|
"clicking and dragging anywhere\n" <>
|
|
|
|
"on or within its border."
|
2016-07-01 05:10:44 +03:00
|
|
|
|
|
|
|
appEvent :: St -> V.Event -> T.EventM () (T.Next St)
|
|
|
|
appEvent st (V.EvKey V.KEsc []) = M.halt st
|
|
|
|
appEvent st ev = do
|
|
|
|
Just e <- M.lookupExtent ()
|
2016-07-01 05:25:16 +03:00
|
|
|
M.continue $ case ev of
|
2016-07-01 05:28:27 +03:00
|
|
|
-- If the mouse button was released, stop dragging.
|
2016-07-01 05:10:44 +03:00
|
|
|
(V.EvMouseUp _ _ _) ->
|
|
|
|
st & lastDragLoc .~ NotDragging
|
|
|
|
(V.EvMouseDown c r V.BLeft _) ->
|
2016-10-24 05:19:16 +03:00
|
|
|
let mouseLoc = T.Location (c, r)
|
2016-07-01 05:10:44 +03:00
|
|
|
in case st^.lastDragLoc of
|
|
|
|
NotDragging
|
2016-07-01 05:28:27 +03:00
|
|
|
-- If the mouse button was down in the layer and
|
|
|
|
-- we were not already dragging it, start dragging
|
|
|
|
-- the layer.
|
2016-10-24 05:24:57 +03:00
|
|
|
| M.clickedExtent (c, r) e -> st & lastDragLoc .~ LastLocation mouseLoc True
|
2016-07-01 05:28:27 +03:00
|
|
|
-- If the mouse button was down outside the layer,
|
|
|
|
-- start dragging outside the layer.
|
2016-07-01 05:10:44 +03:00
|
|
|
| otherwise -> st & lastDragLoc .~ LastLocation mouseLoc False
|
2016-07-01 05:28:27 +03:00
|
|
|
-- If the mouse button was down and we were already
|
|
|
|
-- dragging, update the drag location. If the drag
|
|
|
|
-- was a continuation of a layer movement, update the
|
|
|
|
-- layer location.
|
2016-07-01 05:10:44 +03:00
|
|
|
LastLocation (T.Location (lc, lr)) bound ->
|
2016-10-24 05:19:16 +03:00
|
|
|
let off = T.Location (c-lc, r-lr)
|
2016-07-01 05:10:44 +03:00
|
|
|
in st & lastDragLoc .~ LastLocation mouseLoc bound
|
2016-07-01 05:25:16 +03:00
|
|
|
& draggableLayerLocation %~ if bound then (<> off) else id
|
2016-07-01 05:10:44 +03:00
|
|
|
_ -> st
|
|
|
|
|
2016-07-01 05:25:16 +03:00
|
|
|
aMap :: AttrMap
|
|
|
|
aMap = attrMap V.defAttr
|
|
|
|
[ ("info", V.white `on` V.magenta)
|
|
|
|
, ("dragging", V.black `on` V.yellow)
|
|
|
|
]
|
|
|
|
|
2016-07-01 05:10:44 +03:00
|
|
|
app :: M.App St V.Event ()
|
|
|
|
app =
|
|
|
|
M.App { M.appDraw = drawUi
|
|
|
|
, M.appStartEvent = return
|
|
|
|
, M.appHandleEvent = appEvent
|
2016-07-01 05:25:16 +03:00
|
|
|
, M.appAttrMap = const aMap
|
2016-07-01 05:10:44 +03:00
|
|
|
, M.appLiftVtyEvent = id
|
|
|
|
, M.appChooseCursor = M.neverShowCursor
|
|
|
|
}
|
|
|
|
|
|
|
|
main :: IO ()
|
2016-07-01 05:25:16 +03:00
|
|
|
main = void $ M.defaultMain app $ St (T.Location (0, 0)) NotDragging
|