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
|
|
|
|
|
2016-10-24 08:42:51 +03:00
|
|
|
data Name = MainUI | Layer | Info deriving (Show, Ord, Eq)
|
|
|
|
|
2016-07-01 05:10:44 +03:00
|
|
|
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
|
2016-10-24 08:42:51 +03:00
|
|
|
, _clicked :: [T.Extent Name]
|
2016-10-26 08:32:36 +03:00
|
|
|
, _lastReportedClick :: Maybe (Name, T.Location)
|
2016-07-01 05:10:44 +03:00
|
|
|
}
|
|
|
|
|
|
|
|
makeLenses ''St
|
|
|
|
|
2016-10-24 08:42:51 +03:00
|
|
|
drawUi :: St -> [Widget Name]
|
2016-07-01 05:10:44 +03:00
|
|
|
drawUi st =
|
2016-10-24 08:42:51 +03:00
|
|
|
[ infoLayer st
|
|
|
|
, draggableLayer st
|
2016-07-01 05:10:44 +03:00
|
|
|
]
|
|
|
|
|
2016-10-24 08:42:51 +03:00
|
|
|
infoLayer :: St -> Widget Name
|
|
|
|
infoLayer st = T.Widget T.Fixed T.Fixed $ do
|
|
|
|
c <- T.getContext
|
|
|
|
let h = c^.T.availHeightL
|
2016-10-26 06:44:22 +03:00
|
|
|
T.render $ translateBy (T.Location (0, h-3)) $ clickable Info $
|
|
|
|
withDefAttr "info" $
|
|
|
|
dragInfo st <=>
|
|
|
|
C.hCenter (str ("Last reported click: " <> show (st^.lastReportedClick)))
|
2016-07-01 05:10:44 +03:00
|
|
|
|
2016-10-24 08:42:51 +03:00
|
|
|
dragInfo :: St -> Widget Name
|
2016-07-01 05:25:16 +03:00
|
|
|
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)"
|
2016-10-26 06:44:22 +03:00
|
|
|
in C.hCenter (str $ show $ st^.clicked) <=> C.hCenter infoStr
|
2016-07-01 05:25:16 +03:00
|
|
|
|
2016-10-24 08:42:51 +03:00
|
|
|
draggableLayer :: St -> Widget Name
|
2016-07-01 05:25:16 +03:00
|
|
|
draggableLayer st =
|
|
|
|
let highlight = case st^.lastDragLoc of
|
|
|
|
LastLocation _ True -> withDefAttr "dragging"
|
|
|
|
_ -> id
|
2016-10-24 08:42:51 +03:00
|
|
|
in reportExtent MainUI $
|
|
|
|
(translateBy (st^.draggableLayerLocation) $
|
|
|
|
reportExtent Layer $
|
2016-07-01 05:25:16 +03:00
|
|
|
highlight $
|
|
|
|
B.border $ str $ "This layer can be dragged by\n" <>
|
|
|
|
"clicking and dragging anywhere\n" <>
|
2016-10-24 08:42:51 +03:00
|
|
|
"on or within its border.") <+> fill ' '
|
2016-07-01 05:10:44 +03:00
|
|
|
|
2016-10-26 06:19:31 +03:00
|
|
|
appEvent :: St -> T.BrickEvent Name e -> T.EventM Name (T.Next St)
|
2016-10-26 08:32:36 +03:00
|
|
|
appEvent st (T.Clicked n _ _ loc) = M.continue $ st & lastReportedClick .~ Just (n, loc)
|
2016-10-26 06:19:31 +03:00
|
|
|
appEvent st (T.VtyEvent (V.EvKey V.KEsc [])) = M.halt st
|
|
|
|
appEvent st (T.VtyEvent ev) = do
|
2016-10-24 08:42:51 +03:00
|
|
|
Just e <- M.lookupExtent Layer
|
|
|
|
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 _ _ _) ->
|
2016-10-24 08:42:51 +03:00
|
|
|
return $ st & lastDragLoc .~ NotDragging
|
2016-10-24 08:52:12 +03:00
|
|
|
& clicked .~ []
|
2016-10-24 08:42:51 +03:00
|
|
|
(V.EvMouseDown c r V.BLeft _) -> do
|
2016-10-24 05:19:16 +03:00
|
|
|
let mouseLoc = T.Location (c, r)
|
2016-10-24 08:42:51 +03:00
|
|
|
st' = case st^.lastDragLoc of
|
|
|
|
NotDragging
|
|
|
|
-- If the mouse button was down in the layer and
|
|
|
|
-- we were not already dragging it, start dragging
|
|
|
|
-- the layer.
|
|
|
|
| M.clickedExtent (c, r) e -> st & lastDragLoc .~ LastLocation mouseLoc True
|
|
|
|
-- If the mouse button was down outside the layer,
|
|
|
|
-- start dragging outside the layer.
|
|
|
|
| otherwise -> st & lastDragLoc .~ LastLocation mouseLoc False
|
|
|
|
-- 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.
|
|
|
|
LastLocation (T.Location (lc, lr)) bound ->
|
|
|
|
let off = T.Location (c-lc, r-lr)
|
|
|
|
in st & lastDragLoc .~ LastLocation mouseLoc bound
|
|
|
|
& draggableLayerLocation %~ if bound then (<> off) else id
|
|
|
|
es <- M.findClickedExtents (c, r)
|
|
|
|
return $ st' & clicked .~ es
|
|
|
|
_ -> return st
|
2016-10-26 06:19:31 +03:00
|
|
|
appEvent st _ = M.continue st
|
2016-07-01 05:10:44 +03:00
|
|
|
|
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-10-26 06:19:31 +03:00
|
|
|
app :: M.App St e Name
|
2016-07-01 05:10:44 +03:00
|
|
|
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.appChooseCursor = M.neverShowCursor
|
|
|
|
}
|
|
|
|
|
|
|
|
main :: IO ()
|
2016-10-26 06:44:22 +03:00
|
|
|
main = void $ M.defaultMain app $ St (T.Location (0, 0)) NotDragging [] Nothing
|