diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,10 @@ +0.4 +--- + +* Update for brick 2.7. +* Get rid of `libonly` build flag + 0.3 --- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017, Jonathan Daugherty +Copyright (c) 2017-2025, Jonathan Daugherty All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -16,6 +16,20 @@ ![](screenshots/2.png) +Status +====== + +Expectation management: This is a fun hobby project that I spent time +on when I first created it many years ago. Since then, I have only +done a little bit to keep it working. Since it was (and still is) +mostly intended as a proof of concept, and since I do not use the tool +actively, I have not been putting much energy into maintaining it beyond +keeping it building. While that isn't likely to change, I am happy to +support people who want to contribute to the tool and I may have energy +to fix small things as they are reported. Use at your own risk. If other +tools are more mature or perform better, you are probably better off +using them! + Building ======== @@ -25,17 +39,11 @@ (preferably at least 2.0). Then: ``` -$ cabal update $ git clone https://github.com/jtdaugherty/tart.git $ cd tart $ cabal new-build $ $(find . -name tart -type f) ``` - -By default, `tart` is built as both a library and a command-line tool. -But if you want to use tart only for its Haskell library and avoid the -additional executable dependencies, you can build with the `libonly` -cabal build flag. Features ======== diff --git a/programs/App.hs b/programs/App.hs --- a/programs/App.hs +++ b/programs/App.hs @@ -124,10 +124,9 @@ showCursorNamed LayerNameEditor locs | otherwise -> Nothing , appHandleEvent = handleEvent - , appStartEvent = \s -> do + , appStartEvent = do vty <- getVtyHandle liftIO $ V.setMode (V.outputIface vty) V.Mouse True liftIO $ V.setMode (V.outputIface vty) V.BracketedPaste True - return s , appAttrMap = const theme } diff --git a/programs/Draw.hs b/programs/Draw.hs --- a/programs/Draw.hs +++ b/programs/Draw.hs @@ -17,7 +17,7 @@ import Data.Monoid ((<>)) import Lens.Micro.Platform import Control.Monad.Trans (liftIO) -import Control.Monad (foldM) +import Control.Monad (foldM, void) import qualified Data.Text as T import qualified Graphics.Vty as V import qualified Data.Vector as Vec @@ -29,52 +29,55 @@ import Draw.Line import Draw.Box -undo :: AppState -> EventM Name AppState -undo s = +undo :: EventM Name AppState () +undo = do + s <- get case s^.undoStack of - [] -> return s + [] -> return () (actions:rest) -> do - let go st [] old = return (st, old) - go st (a:as) old = do - (st', old') <- applyAction st a - go st' as (old' <> old) + let go [] old = return old + go (a:as) old = do + old' <- applyAction a + go as (old' <> old) - (finalSt, undoActs) <- go s actions [] - return $ finalSt & undoStack .~ rest - & redoStack %~ (undoActs:) + undoActs <- go actions [] + undoStack .= rest + redoStack %= (undoActs:) -redo :: AppState -> EventM Name AppState -redo s = +redo :: EventM Name AppState () +redo = do + s <- get case s^.redoStack of - [] -> return s + [] -> return () (actions:rest) -> do - let go st [] old = return (st, old) - go st (a:as) old = do - (st', old') <- applyAction st a - go st' as (old' <> old) + let go [] old = return old + go (a:as) old = do + old' <- applyAction a + go as (old' <> old) - (finalSt, undoActs) <- go s actions [] - return $ finalSt & redoStack .~ rest - & undoStack %~ (undoActs:) + undoActs <- go actions [] + redoStack .= rest + undoStack %= (undoActs:) -applyAction :: AppState -> Action -> EventM Name (AppState, [Action]) -applyAction s ClearCanvasDirty = return (s & canvasDirty .~ False, []) -applyAction s (SetPixels idx ps) = do +applyAction :: Action -> EventM Name AppState [Action] +applyAction ClearCanvasDirty = do + canvasDirty .= False + return [] +applyAction (SetPixels idx ps) = do let old' = (\(p, (ch, attr)) -> (p, ch, attr)) <$> ps - (s', old) <- drawMany old' (layerAt idx) (Just idx) s - return (s', old) -applyAction s (InsertLayer c idx ordIdx name) = - return $ insertLayer c idx ordIdx name s -applyAction s (RemoveLayer idx) = - return $ deleteLayer idx s -applyAction s (ChangeLayerName idx newName) = - return $ renameLayer idx newName s -applyAction s (MoveLayerBy idx up) = - return $ moveLayer idx up s -applyAction s (ToggleLayer idx) = - return $ toggleLayer idx s -applyAction s (SelectLayerIndex idx) = - return $ selectLayer idx s + drawMany old' (layerAt idx) (Just idx) +applyAction (InsertLayer c idx ordIdx name) = + insertLayer c idx ordIdx name +applyAction (RemoveLayer idx) = + deleteLayer idx +applyAction (ChangeLayerName idx newName) = + renameLayer idx newName +applyAction (MoveLayerBy idx up) = + moveLayer idx up +applyAction (ToggleLayer idx) = + toggleLayer idx +applyAction (SelectLayerIndex idx) = + selectLayer idx findFgPaletteEntry :: V.Attr -> AppState -> Int findFgPaletteEntry a s = @@ -92,47 +95,46 @@ V.SetTo c -> Just c in maybe 0 id $ Vec.findIndex (== bgc) (s^.palette) -drawWithCurrentTool :: (Int, Int) -> AppState -> EventM Name AppState -drawWithCurrentTool point s = +drawWithCurrentTool :: (Int, Int) -> EventM Name AppState () +drawWithCurrentTool point = do + s <- get case s^.tool of - Freehand -> drawAtPoint point s - Eraser -> eraseAtPoint point (s^.eraserSize) s - Repaint -> repaintAtPoint point (s^.repaintSize) s - Restyle -> restyleAtPoint point (s^.restyleSize) s - FloodFill -> floodFillAtPoint point s - TextString -> return $ beginTextEntry point s + Freehand -> drawAtPoint point + Eraser -> eraseAtPoint point (s^.eraserSize) + Repaint -> repaintAtPoint point (s^.repaintSize) + Restyle -> restyleAtPoint point (s^.restyleSize) + FloodFill -> floodFillAtPoint point + TextString -> modify $ beginTextEntry point Line -> case s^.dragging of - Nothing -> return s + Nothing -> return () Just (n, l0, l1) -> case n of Canvas -> do o <- liftIO $ clearCanvas (s^.drawingOverlay) - (s', _) <- drawLine l0 l1 drawingOverlay Nothing $ - s & drawingOverlay .~ o - return s' - _ -> return s + drawingOverlay .= o + void $ drawLine l0 l1 drawingOverlay Nothing + _ -> return () Box -> do case s^.dragging of - Nothing -> return s + Nothing -> return () Just (n, l0, l1) -> case n of Canvas -> do let bs = snd $ getBoxBorderStyle s o <- liftIO $ clearCanvas (s^.drawingOverlay) - (s', _) <- drawBox bs l0 l1 drawingOverlay Nothing $ - s & drawingOverlay .~ o - return s' - _ -> return s - Eyedropper -> + drawingOverlay .= o + void $ drawBox bs l0 l1 drawingOverlay Nothing + _ -> return () + Eyedropper -> do -- Read the pixel at the canvas location. Set the -- application state's current drawing character and colors -- from it. let (ch, attr) = canvasGetPixel (s^.currentLayer) point - in return $ s & drawCharacter .~ ch - & drawFgPaletteIndex .~ findFgPaletteEntry attr s - & drawBgPaletteIndex .~ findBgPaletteEntry attr s - & drawStyle .~ styleWord (V.attrStyle attr) + drawCharacter .= ch + drawFgPaletteIndex .= findFgPaletteEntry attr s + drawBgPaletteIndex .= findBgPaletteEntry attr s + drawStyle .= styleWord (V.attrStyle attr) styleWord :: V.MaybeDefault V.Style -> V.Style styleWord V.KeepCurrent = 0 @@ -143,12 +145,12 @@ -> Location -> Lens' AppState Canvas -> Maybe Int - -> AppState - -> EventM Name (AppState, [Action]) -drawLine (Location p0) (Location p1) which whichIdx s = + -> EventM Name AppState [Action] +drawLine (Location p0) (Location p1) which whichIdx = do + s <- get let points = plotLine p0 p1 pixels = (, s^.drawCharacter, currentPaletteAttribute s) <$> points - in drawMany pixels which whichIdx s + drawMany pixels which whichIdx truncateText :: (Int, Int) -> [(Char, V.Attr)] -> AppState -> [(Char, V.Attr)] truncateText point t s = @@ -158,8 +160,9 @@ safe = take (maxCol - startCol + 1) t in safe -pasteTextAtPoint :: (Int, Int) -> AppState -> T.Text -> EventM Name AppState -pasteTextAtPoint point s t = do +pasteTextAtPoint :: (Int, Int) -> T.Text -> EventM Name AppState () +pasteTextAtPoint point t = do + s <- get let ls = T.lines t (startCol, startRow) = point pasteWidth = maximum $ T.length <$> ls @@ -171,19 +174,22 @@ pairs = zip [startRow..] ls mkLine line = zip (T.unpack line) $ repeat $ currentPaletteAttribute s - s' <- resizeCanvas s newSize - foldM (\st (row, line) -> drawTextAtPoint (startCol, row) (mkLine line) st) s' pairs + resizeCanvas newSize + mapM_ (\(row, line) -> drawTextAtPoint (startCol, row) (mkLine line)) pairs -drawTextAtPoint :: (Int, Int) -> [(Char, V.Attr)] -> AppState -> EventM Name AppState -drawTextAtPoint point t s = do +drawTextAtPoint :: (Int, Int) -> [(Char, V.Attr)] -> EventM Name AppState () +drawTextAtPoint point t = do + s <- get let (startCol, row) = point pixs = zip ([startCol..]) (truncateText point t s) many = mkEntry <$> pixs mkEntry (col, (ch, attr)) = ((col, row), ch, attr) - withUndo <$> drawMany many currentLayer (Just $ s^.selectedLayerIndex) s + withUndoM $ drawMany many currentLayer (Just $ s^.selectedLayerIndex) -floodFillAtPoint :: (Int, Int) -> AppState -> EventM Name AppState -floodFillAtPoint point s = do +floodFillAtPoint :: (Int, Int) -> EventM Name AppState () +floodFillAtPoint point = do + s <- get + let fillAttr = normalizeAttr fillCh $ currentPaletteAttribute s fillCh = s^.drawCharacter fillPix = (fillCh, fillAttr) @@ -195,44 +201,48 @@ right = (& _1 %~ (min (w-1) . succ)) go :: (Int, Int) - -> (AppState, [((Int, Int), (Char, V.Attr))]) - -> EventM Name (AppState, [((Int, Int), (Char, V.Attr))]) - go p (st, uBuf) = do - let rawPix = canvasGetPixel (st^.currentLayer) p + -> [((Int, Int), (Char, V.Attr))] + -> EventM Name AppState [((Int, Int), (Char, V.Attr))] + go p uBuf = do + curL <- use currentLayer + let rawPix = canvasGetPixel curL p pix = rawPix & _2 %~ normalizeAttr (rawPix^._1) - if | pix == fillPix -> return (st, uBuf) - | pix /= targetPix -> return (st, uBuf) + if | pix == fillPix -> return uBuf + | pix /= targetPix -> return uBuf | otherwise -> do - let old = canvasGetPixel (st^.currentLayer) p - d' <- liftIO $ canvasSetPixel (st^.currentLayer) p fillCh fillAttr - let newSt = st & currentLayer .~ d' & canvasDirty .~ True - go (down p) (newSt, (p, old):uBuf) >>= + let old = canvasGetPixel curL p + d' <- liftIO $ canvasSetPixel curL p fillCh fillAttr + currentLayer .= d' + canvasDirty .= True + go (down p) ((p, old):uBuf) >>= go (up p) >>= go (left p) >>= go (right p) - (finalSt, undoBuf) <- go point (s, []) + undoBuf <- go point [] let prevDirty = s^.canvasDirty newDirty = s^.canvasDirty d = if prevDirty /= newDirty then [ClearCanvasDirty] else [] - return $ pushUndo (d <> [SetPixels (s^.selectedLayerIndex) undoBuf]) finalSt + modify $ pushUndo (d <> [SetPixels (s^.selectedLayerIndex) undoBuf]) -drawAtPoint :: (Int, Int) -> AppState -> EventM Name AppState -drawAtPoint point s = - drawAtPoint' point (s^.drawCharacter) (currentPaletteAttribute s) s +drawAtPoint :: (Int, Int) -> EventM Name AppState () +drawAtPoint point = do + s <- get + drawAtPoint' point (s^.drawCharacter) (currentPaletteAttribute s) -drawAtPoint' :: (Int, Int) -> Char -> V.Attr -> AppState -> EventM Name AppState -drawAtPoint' point ch attr s = do - withUndo <$> drawMany [(point, ch, attr)] currentLayer (Just $ s^.selectedLayerIndex) s +drawAtPoint' :: (Int, Int) -> Char -> V.Attr -> EventM Name AppState () +drawAtPoint' point ch attr = do + s <- get + withUndoM $ drawMany [(point, ch, attr)] currentLayer (Just $ s^.selectedLayerIndex) drawMany :: [((Int, Int), Char, V.Attr)] -> Lens' AppState Canvas -> Maybe Int - -> AppState - -> EventM Name (AppState, [Action]) -drawMany pixels which whichIdx s = do + -> EventM Name AppState [Action] +drawMany pixels which whichIdx = do + s <- get let arr = s^.which old = getOld <$> pixels getOld (oldLoc, _, _) = (oldLoc, canvasGetPixel (s^.which) oldLoc) @@ -241,12 +251,13 @@ newDirty = not $ null pixels newSt = s & which .~ arr' & canvasDirty .~ (prevDirty || newDirty) - return (newSt, catMaybes [ do i <- whichIdx - return $ SetPixels i old - , if prevDirty /= newDirty - then Just ClearCanvasDirty - else Nothing - ]) + put newSt + return (catMaybes [ do i <- whichIdx + return $ SetPixels i old + , if prevDirty /= newDirty + then Just ClearCanvasDirty + else Nothing + ]) makeBoxAboutPoint :: (Int, Int) -> Int -> [(Int, Int)] makeBoxAboutPoint point sz = @@ -260,40 +271,43 @@ ) in addOffset <$> noOffset -eraseAtPoint :: (Int, Int) -> Int -> AppState -> EventM Name AppState -eraseAtPoint point sz s = do +eraseAtPoint :: (Int, Int) -> Int -> EventM Name AppState () +eraseAtPoint point sz = do + s <- get let points = makeBoxAboutPoint point sz pixels = (, ' ', V.defAttr) <$> points - withUndo <$> drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) s + withUndoM $ drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) -repaintAtPoint :: (Int, Int) -> Int -> AppState -> EventM Name AppState -repaintAtPoint point sz s = do +repaintAtPoint :: (Int, Int) -> Int -> EventM Name AppState () +repaintAtPoint point sz = do + s <- get let points = makeBoxAboutPoint point sz attr = currentPaletteAttribute s getPixel p = let old = canvasGetPixel (s^.currentLayer) p in (p, old^._1, attr { V.attrStyle = V.attrStyle $ old^._2 }) pixels = getPixel <$> points - withUndo <$> drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) s + withUndoM $ drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) -restyleAtPoint :: (Int, Int) -> Int -> AppState -> EventM Name AppState -restyleAtPoint point sz s = do +restyleAtPoint :: (Int, Int) -> Int -> EventM Name AppState () +restyleAtPoint point sz = do + s <- get let points = makeBoxAboutPoint point sz attr = currentPaletteAttribute s getPixel p = let old = canvasGetPixel (s^.currentLayer) p in (p, old^._1, (old^._2) { V.attrStyle = V.attrStyle attr }) pixels = getPixel <$> points - withUndo <$> drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) s + withUndoM $ drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) drawBox :: BorderStyle -> Location -> Location -> Lens' AppState Canvas -> Maybe Int - -> AppState - -> EventM Name (AppState, [Action]) -drawBox bs (Location a) (Location b) which whichIdx s = do + -> EventM Name AppState [Action] +drawBox bs (Location a) (Location b) which whichIdx = do + s <- get let attr = currentPaletteAttribute s points = plotBox bs a b pixels = mkPixel <$> points mkPixel (p, ch) = (p, ch, attr) - drawMany pixels which whichIdx s + drawMany pixels which whichIdx diff --git a/programs/Draw/Line.hs b/programs/Draw/Line.hs --- a/programs/Draw/Line.hs +++ b/programs/Draw/Line.hs @@ -6,6 +6,7 @@ where import Data.Bits (shiftR) +import Control.Monad (when, forM_) import Control.Monad.State.Lazy import Lens.Micro.Platform diff --git a/programs/Events.hs b/programs/Events.hs --- a/programs/Events.hs +++ b/programs/Events.hs @@ -22,50 +22,54 @@ import Events.StyleSelect import Events.RenameLayer -handleEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) -handleEvent s (VtyEvent (V.EvResize _ _)) = do - continue =<< updateExtents s -handleEvent s e = do - s' <- updateExtents s +handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleEvent (VtyEvent (V.EvResize _ _)) = do + updateExtents +handleEvent e = do + updateExtents + drg <- use dragging + chan <- use appEventChannel next <- case e of MouseDown n _ _ l -> - case s'^.dragging of + case drg of Nothing -> - return $ Just (e, s' & dragging .~ Just (n, l, l)) + return $ Just (e, dragging .= Just (n, l, l)) Just (n', start, _) | n == n' -> - return $ Just (e, s' & dragging .~ Just (n, start, l)) + return $ Just (e, dragging .= Just (n, start, l)) _ -> - return $ Nothing + return Nothing MouseUp _ _ _ -> do - case s'^.dragging of + case drg of Nothing -> return () Just (n, l0, l1) -> do let ev = DragFinished n l0 l1 - liftIO $ writeBChan (s^.appEventChannel) ev - return $ Just (e, s' & dragging .~ Nothing) + liftIO $ writeBChan chan ev + return $ Just (e, dragging .= Nothing) _ -> - return $ Just (e, s') + return $ Just (e, return ()) case next of - Nothing -> continue s' - Just (ev, st) -> - case currentMode st of - Main -> handleMainEvent st ev - FgPaletteEntrySelect -> handlePaletteEntrySelectEvent st ev - BgPaletteEntrySelect -> handlePaletteEntrySelectEvent st ev - ToolSelect -> handleToolSelectEvent st ev - CharacterSelect -> handleCharacterSelectEvent st ev - CanvasSizePrompt -> handleCanvasSizePromptEvent st ev - AskToSave -> handleAskToSaveEvent st ev - AskForSaveFilename q -> handleAskForSaveFilenameEvent q st ev - TextEntry -> handleTextEntryEvent st ev - BoxStyleSelect -> handleBoxStyleSelectEvent st ev - StyleSelect -> handleStyleSelectEvent st ev - RenameLayer -> handleRenameLayerEvent st ev + Nothing -> return () + Just (ev, act) -> do + act + m <- gets currentMode + case m of + Main -> handleMainEvent ev + FgPaletteEntrySelect -> handlePaletteEntrySelectEvent ev + BgPaletteEntrySelect -> handlePaletteEntrySelectEvent ev + ToolSelect -> handleToolSelectEvent ev + CharacterSelect -> handleCharacterSelectEvent ev + CanvasSizePrompt -> handleCanvasSizePromptEvent ev + AskToSave -> handleAskToSaveEvent ev + AskForSaveFilename q -> handleAskForSaveFilenameEvent q ev + TextEntry -> handleTextEntryEvent ev + BoxStyleSelect -> handleBoxStyleSelectEvent ev + StyleSelect -> handleStyleSelectEvent ev + RenameLayer -> handleRenameLayerEvent ev -updateExtents :: AppState -> EventM Name AppState -updateExtents s = do +updateExtents :: EventM Name AppState () +updateExtents = do fgExtent <- lookupExtent FgSelector bgExtent <- lookupExtent BgSelector tsExtent <- lookupExtent ToolSelector @@ -73,9 +77,9 @@ bsExtent <- lookupExtent BoxStyleSelector ssExtent <- lookupExtent StyleSelector - return $ s & fgPaletteSelectorExtent .~ fgExtent - & bgPaletteSelectorExtent .~ bgExtent - & toolSelectorExtent .~ tsExtent - & canvasExtent .~ cExtent - & boxStyleSelectorExtent .~ bsExtent - & styleSelectorExtent .~ ssExtent + fgPaletteSelectorExtent .= fgExtent + bgPaletteSelectorExtent .= bgExtent + toolSelectorExtent .= tsExtent + canvasExtent .= cExtent + boxStyleSelectorExtent .= bsExtent + styleSelectorExtent .= ssExtent diff --git a/programs/Events/AskForSaveFilename.hs b/programs/Events/AskForSaveFilename.hs --- a/programs/Events/AskForSaveFilename.hs +++ b/programs/Events/AskForSaveFilename.hs @@ -13,19 +13,21 @@ import Types import State -handleAskForSaveFilenameEvent :: Bool -> AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleAskForSaveFilenameEvent isQuitting s (VtyEvent (V.EvKey V.KEsc [])) = - if isQuitting then halt s else continue $ popMode s -handleAskForSaveFilenameEvent isQuitting s (VtyEvent (V.EvKey V.KEnter [])) = do - let [fn] = getEditContents (s^.askToSaveFilenameEdit) +handleAskForSaveFilenameEvent :: Bool -> BrickEvent Name e -> EventM Name AppState () +handleAskForSaveFilenameEvent isQuitting (VtyEvent (V.EvKey V.KEsc [])) = + if isQuitting then halt else modify popMode +handleAskForSaveFilenameEvent isQuitting (VtyEvent (V.EvKey V.KEnter [])) = do + editor <- use askToSaveFilenameEdit + let [fn] = getEditContents editor if T.null fn - then if isQuitting then halt s else continue $ popMode s - else let s' = s & canvasPath .~ Just (T.unpack fn) - in if isQuitting - then quit False (popMode s') - else continue =<< (popMode <$> saveAndContinue s') -handleAskForSaveFilenameEvent _ s (VtyEvent e) = - continue =<< handleEventLensed s askToSaveFilenameEdit handleEditorEvent e -handleAskForSaveFilenameEvent _ s _ = - continue s + then if isQuitting then halt else modify popMode + else do + canvasPath .= Just (T.unpack fn) + if isQuitting + then modify popMode >> quit False + else modify popMode >> saveAndContinue +handleAskForSaveFilenameEvent _ e = do + zoom askToSaveFilenameEdit $ handleEditorEvent e +handleAskForSaveFilenameEvent _ _ = + return () diff --git a/programs/Events/AskToSave.hs b/programs/Events/AskToSave.hs --- a/programs/Events/AskToSave.hs +++ b/programs/Events/AskToSave.hs @@ -10,12 +10,12 @@ import Types import State -handleAskToSaveEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleAskToSaveEvent s (VtyEvent (V.EvKey V.KEsc [])) = - halt s -handleAskToSaveEvent s (VtyEvent (V.EvKey (V.KChar 'n') [])) = - halt s -handleAskToSaveEvent s (VtyEvent (V.EvKey (V.KChar 'y') [])) = - continue $ askForSaveFilename True s -handleAskToSaveEvent s _ = - continue s +handleAskToSaveEvent :: BrickEvent Name e -> EventM Name AppState () +handleAskToSaveEvent (VtyEvent (V.EvKey V.KEsc [])) = + halt +handleAskToSaveEvent (VtyEvent (V.EvKey (V.KChar 'n') [])) = + halt +handleAskToSaveEvent (VtyEvent (V.EvKey (V.KChar 'y') [])) = + askForSaveFilename True +handleAskToSaveEvent _ = + return () diff --git a/programs/Events/BoxStyleSelect.hs b/programs/Events/BoxStyleSelect.hs --- a/programs/Events/BoxStyleSelect.hs +++ b/programs/Events/BoxStyleSelect.hs @@ -12,26 +12,29 @@ import State import Events.Common -handleBoxStyleSelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleBoxStyleSelectEvent s e = do - result <- handleCommonEvent s e +handleBoxStyleSelectEvent :: BrickEvent Name e -> EventM Name AppState () +handleBoxStyleSelectEvent e = do + result <- handleCommonEvent e case result of - Just s' -> continue s' - Nothing -> handleEvent s e + True -> return () + False -> handleEvent e -handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleEvent s (MouseDown (BoxStyleSelectorEntry i) _ _ _) = do - continue $ popMode $ s & boxStyleIndex .~ i -handleEvent s (VtyEvent (V.EvKey (V.KChar c) [])) | isDigit c = do +handleEvent :: BrickEvent Name e -> EventM Name AppState () +handleEvent (MouseDown (BoxStyleSelectorEntry i) _ _ _) = do + boxStyleIndex .= i + modify popMode +handleEvent (VtyEvent (V.EvKey (V.KChar c) [])) | isDigit c = do let i = read [c] case i >= 0 && i < length boxStyles of - True -> continue $ popMode $ s & boxStyleIndex .~ i - False -> continue s -handleEvent s (MouseUp _ _ _) = + True -> do + modify popMode + boxStyleIndex .= i + False -> return () +handleEvent (MouseUp _ _ _) = -- Ignore mouse-up events so we don't go back to Main mode. This -- includes mouse-up events generated in this mode, in addition to -- the mouse-up event generated just after we switch into this mode -- from Main. - continue s -handleEvent s _ = - continue $ popMode s + return () +handleEvent _ = + modify popMode diff --git a/programs/Events/CanvasSizePrompt.hs b/programs/Events/CanvasSizePrompt.hs --- a/programs/Events/CanvasSizePrompt.hs +++ b/programs/Events/CanvasSizePrompt.hs @@ -13,27 +13,26 @@ import Types import State -handleCanvasSizePromptEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleCanvasSizePromptEvent s (MouseDown CanvasSizeWidthEdit _ _ _) = - continue $ s & canvasSizeFocus %~ focusSetCurrent CanvasSizeWidthEdit -handleCanvasSizePromptEvent s (MouseDown CanvasSizeHeightEdit _ _ _) = - continue $ s & canvasSizeFocus %~ focusSetCurrent CanvasSizeHeightEdit -handleCanvasSizePromptEvent s (MouseDown _ _ _ _) = - continue $ popMode s -handleCanvasSizePromptEvent s (VtyEvent (V.EvKey (V.KChar '\t') [])) = - continue $ s & canvasSizeFocus %~ focusNext -handleCanvasSizePromptEvent s (VtyEvent (V.EvKey V.KBackTab [])) = - continue $ s & canvasSizeFocus %~ focusPrev -handleCanvasSizePromptEvent s (VtyEvent (V.EvKey V.KEsc [])) = - continue $ popMode s -handleCanvasSizePromptEvent s (VtyEvent (V.EvKey V.KEnter [])) = - continue =<< tryResizeCanvas s -handleCanvasSizePromptEvent s (VtyEvent e) = - case focusGetCurrent (s^.canvasSizeFocus) of +handleCanvasSizePromptEvent :: BrickEvent Name e -> EventM Name AppState () +handleCanvasSizePromptEvent (MouseDown CanvasSizeWidthEdit _ _ _) = + canvasSizeFocus %= focusSetCurrent CanvasSizeWidthEdit +handleCanvasSizePromptEvent (MouseDown CanvasSizeHeightEdit _ _ _) = + canvasSizeFocus %= focusSetCurrent CanvasSizeHeightEdit +handleCanvasSizePromptEvent (MouseDown _ _ _ _) = + modify popMode +handleCanvasSizePromptEvent (VtyEvent (V.EvKey (V.KChar '\t') [])) = + canvasSizeFocus %= focusNext +handleCanvasSizePromptEvent (VtyEvent (V.EvKey V.KBackTab [])) = + canvasSizeFocus %= focusPrev +handleCanvasSizePromptEvent (VtyEvent (V.EvKey V.KEsc [])) = + modify popMode +handleCanvasSizePromptEvent (VtyEvent (V.EvKey V.KEnter [])) = + tryResizeCanvas +handleCanvasSizePromptEvent e = do + foc <- use canvasSizeFocus + case focusGetCurrent foc of Just CanvasSizeWidthEdit -> - continue =<< handleEventLensed s canvasSizeWidthEdit handleEditorEvent e + zoom canvasSizeWidthEdit $ handleEditorEvent e Just CanvasSizeHeightEdit -> - continue =<< handleEventLensed s canvasSizeHeightEdit handleEditorEvent e - _ -> continue s -handleCanvasSizePromptEvent s _ = - continue s + zoom canvasSizeHeightEdit $ handleEditorEvent e + _ -> return () diff --git a/programs/Events/CharacterSelect.hs b/programs/Events/CharacterSelect.hs --- a/programs/Events/CharacterSelect.hs +++ b/programs/Events/CharacterSelect.hs @@ -9,10 +9,10 @@ import Types import State -handleCharacterSelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleCharacterSelectEvent s (VtyEvent (V.EvKey V.KEsc _)) = - continue $ cancelCharacterSelect s -handleCharacterSelectEvent s (VtyEvent (V.EvKey (V.KChar c) [])) = - continue $ selectCharacter c s -handleCharacterSelectEvent s _ = - continue s +handleCharacterSelectEvent :: BrickEvent Name e -> EventM Name AppState () +handleCharacterSelectEvent (VtyEvent (V.EvKey V.KEsc _)) = + cancelCharacterSelect +handleCharacterSelectEvent (VtyEvent (V.EvKey (V.KChar c) [])) = + selectCharacter c +handleCharacterSelectEvent _ = + return () diff --git a/programs/Events/Common.hs b/programs/Events/Common.hs --- a/programs/Events/Common.hs +++ b/programs/Events/Common.hs @@ -9,17 +9,23 @@ import Types import State -handleCommonEvent :: AppState -> BrickEvent Name e -> EventM Name (Maybe AppState) -handleCommonEvent s (VtyEvent (V.EvKey (V.KChar 't') [])) = do +handleCommonEvent :: BrickEvent Name e -> EventM Name AppState Bool +handleCommonEvent (VtyEvent (V.EvKey (V.KChar 't') [])) = do + s <- get if currentMode s == ToolSelect - then return $ Just $ popMode s - else return $ Just $ beginToolSelect s -handleCommonEvent s (VtyEvent (V.EvKey (V.KChar 'f') [])) = do + then modify popMode + else beginToolSelect + return True +handleCommonEvent (VtyEvent (V.EvKey (V.KChar 'f') [])) = do + s <- get if currentMode s == FgPaletteEntrySelect - then return $ Just $ popMode s - else return $ Just $ beginFgPaletteSelect s -handleCommonEvent s (VtyEvent (V.EvKey (V.KChar 'b') [])) = do + then modify popMode + else beginFgPaletteSelect + return True +handleCommonEvent (VtyEvent (V.EvKey (V.KChar 'b') [])) = do + s <- get if currentMode s == BgPaletteEntrySelect - then return $ Just $ popMode s - else return $ Just $ beginBgPaletteSelect s -handleCommonEvent _ _ = return Nothing + then modify popMode + else beginBgPaletteSelect + return True +handleCommonEvent _ = return False diff --git a/programs/Events/Main.hs b/programs/Events/Main.hs --- a/programs/Events/Main.hs +++ b/programs/Events/Main.hs @@ -5,6 +5,7 @@ where import Brick +import Control.Monad (when, void) import Data.Char (isDigit) import Data.Maybe (isJust) import qualified Graphics.Vty as V @@ -17,88 +18,93 @@ import State import Events.Common -handleMainEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) -handleMainEvent s e = do - result <- handleCommonEvent s e +handleMainEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleMainEvent e = do + result <- handleCommonEvent e case result of - Just s' -> continue s' - Nothing -> do - result2 <- handleAttrEvent s e + True -> return () + False -> do + result2 <- handleAttrEvent e case result2 of - Just s'' -> continue s'' - Nothing -> handleEvent s e + True -> return () + False -> handleEvent e -handleAttrEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Maybe AppState) -handleAttrEvent s (MouseDown FgSelector _ _ _) = - return $ Just $ beginFgPaletteSelect s -handleAttrEvent s (MouseDown BgSelector _ _ _) = - return $ Just $ beginBgPaletteSelect s -handleAttrEvent s (MouseDown StyleSelector _ _ _) = - return $ Just $ beginStyleSelect s -handleAttrEvent _ _ = return Nothing +handleAttrEvent :: BrickEvent Name AppEvent -> EventM Name AppState Bool +handleAttrEvent (MouseDown FgSelector _ _ _) = do + beginFgPaletteSelect + return True +handleAttrEvent (MouseDown BgSelector _ _ _) = do + beginBgPaletteSelect + return True +handleAttrEvent (MouseDown StyleSelector _ _ _) = do + beginStyleSelect + return True +handleAttrEvent _ = + return False -handleEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) -handleEvent s (VtyEvent (V.EvPaste bytes)) = - continue =<< pasteTextAtPoint (0, 0) s (decodeUtf8 bytes) -handleEvent s (AppEvent (DragFinished n _ _)) = - continue =<< handleDragFinished s n -handleEvent s (VtyEvent (V.EvMouseDown _ _ V.BScrollUp _)) = - continue $ increaseToolSize s -handleEvent s (VtyEvent (V.EvMouseDown _ _ V.BScrollDown _)) = - continue $ decreaseToolSize s -handleEvent s (MouseDown _ V.BScrollUp _ _) = - continue $ increaseToolSize s -handleEvent s (MouseDown _ V.BScrollDown _ _) = - continue $ decreaseToolSize s -handleEvent s (MouseDown Canvas _ _ (Location l)) = - continue =<< drawWithCurrentTool l s -handleEvent s (MouseDown n _ _ _) = - continue =<< case n of - LayerName -> return $ beginLayerRename s - DeleteLayer -> return $ deleteSelectedLayer s - MoveLayerUp -> return $ moveCurrentLayerUp s - MoveLayerDown -> return $ moveCurrentLayerDown s - ResizeCanvas -> return $ beginCanvasSizePrompt s - ToggleLayerVisible -> return $ toggleCurrentLayer s - ToolSelector -> return $ beginToolSelect s - IncreaseToolSize -> return $ increaseToolSize s - DecreaseToolSize -> return $ decreaseToolSize s - BoxStyleSelector -> return $ beginBoxStyleSelect s - SelectLayer idx -> return $ fst $ selectLayer idx s - AddLayer -> addLayer s - CharSelector -> return $ whenTool s charTools beginCharacterSelect - _ -> return s -handleEvent s (VtyEvent (V.EvKey (V.KChar 'q') [])) = - quit True s -handleEvent s (VtyEvent e) = - continue =<< case e of - _ | isStyleKey e -> return $ toggleStyleFromKey e s - (EvKey (KChar 'l') [MCtrl]) -> return $ toggleLayerList s - (EvKey (KChar 'w') []) -> return $ canvasMoveDown s - (EvKey (KChar 's') []) -> return $ canvasMoveUp s - (EvKey (KChar 'a') []) -> return $ canvasMoveLeft s - (EvKey (KChar 'd') []) -> return $ canvasMoveRight s - (EvKey (KChar 'y') []) -> return $ beginStyleSelect s - (EvKey (KChar 'v') []) -> return $ beginCanvasSizePrompt s - (EvKey (KChar 's') [MCtrl]) -> return $ askForSaveFilename False s - (EvKey (KChar 'r') [MCtrl]) -> return $ beginLayerRename s - (EvKey (KChar 'x') [MCtrl]) -> return $ deleteSelectedLayer s - (EvKey (KChar 'n') [MCtrl]) -> return $ selectNextLayer s - (EvKey (KChar 'p') [MCtrl]) -> return $ selectPrevLayer s - (EvKey (KChar 'u') [MCtrl]) -> return $ moveCurrentLayerUp s - (EvKey (KChar 'd') [MCtrl]) -> return $ moveCurrentLayerDown s - (EvKey (KChar 'v') [MCtrl]) -> return $ toggleCurrentLayer s - (EvKey (KChar 'C') []) -> return $ recenterCanvas s - (EvKey (KChar '>') []) -> return $ increaseToolSize s - (EvKey (KChar '<') []) -> return $ decreaseToolSize s - (EvKey KEsc []) | isJust (s^.dragging) -> return $ cancelDragging s - (EvKey (KChar c) []) | isDigit c -> return $ setToolByChar c s - (EvKey (KChar 'c') []) -> return $ whenTool s charTools - beginCharacterSelect - (EvKey (KChar '+') []) -> increaseCanvasSize s - (EvKey (KChar '-') []) -> decreaseCanvasSize s - (EvKey (KChar 'a') [MCtrl]) -> addLayer s - (EvKey (KChar 'u') []) -> undo s - (EvKey (KChar 'r') []) -> redo s - _ -> return s -handleEvent s _ = continue s +handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleEvent (VtyEvent (V.EvPaste bytes)) = + pasteTextAtPoint (0, 0) (decodeUtf8 bytes) +handleEvent (AppEvent (DragFinished n _ _)) = + handleDragFinished n +handleEvent (VtyEvent (V.EvMouseDown _ _ V.BScrollUp _)) = + increaseToolSize +handleEvent (VtyEvent (V.EvMouseDown _ _ V.BScrollDown _)) = + decreaseToolSize +handleEvent (MouseDown _ V.BScrollUp _ _) = + increaseToolSize +handleEvent (MouseDown _ V.BScrollDown _ _) = + decreaseToolSize +handleEvent (MouseDown Canvas _ _ (Location l)) = + drawWithCurrentTool l +handleEvent (MouseDown n _ _ _) = + case n of + LayerName -> beginLayerRename + DeleteLayer -> deleteSelectedLayer + MoveLayerUp -> moveCurrentLayerUp + MoveLayerDown -> moveCurrentLayerDown + ResizeCanvas -> beginCanvasSizePrompt + ToggleLayerVisible -> toggleCurrentLayer + ToolSelector -> beginToolSelect + IncreaseToolSize -> increaseToolSize + DecreaseToolSize -> decreaseToolSize + BoxStyleSelector -> beginBoxStyleSelect + SelectLayer idx -> void $ selectLayer idx + AddLayer -> addLayer + CharSelector -> whenTool charTools beginCharacterSelect + _ -> return () +handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = + quit True +handleEvent (VtyEvent e) = + case e of + _ | isStyleKey e -> toggleStyleFromKey e + (EvKey (KChar 'l') [MCtrl]) -> toggleLayerList + (EvKey (KChar 'w') []) -> canvasMoveDown + (EvKey (KChar 's') []) -> canvasMoveUp + (EvKey (KChar 'a') []) -> canvasMoveLeft + (EvKey (KChar 'd') []) -> canvasMoveRight + (EvKey (KChar 'y') []) -> beginStyleSelect + (EvKey (KChar 'v') []) -> beginCanvasSizePrompt + (EvKey (KChar 's') [MCtrl]) -> askForSaveFilename False + (EvKey (KChar 'r') [MCtrl]) -> beginLayerRename + (EvKey (KChar 'x') [MCtrl]) -> deleteSelectedLayer + (EvKey (KChar 'n') [MCtrl]) -> selectNextLayer + (EvKey (KChar 'p') [MCtrl]) -> selectPrevLayer + (EvKey (KChar 'u') [MCtrl]) -> moveCurrentLayerUp + (EvKey (KChar 'd') [MCtrl]) -> moveCurrentLayerDown + (EvKey (KChar 'v') [MCtrl]) -> toggleCurrentLayer + (EvKey (KChar 'C') []) -> recenterCanvas + (EvKey (KChar '>') []) -> increaseToolSize + (EvKey (KChar '<') []) -> decreaseToolSize + (EvKey KEsc []) -> do + drg <- use dragging + when (isJust drg) cancelDragging + (EvKey (KChar c) []) | isDigit c -> setToolByChar c + (EvKey (KChar 'c') []) -> whenTool charTools beginCharacterSelect + (EvKey (KChar '+') []) -> increaseCanvasSize + (EvKey (KChar '-') []) -> decreaseCanvasSize + (EvKey (KChar 'a') [MCtrl]) -> addLayer + (EvKey (KChar 'u') []) -> undo + (EvKey (KChar 'r') []) -> redo + _ -> return () +handleEvent _ = return () diff --git a/programs/Events/PaletteEntrySelect.hs b/programs/Events/PaletteEntrySelect.hs --- a/programs/Events/PaletteEntrySelect.hs +++ b/programs/Events/PaletteEntrySelect.hs @@ -10,27 +10,27 @@ import Events.Common -handlePaletteEntrySelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handlePaletteEntrySelectEvent s e = do - result <- handleCommonEvent s e +handlePaletteEntrySelectEvent :: BrickEvent Name e -> EventM Name AppState () +handlePaletteEntrySelectEvent e = do + result <- handleCommonEvent e case result of - Just s' -> continue s' - Nothing -> handleEvent s e + True -> return () + False -> handleEvent e -handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleEvent s (MouseDown FgSelector _ _ _) = do - continue $ beginFgPaletteSelect s -handleEvent s (MouseDown BgSelector _ _ _) = do - continue $ beginBgPaletteSelect s -handleEvent s (MouseDown (FgPaletteEntry idx) _ _ _) = do - continue $ setFgPaletteIndex s idx -handleEvent s (MouseDown (BgPaletteEntry idx) _ _ _) = do - continue $ setBgPaletteIndex s idx -handleEvent s (MouseUp _ _ _) = +handleEvent :: BrickEvent Name e -> EventM Name AppState () +handleEvent (MouseDown FgSelector _ _ _) = do + beginFgPaletteSelect +handleEvent (MouseDown BgSelector _ _ _) = do + beginBgPaletteSelect +handleEvent (MouseDown (FgPaletteEntry idx) _ _ _) = do + setFgPaletteIndex idx +handleEvent (MouseDown (BgPaletteEntry idx) _ _ _) = do + setBgPaletteIndex idx +handleEvent (MouseUp _ _ _) = -- Ignore mouse-up events so we don't go back to Main mode. This -- includes mouse-up events generated in this mode, in addition to -- the mouse-up event generated just after we switch into this mode -- from Main. - continue s -handleEvent s _ = - continue $ popMode s + return () +handleEvent _ = + modify popMode diff --git a/programs/Events/RenameLayer.hs b/programs/Events/RenameLayer.hs --- a/programs/Events/RenameLayer.hs +++ b/programs/Events/RenameLayer.hs @@ -12,14 +12,14 @@ import Types import State -handleRenameLayerEvent :: AppState - -> BrickEvent Name AppEvent - -> EventM Name (Next AppState) -handleRenameLayerEvent s (VtyEvent (V.EvKey V.KEsc [])) = - continue $ popMode s -handleRenameLayerEvent s (VtyEvent (V.EvKey V.KEnter [])) = - continue $ renameCurrentLayer (T.concat $ getEditContents $ s^.layerNameEditor) s -handleRenameLayerEvent s (VtyEvent e) = - continue =<< handleEventLensed s layerNameEditor handleEditorEvent e -handleRenameLayerEvent s _ = - continue s +handleRenameLayerEvent :: BrickEvent Name AppEvent + -> EventM Name AppState () +handleRenameLayerEvent (VtyEvent (V.EvKey V.KEsc [])) = + modify popMode +handleRenameLayerEvent (VtyEvent (V.EvKey V.KEnter [])) = do + ed <- use layerNameEditor + renameCurrentLayer (T.concat $ getEditContents ed) +handleRenameLayerEvent e = + zoom layerNameEditor $ handleEditorEvent e +handleRenameLayerEvent _ = + return () diff --git a/programs/Events/StyleSelect.hs b/programs/Events/StyleSelect.hs --- a/programs/Events/StyleSelect.hs +++ b/programs/Events/StyleSelect.hs @@ -10,23 +10,25 @@ import State import Events.Common -handleStyleSelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleStyleSelectEvent s e = do - result <- handleCommonEvent s e +handleStyleSelectEvent :: BrickEvent Name e -> EventM Name AppState () +handleStyleSelectEvent e = do + result <- handleCommonEvent e case result of - Just s' -> continue s' - Nothing -> handleEvent s e + True -> return () + False -> handleEvent e -handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleEvent s (VtyEvent e) | isStyleKey e = - continue $ popMode $ toggleStyleFromKey e s -handleEvent s (MouseDown (StyleSelectorEntry sty) _ _ _) = do - continue $ popMode $ s & drawStyle %~ toggleStyle sty -handleEvent s (MouseUp _ _ _) = +handleEvent :: BrickEvent Name e -> EventM Name AppState () +handleEvent (VtyEvent e) | isStyleKey e = do + toggleStyleFromKey e + modify popMode +handleEvent (MouseDown (StyleSelectorEntry sty) _ _ _) = do + drawStyle %= toggleStyle sty + modify popMode +handleEvent (MouseUp _ _ _) = -- Ignore mouse-up events so we don't go back to Main mode. This -- includes mouse-up events generated in this mode, in addition to -- the mouse-up event generated just after we switch into this mode -- from Main. - continue s -handleEvent s _ = - continue $ popMode s + return () +handleEvent _ = + modify popMode diff --git a/programs/Events/TextEntry.hs b/programs/Events/TextEntry.hs --- a/programs/Events/TextEntry.hs +++ b/programs/Events/TextEntry.hs @@ -13,26 +13,31 @@ import Draw import Events.Main -handleTextEntryEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) -handleTextEntryEvent s e = do - result <- handleAttrEvent s e +handleTextEntryEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleTextEntryEvent e = do + result <- handleAttrEvent e case result of - Just s' -> continue s' - Nothing -> handleEvent s e + True -> return () + False -> handleEvent e -handleEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) -handleEvent s (VtyEvent (V.EvKey V.KEnter [])) = do +handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleEvent (VtyEvent (V.EvKey V.KEnter [])) = do -- Commit the text to the drawing and return to main mode - continue =<< drawTextAtPoint (s^.textEntryStart) (s^.textEntered) (popMode s) -handleEvent s (VtyEvent (V.EvKey V.KBS [])) = do - continue $ s & textEntered %~ (\t -> if null t then t else init t) -handleEvent s (VtyEvent (V.EvKey V.KEsc [])) = + s <- get + modify popMode + drawTextAtPoint (s^.textEntryStart) (s^.textEntered) +handleEvent (VtyEvent (V.EvKey V.KBS [])) = do + textEntered %= (\t -> if null t then t else init t) +handleEvent (VtyEvent (V.EvKey V.KEsc [])) = -- Cancel - continue $ popMode s -handleEvent s (VtyEvent (V.EvKey (V.KChar c) [])) | c /= '\t' = do + modify popMode +handleEvent (VtyEvent (V.EvKey (V.KChar c) [])) | c /= '\t' = do -- Enter character - let s' = s & textEntered %~ (<> [(c, currentPaletteAttribute s)]) - continue $ s' & textEntered .~ truncateText (s'^.textEntryStart) (s'^.textEntered) s' -handleEvent s _ = + s <- get + textEntered %= (<> [(c, currentPaletteAttribute s)]) + start <- use textEntryStart + ent <- use textEntered + textEntered .= truncateText start ent s +handleEvent _ = -- Ignore everything else - continue s + return () diff --git a/programs/Events/ToolSelect.hs b/programs/Events/ToolSelect.hs --- a/programs/Events/ToolSelect.hs +++ b/programs/Events/ToolSelect.hs @@ -11,26 +11,29 @@ import State import Events.Common -handleToolSelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleToolSelectEvent s e = do - result <- handleCommonEvent s e +handleToolSelectEvent :: BrickEvent Name e -> EventM Name AppState () +handleToolSelectEvent e = do + result <- handleCommonEvent e case result of - Just s' -> continue s' - Nothing -> handleEvent s e + True -> return () + False -> handleEvent e -handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) -handleEvent s (MouseDown (ToolSelectorEntry t) _ _ _) = do - continue $ popMode $ setTool s t -handleEvent s (VtyEvent (V.EvKey (V.KChar c) [])) | isDigit c = do +handleEvent :: BrickEvent Name e -> EventM Name AppState () +handleEvent (MouseDown (ToolSelectorEntry t) _ _ _) = do + setTool t + modify popMode +handleEvent (VtyEvent (V.EvKey (V.KChar c) [])) | isDigit c = do let idx = read [c] case filter ((== idx) . snd) tools of - [(t, _)] -> continue $ popMode $ setTool s t - _ -> continue s -handleEvent s (MouseUp _ _ _) = + [(t, _)] -> do + setTool t + modify popMode + _ -> return () +handleEvent (MouseUp _ _ _) = -- Ignore mouse-up events so we don't go back to Main mode. This -- includes mouse-up events generated in this mode, in addition to -- the mouse-up event generated just after we switch into this mode -- from Main. - continue s -handleEvent s _ = - continue $ popMode s + return () +handleEvent _ = + modify popMode diff --git a/programs/Main.hs b/programs/Main.hs --- a/programs/Main.hs +++ b/programs/Main.hs @@ -5,6 +5,7 @@ import Brick import Brick.BChan (newBChan) import qualified Graphics.Vty as V +import qualified Graphics.Vty.CrossPlatform as V import System.Environment (getArgs, getProgName) import System.Exit (exitFailure, exitSuccess) import System.Console.GetOpt @@ -111,7 +112,7 @@ _ -> return Nothing chan <- newBChan 10 - let mkVty = V.mkVty =<< V.standardIOConfig + let mkVty = V.mkVty V.defaultConfig initialVty <- mkVty (void . customMain initialVty mkVty (Just chan) application) =<< mkInitialState chan c diff --git a/programs/State.hs b/programs/State.hs --- a/programs/State.hs +++ b/programs/State.hs @@ -49,7 +49,7 @@ , increaseRestyleSize , decreaseRestyleSize , pushUndo - , withUndo + , withUndoM , toggleStyleFromKey , isStyleKey , styleBindings @@ -82,6 +82,7 @@ import qualified Control.Exception as E import Data.Monoid ((<>)) import qualified Graphics.Vty as V +import qualified Graphics.Vty.CrossPlatform as V import qualified Data.Vector as Vec import qualified Data.Text as T import qualified Data.Map as M @@ -134,13 +135,12 @@ isJust $ lookup c styleBindings isStyleKey _ = False -toggleStyleFromKey :: V.Event -> AppState -> AppState -toggleStyleFromKey e s = - if isStyleKey e - then let V.EvKey (V.KChar c) _ = e - Just (sty, _) = lookup c styleBindings - in s & drawStyle %~ toggleStyle sty - else s +toggleStyleFromKey :: V.Event -> EventM Name AppState () +toggleStyleFromKey e = + when (isStyleKey e) $ do + let V.EvKey (V.KChar c) _ = e + Just (sty, _) = lookup c styleBindings + drawStyle %= toggleStyle sty boxStyles :: [(T.Text, BorderStyle)] boxStyles = @@ -152,23 +152,25 @@ getBoxBorderStyle :: AppState -> (T.Text, BorderStyle) getBoxBorderStyle s = boxStyles !! (s^.boxStyleIndex) -increaseToolSize :: AppState -> AppState -increaseToolSize s = +increaseToolSize :: EventM Name AppState () +increaseToolSize = do + s <- get let f = case s^.tool of Repaint -> increaseRepaintSize Restyle -> increaseRestyleSize Eraser -> increaseEraserSize _ -> id - in f s + modify f -decreaseToolSize :: AppState -> AppState -decreaseToolSize s = +decreaseToolSize :: EventM Name AppState () +decreaseToolSize = do + s <- get let f = case s^.tool of Repaint -> decreaseRepaintSize Restyle -> decreaseRestyleSize Eraser -> decreaseEraserSize _ -> id - in f s + modify f toolSize :: AppState -> Maybe Int toolSize s = @@ -196,6 +198,11 @@ decreaseRestyleSize :: AppState -> AppState decreaseRestyleSize = (& restyleSize %~ (max 1 . pred)) +withUndoM :: EventM Name AppState [Action] -> EventM Name AppState () +withUndoM act = do + as <- act + modify $ pushUndo as + withUndo :: (AppState, [Action]) -> AppState withUndo (s, as) = pushUndo as s @@ -204,54 +211,62 @@ pushUndo l s = s & undoStack %~ (l:) & redoStack .~ [] -beginLayerRename :: AppState -> AppState -beginLayerRename s = +beginLayerRename :: EventM Name AppState () +beginLayerRename = do + s <- get let z = textZipper [line] (Just 1) line = s^.layerInfoFor(s^.selectedLayerIndex).layerName - in pushMode RenameLayer $ - s & layerNameEditor.editContentsL .~ gotoEOL z + layerNameEditor.editContentsL .= gotoEOL z + modify $ pushMode RenameLayer -toggleCurrentLayer :: AppState -> AppState -toggleCurrentLayer s = - withUndo $ toggleLayer (s^.selectedLayerIndex) s +toggleCurrentLayer :: EventM Name AppState () +toggleCurrentLayer = do + idx <- use selectedLayerIndex + withUndoM $ toggleLayer idx -toggleLayer :: Int -> AppState -> (AppState, [Action]) -toggleLayer idx s = - ( s & layerInfoFor(idx).layerVisible %~ not - , [ToggleLayer idx] - ) +toggleLayer :: Int -> EventM Name AppState [Action] +toggleLayer idx = do + layerInfoFor(idx).layerVisible %= not + return [ToggleLayer idx] -renameCurrentLayer :: T.Text -> AppState -> AppState -renameCurrentLayer name s = - withUndo $ renameLayer (s^.selectedLayerIndex) name s +renameCurrentLayer :: T.Text -> EventM Name AppState () +renameCurrentLayer name = do + idx <- use selectedLayerIndex + withUndoM $ renameLayer idx name -renameLayer :: Int -> T.Text -> AppState -> (AppState, [Action]) -renameLayer idx newName s = +renameLayer :: Int -> T.Text -> EventM Name AppState [Action] +renameLayer idx newName = do + s <- get let oldName = s^.layerInfoFor(idx).layerName act = ChangeLayerName idx oldName - in if T.null newName - then (s, []) + if T.null newName + then return [] else if newName == oldName - then (popMode s, []) - else (popMode $ - s & layerInfoFor(idx).layerName .~ newName - & canvasDirty .~ True - , [act]) + then do + modify popMode >> return [] + else do + modify popMode + layerInfoFor(idx).layerName .= newName + canvasDirty .= True + return [act] -moveCurrentLayerDown :: AppState -> AppState -moveCurrentLayerDown s = - withUndo $ moveLayer (s^.selectedLayerIndex) False s +moveCurrentLayerDown :: EventM Name AppState () +moveCurrentLayerDown = do + idx <- use selectedLayerIndex + withUndoM $ moveLayer idx False -moveCurrentLayerUp :: AppState -> AppState -moveCurrentLayerUp s = - withUndo $ moveLayer (s^.selectedLayerIndex) True s +moveCurrentLayerUp :: EventM Name AppState () +moveCurrentLayerUp = do + idx <- use selectedLayerIndex + withUndoM $ moveLayer idx True -moveLayer :: Int -> Bool -> AppState -> (AppState, [Action]) -moveLayer idx up s = +moveLayer :: Int -> Bool -> EventM Name AppState [Action] +moveLayer idx up = do + s <- get if up && idx == (head $ s^.layerOrder) - then (s, []) + then return [] else if (not up) && idx == (last $ s^.layerOrder) - then (s, []) + then return [] else let Just orderIndex = elemIndex idx $ s^.layerOrder newIndex = if up then orderIndex - 1 else orderIndex + 1 @@ -260,44 +275,54 @@ [idx] <> drop newIndex dropped act = MoveLayerBy idx (not up) - in (s & canvasDirty .~ True & layerOrder .~ newOrder, [act]) + in do + canvasDirty .= True + layerOrder .= newOrder + return [act] -selectNextLayer :: AppState -> AppState -selectNextLayer s = +selectNextLayer :: EventM Name AppState () +selectNextLayer = do + s <- get -- Find the selected layer in the layer ordering. let Just selIndex = elemIndex (s^.selectedLayerIndex) (s^.layerOrder) -- Then select the next layer, if any. newSel = if selIndex == length (s^.layerOrder) - 1 then s^.selectedLayerIndex else (s^.layerOrder) !! (selIndex + 1) - in s & selectedLayerIndex .~ newSel + selectedLayerIndex .= newSel -selectPrevLayer :: AppState -> AppState -selectPrevLayer s = +selectPrevLayer :: EventM Name AppState () +selectPrevLayer = do + s <- get -- Find the selected layer in the layer ordering. let Just selIndex = elemIndex (s^.selectedLayerIndex) (s^.layerOrder) -- Then select the previous layer, if any. newSel = if selIndex == 0 then s^.selectedLayerIndex else (s^.layerOrder) !! (selIndex - 1) - in s & selectedLayerIndex .~ newSel + selectedLayerIndex .= newSel -selectLayer :: Int -> AppState -> (AppState, [Action]) -selectLayer idx s = - (s & selectedLayerIndex .~ idx, [SelectLayerIndex $ s^.selectedLayerIndex]) +selectLayer :: Int -> EventM Name AppState [Action] +selectLayer idx = do + oldIdx <- use selectedLayerIndex + selectedLayerIndex .= idx + return [SelectLayerIndex oldIdx] -cancelDragging :: AppState -> AppState -cancelDragging s = - s & dragging .~ Nothing +cancelDragging :: EventM Name AppState () +cancelDragging = + dragging .= Nothing -deleteSelectedLayer :: AppState -> AppState -deleteSelectedLayer s = - withUndo $ deleteLayer (s^.selectedLayerIndex) s +deleteSelectedLayer :: EventM Name AppState () +deleteSelectedLayer = do + idx <- use selectedLayerIndex + withUndoM $ deleteLayer idx -deleteLayer :: Int -> AppState -> (AppState, [Action]) -deleteLayer idx s - | M.size (s^.layers) == 1 = (s, []) - | otherwise = +deleteLayer :: Int -> EventM Name AppState [Action] +deleteLayer idx = do + s <- get + if M.size (s^.layers) == 1 + then return [] + else do let Just orderIndex = elemIndex idx (s^.layerOrder) Just selOrderIndex = elemIndex (s^.selectedLayerIndex) (s^.layerOrder) newSelIndex = if selOrderIndex == orderIndex @@ -320,20 +345,21 @@ orderIndex (_layerName $ fromJust $ s^.layerInfo.at idx) - in (-- Change the selected index - s & selectedLayerIndex .~ newSelIndex - -- Remove the layer from the layer map, fix indices - & layers %~ fixNameKeys - -- Reassign all higher indices in name map, ordering list, - -- layer map - & layerOrder .~ newOrder - -- Remove the layer from the layer visibility map, fix - -- indices - & layerInfo %~ fixNameKeys - , [act]) + -- Change the selected index + selectedLayerIndex .= newSelIndex + -- Remove the layer from the layer map, fix indices + layers %= fixNameKeys + -- Reassign all higher indices in name map, ordering list, + -- layer map + layerOrder .= newOrder + -- Remove the layer from the layer visibility map, fix + -- indices + layerInfo %= fixNameKeys + return [act] -insertLayer :: Canvas -> Int -> Int -> T.Text -> AppState -> (AppState, [Action]) -insertLayer c newIdx orderIndex name s = +insertLayer :: Canvas -> Int -> Int -> T.Text -> EventM Name AppState [Action] +insertLayer c newIdx orderIndex name = do + s <- get let newOrderNoInsert = (\i -> if i >= newIdx then i + 1 else i) <$> s^.layerOrder newOrder = take orderIndex newOrderNoInsert <> [newIdx] <> @@ -347,33 +373,33 @@ removeAct = RemoveLayer newIdx selAct = SelectLayerIndex (s^.selectedLayerIndex) - in ( - s & selectedLayerIndex .~ (length (s^.layerOrder)) - & layers %~ (M.insert newIdx c . fixNameKeys) - & layerOrder .~ newOrder - & layerInfo %~ (M.insert newIdx (LayerInfo name True) . fixNameKeys) - , [removeAct, selAct]) + selectedLayerIndex .= (length (s^.layerOrder)) + layers %= (M.insert newIdx c . fixNameKeys) + layerOrder .= newOrder + layerInfo %= (M.insert newIdx (LayerInfo name True) . fixNameKeys) + return [removeAct, selAct] -quit :: Bool -> AppState -> EventM Name (Next AppState) -quit ask s = do +quit :: Bool -> EventM Name AppState () +quit ask = do + s <- get case (s^.canvasDirty) of True -> case s^.canvasPath of Nothing -> case ask of - True -> continue $ askToSave s - False -> halt s + True -> modify askToSave + False -> halt Just p -> if ask - then continue $ askToSave s + then modify askToSave else do result <- liftIO $ E.try $ saveToDisk s p case result of - Left (e::E.SomeException) -> - continue $ askForSaveFilename True $ - s & saveError .~ (Just $ T.pack $ show e) - Right () -> halt s - False -> halt s + Left (e::E.SomeException) -> do + saveError .= (Just $ T.pack $ show e) + askForSaveFilename True + Right () -> halt + False -> halt saveToDisk :: AppState -> FilePath -> IO () saveToDisk s p = do @@ -381,13 +407,14 @@ writeCanvasFiles p ls (s^.layerOrder) (_layerName <$> snd <$> (sortOn fst $ M.toList $ s^.layerInfo)) -saveAndContinue :: AppState -> EventM Name AppState -saveAndContinue s = do +saveAndContinue :: EventM Name AppState () +saveAndContinue = do + s <- get case s^.canvasPath of - Nothing -> return s + Nothing -> return () Just p -> do liftIO $ saveToDisk s p - return $ s & canvasDirty .~ False + put $ s & canvasDirty .~ False writeCanvasFiles :: FilePath -> [Canvas] -> [Int] -> [T.Text] -> IO () writeCanvasFiles path cs order names = do @@ -400,42 +427,46 @@ askToSave s = pushMode AskToSave s -askForSaveFilename :: Bool -> AppState -> AppState -askForSaveFilename shouldQuit s = - pushMode (AskForSaveFilename shouldQuit) $ - s & askToSaveFilenameEdit .~ applyEdit gotoEOL (editor AskToSaveFilenameEdit (Just 1) $ +askForSaveFilename :: Bool -> EventM Name AppState () +askForSaveFilename shouldQuit = do + s <- get + askToSaveFilenameEdit .= applyEdit gotoEOL (editor AskToSaveFilenameEdit (Just 1) $ T.pack $ maybe "" id $ s^.canvasPath) + modify $ pushMode (AskForSaveFilename shouldQuit) beginTextEntry :: (Int, Int) -> AppState -> AppState beginTextEntry start s = pushMode TextEntry $ s & textEntryStart .~ start & textEntered .~ mempty -handleDragFinished :: AppState -> Name -> EventM Name AppState -handleDragFinished s n = +handleDragFinished :: Name -> EventM Name AppState () +handleDragFinished n = do + s <- get case n of Canvas -> case s^.tool `elem` [Box, Line] of True -> do (c', old) <- liftIO $ merge (s^.currentLayer) (s^.drawingOverlay) o' <- liftIO $ clearCanvas (s^.drawingOverlay) - return $ pushUndo [SetPixels (s^.selectedLayerIndex) old] $ + put $ pushUndo [SetPixels (s^.selectedLayerIndex) old] $ s & currentLayer .~ c' & drawingOverlay .~ o' - False -> return s - _ -> return s + False -> return () + _ -> return () -increaseCanvasSize :: AppState -> EventM Name AppState -increaseCanvasSize s = - resizeCanvas s $ - (s^.appCanvasSize) & _1 %~ (\w -> if w == 1 then 4 else w + 4) - & _2 %~ (\h -> if h == 1 then 2 else h + 2) +increaseCanvasSize :: EventM Name AppState () +increaseCanvasSize = do + sz <- use appCanvasSize + resizeCanvas $ + sz & _1 %~ (\w -> if w == 1 then 4 else w + 4) + & _2 %~ (\h -> if h == 1 then 2 else h + 2) -decreaseCanvasSize :: AppState -> EventM Name AppState -decreaseCanvasSize s = - resizeCanvas s $ - (s^.appCanvasSize) & _1 %~ (max 1 . (subtract 4)) - & _2 %~ (max 1 . (subtract 2)) +decreaseCanvasSize :: EventM Name AppState () +decreaseCanvasSize = do + sz <- use appCanvasSize + resizeCanvas $ + sz & _1 %~ (max 1 . (subtract 4)) + & _2 %~ (max 1 . (subtract 2)) pushMode :: Mode -> AppState -> AppState pushMode m s = @@ -449,35 +480,37 @@ popMode s = s & modes %~ (\m -> if length m == 1 then m else tail m) & dragging .~ Nothing -beginCanvasSizePrompt :: AppState -> AppState -beginCanvasSizePrompt s = - pushMode CanvasSizePrompt $ - s & canvasSizeFocus .~ focusRing [ CanvasSizeWidthEdit - , CanvasSizeHeightEdit - ] - & canvasSizeWidthEdit .~ applyEdit gotoEOL (editor CanvasSizeWidthEdit (Just 1) $ - T.pack $ show $ fst $ s^.appCanvasSize) - & canvasSizeHeightEdit .~ applyEdit gotoEOL (editor CanvasSizeHeightEdit (Just 1) $ - T.pack $ show $ snd $ s^.appCanvasSize) +beginCanvasSizePrompt :: EventM Name AppState () +beginCanvasSizePrompt = do + s <- get + canvasSizeFocus .= focusRing [ CanvasSizeWidthEdit + , CanvasSizeHeightEdit + ] + canvasSizeWidthEdit .= applyEdit gotoEOL (editor CanvasSizeWidthEdit (Just 1) $ + T.pack $ show $ fst $ s^.appCanvasSize) + canvasSizeHeightEdit .= applyEdit gotoEOL (editor CanvasSizeHeightEdit (Just 1) $ + T.pack $ show $ snd $ s^.appCanvasSize) + modify $ pushMode CanvasSizePrompt -canvasMoveDown :: AppState -> AppState -canvasMoveDown s = - s & canvasOffset._2 %~ pred +canvasMoveDown :: EventM Name AppState () +canvasMoveDown = + canvasOffset._2 %= pred -canvasMoveUp :: AppState -> AppState -canvasMoveUp s = - s & canvasOffset._2 %~ succ +canvasMoveUp :: EventM Name AppState () +canvasMoveUp = + canvasOffset._2 %= succ -canvasMoveLeft :: AppState -> AppState -canvasMoveLeft s = - s & canvasOffset._1 %~ pred +canvasMoveLeft :: EventM Name AppState () +canvasMoveLeft = + canvasOffset._1 %= pred -canvasMoveRight :: AppState -> AppState -canvasMoveRight s = - s & canvasOffset._1 %~ succ +canvasMoveRight :: EventM Name AppState () +canvasMoveRight = + canvasOffset._1 %= succ -tryResizeCanvas :: AppState -> EventM Name AppState -tryResizeCanvas s = do +tryResizeCanvas :: EventM Name AppState () +tryResizeCanvas = do + s <- get -- If the canvas size prompt inputs are valid, resize the canvas and -- exit prompt mode. Otherwise stay in prompt mode. let [wStr] = getEditContents $ s^.canvasSizeWidthEdit @@ -486,55 +519,66 @@ <*> (readMaybe $ T.unpack hStr) case result of Just (w, h) | w > 0 && h > 0 -> do - resizeCanvas (popMode s) (w, h) - _ -> return s + modify popMode + resizeCanvas (w, h) + _ -> return () -beginToolSelect :: AppState -> AppState -beginToolSelect = pushMode ToolSelect +beginToolSelect :: EventM Name AppState () +beginToolSelect = modify $ pushMode ToolSelect -beginBoxStyleSelect :: AppState -> AppState -beginBoxStyleSelect = pushMode BoxStyleSelect +beginBoxStyleSelect :: EventM Name AppState () +beginBoxStyleSelect = modify $ pushMode BoxStyleSelect -beginStyleSelect :: AppState -> AppState -beginStyleSelect = pushMode StyleSelect +beginStyleSelect :: EventM Name AppState () +beginStyleSelect = modify $ pushMode StyleSelect -beginFgPaletteSelect :: AppState -> AppState -beginFgPaletteSelect = pushMode FgPaletteEntrySelect +beginFgPaletteSelect :: EventM Name AppState () +beginFgPaletteSelect = modify $ pushMode FgPaletteEntrySelect -beginBgPaletteSelect :: AppState -> AppState -beginBgPaletteSelect = pushMode BgPaletteEntrySelect +beginBgPaletteSelect :: EventM Name AppState () +beginBgPaletteSelect = modify $ pushMode BgPaletteEntrySelect -setTool :: AppState -> Tool -> AppState -setTool s t = s & tool .~ t +setTool :: Tool -> EventM Name AppState () +setTool t = tool .= t -setToolByChar :: Char -> AppState -> AppState -setToolByChar c s = +setToolByChar :: Char -> EventM Name AppState () +setToolByChar c = let idx = read [c] in case filter ((== idx) . snd) tools of - [(t, _)] -> popMode $ setTool s t - _ -> s + [(t, _)] -> do + setTool t + modify popMode + _ -> return () -whenTool :: AppState -> [Tool] -> (AppState -> AppState) -> AppState -whenTool s ts f = if s^.tool `elem` ts then f s else s +whenTool :: [Tool] -> EventM Name AppState () -> EventM Name AppState () +whenTool ts act = do + t <- use tool + when (t `elem` ts) act -setFgPaletteIndex :: AppState -> Int -> AppState -setFgPaletteIndex s i = popMode $ s & drawFgPaletteIndex .~ i +setFgPaletteIndex :: Int -> EventM Name AppState () +setFgPaletteIndex i = do + drawFgPaletteIndex .= i + modify popMode -setBgPaletteIndex :: AppState -> Int -> AppState -setBgPaletteIndex s i = popMode $ s & drawBgPaletteIndex .~ i +setBgPaletteIndex :: Int -> EventM Name AppState () +setBgPaletteIndex i = do + drawBgPaletteIndex .= i + modify popMode -beginCharacterSelect :: AppState -> AppState -beginCharacterSelect = pushMode CharacterSelect +beginCharacterSelect :: EventM Name AppState () +beginCharacterSelect = modify $ pushMode CharacterSelect -cancelCharacterSelect :: AppState -> AppState -cancelCharacterSelect = popMode +cancelCharacterSelect :: EventM Name AppState () +cancelCharacterSelect = modify popMode -selectCharacter :: Char -> AppState -> AppState -selectCharacter c s = popMode $ s & drawCharacter .~ c +selectCharacter :: Char -> EventM Name AppState () +selectCharacter c = do + drawCharacter .= c + modify popMode checkForMouseSupport :: IO () checkForMouseSupport = do - vty <- V.mkVty =<< V.standardIOConfig + vty <- V.mkVty V.defaultConfig when (not $ V.supportsMode (V.outputIface vty) V.Mouse) $ do putStrLn "Error: this terminal does not support mouse interaction" @@ -542,35 +586,35 @@ V.shutdown vty -resizeCanvas :: AppState -> (Int, Int) -> EventM n AppState -resizeCanvas s newSz = do +resizeCanvas :: (Int, Int) -> EventM n AppState () +resizeCanvas newSz = do + s <- get ls <- liftIO $ forM (M.toList $ s^.layers) $ \(idx, l) -> (idx,) <$> resizeFrom l newSz o <- liftIO $ resizeFrom (s^.drawingOverlay) newSz - return $ - recenterCanvas $ - s & layers .~ (M.fromList ls) - & drawingOverlay .~ o - & appCanvasSize .~ newSz - & canvasDirty .~ (s^.appCanvasSize /= newSz) + layers .= (M.fromList ls) + drawingOverlay .= o + appCanvasSize .= newSz + canvasDirty .= (s^.appCanvasSize /= newSz) + recenterCanvas -recenterCanvas :: AppState -> AppState -recenterCanvas s = - let sz = s^.appCanvasSize - in s & canvasOffset .~ (Location $ sz & each %~ (`div` 2)) +recenterCanvas :: EventM n AppState () +recenterCanvas = do + sz <- use appCanvasSize + canvasOffset .= (Location $ sz & each %~ (`div` 2)) -toggleLayerList :: AppState -> AppState -toggleLayerList s = - s & layerListVisible %~ not +toggleLayerList :: EventM Name AppState () +toggleLayerList = + layerListVisible %= not -addLayer :: AppState -> EventM Name AppState -addLayer s = do +addLayer :: EventM Name AppState () +addLayer = do + s <- get let newLayerName = T.pack $ "layer " <> (show $ idx + 1) idx = M.size $ s^.layers - orderIndex = length (s^.layerOrder) c <- liftIO $ newCanvas (s^.appCanvasSize) - return $ withUndo $ insertLayer c idx orderIndex newLayerName s + withUndoM $ insertLayer c idx 0 newLayerName currentPaletteAttribute :: AppState -> V.Attr currentPaletteAttribute s = diff --git a/programs/Theme.hs b/programs/Theme.hs --- a/programs/Theme.hs +++ b/programs/Theme.hs @@ -15,19 +15,19 @@ import Graphics.Vty keybindingAttr :: AttrName -keybindingAttr = "keybinding" +keybindingAttr = attrName "keybinding" selectedLayerAttr :: AttrName -selectedLayerAttr = "selectedLayer" +selectedLayerAttr = attrName "selectedLayer" clickableAttr :: AttrName -clickableAttr = "clickable" +clickableAttr = attrName "clickable" headerAttr :: AttrName -headerAttr = "header" +headerAttr = attrName "header" errorAttr :: AttrName -errorAttr = "error" +errorAttr = attrName "error" theme :: AttrMap theme = attrMap defAttr diff --git a/tart.cabal b/tart.cabal --- a/tart.cabal +++ b/tart.cabal @@ -1,12 +1,12 @@ name: tart -version: 0.3 +version: 0.4 synopsis: Terminal Art description: A program to make ASCII art license: BSD3 license-file: LICENSE author: Jonathan Daugherty maintainer: cygnus@foobox.com -copyright: 2017 Jonathan Daugherty +copyright: 2025 Jonathan Daugherty category: Graphics build-type: Simple extra-source-files: CHANGELOG.md @@ -19,10 +19,6 @@ type: git location: git://github.com/jtdaugherty/tart.git -Flag libonly - Description: Build only the library, not the tool - Default: False - library ghc-options: -Wall hs-source-dirs: src @@ -37,7 +33,7 @@ build-depends: base >=4.9 && < 5, array, binary, - vty >= 5.17.1, + vty, microlens-platform, bytestring, mtl, @@ -45,8 +41,6 @@ text executable tart - if flag(libonly) - Buildable: False ghc-options: -threaded -Wall hs-source-dirs: programs main-is: Main.hs @@ -84,8 +78,9 @@ Draw.Box default-language: Haskell2010 build-depends: base >=4.9 && < 5, - brick >= 0.52 && < 0.58, + brick >= 2.7 && < 2.8, vty, + vty-crossplatform, vector, microlens-platform, microlens-th,