tart 0.1.2 → 0.2
raw patch · 20 files changed
+198/−149 lines, 20 filesdep ~brickdep ~vty
Dependency ranges changed: brick, vty
Files
- CHANGELOG.md +19/−0
- README.md +3/−1
- programs/App.hs +6/−4
- programs/Draw.hs +2/−0
- programs/Events/Main.hs +33/−32
- programs/Main.hs +11/−6
- programs/State.hs +24/−28
- programs/Theme.hs +5/−0
- programs/Types.hs +5/−3
- programs/UI/BoxStyleSelect.hs +1/−1
- programs/UI/Main.hs +26/−25
- programs/UI/StyleSelect.hs +6/−4
- programs/UI/ToolSelect.hs +4/−2
- src/Tart/Canvas.hs +32/−27
- src/Tart/Format.hs +2/−1
- src/Tart/Format/Types.hs +2/−1
- src/Tart/Format/V0.hs +2/−1
- src/Tart/Format/V1.hs +4/−3
- src/Tart/Format/V2.hs +4/−3
- tart.cabal +7/−7
CHANGELOG.md view
@@ -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 -----
README.md view
@@ -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). 
programs/App.hs view
@@ -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 }
programs/Draw.hs view
@@ -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 =
programs/Events/Main.hs view
@@ -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
programs/Main.hs view
@@ -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
programs/State.hs view
@@ -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)
programs/Theme.hs view
@@ -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) ]
programs/Types.hs view
@@ -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 }
programs/UI/BoxStyleSelect.hs view
@@ -37,4 +37,4 @@ clickable (BoxStyleSelectorEntry i) $ vLimit 1 $ hLimit boxStyleSelectorEntryWidth $- (str n) <+> fill ' '+ (txt n) <+> fill ' '
programs/UI/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module UI.Main ( drawMainUI , toolSelectorEntryWidth@@ -45,11 +46,11 @@ ] filename = case s^.canvasPath of Nothing -> "<unsaved>"- 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
programs/UI/StyleSelect.hs view
@@ -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 ' '
programs/UI/ToolSelect.hs view
@@ -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 ' '
src/Tart/Canvas.hs view
@@ -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)
src/Tart/Format.hs view
@@ -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 ()
src/Tart/Format/Types.hs view
@@ -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] }
src/Tart/Format/V0.hs view
@@ -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]
src/Tart/Format/V1.hs view
@@ -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
src/Tart/Format/V2.hs view
@@ -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
tart.cabal view
@@ -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