├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── docs └── structural-json.mov ├── hie.yaml ├── jet.cabal ├── package.yaml ├── src ├── Jet.hs └── Jet │ └── Render.hs ├── stack.yaml ├── stack.yaml.lock └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for structural-json 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Jet - A Structural JSON editor 2 | 3 | 4 | 5 | * [Features](#features) 6 | * [Keymaps](#keymaps) 7 | * [Installation](#installation) 8 | * [Usage](#usage) 9 | * [Roadmap/Known bugs](#roadmapknown-bugs) 10 | 11 | 12 | 13 | Jet is a structural editor for JSON. 14 | 15 | I.e. an editor which is aware of the *structure* of JSON and allows you to manipulate it directly. 16 | The document is _always_ in a valid state. 17 | 18 | https://user-images.githubusercontent.com/6439644/143655548-3c556ea8-7673-4439-8624-15b4b503001f.mov 19 | 20 | 21 | # Features 22 | 23 | * [x] Structurally sound editing, never outputs invalid JSON. 24 | * [x] Copy/Cut/Paste JSON subtrees 25 | * [x] Subtree folding so you can focus on what's important. 26 | * [x] Transpose values around each other in lists. 27 | * [x] Undo/redo system, everyone makes mistakes 28 | * [x] Save functionality 29 | 30 | 31 | # Keymaps 32 | 33 | Press `?` to see the key map, which should feel familiar to vim users. 34 | 35 | # Installation 36 | 37 | ```shell 38 | cabal update && cabal install jet 39 | ``` 40 | 41 | # Usage 42 | 43 | ```shell 44 | # Open a file for editing. Use ctrl-s to save back to the file. 45 | # The edited file is output to stdout even if unsaved. 46 | jet myfile.json 47 | 48 | # Using jet in a pipeline for quick in-line edits. 49 | cat myfile.json | jet > result.json 50 | ``` 51 | 52 | # Roadmap/Known bugs 53 | 54 | - [ ] Figure out why vty needs two keystrokes to quit for some reason. 55 | - [ ] Allow cut/paste of _keys_ of objects. 56 | - [ ] Allow inserting when empty key already exists 57 | - [ ] Add search 58 | - [ ] Improved visibility around copy/paste with highlighting 59 | - [ ] Increment/decrement commands for integers. 60 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Jet 4 | 5 | main :: IO () 6 | main = run 7 | -------------------------------------------------------------------------------- /docs/structural-json.mov: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPenner/jet/eeab6c3e845fc839e96ffa577fe7aa89b6058bd8/docs/structural-json.mov -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | 4 | -------------------------------------------------------------------------------- /jet.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: jet 8 | version: 0.0.0.2 9 | description: Please see the README on GitHub at 10 | homepage: https://github.com/ChrisPenner/jet#readme 11 | bug-reports: https://github.com/ChrisPenner/jet/issues 12 | author: Chris Penner 13 | maintainer: example@example.com 14 | copyright: 2021 Chris Penner 15 | license: BSD3 16 | license-file: LICENSE 17 | build-type: Simple 18 | extra-source-files: 19 | README.md 20 | ChangeLog.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/ChrisPenner/jet 25 | 26 | library 27 | exposed-modules: 28 | Jet 29 | Jet.Render 30 | other-modules: 31 | Paths_jet 32 | hs-source-dirs: 33 | src 34 | default-extensions: 35 | FlexibleInstances 36 | FlexibleContexts 37 | ScopedTypeVariables 38 | LambdaCase 39 | ViewPatterns 40 | TypeApplications 41 | TypeOperators 42 | DeriveFunctor 43 | DeriveTraversable 44 | DeriveGeneric 45 | DerivingStrategies 46 | StandaloneDeriving 47 | TemplateHaskell 48 | RankNTypes 49 | GADTs 50 | MultiParamTypeClasses 51 | ghc-options: -Wall 52 | build-depends: 53 | Hclip 54 | , aeson 55 | , aeson-extra 56 | , aeson-pretty 57 | , ansi-terminal 58 | , base >=4.7 && <5 59 | , bytestring 60 | , comonad 61 | , containers 62 | , free 63 | , hashable 64 | , lens 65 | , mtl 66 | , prettyprinter 67 | , prettyprinter-ansi-terminal 68 | , recursion-schemes 69 | , recursive-zipper >=0.0 70 | , scientific 71 | , text 72 | , text-zipper 73 | , transformers 74 | , unix 75 | , unordered-containers 76 | , vector 77 | , vty 78 | default-language: Haskell2010 79 | 80 | executable jet 81 | main-is: Main.hs 82 | other-modules: 83 | Paths_jet 84 | hs-source-dirs: 85 | app 86 | default-extensions: 87 | FlexibleInstances 88 | FlexibleContexts 89 | ScopedTypeVariables 90 | LambdaCase 91 | ViewPatterns 92 | TypeApplications 93 | TypeOperators 94 | DeriveFunctor 95 | DeriveTraversable 96 | DeriveGeneric 97 | DerivingStrategies 98 | StandaloneDeriving 99 | TemplateHaskell 100 | RankNTypes 101 | GADTs 102 | MultiParamTypeClasses 103 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 104 | build-depends: 105 | Hclip 106 | , aeson 107 | , aeson-extra 108 | , aeson-pretty 109 | , ansi-terminal 110 | , base >=4.7 && <5 111 | , bytestring 112 | , comonad 113 | , containers 114 | , free 115 | , hashable 116 | , jet 117 | , lens 118 | , mtl 119 | , prettyprinter 120 | , prettyprinter-ansi-terminal 121 | , recursion-schemes 122 | , recursive-zipper >=0.0 123 | , scientific 124 | , text 125 | , text-zipper 126 | , transformers 127 | , unix 128 | , unordered-containers 129 | , vector 130 | , vty 131 | default-language: Haskell2010 132 | 133 | test-suite jet-test 134 | type: exitcode-stdio-1.0 135 | main-is: Spec.hs 136 | other-modules: 137 | Paths_jet 138 | hs-source-dirs: 139 | test 140 | default-extensions: 141 | FlexibleInstances 142 | FlexibleContexts 143 | ScopedTypeVariables 144 | LambdaCase 145 | ViewPatterns 146 | TypeApplications 147 | TypeOperators 148 | DeriveFunctor 149 | DeriveTraversable 150 | DeriveGeneric 151 | DerivingStrategies 152 | StandaloneDeriving 153 | TemplateHaskell 154 | RankNTypes 155 | GADTs 156 | MultiParamTypeClasses 157 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 158 | build-depends: 159 | Hclip 160 | , aeson 161 | , aeson-extra 162 | , aeson-pretty 163 | , ansi-terminal 164 | , base >=4.7 && <5 165 | , bytestring 166 | , comonad 167 | , containers 168 | , free 169 | , hashable 170 | , jet 171 | , lens 172 | , mtl 173 | , prettyprinter 174 | , prettyprinter-ansi-terminal 175 | , recursion-schemes 176 | , recursive-zipper >=0.0 177 | , scientific 178 | , text 179 | , text-zipper 180 | , transformers 181 | , unix 182 | , unordered-containers 183 | , vector 184 | , vty 185 | default-language: Haskell2010 186 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: jet 2 | version: 0.0.0.2 3 | github: "ChrisPenner/jet" 4 | license: BSD3 5 | author: "Chris Penner" 6 | maintainer: "example@example.com" 7 | copyright: "2021 Chris Penner" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - bytestring 25 | - recursive-zipper >= 0.0 26 | - aeson 27 | - aeson-extra 28 | - lens 29 | - recursion-schemes 30 | - mtl 31 | - transformers 32 | - containers 33 | - vty 34 | - text 35 | - free 36 | - vector 37 | - unordered-containers 38 | - aeson-pretty 39 | - comonad 40 | - text-zipper 41 | - scientific 42 | - hashable 43 | - prettyprinter-ansi-terminal 44 | - prettyprinter 45 | - ansi-terminal 46 | - Hclip 47 | - unix 48 | 49 | default-extensions: 50 | - FlexibleInstances 51 | - FlexibleContexts 52 | - ScopedTypeVariables 53 | - LambdaCase 54 | - ViewPatterns 55 | - TypeApplications 56 | - TypeOperators 57 | - DeriveFunctor 58 | - DeriveTraversable 59 | - DeriveGeneric 60 | - DerivingStrategies 61 | - StandaloneDeriving 62 | - TemplateHaskell 63 | - RankNTypes 64 | - GADTs 65 | - MultiParamTypeClasses 66 | 67 | ghc-options: 68 | - -Wall 69 | 70 | library: 71 | source-dirs: src 72 | 73 | executables: 74 | jet: 75 | main: Main.hs 76 | source-dirs: app 77 | ghc-options: 78 | - -threaded 79 | - -rtsopts 80 | - -with-rtsopts=-N 81 | dependencies: 82 | - jet 83 | 84 | tests: 85 | jet-test: 86 | main: Spec.hs 87 | source-dirs: test 88 | ghc-options: 89 | - -threaded 90 | - -rtsopts 91 | - -with-rtsopts=-N 92 | dependencies: 93 | - jet 94 | -------------------------------------------------------------------------------- /src/Jet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE InstanceSigs #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TupleSections #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | {-# LANGUAGE ViewPatterns #-} 18 | {-# OPTIONS_GHC -Wno-orphans #-} 19 | 20 | module Jet (run) where 21 | 22 | import Control.Category ((>>>)) 23 | import Control.Comonad (extract) 24 | import qualified Control.Comonad as Comonad 25 | import Control.Comonad.Cofree 26 | import qualified Control.Comonad.Trans.Cofree as CofreeF 27 | import Control.Lens hiding ((:<)) 28 | import qualified Control.Lens.Cons as Cons 29 | import Control.Monad.State 30 | import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) 31 | import Data.Aeson (Value) 32 | import qualified Data.Aeson as Aeson 33 | import Data.Aeson.Encode.Pretty (encodePretty) 34 | import Data.Aeson.Extra 35 | import qualified Data.ByteString.Lazy.Char8 as BS 36 | import qualified Data.ByteString.Lazy.Char8 as LBS 37 | import Data.Functor.Classes (Eq1 (..), Ord1 (liftCompare)) 38 | import qualified Data.Functor.Foldable as FF 39 | import Data.HashMap.Strict (HashMap) 40 | import qualified Data.HashMap.Strict as HM 41 | import qualified Data.HashMap.Strict as HashMap 42 | import Data.Hashable (Hashable) 43 | import qualified Data.List as List 44 | import Data.Maybe 45 | import Data.Sequence (Seq) 46 | import Data.Text (Text) 47 | import qualified Data.Text as Text 48 | import Data.Text.Zipper as TZ 49 | import Data.Vector (Vector) 50 | import qualified Data.Vector as Vector 51 | import qualified Graphics.Vty as Vty 52 | import Graphics.Vty.Input.Events 53 | import qualified Jet.Render as Render 54 | import Prettyprinter as P 55 | import System.Environment (getArgs) 56 | import System.Exit (exitFailure) 57 | import System.Hclip 58 | import System.IO (IOMode (ReadWriteMode), openFile) 59 | import qualified System.IO as IO 60 | import qualified System.Posix as Posix 61 | import Text.Read (readMaybe) 62 | import qualified Zipper.Recursive as Z 63 | 64 | tabSize :: Int 65 | tabSize = 2 66 | 67 | maxUndoStates :: Int 68 | maxUndoStates = 100 69 | 70 | hoistMaybe :: Maybe a -> MaybeT Editor a 71 | hoistMaybe = MaybeT . pure 72 | 73 | data EditorState = EditorState 74 | { _undo :: UndoZipper (Z.Zipper JIndex ValueF FocusState), 75 | _mode :: Mode, 76 | _register :: ValueF (Cofree ValueF FocusState), 77 | _vty :: Vty.Vty, 78 | _flash :: Text, 79 | _save :: Z.Zipper JIndex ValueF FocusState -> Editor () 80 | } 81 | 82 | newtype Editor a = Editor {runEditor :: StateT EditorState IO a} 83 | deriving newtype (Functor, Applicative, Monad, MonadState EditorState, MonadIO) 84 | 85 | mode_ :: Lens' EditorState Mode 86 | mode_ = lens _mode (\s m -> s {_mode = m}) 87 | 88 | register_ :: Lens' EditorState (ValueF (Cofree ValueF FocusState)) 89 | register_ = lens _register (\s m -> s {_register = m}) 90 | 91 | undo_ :: Lens' EditorState (UndoZipper (Z.Zipper JIndex ValueF FocusState)) 92 | undo_ = lens _undo (\s m -> s {_undo = m}) 93 | 94 | vty_ :: Lens' EditorState Vty.Vty 95 | vty_ = lens _vty (\s m -> s {_vty = m}) 96 | 97 | flash_ :: Lens' EditorState Text 98 | flash_ = lens _flash (\s m -> s {_flash = m}) 99 | 100 | save_ :: Lens' EditorState (Z.Zipper JIndex ValueF FocusState -> Editor ()) 101 | save_ = lens _save (\s m -> s {_save = m}) 102 | 103 | recover :: a -> MaybeT Editor a -> Editor a 104 | recover def m = do 105 | let e = runMaybeT m 106 | s <- get 107 | r <- liftIO $ flip runStateT s . runEditor $ e 108 | case r of 109 | (Just a, newS) -> put newS *> pure a 110 | (Nothing, _) -> pure def 111 | 112 | data Focused = Focused | NotFocused 113 | deriving (Eq) 114 | 115 | data Folded = Folded | NotFolded 116 | deriving (Eq) 117 | 118 | type PrettyJSON = Doc (Either Render.Cursor Vty.Attr) 119 | 120 | type Buffer = TZ.TextZipper Text 121 | 122 | -- | Nodes are annotated with one of these. 123 | -- This includes information about the node itself, but also 124 | -- a cached render of the node, which allows us to re-render 125 | -- the whole tree much faster. 126 | data FocusState = FocusState 127 | { isFocused :: Focused, 128 | isFolded :: Folded, 129 | rendered :: PrettyJSON 130 | } 131 | 132 | instance Eq FocusState where 133 | a == b = 134 | isFocused a == isFocused b 135 | && isFolded a == isFolded b 136 | 137 | focused_ :: Lens' FocusState Focused 138 | focused_ = lens isFocused (\fs new -> fs {isFocused = new}) 139 | 140 | folded_ :: Lens' FocusState Folded 141 | folded_ = lens isFolded (\fs new -> fs {isFolded = new}) 142 | 143 | toggleFold :: Folded -> Folded 144 | toggleFold Folded = NotFolded 145 | toggleFold NotFolded = Folded 146 | 147 | run :: IO () 148 | run = do 149 | (json, srcFile) <- 150 | getArgs >>= \case 151 | [] -> do 152 | json <- 153 | (Aeson.eitherDecode . BS.pack <$> getContents) >>= \case 154 | Left err -> do 155 | IO.hPutStrLn IO.stderr err 156 | exitFailure 157 | Right json -> pure json 158 | pure (json, Nothing) 159 | [f] -> do 160 | json <- 161 | Aeson.eitherDecodeFileStrict f >>= \case 162 | Left err -> do 163 | IO.hPutStrLn IO.stderr err 164 | exitFailure 165 | Right json -> pure json 166 | pure (json, Just f) 167 | _ -> IO.hPutStrLn IO.stderr "usage: structural-json FILE.json" *> exitFailure 168 | result <- edit srcFile $ json 169 | BS.putStrLn $ encodePretty result 170 | 171 | edit :: Maybe FilePath -> Value -> IO Value 172 | edit srcFile value = do 173 | -- Use tty so we don't interfere with stdin/stdout 174 | tty <- openFile "/dev/tty" ReadWriteMode >>= Posix.handleToFd 175 | config <- liftIO $ Vty.standardIOConfig 176 | vty <- (liftIO $ Vty.mkVty config {Vty.inputFd = Just tty, Vty.outputFd = Just tty}) 177 | -- load the value into a zipper. 178 | let z = Z.zipper . toCofree $ value 179 | v <- flip evalStateT (editorState srcFile vty) . runEditor $ loop z 180 | Vty.shutdown vty 181 | pure (Z.flatten v) 182 | 183 | loop :: 184 | Z.Zipper JIndex ValueF FocusState -> 185 | Editor (Z.Zipper JIndex ValueF FocusState) 186 | loop z = do 187 | vty <- use vty_ 188 | renderScreen z 189 | flash_ .= "" 190 | e <- liftIO $ Vty.nextEvent vty 191 | nextZ <- handleEvent e z 192 | if (shouldExit e) 193 | then pure nextZ 194 | else (loop nextZ) 195 | 196 | renderScreen :: Z.Zipper JIndex ValueF FocusState -> Editor () 197 | renderScreen z = do 198 | vty <- use vty_ 199 | (winWidth, winHeight) <- bounds 200 | rendered <- uses mode_ (\m -> fullRender m z) 201 | footer <- footerImg 202 | let screen = Vty.vertCat . Render.renderScreen (winHeight - Vty.imageHeight footer) . layoutPretty defaultLayoutOptions $ rendered 203 | let spacerHeight = winHeight - (Vty.imageHeight screen + Vty.imageHeight footer) 204 | let spacers = Vty.charFill Vty.defAttr ' ' winWidth spacerHeight 205 | liftIO $ Vty.update vty (Vty.picForImage (screen Vty.<-> spacers Vty.<-> footer)) 206 | 207 | -- | Get the current bounds of the current terminal screen. 208 | bounds :: Editor (Int, Int) 209 | bounds = use vty_ >>= liftIO . Vty.displayBounds . Vty.outputIface 210 | 211 | -- | Render the footer bar to an image 212 | footerImg :: Editor Vty.Image 213 | footerImg = do 214 | (w, _) <- bounds 215 | flash <- gets _flash 216 | let attr = (Vty.defAttr `Vty.withForeColor` Vty.green `Vty.withStyle` Vty.reverseVideo) 217 | helpMsg = Vty.text' attr "| Press '?' for help" 218 | flashMsg = Vty.text' (attr `Vty.withStyle` Vty.bold) (" " <> flash) 219 | pure $ 220 | Vty.horizCat 221 | [ flashMsg, 222 | Vty.charFill attr ' ' (w - (Vty.imageWidth helpMsg + Vty.imageWidth flashMsg)) 1, 223 | helpMsg 224 | ] 225 | 226 | -- | Push the given zipper onto history iff it's distinct from the most recent undo state. 227 | pushUndo :: Z.Zipper JIndex ValueF FocusState -> Editor () 228 | pushUndo z = 229 | undo_ %= \case 230 | (UndoZipper (ls Cons.:> _) _) | length ls >= maxUndoStates -> UndoZipper (z <| ls) Empty 231 | (UndoZipper ls _) -> UndoZipper (z <| ls) Empty 232 | 233 | editorState :: Maybe FilePath -> Vty.Vty -> EditorState 234 | editorState srcFile vty = 235 | EditorState 236 | { _undo = UndoZipper Empty Empty, 237 | _mode = Move, 238 | _register = NullF, 239 | _vty = vty, 240 | _flash = "Hello World", 241 | _save = saveFile 242 | } 243 | where 244 | saveFile = case srcFile of 245 | Nothing -> const (pure ()) 246 | Just fp -> \z -> do 247 | liftIO $ BS.writeFile fp (z & Z.flatten & encodePretty @Value) 248 | flash_ .= "Saved to " <> Text.pack fp 249 | 250 | shouldExit :: Vty.Event -> Bool 251 | shouldExit = \case 252 | EvKey (KChar 'c') [Vty.MCtrl] -> True 253 | EvKey (KChar 'q') [] -> True 254 | _ -> False 255 | 256 | bufferText :: Buffer -> Text 257 | bufferText = Text.concat . TZ.getText 258 | 259 | -- | Apply the state that's in the current mode's buffer to the selected node if possible. 260 | applyBuf :: Z.Zipper JIndex ValueF FocusState -> Editor (Z.Zipper JIndex ValueF FocusState) 261 | applyBuf z = do 262 | use mode_ >>= \case 263 | Edit buf -> do 264 | let txt = buf ^. to bufferText 265 | mode_ .= Move 266 | pure 267 | ( z & Z.unwrapped_ . _unwrap 268 | %~ ( \case 269 | StringF _ -> StringF txt 270 | (NumberF n) -> NumberF . fromMaybe n . readMaybe $ Text.unpack txt 271 | x -> x 272 | ) 273 | ) 274 | KeyEdit key buf -> do 275 | let txt = buf ^. to bufferText 276 | mode_ .= (KeyMove txt) 277 | pure 278 | ( z & Z.unwrapped_ . _unwrap 279 | %~ ( \case 280 | (ObjectF hm) -> ObjectF $ renameKey key txt hm 281 | x -> x 282 | ) 283 | ) 284 | _ -> pure z 285 | 286 | renameKey :: (Hashable k, Eq k) => k -> k -> HashMap k v -> HashMap k v 287 | renameKey srcKey destKey hm = 288 | hm 289 | &~ do 290 | v <- use (at srcKey) 291 | at srcKey .= Nothing 292 | at destKey .= v 293 | 294 | -- | Create a buffer using the text from the current value. 295 | bufferForValueF :: ValueF x -> Maybe Buffer 296 | bufferForValueF = \case 297 | (ObjectF _hm) -> Nothing 298 | (ArrayF _vec) -> Nothing 299 | StringF txt -> Just $ newBuffer txt 300 | (NumberF sci) -> 301 | Just $ newBuffer (Text.pack . show $ sci) 302 | (BoolF True) -> Just $ newBuffer "true" 303 | (BoolF False) -> Just $ newBuffer "true" 304 | NullF -> Just $ newBuffer "null" 305 | 306 | boolText_ :: Prism' Text Bool 307 | boolText_ = prism' toText toBool 308 | where 309 | toText True = "true" 310 | toText False = "false" 311 | toBool "true" = Just True 312 | toBool "false" = Just False 313 | toBool _ = Nothing 314 | 315 | data Mode 316 | = Edit {_buf :: Buffer} 317 | | Move 318 | | KeyMove {_selectedKey :: Text} 319 | | KeyEdit {_selectedKey :: Text, _buf :: Buffer} 320 | deriving (Show) 321 | 322 | buf_ :: Traversal' Mode Buffer 323 | buf_ f = \case 324 | Edit b -> Edit <$> f b 325 | Move -> pure Move 326 | KeyMove txt -> pure (KeyMove txt) 327 | KeyEdit txt b -> KeyEdit txt <$> f b 328 | 329 | -- | Main event handler 330 | handleEvent :: Vty.Event -> Z.Zipper JIndex ValueF FocusState -> Editor (Z.Zipper JIndex ValueF FocusState) 331 | handleEvent evt zipper = do 332 | use mode_ >>= \case 333 | KeyMove {} -> handleMove zipper 334 | Move {} -> handleMove zipper 335 | KeyEdit {} -> handleEdit zipper 336 | Edit {} -> handleEdit zipper 337 | where 338 | handleEdit :: 339 | ( Z.Zipper JIndex ValueF FocusState -> 340 | Editor (Z.Zipper JIndex ValueF FocusState) 341 | ) 342 | handleEdit z = 343 | case evt of 344 | EvKey key [] -> 345 | -- Perform buffer updates: 346 | case key of 347 | KChar c -> do 348 | mode_ . buf_ %= TZ.insertChar c 349 | pure z 350 | KLeft -> do 351 | mode_ . buf_ %= TZ.moveLeft 352 | pure z 353 | KRight -> do 354 | mode_ . buf_ %= TZ.moveRight 355 | pure z 356 | KBS -> do 357 | mode_ . buf_ %= TZ.deletePrevChar 358 | pure z 359 | KEsc -> do 360 | newZ <- applyBuf z 361 | pure $ newZ 362 | _ -> pure z 363 | _ -> pure z 364 | handleMove :: 365 | ( Z.Zipper JIndex ValueF FocusState -> 366 | Editor (Z.Zipper JIndex ValueF FocusState) 367 | ) 368 | handleMove z = 369 | case evt of 370 | EvKey key mods -> case key of 371 | -- move up 372 | KChar 'h' -> z & outOf 373 | -- move down 374 | KChar 'l' -> do 375 | z & Z.focus_ . folded_ .~ NotFolded 376 | & into 377 | -- next sibling 378 | KChar 'j' -> z & sibling Forward 379 | -- move down 380 | KChar 'J' -> do 381 | pushUndo z 382 | pure (z & moveElement Forward) 383 | -- prev sibling 384 | KChar 'k' -> z & sibling Backward 385 | -- move up 386 | KChar 'K' -> do 387 | pushUndo z 388 | pure (z & moveElement Backward) 389 | -- add new node 390 | KChar 'i' -> do 391 | pushUndo z 392 | insert z 393 | -- replace with boolean 394 | KChar 'b' -> do 395 | pushUndo z 396 | pure (z & setFocus (BoolF True)) 397 | -- replace with object 398 | KChar 'o' -> do 399 | pushUndo z 400 | pure (z & setFocus (ObjectF mempty)) 401 | -- replace with array 402 | KChar 'a' -> do 403 | pushUndo z 404 | pure (z & setFocus (ArrayF mempty)) 405 | -- replace with number 406 | KChar 'n' -> do 407 | pushUndo z 408 | pure (z & setFocus (NumberF 0)) 409 | -- replace with Null 410 | KChar 'N' -> do 411 | pushUndo z 412 | pure (z & setFocus NullF) 413 | -- Save file 414 | KChar 's' 415 | | [Vty.MCtrl] <- mods -> do 416 | saver <- use save_ 417 | saver z 418 | pure z 419 | -- replace with string 420 | KChar 's' -> do 421 | pushUndo z 422 | pure (z & setFocus (StringF "")) 423 | -- undo 424 | KChar 'u' -> do 425 | flash_ .= "Undo" 426 | undo_ %%= \case 427 | (UndoZipper (l Cons.:< ls) rs) -> 428 | (l, UndoZipper ls (z Cons.:< rs)) 429 | lz -> (z, lz) 430 | -- redo 431 | KChar 'r' | [Vty.MCtrl] <- mods -> do 432 | flash_ .= "Redo" 433 | undo_ %%= \case 434 | (UndoZipper ls (r Cons.:< rs)) -> (r, UndoZipper (z Cons.:< ls) rs) 435 | lz -> (z, lz) 436 | -- toggle bool 437 | KChar ' ' -> do 438 | pushUndo z 439 | pure (z & tryToggleBool) 440 | -- copy 441 | KChar 'y' -> do 442 | flash_ .= "Copied" 443 | copy z 444 | -- paste 445 | KChar 'p' -> do 446 | flash_ .= "Paste" 447 | pushUndo z 448 | paste z 449 | -- cut 450 | KChar 'x' -> do 451 | flash_ .= "Cut" 452 | pushUndo z 453 | copy z >>= delete 454 | -- help 455 | KChar '?' -> do 456 | vty <- use vty_ 457 | liftIO $ Vty.update vty (Vty.picForImage helpImg) 458 | void $ liftIO $ Vty.nextEvent vty 459 | pure z 460 | -- add child 461 | KEnter -> do 462 | pushUndo z 463 | tryAddChild z 464 | -- toggle fold 465 | KChar '\t' -> do 466 | -- Exit KeyMove mode if we're in it. 467 | mode_ .= Move 468 | pure $ (z & Z.focus_ . folded_ %~ toggleFold) 469 | -- Fold all children 470 | KChar 'F' -> do 471 | -- Fold all child branches 472 | pure $ mapChildren (mapped . folded_ .~ Folded) z 473 | -- unfold all children 474 | KChar 'f' -> do 475 | -- Unfold all child branches 476 | pure $ mapChildren (mapped . folded_ .~ NotFolded) z 477 | -- delete node 478 | KBS -> do 479 | flash_ .= "Deleted" 480 | pushUndo z 481 | delete z 482 | _ -> pure z 483 | _ -> pure z 484 | paste z = do 485 | reg <- use register_ 486 | pure (z & setFocus reg) 487 | copy z = do 488 | let curVal = Z.branches z 489 | register_ .= curVal 490 | liftIO $ setClipboard (encodeValueFCofree curVal) 491 | pure z 492 | insert z = do 493 | use mode_ >>= \case 494 | KeyMove k -> do 495 | mode_ .= KeyEdit k (newBuffer k) 496 | pure $ z & Z.focus_ . folded_ .~ NotFolded 497 | Move 498 | | Just editBuf <- bufferForValueF (z ^. Z.branches_) -> do 499 | mode_ .= Edit editBuf 500 | pure $ z & Z.focus_ . folded_ .~ NotFolded 501 | _ -> pure z 502 | 503 | encodeValueFCofree :: ValueF (Cofree ValueF FocusState) -> String 504 | encodeValueFCofree vf = LBS.unpack . encodePretty . FF.embed $ fmap (FF.cata alg) vf 505 | where 506 | alg :: CofreeF.CofreeF ValueF ann Value -> Value 507 | alg (_ CofreeF.:< vf') = FF.embed vf' 508 | 509 | -- | Set the value of the focused node. 510 | setFocus :: 511 | ValueF (Cofree ValueF FocusState) -> 512 | Z.Zipper JIndex ValueF FocusState -> 513 | Z.Zipper JIndex ValueF FocusState 514 | setFocus f z = z & Z.branches_ .~ f & rerender 515 | 516 | data Dir = Forward | Backward 517 | 518 | -- | Move the current value within an array 519 | moveElement :: Dir -> Z.Zipper JIndex ValueF FocusState -> Z.Zipper JIndex ValueF FocusState 520 | moveElement dir z = fromMaybe z $ do 521 | i <- case Z.currentIndex z of 522 | Just (Index i) -> pure i 523 | _ -> Nothing 524 | parent <- z & rerender & Z.up 525 | pure $ 526 | case parent ^. Z.branches_ of 527 | ArrayF arr -> 528 | let swapI = case dir of 529 | Forward -> i + 1 530 | Backward -> i - 1 531 | moves = 532 | [ (i, arr Vector.!? swapI), 533 | (swapI, arr Vector.!? i) 534 | ] 535 | & sequenceOf (traversed . _2) 536 | & fromMaybe [] 537 | in parent 538 | & Z.branches_ .~ ArrayF (arr Vector.// moves) 539 | & fromMaybe z . Z.down (Index swapI) 540 | _ -> z 541 | 542 | tryToggleBool :: Z.Zipper JIndex ValueF FocusState -> Z.Zipper JIndex ValueF FocusState 543 | tryToggleBool z = 544 | z & Z.branches_ %~ \case 545 | BoolF b -> BoolF (not b) 546 | x -> x 547 | 548 | tryAddChild :: Z.Zipper JIndex ValueF FocusState -> Editor (Z.Zipper JIndex ValueF FocusState) 549 | tryAddChild z = 550 | z & Z.branches_ %%~ \case 551 | ObjectF hm -> do 552 | mode_ .= (KeyEdit "" $ newBuffer "") 553 | pure $ ObjectF $ HM.insert "" (toCofree Aeson.Null) hm 554 | ArrayF arr -> do 555 | mode_ .= Move 556 | pure $ ArrayF $ arr <> pure (toCofree Aeson.Null) 557 | x -> pure x 558 | 559 | -- | Delete the current node 560 | delete :: Z.Zipper JIndex ValueF FocusState -> Editor (Z.Zipper JIndex ValueF FocusState) 561 | delete z = do 562 | curMode <- use mode_ 563 | mode_ .= Move 564 | pure $ case z ^. Z.branches_ of 565 | -- If we're in a Key focus, delete that key 566 | ObjectF hm 567 | | KeyMove k <- curMode -> 568 | ( z & Z.branches_ .~ ObjectF (HM.delete k hm) 569 | ) 570 | -- Otherwise move up a layer and delete the key we were in. 571 | _ -> case Z.currentIndex z of 572 | -- If we don't have a parent, set the current node to null 573 | Nothing -> 574 | z & Z.branches_ .~ NullF 575 | Just i -> fromMaybe z $ do 576 | parent <- z & rerender & Z.up 577 | pure $ 578 | parent & Z.branches_ %~ \case 579 | ObjectF hm | Key k <- i -> ObjectF (HM.delete k hm) 580 | ArrayF arr | Index j <- i -> ArrayF (Vector.ifilter (\i' _ -> i' /= j) arr) 581 | x -> x 582 | 583 | -- | Move to next/previous sibling. 584 | sibling :: Dir -> Z.Zipper JIndex ValueF FocusState -> Editor (Z.Zipper JIndex ValueF FocusState) 585 | sibling dir z = recover z $ do 586 | mode <- use mode_ 587 | case (mode, Z.branches z) of 588 | (KeyMove k, ObjectF hm) -> do 589 | case findSiblingIndex (== k) $ HashMap.keys hm of 590 | Nothing -> pure z 591 | Just theKey -> do 592 | mode_ .= KeyMove theKey 593 | pure z 594 | _ -> do 595 | curI <- hoistMaybe $ Z.currentIndex z 596 | parent <- hoistMaybe $ (z & rerender & Z.up) 597 | let newI = case Z.branches parent of 598 | ObjectF hm -> do 599 | let keys = HM.keys hm 600 | newKey <- findSiblingIndex (\k -> Key k == curI) keys 601 | pure $ Key newKey 602 | ArrayF xs -> case curI of 603 | (Index i) -> alterIndex xs i 604 | _ -> Nothing 605 | StringF {} -> Nothing 606 | NumberF {} -> Nothing 607 | BoolF {} -> Nothing 608 | NullF -> Nothing 609 | case newI of 610 | Just i -> hoistMaybe $ Z.down i parent 611 | Nothing -> hoistMaybe Nothing 612 | where 613 | (findSiblingIndex, alterIndex) = case dir of 614 | Forward -> 615 | ( findAfter, 616 | \xs i -> if i < length xs - 1 then Just (Index (i + 1)) else Nothing 617 | ) 618 | Backward -> 619 | ( findBefore, 620 | \_xs i -> if i > 0 then Just (Index (i -1)) else Nothing 621 | ) 622 | 623 | findAfter :: (a -> Bool) -> [a] -> Maybe a 624 | findAfter p xs = fmap snd . List.find (p . fst) $ zip xs (drop 1 xs) 625 | 626 | findBefore :: (a -> Bool) -> [a] -> Maybe a 627 | findBefore p xs = fmap snd . List.find (p . fst) $ zip (drop 1 xs) xs 628 | 629 | newBuffer :: Text -> Buffer 630 | newBuffer txt = TZ.gotoEOF $ TZ.textZipper (Text.lines txt) Nothing 631 | 632 | -- | Move into the current node 633 | into :: Z.Zipper JIndex ValueF FocusState -> Editor (Z.Zipper JIndex ValueF FocusState) 634 | into z = do 635 | mode <- use mode_ 636 | case (Z.branches z, mode) of 637 | (ObjectF _, KeyMove key) -> do 638 | mode_ .= Move 639 | pure (Z.tug (Z.down (Key key)) z) 640 | (ObjectF hm, Move) -> do 641 | case (HM.keys hm) ^? _head of 642 | Just fstKey -> do 643 | mode_ .= KeyMove fstKey 644 | pure z 645 | _ -> pure z 646 | (ArrayF {}, _) -> do 647 | pure $ Z.tug (Z.down (Index 0)) z 648 | _ -> pure z 649 | 650 | -- | Move out of the current node 651 | outOf :: Z.Zipper JIndex ValueF FocusState -> Editor (Z.Zipper JIndex ValueF FocusState) 652 | outOf z = do 653 | mode <- use mode_ 654 | maybeParentKey <- case (Z.currentIndex z) of 655 | Just (Key k) -> pure $ Just k 656 | _ -> pure Nothing 657 | 658 | case (Z.branches z, mode) of 659 | (ObjectF _, KeyMove {}) -> do 660 | mode_ .= Move 661 | pure z 662 | _ -> do 663 | maybe (pure ()) (\k -> mode_ .= KeyMove k) maybeParentKey 664 | pure (Z.tug (rerender >>> Z.up) z) 665 | 666 | -- | Render the full zipper using render caches stored in each node. 667 | fullRender :: Mode -> Z.Zipper JIndex ValueF FocusState -> PrettyJSON 668 | fullRender mode z = do 669 | let focusedRender = 670 | z & Z.focus_ . focused_ .~ Focused 671 | & Z.unwrapped_ %~ \(fs :< vf) -> 672 | let rerendered = renderSubtree fs mode (rendered . extract <$> vf) 673 | in (fs {rendered = rerendered} :< vf) 674 | rendered . foldSpine alg $ focusedRender 675 | where 676 | alg fs vf = 677 | fs {rendered = rerenderCached fs (rendered <$> vf)} 678 | rerenderCached fs = \case 679 | ObjectF o -> prettyObj (isFocused fs) mode o 680 | ArrayF a -> prettyArray (isFocused fs) a 681 | -- Nodes without children are never part of the spine, but just to have something 682 | -- we can render the cache. 683 | _ -> rendered fs 684 | 685 | -- | Updates the cached render of the current focus, using cached renders for subtrees. 686 | rerender :: Z.Zipper JIndex ValueF FocusState -> Z.Zipper JIndex ValueF FocusState 687 | rerender = Z.unwrapped_ %~ rerenderCofree 688 | 689 | -- Rerenders a layer of a cofree structure. Doesn't re-render the children. 690 | rerenderCofree :: Cofree ValueF FocusState -> Cofree ValueF FocusState 691 | rerenderCofree (fs :< vf) = 692 | let rerendered = (renderSubtree fs mode (rendered . extract <$> vf)) 693 | in fs {rendered = rerendered} :< vf 694 | where 695 | -- Currently the mode is required by renderSubtree, but for the rerender cache it's 696 | -- irrelevant, because it only matters if we're 'focused', and if we're focused, we'll be 697 | -- manually rerendered later anyways. 698 | mode = Move 699 | 700 | -- | Renders a subtree 701 | renderSubtree :: FocusState -> Mode -> ValueF PrettyJSON -> PrettyJSON 702 | renderSubtree (FocusState {isFolded = Folded, isFocused}) _ vf = case vf of 703 | ObjectF {} -> colored' Vty.white "{...}" 704 | ArrayF {} -> colored' Vty.white "[...]" 705 | StringF {} -> colored' Vty.green "\"...\"" 706 | NumberF {} -> colored' Vty.blue "..." 707 | NullF {} -> colored' Vty.yellow "..." 708 | BoolF {} -> colored' Vty.magenta "..." 709 | where 710 | colored' :: Vty.Color -> String -> PrettyJSON 711 | colored' col txt = 712 | P.annotate (Right $ if isFocused == Focused then reverseCol col else Vty.defAttr `Vty.withForeColor` col) (pretty txt) 713 | renderSubtree (FocusState {isFocused}) mode vf = case vf of 714 | (StringF txt) -> cursor isFocused $ case (isFocused, mode) of 715 | (Focused, Edit buf) -> 716 | colored' Vty.green "\"" <> renderBuffer Vty.green buf <> colored' Vty.green "\"" 717 | _ -> colored' Vty.green "\"" <> colored' Vty.green (Text.unpack txt) <> colored' Vty.green "\"" 718 | (NullF) -> cursor isFocused $ colored' Vty.yellow "null" 719 | (NumberF n) -> cursor isFocused $ case (isFocused, mode) of 720 | (Focused, Edit buf) -> renderBuffer Vty.blue buf 721 | _ -> colored' Vty.blue (show n) 722 | (BoolF b) -> cursor isFocused $ colored' Vty.magenta (Text.unpack $ boolText_ # b) 723 | (ArrayF xs) -> prettyArray isFocused xs 724 | (ObjectF xs) -> prettyObj isFocused mode xs 725 | where 726 | colored' :: Vty.Color -> String -> PrettyJSON 727 | colored' col txt = 728 | P.annotate (Right $ if isFocused == Focused then reverseCol col else Vty.defAttr `Vty.withForeColor` col) (pretty txt) 729 | 730 | -- | Attr in reverse-video 731 | reverseCol :: Vty.Color -> Vty.Attr 732 | reverseCol col = Vty.defAttr `Vty.withForeColor` col `Vty.withStyle` Vty.reverseVideo 733 | 734 | -- | Map over all children of the current node, re-rendering after changes. 735 | mapChildren :: 736 | (Cofree ValueF FocusState -> Cofree ValueF FocusState) -> 737 | Z.Zipper JIndex ValueF FocusState -> 738 | Z.Zipper JIndex ValueF FocusState 739 | mapChildren f = Z.branches_ . mapped %~ FF.cata alg 740 | where 741 | alg :: CofreeF.CofreeF ValueF FocusState (Cofree ValueF FocusState) -> Cofree ValueF FocusState 742 | alg (cf CofreeF.:< vf) = rerenderCofree $ f (cf :< vf) 743 | 744 | prettyWith :: Pretty a => Vty.Attr -> a -> PrettyJSON 745 | prettyWith ann a = annotate (Right ann) $ pretty a 746 | 747 | colored :: Pretty a => Vty.Color -> a -> PrettyJSON 748 | colored col a = annotate (Right $ Vty.defAttr `Vty.withForeColor` col) $ pretty a 749 | 750 | renderBuffer :: Vty.Color -> Buffer -> PrettyJSON 751 | renderBuffer col buf = 752 | let (prefix, suffix) = Text.splitAt (snd $ TZ.cursorPosition buf) (bufferText buf) 753 | suffixImg = case Text.uncons suffix of 754 | Nothing -> prettyWith (reverseCol col) ' ' 755 | Just (c, rest) -> prettyWith (reverseCol col) c <> colored col rest 756 | in colored col prefix <> suffixImg 757 | 758 | cursor :: Focused -> PrettyJSON -> PrettyJSON 759 | cursor Focused = P.annotate (Left Render.Cursor) 760 | cursor _ = id 761 | 762 | prettyArray :: Focused -> Vector PrettyJSON -> PrettyJSON 763 | prettyArray foc vs = 764 | let inner :: [PrettyJSON] = 765 | Vector.toList vs 766 | & imap (\i v -> v <> commaKey i) 767 | in cursor foc $ vsep $ [img "[", indent tabSize (vsep inner), img "]"] 768 | where 769 | img :: Text -> PrettyJSON 770 | img t = case foc of 771 | Focused -> prettyWith (reverseCol Vty.white) t 772 | NotFocused -> pretty t 773 | commaKey i 774 | | i == Vector.length vs - 1 = mempty 775 | | otherwise = "," 776 | 777 | prettyObj :: Focused -> Mode -> HashMap Text PrettyJSON -> PrettyJSON 778 | prettyObj focused mode vs = 779 | let inner :: PrettyJSON 780 | inner = 781 | vsep 782 | ( HM.toList vs 783 | & imap 784 | ( \i (k, v) -> 785 | vsep [imgForKey k <> pretty @Text ": ", indent tabSize (v <> commaKey i)] 786 | ) 787 | ) 788 | rendered = vsep [img "{", indent tabSize inner, img "}"] 789 | in case mode of 790 | Move -> cursor focused rendered 791 | _ -> rendered 792 | where 793 | hmSize = HM.size vs 794 | commaKey i 795 | | i == hmSize - 1 = mempty 796 | | otherwise = "," 797 | imgForKey k = case focused of 798 | NotFocused -> colored Vty.cyan (show k) 799 | Focused -> case mode of 800 | KeyMove focKey | focKey == k -> cursor Focused $ prettyWith (reverseCol Vty.cyan) (show focKey) 801 | KeyEdit focKey buf | focKey == k -> cursor Focused $ colored Vty.cyan '"' <> renderBuffer Vty.cyan buf <> colored Vty.cyan '"' 802 | _ -> colored Vty.cyan (show k) 803 | img :: Text -> PrettyJSON 804 | img t = case (focused, mode) of 805 | (Focused, Move) -> prettyWith (reverseCol Vty.white) t 806 | _ -> pretty t 807 | 808 | -- Orphan instances 809 | instance Eq1 ValueF where 810 | liftEq f vf1 vf2 = case (vf1, vf2) of 811 | (ObjectF l, ObjectF r) -> liftEq f l r 812 | (ArrayF l, ArrayF r) -> liftEq f l r 813 | (NullF, NullF) -> True 814 | (StringF l, StringF r) -> l == r 815 | (NumberF l, NumberF r) -> l == r 816 | (BoolF l, BoolF r) -> l == r 817 | _ -> False 818 | 819 | instance Ord1 ValueF where 820 | liftCompare f vf1 vf2 = case (vf1, vf2) of 821 | (ObjectF l, ObjectF r) -> liftCompare f l r 822 | (ArrayF l, ArrayF r) -> liftCompare f l r 823 | (NullF, NullF) -> EQ 824 | (StringF l, StringF r) -> compare l r 825 | (NumberF l, NumberF r) -> compare l r 826 | (BoolF l, BoolF r) -> compare l r 827 | (NullF, _) -> LT 828 | (_, NullF) -> GT 829 | (BoolF _, _) -> LT 830 | (_, BoolF _) -> GT 831 | (NumberF _, _) -> LT 832 | (_, NumberF _) -> GT 833 | (StringF _, _) -> LT 834 | (_, StringF _) -> GT 835 | (ArrayF _, _) -> LT 836 | (_, ArrayF _) -> GT 837 | 838 | data JIndex 839 | = Index Int 840 | | Key Text 841 | deriving (Show, Eq, Ord) 842 | 843 | instance FunctorWithIndex JIndex ValueF 844 | 845 | instance FoldableWithIndex JIndex ValueF 846 | 847 | instance TraversableWithIndex JIndex ValueF where 848 | itraverse f = \case 849 | NullF -> pure NullF 850 | StringF txt -> pure (StringF txt) 851 | NumberF sci -> pure (NumberF sci) 852 | BoolF b -> pure (BoolF b) 853 | ObjectF hm -> ObjectF <$> itraverse (\k a -> f (Key k) a) hm 854 | ArrayF arr -> ArrayF <$> itraverse (\k a -> f (Index k) a) arr 855 | 856 | type instance Index (ValueF a) = JIndex 857 | 858 | type instance IxValue (ValueF a) = a 859 | 860 | instance Ixed (ValueF a) where 861 | ix (Index i) f (ArrayF xs) = ArrayF <$> ix i f xs 862 | ix (Key k) f (ObjectF xs) = ObjectF <$> ix k f xs 863 | ix _ _ x = pure x 864 | 865 | toCofree :: (Value -> Cofree ValueF FocusState) 866 | toCofree t = FF.hylo alg FF.project $ t 867 | where 868 | defaultFs = FocusState NotFocused NotFolded mempty 869 | mode = Move 870 | alg :: ValueF (Cofree ValueF FocusState) -> Cofree ValueF FocusState 871 | alg vf = defaultFs {rendered = renderSubtree defaultFs mode (rendered . extract <$> vf)} :< vf 872 | 873 | helpImg :: Vty.Image 874 | helpImg = 875 | let helps = 876 | [ ("h", "ascend"), 877 | ("l", "descend"), 878 | ("j", "next sibling"), 879 | ("k", "previous sibling"), 880 | ("J", "move down (in array)"), 881 | ("K", "move up (in array)"), 882 | ("i", "enter edit mode (string/number)"), 883 | ("", "save file"), 884 | ("", "toggle boolean"), 885 | ("", "exit edit mode"), 886 | ("", "delete key/element"), 887 | ("", "add new key/element (object/array)"), 888 | ("", "toggle fold"), 889 | ("f", "unfold all children"), 890 | ("F", "fold all children"), 891 | ("s", "replace element with string"), 892 | ("b", "replace element with bool"), 893 | ("n", "replace element with number"), 894 | ("N", "replace element with null"), 895 | ("a", "replace element with array"), 896 | ("o", "replace element with object"), 897 | ("u", "undo last change (undo buffer keeps 100 states)"), 898 | ("", "redo from undo states"), 899 | ("y", "copy current value into buffer (and clipboard)"), 900 | ("p", "paste value from buffer over current value"), 901 | ("x", "cut a value, equivalent to a copy -> delete"), 902 | ("q | ctrl-c", "quit without saving. Due to a bug, tap twice") 903 | ] 904 | 905 | (keys, descs) = 906 | unzip 907 | ( helps <&> \(key, desc) -> 908 | ( Vty.text' (Vty.defAttr `Vty.withForeColor` Vty.green) (key <> ": "), 909 | Vty.text' Vty.defAttr desc 910 | ) 911 | ) 912 | in (Vty.vertCat keys Vty.<|> Vty.vertCat descs) 913 | 914 | -- | Recomputes the spine at the current position, then at every position from that point 915 | -- upwards until the zipper is closed, returning the result. 916 | foldSpine :: (Functor f, Z.Idx i f a) => (a -> f a -> a) -> Z.Zipper i f a -> a 917 | foldSpine f z = 918 | case Z.up z of 919 | Nothing -> z ^. Z.focus_ 920 | Just parent -> 921 | let next = f (parent ^. Z.focus_) (fmap Comonad.extract . Z.branches $ parent) 922 | in foldSpine f (parent & Z.focus_ .~ next) 923 | 924 | data UndoZipper a 925 | = UndoZipper 926 | (Seq a) 927 | -- ^ undo states 928 | (Seq a) 929 | -- ^ redo states 930 | -------------------------------------------------------------------------------- /src/Jet/Render.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Jet.Render where 4 | 5 | import Control.Lens 6 | import Control.Monad.State 7 | import qualified Data.List as List 8 | import Data.Maybe 9 | import qualified Graphics.Vty as Vty 10 | import Prettyprinter 11 | import Prettyprinter.Render.Util.StackMachine (renderSimplyDecoratedA) 12 | 13 | data Cursor = Cursor 14 | deriving (Show, Eq) 15 | 16 | data Output = LineBreak | ImgChunk Vty.Image 17 | 18 | renderScreen :: Int -> SimpleDocStream (Either Cursor Vty.Attr) -> [Vty.Image] 19 | renderScreen winHeight doc = do 20 | let (outputs, (_, _, mcursor)) = 21 | doc 22 | & toLineStream 23 | & flip runState ([], 0, Nothing) 24 | 25 | let allLines = 26 | outputs & List.foldr collapse ([], []) 27 | -- clean up anything remaining in the buffer 28 | & ( \(buf, rest) -> 29 | if null buf 30 | then rest 31 | else Vty.horizCat buf : rest 32 | ) 33 | 34 | let cropped = case mcursor of 35 | Nothing -> allLines 36 | Just cursorPos -> takeSurroundingCursor winHeight cursorPos allLines 37 | cropped 38 | where 39 | collapse out (buf, rest) = 40 | case out of 41 | LineBreak -> ([], Vty.horizCat buf : rest) 42 | ImgChunk img -> (img : buf, rest) 43 | 44 | -- Take only enough lines to fill the screen, with the cursor centered don't print any more. 45 | takeSurroundingCursor :: Int -> Int -> [a] -> [a] 46 | takeSurroundingCursor height cursorPos xs 47 | | cursorPos - half > 0 = 48 | xs 49 | & drop (cursorPos - half) 50 | & take height 51 | | otherwise = take height xs 52 | where 53 | half = height `div` 2 54 | 55 | toLineStream :: 56 | SimpleDocStream (Either Cursor Vty.Attr) -> 57 | State ([Vty.Attr], Int, Maybe Int) [Output] 58 | toLineStream doc = 59 | renderSimplyDecoratedA 60 | renderText 61 | pushAnn 62 | popAnn 63 | doc 64 | where 65 | popAnn _ = do 66 | _1 %= drop 1 67 | -- Need to clear existing colors or they bleed to the right. 68 | pure [ImgChunk (Vty.text' Vty.defAttr "")] 69 | pushAnn = \case 70 | Left Cursor -> do 71 | cursorLine <- use _2 72 | _3 ?= cursorLine 73 | pure [] 74 | Right ann -> do 75 | _1 %= (ann :) 76 | pure mempty 77 | -- prettyprinter always renders lines as a single text fragment 78 | renderText "\n" = do 79 | _2 += 1 80 | pure [LineBreak] 81 | -- prettyprinter never passes text with newlines here 82 | renderText txt = do 83 | attr <- uses _1 (fromMaybe Vty.defAttr . listToMaybe) 84 | pure [ImgChunk (Vty.text' attr txt)] 85 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-18.10 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # - ../recursive-zipper 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | # extra-deps: 39 | # - acme-missiles-0.3 40 | # - git: https://github.com/commercialhaskell/stack.git 41 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # 43 | extra-deps: 44 | - recursive-zipper-0.0.0.1 45 | - aeson-extra-0.5.1@sha256:6070bf5aea22283acf72fa0252883e80f389613efb8f40ef928848d8f7b49f83,2829 46 | - Hclip-3.0.0.4@sha256:df341c936594465df25c3b9f93f6ebe3110a36d64a51dbbd1dbd557394bbdba4,1648 47 | 48 | # Override default flag values for local packages and extra-deps 49 | # flags: {} 50 | 51 | # Extra package databases containing global packages 52 | # extra-package-dbs: [] 53 | 54 | # Control whether we use the GHC we find on the path 55 | # system-ghc: true 56 | # 57 | # Require a specific version of stack, using version ranges 58 | # require-stack-version: -any # Default 59 | # require-stack-version: ">=2.7" 60 | # 61 | # Override the architecture used by stack, especially useful on Windows 62 | # arch: i386 63 | # arch: x86_64 64 | # 65 | # Extra directories used by stack for building 66 | # extra-include-dirs: [/path/to/dir] 67 | # extra-lib-dirs: [/path/to/dir] 68 | # 69 | # Allow a newer minor version of GHC than the snapshot specifies 70 | # compiler-check: newer-minor 71 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: recursive-zipper-0.0.0.1@sha256:dc96b1a36c1c1c0d4166756d02e21edcefae0010e668d891cfbbaa8c26a1d65f,1170 9 | pantry-tree: 10 | size: 395 11 | sha256: 32eb74301ae557495b374759426413ab64bb81d148b4505de73207a3fcbed922 12 | original: 13 | hackage: recursive-zipper-0.0.0.1 14 | - completed: 15 | hackage: aeson-extra-0.5.1@sha256:6070bf5aea22283acf72fa0252883e80f389613efb8f40ef928848d8f7b49f83,2829 16 | pantry-tree: 17 | size: 1007 18 | sha256: 3041cdd4b7f4de26eb2b0c9eed2719b3742eb60a13c6501cf7ecb0c22e786b10 19 | original: 20 | hackage: aeson-extra-0.5.1@sha256:6070bf5aea22283acf72fa0252883e80f389613efb8f40ef928848d8f7b49f83,2829 21 | - completed: 22 | hackage: Hclip-3.0.0.4@sha256:df341c936594465df25c3b9f93f6ebe3110a36d64a51dbbd1dbd557394bbdba4,1648 23 | pantry-tree: 24 | size: 205 25 | sha256: bc09b0acdf0ffce64e16a53ffc18d76dc05d4282433cae723402d1b8ecc01301 26 | original: 27 | hackage: Hclip-3.0.0.4@sha256:df341c936594465df25c3b9f93f6ebe3110a36d64a51dbbd1dbd557394bbdba4,1648 28 | snapshots: 29 | - completed: 30 | size: 587546 31 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/10.yaml 32 | sha256: 88b4f81e162ba3adc230a9fcccc4d19ac116377656bab56c7382ca88598b257a 33 | original: lts-18.10 34 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------