tart 0.3 → 0.4
raw patch · 23 files changed
+701/−603 lines, 23 filesdep +vty-crossplatformdep ~brickdep ~vty
Dependencies added: vty-crossplatform
Dependency ranges changed: brick, vty
Files
- CHANGELOG.md +6/−0
- LICENSE +1/−1
- README.md +14/−6
- programs/App.hs +1/−2
- programs/Draw.hs +128/−114
- programs/Draw/Line.hs +1/−0
- programs/Events.hs +40/−36
- programs/Events/AskForSaveFilename.hs +16/−14
- programs/Events/AskToSave.hs +9/−9
- programs/Events/BoxStyleSelect.hs +18/−15
- programs/Events/CanvasSizePrompt.hs +21/−22
- programs/Events/CharacterSelect.hs +7/−7
- programs/Events/Common.hs +17/−11
- programs/Events/Main.hs +87/−81
- programs/Events/PaletteEntrySelect.hs +18/−18
- programs/Events/RenameLayer.hs +11/−11
- programs/Events/StyleSelect.hs +16/−14
- programs/Events/TextEntry.hs +22/−17
- programs/Events/ToolSelect.hs +18/−15
- programs/Main.hs +2/−1
- programs/State.hs +238/−194
- programs/Theme.hs +5/−5
- tart.cabal +5/−10
CHANGELOG.md view
@@ -1,4 +1,10 @@ +0.4+---++* Update for brick 2.7.+* Get rid of `libonly` build flag+ 0.3 ---
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2017, Jonathan Daugherty+Copyright (c) 2017-2025, Jonathan Daugherty All rights reserved.
README.md view
@@ -16,6 +16,20 @@  +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 ========
programs/App.hs view
@@ -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 }
programs/Draw.hs view
@@ -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
programs/Draw/Line.hs view
@@ -6,6 +6,7 @@ where import Data.Bits (shiftR)+import Control.Monad (when, forM_) import Control.Monad.State.Lazy import Lens.Micro.Platform
programs/Events.hs view
@@ -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
programs/Events/AskForSaveFilename.hs view
@@ -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 ()
programs/Events/AskToSave.hs view
@@ -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 ()
programs/Events/BoxStyleSelect.hs view
@@ -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
programs/Events/CanvasSizePrompt.hs view
@@ -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 ()
programs/Events/CharacterSelect.hs view
@@ -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 ()
programs/Events/Common.hs view
@@ -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
programs/Events/Main.hs view
@@ -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 ()
programs/Events/PaletteEntrySelect.hs view
@@ -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
programs/Events/RenameLayer.hs view
@@ -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 ()
programs/Events/StyleSelect.hs view
@@ -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
programs/Events/TextEntry.hs view
@@ -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 ()
programs/Events/ToolSelect.hs view
@@ -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
programs/Main.hs view
@@ -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
programs/State.hs view
@@ -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 =
programs/Theme.hs view
@@ -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
tart.cabal view
@@ -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,