diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,23 @@ +0.2 +--- + +`tart` tool changes: + * When inserting a new layer, also select it and make that selection + part of the undo action. + * Attribute style selector now uses more descriptive labels for style + options. + +Tart library changes: + * Added a dependency on the `text` package. + * The type of some fields was changed from `String` to + `Text` (`TartFile` / `tartFileCanvasNames`, `TartFileDataV1` + / `tartFileDataV1CanvasNames`, `TartFileDataV2` / + `tartFileDataV2CanvasNames`) + * Added `Tart.Canvas.canvasFromString` and changed `canvasFromText` to + take a `Text` input rather than a `String`. + * Relaxed bounds on `vty`. + 0.1.2 ----- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,7 +10,9 @@ ``` Tart is a program that provides an image-editor-like interface to -creating ASCII art - in the terminal, with your mouse! +creating ASCII art - in the terminal, with your mouse! This program is +written using my purely-functional terminal user interface toolkit, +[Brick](https://github.com/jtdaugherty/brick). ![](screenshots/2.png) diff --git a/programs/App.hs b/programs/App.hs --- a/programs/App.hs +++ b/programs/App.hs @@ -7,10 +7,12 @@ ) where +import Control.Monad.Trans (liftIO) import qualified Graphics.Vty as V import qualified Data.Vector as Vec import qualified Data.Map as M import Lens.Micro.Platform +import qualified Data.Text as T import Brick import Brick.BChan (BChan) @@ -48,13 +50,13 @@ initialCanvasSize = (40, 17) mkInitialState :: BChan AppEvent - -> Maybe (Maybe FilePath, [Canvas], [Int], [String]) + -> Maybe (Maybe FilePath, [Canvas], [Int], [T.Text]) -> IO AppState mkInitialState chan mc = do (cs, order, names, fp) <- case mc of Nothing -> do c <- newCanvas initialCanvasSize - return ([c], [0], ["default"], Nothing) + return ([c], [0], [T.pack "default"], Nothing) Just (fp, cs, order, names) -> return (cs, order, names, fp) @@ -124,8 +126,8 @@ , appHandleEvent = handleEvent , appStartEvent = \s -> do vty <- getVtyHandle - V.setMode (V.outputIface vty) V.Mouse True - V.setMode (V.outputIface vty) V.BracketedPaste True + 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 @@ -73,6 +73,8 @@ return $ moveLayer idx up s applyAction s (ToggleLayer idx) = return $ toggleLayer idx s +applyAction s (SelectLayerIndex idx) = + return $ selectLayer idx s findFgPaletteEntry :: V.Attr -> AppState -> Int findFgPaletteEntry a s = diff --git a/programs/Events/Main.hs b/programs/Events/Main.hs --- a/programs/Events/Main.hs +++ b/programs/Events/Main.hs @@ -8,6 +8,7 @@ import Data.Char (isDigit) import Data.Maybe (isJust) import qualified Graphics.Vty as V +import Graphics.Vty (Event(..), Key(..), Modifier(..)) import Lens.Micro.Platform import Data.Text.Encoding (decodeUtf8) @@ -63,7 +64,7 @@ IncreaseToolSize -> return $ increaseToolSize s DecreaseToolSize -> return $ decreaseToolSize s BoxStyleSelector -> return $ beginBoxStyleSelect s - SelectLayer idx -> return $ selectLayer idx s + SelectLayer idx -> return $ fst $ selectLayer idx s AddLayer -> addLayer s CharSelector -> return $ whenTool s charTools beginCharacterSelect _ -> return s @@ -71,35 +72,35 @@ quit True s handleEvent s (VtyEvent e) = continue =<< case e of - _ | isStyleKey e -> return $ toggleStyleFromKey e s - (V.EvKey (V.KChar 'l') [V.MCtrl]) -> return $ toggleLayerList s - (V.EvKey (V.KChar 'w') []) -> return $ canvasMoveDown s - (V.EvKey (V.KChar 's') []) -> return $ canvasMoveUp s - (V.EvKey (V.KChar 'a') []) -> return $ canvasMoveLeft s - (V.EvKey (V.KChar 'd') []) -> return $ canvasMoveRight s - (V.EvKey (V.KChar 'y') []) -> return $ beginStyleSelect s - (V.EvKey (V.KChar 'v') []) -> return $ beginCanvasSizePrompt s - (V.EvKey (V.KChar 's') [V.MCtrl]) -> return $ askForSaveFilename False s - (V.EvKey (V.KChar 'r') [V.MCtrl]) -> return $ beginLayerRename s - (V.EvKey (V.KChar 'x') [V.MCtrl]) -> return $ deleteSelectedLayer s - (V.EvKey (V.KChar 'n') [V.MCtrl]) -> return $ selectNextLayer s - (V.EvKey (V.KChar 'p') [V.MCtrl]) -> return $ selectPrevLayer s - (V.EvKey (V.KChar 'u') [V.MCtrl]) -> return $ moveCurrentLayerUp s - (V.EvKey (V.KChar 'd') [V.MCtrl]) -> return $ moveCurrentLayerDown s - (V.EvKey (V.KChar 'v') [V.MCtrl]) -> return $ toggleCurrentLayer s - (V.EvKey (V.KChar 'C') []) -> return $ recenterCanvas s - (V.EvKey (V.KChar 'f') []) -> return $ beginFgPaletteSelect s - (V.EvKey (V.KChar 'b') []) -> return $ beginBgPaletteSelect s - (V.EvKey (V.KChar '>') []) -> return $ increaseToolSize s - (V.EvKey (V.KChar '<') []) -> return $ decreaseToolSize s - (V.EvKey V.KEsc []) | isJust (s^.dragging) -> return $ cancelDragging s - (V.EvKey (V.KChar c) []) | isDigit c -> return $ setToolByChar c s - (V.EvKey (V.KChar 'c') []) -> return $ whenTool s charTools - beginCharacterSelect - (V.EvKey (V.KChar '+') []) -> increaseCanvasSize s - (V.EvKey (V.KChar '-') []) -> decreaseCanvasSize s - (V.EvKey (V.KChar 'a') [V.MCtrl]) -> addLayer s - (V.EvKey (V.KChar 'u') []) -> undo s - (V.EvKey (V.KChar 'r') []) -> redo s - _ -> return s + _ | 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 'f') []) -> return $ beginFgPaletteSelect s + (EvKey (KChar 'b') []) -> return $ beginBgPaletteSelect 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 diff --git a/programs/Main.hs b/programs/Main.hs --- a/programs/Main.hs +++ b/programs/Main.hs @@ -10,6 +10,8 @@ import System.Console.GetOpt import Data.Monoid ((<>)) import System.Directory (doesFileExist) +import qualified Data.Text as T +import qualified Data.Text.IO as T import App import State @@ -54,7 +56,9 @@ configFromOpts (Import f:os) c = do ex <- doesFileExist f case ex of - False -> error $ "file not found: " <> f + False -> do + putStrLn $ "Error: file not found: " <> f + exitFailure True -> configFromOpts os $ c { configImport = Just f } showHelp :: IO () @@ -83,12 +87,12 @@ -- format c <- case configImport cfg of Just f -> do - s <- readFile f - c <- canvasFromText s + t <- T.readFile f + c <- canvasFromText t case configOutput cfg of - Nothing -> return $ Just (Nothing, [c], [0], ["default"]) + Nothing -> return $ Just (Nothing, [c], [0], [T.pack "default"]) Just output -> do - writeCanvasFiles output [c] [0] ["default"] + writeCanvasFiles output [c] [0] [T.pack "default"] exitSuccess Nothing -> case rest of @@ -109,4 +113,5 @@ chan <- newBChan 10 let mkVty = V.mkVty =<< V.standardIOConfig - (void . customMain mkVty (Just chan) application) =<< mkInitialState chan c + 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 @@ -121,12 +121,12 @@ , FloodFill ] -styleBindings :: [(Char, V.Style)] +styleBindings :: [(Char, (V.Style, T.Text))] styleBindings = - [ ('!', V.bold) - , ('@', V.underline) - , ('#', V.blink) - , ('$', V.reverseVideo) + [ ('!', (V.bold, "Bold")) + , ('@', (V.underline, "Underline")) + , ('#', (V.blink, "Blink")) + , ('$', (V.reverseVideo, "Reverse")) ] isStyleKey :: V.Event -> Bool @@ -138,18 +138,18 @@ toggleStyleFromKey e s = if isStyleKey e then let V.EvKey (V.KChar c) _ = e - Just sty = lookup c styleBindings + Just (sty, _) = lookup c styleBindings in s & drawStyle %~ toggleStyle sty else s -boxStyles :: [(String, BorderStyle)] +boxStyles :: [(T.Text, BorderStyle)] boxStyles = [ ("ASCII", ascii) , ("Unicode", unicode) , ("Unicode rounded", unicodeRounded) ] -getBoxBorderStyle :: AppState -> (String, BorderStyle) +getBoxBorderStyle :: AppState -> (T.Text, BorderStyle) getBoxBorderStyle s = boxStyles !! (s^.boxStyleIndex) increaseToolSize :: AppState -> AppState @@ -207,7 +207,7 @@ beginLayerRename :: AppState -> AppState beginLayerRename s = let z = textZipper [line] (Just 1) - line = T.pack $ s^.layerInfoFor(s^.selectedLayerIndex).layerName + line = s^.layerInfoFor(s^.selectedLayerIndex).layerName in pushMode RenameLayer $ s & layerNameEditor.editContentsL .~ gotoEOL z @@ -226,16 +226,15 @@ withUndo $ renameLayer (s^.selectedLayerIndex) name s renameLayer :: Int -> T.Text -> AppState -> (AppState, [Action]) -renameLayer idx name s = - let newName = T.unpack name - oldName = s^.layerInfoFor(idx).layerName - act = ChangeLayerName idx (T.pack oldName) - in if null newName +renameLayer idx newName s = + let oldName = s^.layerInfoFor(idx).layerName + act = ChangeLayerName idx oldName + in if T.null newName then (s, []) else if newName == oldName then (popMode s, []) else (popMode $ - s & layerInfoFor(idx).layerName .~ T.unpack name + s & layerInfoFor(idx).layerName .~ newName & canvasDirty .~ True , [act]) @@ -283,9 +282,9 @@ else (s^.layerOrder) !! (selIndex - 1) in s & selectedLayerIndex .~ newSel -selectLayer :: Int -> AppState -> AppState +selectLayer :: Int -> AppState -> (AppState, [Action]) selectLayer idx s = - s & selectedLayerIndex .~ idx + (s & selectedLayerIndex .~ idx, [SelectLayerIndex $ s^.selectedLayerIndex]) cancelDragging :: AppState -> AppState cancelDragging s = @@ -333,13 +332,9 @@ & layerInfo %~ fixNameKeys , [act]) -insertLayer :: Canvas -> Int -> Int -> String -> AppState -> (AppState, [Action]) +insertLayer :: Canvas -> Int -> Int -> T.Text -> AppState -> (AppState, [Action]) insertLayer c newIdx orderIndex name s = - let selIdx = s^.selectedLayerIndex - newSelIndex = if selIdx >= newIdx - then selIdx + 1 - else selIdx - newOrderNoInsert = (\i -> if i >= newIdx then i + 1 else i) <$> s^.layerOrder + let newOrderNoInsert = (\i -> if i >= newIdx then i + 1 else i) <$> s^.layerOrder newOrder = take orderIndex newOrderNoInsert <> [newIdx] <> drop orderIndex newOrderNoInsert @@ -349,14 +344,15 @@ then (i + 1, n) else (i, n) - act = RemoveLayer newIdx + removeAct = RemoveLayer newIdx + selAct = SelectLayerIndex (s^.selectedLayerIndex) in ( - s & selectedLayerIndex .~ newSelIndex + s & selectedLayerIndex .~ (length (s^.layerOrder)) & layers %~ (M.insert newIdx c . fixNameKeys) & layerOrder .~ newOrder & layerInfo %~ (M.insert newIdx (LayerInfo name True) . fixNameKeys) - , [act]) + , [removeAct, selAct]) quit :: Bool -> AppState -> EventM Name (Next AppState) quit ask s = do @@ -393,7 +389,7 @@ liftIO $ saveToDisk s p return $ s & canvasDirty .~ False -writeCanvasFiles :: FilePath -> [Canvas] -> [Int] -> [String] -> IO () +writeCanvasFiles :: FilePath -> [Canvas] -> [Int] -> [T.Text] -> IO () writeCanvasFiles path cs order names = do let tf = TartFile cs names order tfp = toTartFilepath path @@ -569,7 +565,7 @@ addLayer :: AppState -> EventM Name AppState addLayer s = do - let newLayerName = "layer " <> (show $ idx + 1) + let newLayerName = T.pack $ "layer " <> (show $ idx + 1) idx = M.size $ s^.layers orderIndex = length (s^.layerOrder) diff --git a/programs/Theme.hs b/programs/Theme.hs --- a/programs/Theme.hs +++ b/programs/Theme.hs @@ -6,6 +6,7 @@ , selectedLayerAttr , clickableAttr , errorAttr + , headerAttr ) where @@ -22,6 +23,9 @@ clickableAttr :: AttrName clickableAttr = "clickable" +headerAttr :: AttrName +headerAttr = "header" + errorAttr :: AttrName errorAttr = "error" @@ -32,5 +36,6 @@ , (editFocusedAttr, black `on` yellow) , (selectedLayerAttr, white `on` magenta) , (clickableAttr, fg white `withStyle` bold) + , (headerAttr, fg white `withStyle` underline) , (errorAttr, fg red) ] diff --git a/programs/Types.hs b/programs/Types.hs --- a/programs/Types.hs +++ b/programs/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} module Types ( Mode(..) , Name(..) @@ -89,8 +90,9 @@ data Action = SetPixels Int [((Int, Int), (Char, V.Attr))] | ClearCanvasDirty - | InsertLayer Canvas Int Int String + | InsertLayer Canvas Int Int T.Text | RemoveLayer Int + | SelectLayerIndex Int | ChangeLayerName Int T.Text | MoveLayerBy Int Bool | ToggleLayer Int @@ -164,7 +166,7 @@ | TextString deriving (Eq, Show, Ord) -toolName :: Tool -> String +toolName :: Tool -> T.Text toolName Freehand = "Freehand" toolName Box = "Box" toolName Line = "Line" @@ -198,7 +200,7 @@ noStyle = 0 data LayerInfo = - LayerInfo { _layerName :: String + LayerInfo { _layerName :: T.Text , _layerVisible :: Bool } diff --git a/programs/UI/BoxStyleSelect.hs b/programs/UI/BoxStyleSelect.hs --- a/programs/UI/BoxStyleSelect.hs +++ b/programs/UI/BoxStyleSelect.hs @@ -37,4 +37,4 @@ clickable (BoxStyleSelectorEntry i) $ vLimit 1 $ hLimit boxStyleSelectorEntryWidth $ - (str n) <+> fill ' ' + (txt n) <+> fill ' ' diff --git a/programs/UI/Main.hs b/programs/UI/Main.hs --- a/programs/UI/Main.hs +++ b/programs/UI/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module UI.Main ( drawMainUI , toolSelectorEntryWidth @@ -45,11 +46,11 @@ ] filename = case s^.canvasPath of Nothing -> "" - Just p -> p + Just p -> T.pack p modified = if not $ s^.canvasDirty then "" else "*" in clickable TopHud $ vBox [ (padLeft (Pad 1) $ hBox $ padRight (Pad 1) <$> toolbarEntries) - , hBox [hBorder, str ("[" <> filename <> modified <> "]"), borderElem bsHorizontal] + , hBox [hBorder, txt ("[" <> filename <> modified <> "]"), borderElem bsHorizontal] ] layerHud :: AppState -> Widget Name @@ -57,7 +58,7 @@ padBottom (Pad 4) $ (hLimit 20 $ layerList <=> fill ' ' <=> layerOptions) <+> vBorder where - layerList = vBox $ (hCenter $ str "Layers") : + layerList = vBox $ (hCenter $ withDefAttr headerAttr $ txt "Layers") : (mkEntry <$> entries) <> [addLayerEntry] entries = [ ( i @@ -67,7 +68,7 @@ ] addLayerEntry = clickable AddLayer $ hCenter $ - withDefAttr clickableAttr $ str "Add Layer (C-a)" + withDefAttr clickableAttr $ txt "Add Layer (C-a)" mkEntry (idx, LayerInfo name vis) = if RenameLayer `elem` s^.modes && s^.selectedLayerIndex == idx then @@ -76,20 +77,20 @@ let applyAttr = if idx == s^.selectedLayerIndex then withDefAttr selectedLayerAttr else id - showHiddenStatus = if vis then id else (<+> str "H") + showHiddenStatus = if vis then id else (<+> txt "H") in clickable (if idx == s^.selectedLayerIndex then LayerName else SelectLayer idx) $ applyAttr $ vLimit 1 $ showHiddenStatus $ - str name <+> fill ' ' + txt name <+> fill ' ' layerOptions = let i = s^.selectedLayerIndex entry n label = clickable n $ vLimit 1 $ withDefAttr clickableAttr $ - str label <+> fill ' ' + txt label <+> fill ' ' in vBox $ catMaybes - [ Just $ hBorderWithLabel (str "Layer Options") + [ Just $ hBorderWithLabel (txt "Layer Options") , Just $ entry ToggleLayerVisible (if s^.layerInfoFor(i).layerVisible then "Hide (C-v)" @@ -136,7 +137,7 @@ boxStyleSelectorEntryWidth = 18 styleSelectorEntryWidth :: Int -styleSelectorEntryWidth = 7 +styleSelectorEntryWidth = 12 boxHud :: AppState -> Widget Name boxHud = drawBoxStyleSelector @@ -152,24 +153,24 @@ drawToolSize :: AppState -> Widget Name drawToolSize s = - let inc = clickable IncreaseToolSize $ withDefAttr keybindingAttr $ str ">>" - dec = clickable DecreaseToolSize $ withDefAttr keybindingAttr $ str "<<" + let inc = clickable IncreaseToolSize $ withDefAttr keybindingAttr $ txt ">>" + dec = clickable DecreaseToolSize $ withDefAttr keybindingAttr $ txt "<<" sz = fromMaybe (error "BUG: current tool has no size") $ toolSize s - in borderWithLabel (str "Size") $ - dec <+> (hLimit 5 $ hCenter $ str $ show sz) <+> inc + in borderWithLabel (txt "Size") $ + dec <+> (hLimit 5 $ hCenter $ txt $ T.pack $ show sz) <+> inc drawBoxStyleSelector :: AppState -> Widget Name drawBoxStyleSelector s = let styleName = fst $ getBoxBorderStyle s in clickable BoxStyleSelector $ - borderWithLabel (str "Box Style") $ + borderWithLabel (txt "Box Style") $ hLimit boxStyleSelectorEntryWidth $ - hCenter $ str styleName + hCenter $ txt styleName drawStyleSelector :: AppState -> Widget Name drawStyleSelector s = clickable StyleSelector $ - borderWithLabel (str "St" <+> (withDefAttr keybindingAttr $ str "y") <+> str "le") $ + borderWithLabel (txt "St" <+> (withDefAttr keybindingAttr $ txt "y") <+> txt "le") $ hLimit styleSelectorEntryWidth $ hCenter $ raw $ V.string (V.defAttr `V.withStyle` (s^.drawStyle)) "demo" @@ -177,14 +178,14 @@ drawCanvasSize s = let (width, height) = s^.appCanvasSize in clickable ResizeCanvas $ - borderWithLabel (str "Can" <+> (withDefAttr keybindingAttr (str "v")) <+> str "as") $ - hLimit 8 $ hCenter (str $ show width <> "x" <> show height) + borderWithLabel (txt "Can" <+> (withDefAttr keybindingAttr (txt "v")) <+> txt "as") $ + hLimit 8 $ hCenter (txt $ T.pack $ show width <> "x" <> show height) drawChar :: AppState -> Widget Name drawChar s = clickable CharSelector $ - borderWithLabel ((withDefAttr keybindingAttr $ str "C") <+> str "har") $ - padLeftRight 2 $ str [s^.drawCharacter] + borderWithLabel ((withDefAttr keybindingAttr $ txt "C") <+> txt "har") $ + padLeftRight 2 $ txt $ T.singleton $ s^.drawCharacter toolSelectorEntryWidth :: Int toolSelectorEntryWidth = 20 @@ -193,19 +194,19 @@ drawToolSelector s = let Just idx = lookup (s^.tool) tools in clickable ToolSelector $ - borderWithLabel ((withDefAttr keybindingAttr $ str "T") <+> str "ool") $ + borderWithLabel ((withDefAttr keybindingAttr $ txt "T") <+> txt "ool") $ hLimit toolSelectorEntryWidth $ hCenter $ - (withDefAttr keybindingAttr (str $ show idx)) <+> - (str $ ":" <> toolName (s^.tool)) + (withDefAttr keybindingAttr (txt $ T.pack $ show idx)) <+> + (txt $ ":" <> toolName (s^.tool)) drawPaletteSelector :: AppState -> Bool -> Widget Name drawPaletteSelector s isFg = (clickable selName $ borderWithLabel label curColor) where label = if isFg - then (withDefAttr keybindingAttr $ str "F") <+> str "G" - else (withDefAttr keybindingAttr $ str "B") <+> str "G" + then (withDefAttr keybindingAttr $ txt "F") <+> txt "G" + else (withDefAttr keybindingAttr $ txt "B") <+> txt "G" curIdx = if isFg then s^.drawFgPaletteIndex else s^.drawBgPaletteIndex selName = if isFg then FgSelector else BgSelector diff --git a/programs/UI/StyleSelect.hs b/programs/UI/StyleSelect.hs --- a/programs/UI/StyleSelect.hs +++ b/programs/UI/StyleSelect.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module UI.StyleSelect ( drawStyleSelectUI ) @@ -8,6 +9,7 @@ import Brick.Widgets.Border.Style import Lens.Micro.Platform import qualified Graphics.Vty as V +import qualified Data.Text as T import Types import UI.Main @@ -37,12 +39,12 @@ entries = mkEntry <$> styleBindings maybeActive sty = if hasStyle sty curStyle - then (<+> str "*") + then (<+> txt "*") else id - mkEntry (ch, sty) = + mkEntry (ch, (sty, label)) = clickable (StyleSelectorEntry sty) $ vLimit 1 $ hLimit styleSelectorEntryWidth $ - (withDefAttr keybindingAttr (str [ch])) <+> str ":" <+> - (maybeActive sty $ raw $ V.string (V.defAttr `V.withStyle` sty) "demo") <+> + (withDefAttr keybindingAttr (txt $ T.singleton ch)) <+> txt ":" <+> + (maybeActive sty $ raw $ V.text' (V.defAttr `V.withStyle` sty) label) <+> fill ' ' diff --git a/programs/UI/ToolSelect.hs b/programs/UI/ToolSelect.hs --- a/programs/UI/ToolSelect.hs +++ b/programs/UI/ToolSelect.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module UI.ToolSelect ( drawToolSelectUI ) @@ -8,6 +9,7 @@ import Brick.Widgets.Border import Brick.Widgets.Border.Style import Lens.Micro.Platform +import qualified Data.Text as T import Types import UI.Main @@ -37,5 +39,5 @@ clickable (ToolSelectorEntry t) $ vLimit 1 $ hLimit toolSelectorEntryWidth $ - (withDefAttr keybindingAttr (str $ show i)) <+> - (str $ ":" <> toolName t) <+> fill ' ' + (withDefAttr keybindingAttr (txt $ T.pack $ show i)) <+> + (txt $ ":" <> toolName t) <+> fill ' ' diff --git a/src/Tart/Canvas.hs b/src/Tart/Canvas.hs --- a/src/Tart/Canvas.hs +++ b/src/Tart/Canvas.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} module Tart.Canvas ( Canvas , CanvasData @@ -15,6 +16,7 @@ , prettyPrintCanvas , merge , clearCanvas + , canvasFromString , canvasFromText , canvasLayersToImage , normalizeAttr @@ -27,7 +29,6 @@ import Data.Word (Word64) import Data.Monoid ((<>)) import Data.Maybe (catMaybes) -import Data.List (intercalate) import qualified Graphics.Vty as V import qualified Data.Array.IArray as I import qualified Data.Array.MArray as A @@ -35,6 +36,7 @@ import Data.Array.IO (IOUArray) import Data.Array.Unboxed (UArray) import Lens.Micro.Platform +import qualified Data.Text as T data Canvas = Canvas { mut :: IOUArray (Int, Int) Word64 @@ -87,17 +89,20 @@ drawFreeze <- A.freeze draw return $ Canvas draw drawFreeze sz -canvasFromText :: String -> IO Canvas -canvasFromText s = do - let ls = convertTab <$> lines s - convertTab l = concat $ convertTabChar <$> l - convertTabChar '\t' = replicate 8 ' ' - convertTabChar c = [c] +canvasFromString :: String -> IO Canvas +canvasFromString = canvasFromText . T.pack + +canvasFromText :: T.Text -> IO Canvas +canvasFromText t = do + let ls = convertTab <$> T.lines t + convertTab = T.concatMap convertTabChar + convertTabChar '\t' = T.replicate 8 " " + convertTabChar c = T.singleton c height = length ls - width = maximum $ length <$> ls + width = maximum $ T.length <$> ls pixs = concat $ mkRowPixels <$> zip [0..] ls mkRowPixels (rowNum, row) = - mkPixel rowNum <$> zip [0..] row + mkPixel rowNum <$> zip [0..] (T.unpack row) mkPixel rowNum (colNum, ch) = ((colNum, rowNum), ch, V.defAttr) @@ -116,12 +121,12 @@ type RLE a = State RLEState a data RLEState = - RLEState { content :: [(String, V.Attr)] - , currentString :: String + RLEState { content :: [(T.Text, V.Attr)] + , currentString :: T.Text , currentAttr :: V.Attr } -runRLE :: RLE () -> [(String, V.Attr)] +runRLE :: RLE () -> [(T.Text, V.Attr)] runRLE act = let s = execState (act >> sealFinalToken) (RLEState [] "" V.defAttr) in content s @@ -137,26 +142,26 @@ appendCharacter :: Char -> RLE () appendCharacter c = - modify $ \s -> s { currentString = currentString s <> [c] + modify $ \s -> s { currentString = currentString s <> T.singleton c } sealFinalToken :: RLE () sealFinalToken = - modify $ \s -> s { content = if null $ currentString s + modify $ \s -> s { content = if T.null $ currentString s then content s else content s <> [(currentString s, currentAttr s)] } newToken :: Char -> V.Attr -> RLE () newToken c a = - modify $ \s -> s { currentString = [c] + modify $ \s -> s { currentString = T.singleton c , currentAttr = a - , content = if null $ currentString s + , content = if T.null $ currentString s then content s else content s <> [(currentString s, currentAttr s)] } -prettyPrintCanvas :: Bool -> [Canvas] -> String +prettyPrintCanvas :: Bool -> [Canvas] -> T.Text prettyPrintCanvas emitSequences cs = let pairs = runRLE (mkRLE cs) mkOutput (s, attr) = @@ -165,7 +170,7 @@ else s ctrlSequence a = "\ESC[0m" <> attrSequence a - in concat $ mkOutput <$> pairs + in T.concat $ mkOutput <$> pairs mkRLE :: [Canvas] -> RLE () mkRLE [] = return () @@ -176,14 +181,14 @@ rleNext $ findPixel cs (col, row) rleNext ('\n', V.defAttr) -attrSequence :: V.Attr -> String +attrSequence :: V.Attr -> T.Text attrSequence a = let fg = colorCode True (V.attrForeColor a) bg = colorCode False (V.attrBackColor a) sty = styleCode (V.attrStyle a) in fg <> bg <> sty -styleCode :: V.MaybeDefault V.Style -> String +styleCode :: V.MaybeDefault V.Style -> T.Text styleCode V.KeepCurrent = "" styleCode V.Default = "" styleCode (V.SetTo s) = styleCode' s @@ -196,14 +201,14 @@ , V.reverseVideo ] -styleCode' :: V.Style -> String +styleCode' :: V.Style -> T.Text styleCode' s = let present = filter (V.hasStyle s) styles in if null present then "" - else "\ESC[" <> intercalate ";" (styleToCode <$> present) <> "m" + else "\ESC[" <> T.intercalate ";" (styleToCode <$> present) <> "m" -styleToCode :: V.Style -> String +styleToCode :: V.Style -> T.Text styleToCode s = let mapping = [ (V.bold, "1") , (V.underline, "4") @@ -212,19 +217,19 @@ ] in maybe "" id $ lookup s mapping -colorCode :: Bool -> V.MaybeDefault V.Color -> String +colorCode :: Bool -> V.MaybeDefault V.Color -> T.Text colorCode _ V.KeepCurrent = "" colorCode _ V.Default = "" colorCode f (V.SetTo c) = colorCode' f c -colorCode' :: Bool -> V.Color -> String +colorCode' :: Bool -> V.Color -> T.Text colorCode' f (V.Color240 w) = - "\ESC[" <> if f then "38" else "48" <> ";5;" <> show w <> "m" + "\ESC[" <> if f then "38" else "48" <> ";5;" <> T.pack (show w) <> "m" colorCode' f (V.ISOColor w) = let c = if f then "38" else "48" valid v = v >= 0 && v <= 15 in if valid w - then "\ESC[" <> c <> ";5;" <> show w <> "m" + then "\ESC[" <> c <> ";5;" <> T.pack (show w) <> "m" else "" canvasSize :: Canvas -> (Int, Int) diff --git a/src/Tart/Format.hs b/src/Tart/Format.hs --- a/src/Tart/Format.hs +++ b/src/Tart/Format.hs @@ -15,6 +15,7 @@ import qualified Data.Binary.Get as B import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text.IO as T import Tart.Canvas import Tart.Format.Types @@ -87,7 +88,7 @@ let ext = if color then ".color.txt" else ".plain.txt" fn = path <> ext - in writeFile fn $ + in T.writeFile fn $ prettyPrintCanvas color $ tartFileCanvasesSorted tf writeTartFileBinary :: TartFile -> TartFilePath -> IO () diff --git a/src/Tart/Format/Types.hs b/src/Tart/Format/Types.hs --- a/src/Tart/Format/Types.hs +++ b/src/Tart/Format/Types.hs @@ -6,12 +6,13 @@ where import qualified Data.Binary as B +import qualified Data.Text as T import Tart.Canvas data TartFile = TartFile { tartFileCanvasList :: [Canvas] - , tartFileCanvasNames :: [String] + , tartFileCanvasNames :: [T.Text] , tartFileCanvasOrder :: [Int] } diff --git a/src/Tart/Format/V0.hs b/src/Tart/Format/V0.hs --- a/src/Tart/Format/V0.hs +++ b/src/Tart/Format/V0.hs @@ -4,6 +4,7 @@ where import qualified Data.Binary as B +import qualified Data.Text as T import Tart.Canvas import Tart.Format.Types @@ -27,4 +28,4 @@ result <- canvasFromData (tartFileDataV0CanvasData d) case result of Left s -> return $ Left s - Right c -> return $ Right $ TartFile [c] ["default"] [0] + Right c -> return $ Right $ TartFile [c] [T.pack "default"] [0] diff --git a/src/Tart/Format/V1.hs b/src/Tart/Format/V1.hs --- a/src/Tart/Format/V1.hs +++ b/src/Tart/Format/V1.hs @@ -5,13 +5,14 @@ where import qualified Data.Binary as B +import qualified Data.Text as T import Tart.Canvas import Tart.Format.Types data TartFileDataV1 = TartFileDataV1 { tartFileDataV1CanvasData :: [CanvasData] - , tartFileDataV1CanvasNames :: [String] + , tartFileDataV1CanvasNames :: [T.Text] , tartFileDataV1CanvasOrder :: [Int] } @@ -25,11 +26,11 @@ instance B.Binary TartFileDataV1 where put d = do B.put $ tartFileDataV1CanvasData d - B.put $ tartFileDataV1CanvasNames d + B.put $ T.unpack <$> tartFileDataV1CanvasNames d B.put $ tartFileDataV1CanvasOrder d get = do TartFileDataV1 <$> B.get - <*> B.get + <*> (fmap T.pack <$> B.get) <*> B.get tartFileToDataV1 :: TartFile -> TartFileDataV1 diff --git a/src/Tart/Format/V2.hs b/src/Tart/Format/V2.hs --- a/src/Tart/Format/V2.hs +++ b/src/Tart/Format/V2.hs @@ -7,13 +7,14 @@ import Control.Monad (when) import Data.Int (Int32) import qualified Data.Binary as B +import qualified Data.Text as T import Tart.Canvas import Tart.Format.Types data TartFileDataV2 = TartFileDataV2 { tartFileDataV2CanvasData :: [CanvasData] - , tartFileDataV2CanvasNames :: [String] + , tartFileDataV2CanvasNames :: [T.Text] , tartFileDataV2CanvasOrder :: [Int] } @@ -31,7 +32,7 @@ put d = do B.put tartFileDataV2Magic B.put $ tartFileDataV2CanvasData d - B.put $ tartFileDataV2CanvasNames d + B.put $ T.unpack <$> tartFileDataV2CanvasNames d B.put $ tartFileDataV2CanvasOrder d get = do magic <- B.get @@ -39,7 +40,7 @@ fail "not a valid tart file version 1" TartFileDataV2 <$> B.get - <*> B.get + <*> (fmap T.pack <$> B.get) <*> B.get tartFileToDataV2 :: TartFile -> TartFileDataV2 diff --git a/tart.cabal b/tart.cabal --- a/tart.cabal +++ b/tart.cabal @@ -1,5 +1,5 @@ name: tart -version: 0.1.2 +version: 0.2 synopsis: Terminal Art description: A program to make ASCII art license: BSD3 @@ -33,11 +33,12 @@ build-depends: base >=4.9 && < 5, array, binary, - vty >= 5.17.1, + vty >= 5.17.1 && < 5.27, microlens-platform, bytestring, mtl, - binary + binary, + text executable tart ghc-options: -threaded -Wall @@ -77,8 +78,8 @@ Draw.Box default-language: Haskell2010 build-depends: base >=4.9 && < 5, - brick >= 0.30, - vty >= 5.17, + brick >= 0.52 && < 0.53, + vty >= 5.17 && < 5.27, vector, microlens-platform, microlens-th, @@ -87,5 +88,4 @@ text-zipper, directory, containers, - tart, - text-zipper + tart