chiasma 0.1.0.0 → 0.12.2.0
raw patch · 116 files changed
Files
- LICENSE +28/−24
- README.md +0/−3
- changelog.md +3/−0
- chiasma.cabal +169/−80
- lib/Chiasma.hs +12/−0
- lib/Chiasma/Api/Class.hs +0/−15
- lib/Chiasma/Class/CmdArgs.hs +55/−0
- lib/Chiasma/Codec.hs +66/−24
- lib/Chiasma/Codec/Data.hs +9/−0
- lib/Chiasma/Codec/Data/Client.hs +13/−0
- lib/Chiasma/Codec/Data/Pane.hs +19/−0
- lib/Chiasma/Codec/Data/PaneCoords.hs +17/−0
- lib/Chiasma/Codec/Data/PaneMode.hs +16/−0
- lib/Chiasma/Codec/Data/PanePid.hs +16/−0
- lib/Chiasma/Codec/Data/Session.hs +13/−0
- lib/Chiasma/Codec/Data/Window.hs +13/−0
- lib/Chiasma/Codec/Decode.hs +71/−50
- lib/Chiasma/Codec/Query.hs +20/−25
- lib/Chiasma/Command/Pane.hs +158/−0
- lib/Chiasma/Command/Session.hs +61/−0
- lib/Chiasma/Command/Window.hs +79/−0
- lib/Chiasma/Control/IO/Unsafe.hs +6/−0
- lib/Chiasma/Data/Axis.hs +31/−0
- lib/Chiasma/Data/CapturePaneParams.hs +84/−0
- lib/Chiasma/Data/Cmd.hs +26/−0
- lib/Chiasma/Data/CodecError.hs +8/−0
- lib/Chiasma/Data/CopyModeParams.hs +32/−0
- lib/Chiasma/Data/DecodeError.hs +26/−0
- lib/Chiasma/Data/Direction.hs +22/−0
- lib/Chiasma/Data/Ident.hs +55/−0
- lib/Chiasma/Data/KillPaneParams.hs +24/−0
- lib/Chiasma/Data/LayoutError.hs +6/−0
- lib/Chiasma/Data/List.hs +16/−0
- lib/Chiasma/Data/Pane.hs +0/−23
- lib/Chiasma/Data/PaneSelection.hs +22/−0
- lib/Chiasma/Data/Panes.hs +105/−0
- lib/Chiasma/Data/PipePaneParams.hs +38/−0
- lib/Chiasma/Data/ProcessError.hs +5/−0
- lib/Chiasma/Data/RenderError.hs +21/−0
- lib/Chiasma/Data/ResizePaneParams.hs +58/−0
- lib/Chiasma/Data/SelectParams.hs +65/−0
- lib/Chiasma/Data/SelectWindowParams.hs +38/−0
- lib/Chiasma/Data/SendKeysParams.hs +78/−0
- lib/Chiasma/Data/SessionGroupId.hs +6/−0
- lib/Chiasma/Data/SessionParams.hs +72/−0
- lib/Chiasma/Data/SplitParams.hs +84/−0
- lib/Chiasma/Data/Target.hs +32/−0
- lib/Chiasma/Data/TmuxCommand.hs +213/−0
- lib/Chiasma/Data/TmuxError.hs +23/−0
- lib/Chiasma/Data/TmuxEvent.hs +10/−0
- lib/Chiasma/Data/TmuxId.hs +75/−0
- lib/Chiasma/Data/TmuxNative.hs +10/−0
- lib/Chiasma/Data/TmuxNotification.hs +8/−0
- lib/Chiasma/Data/TmuxOutputBlock.hs +13/−0
- lib/Chiasma/Data/TmuxQuery.hs +6/−0
- lib/Chiasma/Data/TmuxRequest.hs +24/−0
- lib/Chiasma/Data/TmuxResponse.hs +6/−0
- lib/Chiasma/Data/TmuxThunk.hs +0/−53
- lib/Chiasma/Data/View.hs +19/−0
- lib/Chiasma/Data/Views.hs +35/−0
- lib/Chiasma/Data/Window.hs +0/−23
- lib/Chiasma/Data/WindowParams.hs +56/−0
- lib/Chiasma/Data/WindowSelection.hs +19/−0
- lib/Chiasma/Data/WindowState.hs +18/−0
- lib/Chiasma/Data/WithPaneId.hs +39/−0
- lib/Chiasma/Effect/Codec.hs +32/−0
- lib/Chiasma/Effect/TmuxApi.hs +15/−0
- lib/Chiasma/Effect/TmuxClient.hs +21/−0
- lib/Chiasma/Function.hs +7/−0
- lib/Chiasma/Interpreter/Codec.hs +48/−0
- lib/Chiasma/Interpreter/ProcessOutput.hs +24/−0
- lib/Chiasma/Interpreter/Pure.hs +13/−0
- lib/Chiasma/Interpreter/TmuxApi.hs +82/−0
- lib/Chiasma/Interpreter/TmuxClient.hs +246/−0
- lib/Chiasma/Lens/Tree.hs +178/−0
- lib/Chiasma/Lens/Where.hs +6/−0
- lib/Chiasma/Monad/Buffered.hs +0/−29
- lib/Chiasma/Monad/Simple.hs +0/−38
- lib/Chiasma/Monad/Tmux.hs +0/−21
- lib/Chiasma/Native/Api.hs +0/−15
- lib/Chiasma/Native/Parse.hs +18/−26
- lib/Chiasma/Native/Process.hs +0/−45
- lib/Chiasma/Native/TmuxOutputBlock.hs +71/−0
- lib/Chiasma/Pack.hs +112/−0
- lib/Chiasma/Pane.hs +17/−0
- lib/Chiasma/Path.hs +14/−0
- lib/Chiasma/Render.hs +47/−0
- lib/Chiasma/Session.hs +47/−0
- lib/Chiasma/Test/File.hs +0/−32
- lib/Chiasma/Test/Tmux.hs +0/−71
- lib/Chiasma/Tmux.hs +89/−0
- lib/Chiasma/TmuxApi.hs +7/−0
- lib/Chiasma/TmuxNative.hs +68/−0
- lib/Chiasma/Ui/Data/Measure.hs +53/−0
- lib/Chiasma/Ui/Data/RenderableTree.hs +55/−0
- lib/Chiasma/Ui/Data/Tree.hs +44/−0
- lib/Chiasma/Ui/Data/TreeModError.hs +21/−0
- lib/Chiasma/Ui/Data/View.hs +198/−0
- lib/Chiasma/Ui/Data/ViewGeometry.hs +26/−0
- lib/Chiasma/Ui/Data/ViewState.hs +12/−0
- lib/Chiasma/Ui/Lens/Ident.hs +21/−0
- lib/Chiasma/Ui/Measure.hs +79/−0
- lib/Chiasma/Ui/Measure/Balance.hs +169/−0
- lib/Chiasma/Ui/Measure/Weights.hs +36/−0
- lib/Chiasma/Ui/Pane.hs +17/−0
- lib/Chiasma/Ui/ShowTree.hs +45/−0
- lib/Chiasma/Ui/ViewTree.hs +306/−0
- lib/Chiasma/View.hs +125/−0
- lib/Chiasma/View/State.hs +13/−0
- lib/Chiasma/Window.hs +224/−0
- readme.md +3/−0
- test/u/BufferedSpec.hs +0/−45
- test/u/CodecSpec.hs +0/−27
- test/u/OutputParseSpec.hs +0/−30
- test/u/SimpleSpec.hs +0/−32
- test/u/SpecMain.hs +0/−12
LICENSE view
@@ -1,30 +1,34 @@-Copyright Torsten Schmits (c) 2018+Copyright (c) 2022 Torsten Schmits -All rights reserved.+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met: -Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+ 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+ disclaimer.+ 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided with the distribution. - * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by: - * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.+ (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+ contributors, in source or binary form) alone; or+ (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+ copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+ be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution. - * Neither the name of Torsten Schmits nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.+Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+DISCLAIMER++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− README.md
@@ -1,3 +0,0 @@-# Intro--**chiasma** is a tmux api client for Haskell.
+ changelog.md view
@@ -0,0 +1,3 @@+# 0.10.1.0++* Convert to Polysemy
chiasma.cabal view
@@ -1,106 +1,195 @@-cabal-version: 1.12+cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.38.2. -- -- see: https://github.com/sol/hpack------ hash: 3809c3d5d4204b2ce3be054873e25b993f46159354efa61c45f34aa594ce9f29 name: chiasma-version: 0.1.0.0-synopsis: tmux api-description: Please see the README on GitHub at <https://github.com/tek/chiasma-hs>+version: 0.12.2.0+synopsis: A tmux client for Polysemy+description: See https://hackage.haskell.org/package/chiasma/docs/Chiasma.html category: Terminal-homepage: https://github.com/tek/chiasma-hs#readme-bug-reports: https://github.com/tek/chiasma-hs/issues+homepage: https://github.com/tek/chiasma#readme+bug-reports: https://github.com/tek/chiasma/issues author: Torsten Schmits-maintainer: tek@tryp.io-copyright: 2019 Torsten Schmits-license: MIT+maintainer: hackage@tryp.io+copyright: 2025 Torsten Schmits+license: BSD-2-Clause-Patent license-file: LICENSE build-type: Simple extra-source-files:- README.md+ readme.md+ changelog.md source-repository head type: git- location: https://github.com/tek/chiasma-hs+ location: https://github.com/tek/chiasma library exposed-modules:- Chiasma.Api.Class+ Chiasma+ Chiasma.Class.CmdArgs Chiasma.Codec+ Chiasma.Codec.Data+ Chiasma.Codec.Data.Client+ Chiasma.Codec.Data.Pane+ Chiasma.Codec.Data.PaneCoords+ Chiasma.Codec.Data.PaneMode+ Chiasma.Codec.Data.PanePid+ Chiasma.Codec.Data.Session+ Chiasma.Codec.Data.Window Chiasma.Codec.Decode Chiasma.Codec.Query- Chiasma.Data.Pane- Chiasma.Data.TmuxThunk- Chiasma.Data.Window- Chiasma.Monad.Buffered- Chiasma.Monad.Simple- Chiasma.Monad.Tmux- Chiasma.Native.Api+ Chiasma.Command.Pane+ Chiasma.Command.Session+ Chiasma.Command.Window+ Chiasma.Control.IO.Unsafe+ Chiasma.Data.Axis+ Chiasma.Data.CapturePaneParams+ Chiasma.Data.Cmd+ Chiasma.Data.CodecError+ Chiasma.Data.CopyModeParams+ Chiasma.Data.DecodeError+ Chiasma.Data.Direction+ Chiasma.Data.Ident+ Chiasma.Data.KillPaneParams+ Chiasma.Data.LayoutError+ Chiasma.Data.List+ Chiasma.Data.Panes+ Chiasma.Data.PaneSelection+ Chiasma.Data.PipePaneParams+ Chiasma.Data.ProcessError+ Chiasma.Data.RenderError+ Chiasma.Data.ResizePaneParams+ Chiasma.Data.SelectParams+ Chiasma.Data.SelectWindowParams+ Chiasma.Data.SendKeysParams+ Chiasma.Data.SessionGroupId+ Chiasma.Data.SessionParams+ Chiasma.Data.SplitParams+ Chiasma.Data.Target+ Chiasma.Data.TmuxCommand+ Chiasma.Data.TmuxError+ Chiasma.Data.TmuxEvent+ Chiasma.Data.TmuxId+ Chiasma.Data.TmuxNative+ Chiasma.Data.TmuxNotification+ Chiasma.Data.TmuxOutputBlock+ Chiasma.Data.TmuxQuery+ Chiasma.Data.TmuxRequest+ Chiasma.Data.TmuxResponse+ Chiasma.Data.View+ Chiasma.Data.Views+ Chiasma.Data.WindowParams+ Chiasma.Data.WindowSelection+ Chiasma.Data.WindowState+ Chiasma.Data.WithPaneId+ Chiasma.Effect.Codec+ Chiasma.Effect.TmuxApi+ Chiasma.Effect.TmuxClient+ Chiasma.Function+ Chiasma.Interpreter.Codec+ Chiasma.Interpreter.ProcessOutput+ Chiasma.Interpreter.Pure+ Chiasma.Interpreter.TmuxApi+ Chiasma.Interpreter.TmuxClient+ Chiasma.Lens.Tree+ Chiasma.Lens.Where Chiasma.Native.Parse- Chiasma.Native.Process- Chiasma.Test.File- Chiasma.Test.Tmux- other-modules:- Paths_chiasma+ Chiasma.Native.TmuxOutputBlock+ Chiasma.Pack+ Chiasma.Pane+ Chiasma.Path+ Chiasma.Render+ Chiasma.Session+ Chiasma.Tmux+ Chiasma.TmuxApi+ Chiasma.TmuxNative+ Chiasma.Ui.Data.Measure+ Chiasma.Ui.Data.RenderableTree+ Chiasma.Ui.Data.Tree+ Chiasma.Ui.Data.TreeModError+ Chiasma.Ui.Data.View+ Chiasma.Ui.Data.ViewGeometry+ Chiasma.Ui.Data.ViewState+ Chiasma.Ui.Lens.Ident+ Chiasma.Ui.Measure+ Chiasma.Ui.Measure.Balance+ Chiasma.Ui.Measure.Weights+ Chiasma.Ui.Pane+ Chiasma.Ui.ShowTree+ Chiasma.Ui.ViewTree+ Chiasma.View+ Chiasma.View.State+ Chiasma.Window hs-source-dirs: lib- default-extensions: ExistentialQuantification UnicodeSyntax TypeApplications ScopedTypeVariables DeriveGeneric DeriveAnyClass- build-depends:- base >=4.7 && <5- , bytestring- , data-default-class- , directory- , either- , filepath- , free- , lens- , mtl- , parsec- , posix-pty- , process- , resourcet- , split- , transformers- , typed-process- , unix- , unliftio- default-language: Haskell2010--test-suite chiasma-unit- type: exitcode-stdio-1.0- main-is: SpecMain.hs- other-modules:- BufferedSpec- CodecSpec- OutputParseSpec- SimpleSpec- Paths_chiasma- hs-source-dirs:- test/u- default-extensions: ExistentialQuantification UnicodeSyntax TypeApplications ScopedTypeVariables DeriveGeneric DeriveAnyClass- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-extensions:+ AllowAmbiguousTypes+ ApplicativeDo+ BlockArguments+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DerivingStrategies+ DerivingVia+ DisambiguateRecordFields+ DuplicateRecordFields+ FunctionalDependencies+ GADTs+ LambdaCase+ LiberalTypeSynonyms+ MonadComprehensions+ MultiWayIf+ NoFieldSelectors+ OverloadedLabels+ OverloadedLists+ OverloadedRecordDot+ OverloadedStrings+ PackageImports+ PartialTypeSignatures+ PatternSynonyms+ QuantifiedConstraints+ QuasiQuotes+ RecordWildCards+ RecursiveDo+ RoleAnnotations+ TemplateHaskell+ TypeFamilies+ TypeFamilyDependencies+ UndecidableInstances+ UnicodeSyntax+ ViewPatterns+ ghc-options: -fplugin=Polysemy.Plugin -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages build-depends:- HTF- , base >=4.7 && <5+ attoparsec >=0.13+ , base ==4.* , bytestring- , chiasma- , data-default-class- , directory- , either- , filepath- , free- , lens- , mtl+ , composition >=1.0+ , containers+ , exon+ , extra+ , first-class-families+ , lens >=4 , parsec- , posix-pty- , process- , resourcet- , split+ , parsers >=0.12+ , path+ , polysemy+ , polysemy-conc >=0.9+ , polysemy-log >=0.7+ , polysemy-plugin+ , polysemy-process >=0.9+ , polysemy-time >=0.5+ , prelate ==0.9.*+ , prettyprinter >=1.6+ , prettyprinter-ansi-terminal >=1.1+ , random >=1.1+ , text , transformers- , typed-process- , unix- , unliftio- default-language: Haskell2010+ , typed-process >=0.2+ , uuid >=1.3+ mixins:+ base hiding (Prelude)+ , prelate (Prelate as Prelude)+ , prelate hiding (Prelate)+ default-language: GHC2021
+ lib/Chiasma.hs view
@@ -0,0 +1,12 @@+module Chiasma (+ TmuxApi,+ Tmux,+ Codec,+ NativeCodec,+ NativeCodecE,+ NativeCommandCodec,+ NativeCommandCodecE,+) where++import Chiasma.Effect.Codec (Codec, NativeCodec, NativeCodecE, NativeCommandCodec, NativeCommandCodecE)+import Chiasma.Effect.TmuxApi (Tmux, TmuxApi)
− lib/Chiasma/Api/Class.hs
@@ -1,15 +0,0 @@-module Chiasma.Api.Class(- TmuxApi(..),- DecodeTmuxResponse(..),-) where--import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Except (ExceptT)-import Chiasma.Codec.Decode (TmuxDecodeError)-import Chiasma.Data.TmuxThunk (Cmds, TmuxError)--class TmuxApi a where- runCommands :: MonadIO m => a -> ([String] -> Either TmuxDecodeError b) -> Cmds -> ExceptT TmuxError m [b]--class DecodeTmuxResponse a where- decode :: String -> Either TmuxError a
+ lib/Chiasma/Class/CmdArgs.hs view
@@ -0,0 +1,55 @@+module Chiasma.Class.CmdArgs where++import qualified Data.Map.Strict as Map+import Exon (exon)++import Chiasma.Data.Ident (Ident, identText)++class CmdArgs a where+ cmdArgs :: a -> [Text]++flag :: [Text] -> Bool -> [Text]+flag =+ bool []++flag1 :: Text -> Bool -> [Text]+flag1 =+ flag . pure++optionWith :: Text -> (a -> Text) -> Maybe a -> [Text]+optionWith flg f =+ foldMap \ a -> [flg, f a]++option :: Text -> Maybe Text -> [Text]+option flg =+ optionWith flg id++identOption :: Text -> Maybe Ident -> [Text]+identOption flg =+ optionWith flg identText++arg :: Maybe Text -> [Text]+arg =+ maybeToList++envVars :: Map Text Text -> [Text]+envVars =+ concatMap \case+ (k, v) -> ["-e", [exon|#{k}=#{v}|]]+ .+ Map.toList++optionArgs ::+ CmdArgs a =>+ Maybe a ->+ [Text]+optionArgs =+ foldMap cmdArgs++optionArgsWith ::+ CmdArgs a =>+ Text ->+ Maybe a ->+ [Text]+optionArgsWith flg =+ foldMap \ a -> flg : cmdArgs a
lib/Chiasma/Codec.hs view
@@ -1,32 +1,74 @@-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE AllowAmbiguousTypes #-}+module Chiasma.Codec where -module Chiasma.Codec(- TmuxCodec(..),- TmuxQuery(..),-) where+import qualified Data.Text as Text+import GHC.Generics (Rep, to)+import Prelude hiding (to) -import GHC.Generics (Generic, Rep, to)-import Chiasma.Codec.Decode (TmuxDataDecode(..), TmuxDecodeError(TooManyFields))-import Chiasma.Codec.Query (TmuxDataQuery(..))+import Chiasma.Codec.Decode (TmuxDataDecode (..))+import Chiasma.Codec.Query (TmuxDataQuery (..))+import qualified Chiasma.Data.DecodeError as DecodeFailure (DecodeFailure (..))+import Chiasma.Data.DecodeError (DecodeError (DecodeError), DecodeFailure)+import Chiasma.Data.TmuxId (PaneId, SessionId, WindowId)+import Chiasma.Data.TmuxQuery (TmuxQuery (TmuxQuery)) -newtype TmuxQuery =- TmuxQuery { unQ :: String }- deriving (Eq, Show)+-- | Remove one leading and trailing space from tmux output if both are present.+tryTrim :: Text -> Maybe Text+tryTrim text = do+ (prefix, lastChar) <- Text.unsnoc text+ guard (lastChar == ' ')+ (firstChar, payload) <- Text.uncons prefix+ guard (firstChar == ' ')+ pure payload -genDecode :: (Generic a, TmuxDataDecode (Rep a)) => [String] -> Either TmuxDecodeError a+trim :: Text -> Text+trim text =+ fromMaybe text (tryTrim text)++checkRemainder :: ([Text], b) -> Either DecodeFailure b+checkRemainder = \case+ ([], result) -> Right result+ (a, _) -> Left (DecodeFailure.TooManyFields a)++genDecode ::+ Generic a =>+ TmuxDataDecode (Rep a) =>+ Text ->+ Either DecodeError a genDecode fields = do- (rest, result) <- decode' fields- case rest of- [] -> return $ to result- a -> Left $ TooManyFields a+ bimap (DecodeError [fields]) to do+ checkRemainder =<< dataDecode (Text.splitOn " " (trim fields)) class TmuxCodec a where- decode :: [String] -> Either TmuxDecodeError a- default decode :: (Generic a, TmuxDataDecode (Rep a)) => [String] -> Either TmuxDecodeError a- decode = genDecode+ decode :: Text -> Either DecodeError a+ default decode ::+ Generic a =>+ TmuxDataDecode (Rep a) =>+ Text ->+ Either DecodeError a+ decode =+ genDecode - query :: TmuxQuery- default query :: (Generic a, TmuxDataQuery (Rep a)) => TmuxQuery- query = TmuxQuery $ unwords $ query' @(Rep a)+ query :: TmuxQuery+ default query :: TmuxDataQuery (Rep a) => TmuxQuery+ query =+ TmuxQuery (Text.unwords (dataQuery @(Rep a)))++instance TmuxCodec SessionId+instance TmuxCodec WindowId+instance TmuxCodec PaneId++multi ::+ TmuxCodec a =>+ [Text] ->+ Either DecodeError [a]+multi =+ traverse decode++single ::+ TmuxCodec a =>+ [Text] ->+ Either DecodeError a+single = \case+ [out] -> decode out+ [] -> Left (DecodeError [] DecodeFailure.TargetMissing)+ out -> Left (DecodeError out (DecodeFailure.TooManyRecords out))
+ lib/Chiasma/Codec/Data.hs view
@@ -0,0 +1,9 @@+module Chiasma.Codec.Data(+ Session(..),+ Window(..),+ Pane(..),+) where++import Chiasma.Codec.Data.Pane (Pane(..))+import Chiasma.Codec.Data.Session (Session(..))+import Chiasma.Codec.Data.Window (Window(..))
+ lib/Chiasma/Codec/Data/Client.hs view
@@ -0,0 +1,13 @@+module Chiasma.Codec.Data.Client where++import Chiasma.Codec (TmuxCodec)+import Chiasma.Data.TmuxId (ClientId, SessionId)++data Client =+ Client {+ clientName :: ClientId,+ clientControlMode :: Bool,+ sessionId :: SessionId+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (TmuxCodec)
+ lib/Chiasma/Codec/Data/Pane.hs view
@@ -0,0 +1,19 @@+module Chiasma.Codec.Data.Pane where++import Chiasma.Codec (TmuxCodec)+import Chiasma.Data.TmuxId (HasPaneId, PaneId)+import qualified Chiasma.Data.TmuxId as HasPaneId (HasPaneId (..))++data Pane =+ Pane {+ paneId :: PaneId,+ paneWidth :: Int,+ paneHeight :: Int,+ paneTop :: Int,+ paneLeft :: Int+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (TmuxCodec)++instance HasPaneId Pane where+ paneId = (.paneId)
+ lib/Chiasma/Codec/Data/PaneCoords.hs view
@@ -0,0 +1,17 @@+module Chiasma.Codec.Data.PaneCoords where++import Chiasma.Codec (TmuxCodec)+import Chiasma.Data.TmuxId (HasPaneId, PaneId, SessionId, WindowId)+import qualified Chiasma.Data.TmuxId as HasPaneId (HasPaneId (..))++data PaneCoords =+ PaneCoords {+ sessionId :: SessionId,+ windowId :: WindowId,+ paneId :: PaneId+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (TmuxCodec)++instance HasPaneId PaneCoords where+ paneId = (.paneId)
+ lib/Chiasma/Codec/Data/PaneMode.hs view
@@ -0,0 +1,16 @@+module Chiasma.Codec.Data.PaneMode where++import Chiasma.Codec (TmuxCodec)+import Chiasma.Data.TmuxId (HasPaneId, PaneId)+import qualified Chiasma.Data.TmuxId as HasPaneId (HasPaneId (paneId))++data PaneMode =+ PaneMode {+ paneId :: PaneId,+ paneMode :: Text+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (TmuxCodec)++instance HasPaneId PaneMode where+ paneId = (.paneId)
+ lib/Chiasma/Codec/Data/PanePid.hs view
@@ -0,0 +1,16 @@+module Chiasma.Codec.Data.PanePid where++import Chiasma.Codec (TmuxCodec)+import Chiasma.Data.TmuxId (HasPaneId, PaneId)+import qualified Chiasma.Data.TmuxId as HasPaneId (HasPaneId (paneId))++data PanePid =+ PanePid {+ paneId :: PaneId,+ panePid :: Int+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (TmuxCodec)++instance HasPaneId PanePid where+ paneId = (.paneId)
+ lib/Chiasma/Codec/Data/Session.hs view
@@ -0,0 +1,13 @@+module Chiasma.Codec.Data.Session where++import Chiasma.Codec (TmuxCodec)+import Chiasma.Data.TmuxId (SessionId)++-- must be data for now because of how derivation of `TmuxCodec` is implemented+data Session =+ Session {+ sessionId :: SessionId,+ sessionName :: Text+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (TmuxCodec)
+ lib/Chiasma/Codec/Data/Window.hs view
@@ -0,0 +1,13 @@+module Chiasma.Codec.Data.Window where++import Chiasma.Codec (TmuxCodec)+import Chiasma.Data.TmuxId (WindowId)++data Window =+ Window {+ windowId :: WindowId,+ windowWidth :: Int,+ windowHeight :: Int+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (TmuxCodec)
lib/Chiasma/Codec/Decode.hs view
@@ -1,70 +1,91 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}+module Chiasma.Codec.Decode where -module Chiasma.Codec.Decode(- TmuxDecodeError(..),- TmuxPrimDecode(..),- TmuxDataDecode(..),- idParser,- parseId,- readInt,-) where+import qualified Data.Text as Text (null, unpack)+import Data.Text.Read (decimal)+import GHC.Generics (K1 (..), M1 (..), (:*:) (..))+import Prelude hiding (many)+import Text.Parsec.Char (digit, string)+import Text.ParserCombinators.Parsec (GenParser, many, parse) -import GHC.Generics ((:*:)(..), K1(..), M1(..))-import Data.Bifunctor (first, second)-import Text.Read (readEither)-import Text.ParserCombinators.Parsec (- GenParser,- ParseError,- parse,- many,+import Chiasma.Data.DecodeError (DecodeFailure (BoolParsingFailure, IntParsingFailure, ParseFailure, TooFewFields))+import Chiasma.Data.TmuxId (+ ClientId (ClientId),+ PaneId (..),+ SessionId (..),+ WindowId (..),+ panePrefix,+ sessionPrefix,+ windowPrefix, )-import Text.Parsec.Char (char, digit) -data TmuxDecodeError =- ParseFailure String ParseError- |- IntParsingFailure String- |- TooFewFields- |- TooManyFields [String]- deriving (Eq, Show)- class TmuxPrimDecode a where- primDecode :: String -> Either TmuxDecodeError a+ primDecode :: Text -> Either DecodeFailure a class TmuxDataDecode f where- decode' :: [String] -> Either TmuxDecodeError ([String], f a)+ dataDecode :: [Text] -> Either DecodeFailure ([Text], f a) instance (TmuxDataDecode f, TmuxDataDecode g) => TmuxDataDecode (f :*: g) where- decode' fields = do- (rest, left) <- decode' fields- (rest1, right) <- decode' rest- return (rest1, left :*: right)+ dataDecode fields = do+ (rest, left) <- dataDecode fields+ (rest1, right) <- dataDecode rest+ pure (rest1, left :*: right) instance TmuxDataDecode f => (TmuxDataDecode (M1 i c f)) where- decode' fields =- second M1 <$> decode' fields+ dataDecode fields =+ second M1 <$> dataDecode fields instance TmuxPrimDecode a => (TmuxDataDecode (K1 c a)) where- decode' (a:as) = do+ dataDecode (a:as') = do prim <- primDecode a- return (as, K1 prim)- decode' [] = Left TooFewFields+ pure (as', K1 prim)+ dataDecode [] = Left TooFewFields -readInt :: String -> String -> Either TmuxDecodeError Int-readInt input num =- first (const $ IntParsingFailure input) $ readEither num+readInt :: Text -> Text -> Either DecodeFailure Int+readInt text num =+ first (const $ IntParsingFailure text) parsed+ where+ parsed = do+ (num', rest) <- decimal num+ if Text.null rest then Right num' else Left "" instance TmuxPrimDecode Int where primDecode field = readInt field field -idParser :: Char -> GenParser Char st String-idParser sym = char sym >> many digit+instance TmuxPrimDecode Bool where+ primDecode field =+ convert =<< readInt field field+ where+ convert 0 =+ Right False+ convert 1 =+ Right True+ convert _ =+ Left (BoolParsingFailure $ "got non-bool `" <> show field <> "`") -parseId :: (Int -> a) -> Char -> String -> Either TmuxDecodeError a-parseId cons sym input = do- num <- first (ParseFailure "id") $ parse (idParser sym) "none" input- i <- readInt input num- return $ cons i+idParser :: Text -> GenParser Char st Text+idParser sym =+ string (toString sym) *> (toText <$> many digit)++parseId :: (Int -> a) -> Text -> Text -> Either DecodeFailure a+parseId cons sym text = do+ num <- first (ParseFailure "id") $ parse (idParser sym) "none" (Text.unpack text)+ i <- readInt text num+ pure (cons i)++instance TmuxPrimDecode ClientId where+ primDecode = pure . ClientId++instance TmuxPrimDecode SessionId where+ primDecode = parseId SessionId sessionPrefix++instance TmuxPrimDecode WindowId where+ primDecode = parseId WindowId windowPrefix++instance TmuxPrimDecode PaneId where+ primDecode = parseId PaneId panePrefix++instance TmuxPrimDecode [Char] where+ primDecode = Right . toString++instance TmuxPrimDecode Text where+ primDecode = Right
lib/Chiasma/Codec/Query.hs view
@@ -1,39 +1,34 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE AllowAmbiguousTypes #-}--module Chiasma.Codec.Query(- TmuxDataQuery(..),-) where+module Chiasma.Codec.Query where -import GHC.Generics ((:*:), D1, C1, S1, Selector, selName)-import GHC.Unicode (isUpper, toLower)+import Data.Char (isUpper, toLower)+import qualified Data.Text as Text (concatMap, singleton)+import GHC.Generics (C1, D1, S1, Selector, selName, (:*:)) class TmuxDataQuery f where- query' :: [String]--instance (TmuxDataQuery f, TmuxDataQuery g) => TmuxDataQuery (f :*: g) where- query' = query' @f ++ query' @g+ dataQuery :: [Text] instance TmuxDataQuery f => (TmuxDataQuery (D1 c f)) where- query' = query' @f+ dataQuery = dataQuery @f instance TmuxDataQuery f => (TmuxDataQuery (C1 c f)) where- query' = query' @f+ dataQuery = dataQuery @f -trans :: Char -> String-trans a | isUpper a = ['_', toLower a]-trans a = [a]+instance (TmuxDataQuery f, TmuxDataQuery g) => TmuxDataQuery (f :*: g) where+ dataQuery = dataQuery @f <> dataQuery @g -snakeCase :: String -> String-snakeCase = (>>= trans)+trans :: Char -> Text+trans a | isUpper a = toText @String ['_', toLower a]+trans a = Text.singleton a -formatQuery :: String -> String-formatQuery q = "#{" ++ snakeCase q ++ "}"+snakeCase :: Text -> Text+snakeCase =+ Text.concatMap trans +formatQuery :: Text -> Text+formatQuery q = "#{" <> snakeCase q <> "}"+ instance Selector s => (TmuxDataQuery (S1 s f)) where- query' =- [formatQuery query]+ dataQuery =+ [formatQuery (toText query)] where query = selName (undefined :: t s f p)
+ lib/Chiasma/Command/Pane.hs view
@@ -0,0 +1,158 @@+module Chiasma.Command.Pane where++import Prelude hiding (output)++import qualified Chiasma.Codec.Data.Pane as Codec (Pane)+import qualified Chiasma.Codec.Data.PaneMode as Codec (PaneMode (PaneMode))+import Chiasma.Data.Axis (Axis)+import Chiasma.Data.CapturePaneParams (CaptureOutput (Stdout), CapturePaneParams (..))+import qualified Chiasma.Data.CopyModeParams as CopyModeParams+import qualified Chiasma.Data.KillPaneParams as KillPaneParams+import qualified Chiasma.Data.PaneSelection as PaneSelection+import qualified Chiasma.Data.Panes as Panes+import Chiasma.Data.Panes (TmuxPanes)+import Chiasma.Data.PipePaneParams (PipePaneParams (..))+import Chiasma.Data.ResizePaneParams (ResizeAbsolute (ResizeAbsolute), ResizePaneParams (..))+import qualified Chiasma.Data.SelectParams as SelectParams+import qualified Chiasma.Data.SendKeysParams as SendKeysParams+import Chiasma.Data.SendKeysParams (Key, SendKeysParams (..))+import Chiasma.Data.SplitParams (JoinPaneParams (axis, detach, source, target))+import qualified Chiasma.Data.Target as Target+import Chiasma.Data.TmuxCommand (TmuxCommand (..))+import Chiasma.Data.TmuxId (PaneId, WindowId)+import Chiasma.Data.View (View (View))+import qualified Chiasma.Effect.TmuxApi as Tmux+import Chiasma.Effect.TmuxApi (Tmux)++panes ::+ Member (TmuxPanes a) r =>+ Sem r [a]+panes =+ Tmux.send (Panes.List PaneSelection.All)++pane ::+ Member (TmuxPanes a) r =>+ PaneId ->+ Sem r (Maybe a)+pane paneId =+ Tmux.send (Panes.Find paneId)++windowPanes ::+ Member (TmuxPanes a) r =>+ WindowId ->+ Sem r [a]+windowPanes windowId =+ Tmux.send (Panes.List (PaneSelection.InWindow (Target.Window windowId)))++firstWindowPane ::+ Member (TmuxPanes a) r =>+ WindowId ->+ Sem r a+firstWindowPane windowId =+ Tmux.send (Panes.First (PaneSelection.InWindow (Target.Window windowId)))++closePane ::+ Member Tmux r =>+ PaneId ->+ Sem r ()+closePane paneId =+ Tmux.send (KillPane def { KillPaneParams.target = Target.Pane paneId })++isPaneIdOpen ::+ Member (TmuxPanes Codec.Pane) r =>+ PaneId ->+ Sem r Bool+isPaneIdOpen paneId =+ isJust <$> pane paneId++isPaneOpen ::+ Member (TmuxPanes Codec.Pane) r =>+ View PaneId ->+ Sem r Bool+isPaneOpen (View _ (Just paneId)) =+ isPaneIdOpen paneId+isPaneOpen _ =+ pure False++movePane ::+ Member Tmux r =>+ PaneId ->+ PaneId ->+ Axis ->+ Sem r ()+movePane paneId refId axis =+ Tmux.send (MovePane def {+ detach = True,+ source = Just (Target.Pane paneId),+ target = Target.Pane refId,+ axis = Just axis+ })++resizePane ::+ Member Tmux r =>+ PaneId ->+ Axis ->+ Int ->+ Sem r ()+resizePane paneId axis size =+ Tmux.send (ResizePane def {+ target = Target.Pane paneId,+ absolute = Just (ResizeAbsolute axis size)+ })++sendKeys ::+ Member Tmux r =>+ PaneId ->+ [Key] ->+ Sem r ()+sendKeys paneId lines' =+ for_ lines' \ line ->+ Tmux.send (SendKeys def { target = Target.Pane paneId, keys = [line] })++pipePane ::+ Member Tmux r =>+ PaneId ->+ Text ->+ Sem r ()+pipePane paneId cmd =+ Tmux.schedule (PipePane def { target = Target.Pane paneId, command = Just cmd })++capturePane ::+ Member Tmux r =>+ PaneId ->+ Sem r [Text]+capturePane paneId =+ Tmux.send (CapturePane def { target = Target.Pane paneId, escapeSequences = True, output = Just Stdout})++selectPane ::+ Member Tmux r =>+ PaneId ->+ Sem r ()+selectPane paneId =+ Tmux.send (SelectPane def { SelectParams.target = Target.Pane paneId })++copyMode ::+ Member Tmux r =>+ PaneId ->+ Sem r ()+copyMode paneId =+ Tmux.send (CopyMode def { CopyModeParams.target = Target.Pane paneId })++paneMode ::+ Member (TmuxPanes Codec.PaneMode) r =>+ PaneId ->+ Sem r (Maybe Codec.PaneMode)+paneMode =+ pane++quitCopyMode ::+ Member Tmux r =>+ Member (TmuxPanes Codec.PaneMode) r =>+ PaneId ->+ Sem r ()+quitCopyMode paneId =+ traverse_ check =<< pane paneId+ where+ check (Codec.PaneMode _ mode) =+ when (mode == "copy-mode") do+ Tmux.send (SendKeys def { target = Target.Pane paneId, SendKeysParams.copyMode = True, keys = ["cancel"] })
+ lib/Chiasma/Command/Session.hs view
@@ -0,0 +1,61 @@+module Chiasma.Command.Session where++import Chiasma.Codec.Data.Client (Client (Client))+import Chiasma.Codec.Data.Session (Session (Session))+import Chiasma.Data.Ident (Ident)+import Chiasma.Data.SessionParams (SessionParams (..))+import qualified Chiasma.Data.Target as Target+import Chiasma.Data.TmuxCommand (TmuxCommand (ListClients, ListSessions, NewSession, SwitchClient))+import Chiasma.Data.TmuxError (TmuxError (NoClients))+import Chiasma.Data.TmuxId (SessionId)+import qualified Chiasma.Effect.TmuxApi as Tmux+import Chiasma.Effect.TmuxApi (Tmux)++sameId :: SessionId -> Session -> Bool+sameId target (Session i _) = target == i++sessions ::+ Member Tmux r =>+ Sem r [Session]+sessions =+ Tmux.send ListSessions++doesSessionExist ::+ Member Tmux r =>+ SessionId ->+ Sem r Bool+doesSessionExist sessionId =+ any (sameId sessionId) <$> sessions++existingSessionId ::+ Member Tmux r =>+ SessionId ->+ Sem r (Maybe SessionId)+existingSessionId sessionId = do+ exists <- doesSessionExist sessionId+ pure $ if exists then Just sessionId else Nothing++newSession ::+ Member Tmux r =>+ Ident ->+ Sem r Session+newSession name =+ Tmux.send (NewSession def { name = Just name })++clientForSession :: SessionId -> [Client] -> Maybe Client+clientForSession session =+ find \case+ Client _ False sid ->+ sid == session+ _ ->+ False++switchClient ::+ Members [Tmux, Stop TmuxError] r =>+ SessionId ->+ SessionId ->+ Sem r ()+switchClient clientSession session = do+ clients <- Tmux.send ListClients+ Client client _ _ <- stopNote NoClients (clientForSession clientSession clients)+ Tmux.send (SwitchClient client (Target.Session session))
+ lib/Chiasma/Command/Window.hs view
@@ -0,0 +1,79 @@+module Chiasma.Command.Window where++import Exon (exon)+import Path (Abs, Dir, Path)++import Chiasma.Codec.Data.Pane (Pane)+import Chiasma.Codec.Data.Window (Window (Window))+import Chiasma.Data.Ident (Ident)+import Chiasma.Data.LayoutError (LayoutError (LayoutError))+import qualified Chiasma.Data.Target as Target+import Chiasma.Data.TmuxCommand (TmuxCommand (ListWindows, NewWindow, SplitWindow))+import Chiasma.Data.TmuxId (SessionId, WindowId)+import Chiasma.Data.WindowParams (WindowParams (..))+import qualified Chiasma.Data.WindowSelection as WindowSelection+import qualified Chiasma.Effect.TmuxApi as Tmux+import Chiasma.Effect.TmuxApi (Tmux)++sameId :: WindowId -> Window -> Bool+sameId target (Window i _ _) = target == i++windows ::+ Member Tmux r =>+ Sem r [Window]+windows =+ Tmux.send (ListWindows WindowSelection.All)++window ::+ Member Tmux r =>+ WindowId ->+ Sem r (Maybe Window)+window windowId =+ find (sameId windowId) <$> windows++sessionWindows ::+ Member Tmux r =>+ SessionId ->+ Sem r [Window]+sessionWindows sid =+ Tmux.send (ListWindows (WindowSelection.InSession (Target.Session sid)))++-- TODO this could be ListWindow+newSessionWindow ::+ Members [Tmux, Stop LayoutError] r =>+ SessionId ->+ Sem r Window+newSessionWindow sid =+ sessionWindows sid >>= \case+ [w] -> pure w+ ws -> stop (LayoutError [exon|New session contains multiple windows: #{show ws}|])++doesWindowExist ::+ Member Tmux r =>+ WindowId ->+ Sem r Bool+doesWindowExist windowId =+ any (sameId windowId) <$> windows++newWindow ::+ Member Tmux r =>+ SessionId ->+ Ident ->+ Sem r Window+newWindow sid name =+ Tmux.send (NewWindow def { target = Target.Session sid, name = Just name })++splitWindowInDir ::+ Member Tmux r =>+ Path Abs Dir ->+ WindowId ->+ Sem r Pane+splitWindowInDir dir windowId =+ Tmux.send (SplitWindow def { target = Target.Window windowId, detach = True, cwd = Just dir } def)++splitWindow ::+ Member Tmux r =>+ WindowId ->+ Sem r Pane+splitWindow windowId =+ Tmux.send (SplitWindow def { target = Target.Window windowId, detach = True } def)
+ lib/Chiasma/Control/IO/Unsafe.hs view
@@ -0,0 +1,6 @@+module Chiasma.Control.IO.Unsafe where++import GHC.IO.Unsafe (unsafePerformIO)++unsafeLog :: Show a => a -> b -> b+unsafeLog a b = unsafePerformIO $ print a >> pure b
+ lib/Chiasma/Data/Axis.hs view
@@ -0,0 +1,31 @@+module Chiasma.Data.Axis where++import Data.Data (Data)+import Prettyprinter (Pretty (pretty))++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs))++data Axis =+ Horizontal+ |+ Vertical+ deriving stock (Eq, Show, Data)++instance Pretty Axis where+ pretty = \case+ Horizontal -> "h"+ Vertical -> "v"++instance CmdArgs Axis where+ cmdArgs = \case+ Horizontal -> ["-h"]+ Vertical -> ["-v"]++instance Default Axis where+ def =+ Vertical++vertical :: Axis -> Bool+vertical = \case+ Horizontal -> False+ Vertical -> True
+ lib/Chiasma/Data/CapturePaneParams.hs view
@@ -0,0 +1,84 @@+module Chiasma.Data.CapturePaneParams where++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), flag1, optionArgs, optionArgsWith)+import qualified Chiasma.Data.Target as Target+import Chiasma.Data.Target (Target)+import Prelude hiding (output)++data CaptureOutput =+ Stdout+ |+ Buffer Text+ deriving stock (Eq, Show)++instance CmdArgs CaptureOutput where+ cmdArgs = \case+ Stdout -> ["-p"]+ Buffer name -> ["-b", name]++data CaptureLine =+ Edge+ |+ CaptureLine Int+ deriving stock (Eq, Show)++instance CmdArgs CaptureLine where+ cmdArgs = \case+ Edge -> ["-"]+ CaptureLine n -> [show n]++data CapturePaneParams =+ CapturePaneParams {+ output :: Maybe CaptureOutput,+ alternate :: Bool,+ quiet :: Bool,+ escapeSequences :: Bool,+ octal :: Bool,+ joinWrapped :: Bool,+ incomplete :: Bool,+ startLine :: Maybe CaptureLine,+ endLine :: Maybe CaptureLine,+ target :: Target,+ stripBlank :: Bool,+ stripTrailingWs :: Bool+ }+ deriving stock (Eq, Show)++instance Default CapturePaneParams where+ def =+ CapturePaneParams {+ output = Nothing,+ alternate = False,+ quiet = False,+ escapeSequences = False,+ octal = False,+ joinWrapped = True,+ incomplete = False,+ startLine = Nothing,+ endLine = Nothing,+ target = Target.Current,+ stripBlank = True,+ stripTrailingWs = True+ }++instance CmdArgs CapturePaneParams where+ cmdArgs CapturePaneParams {..} =+ flag1 "-a" alternate+ <>+ flag1 "-q" quiet+ <>+ flag1 "-e" escapeSequences+ <>+ flag1 "-C" octal+ <>+ flag1 "-J" joinWrapped+ <>+ flag1 "-P" incomplete+ <>+ optionArgs output+ <>+ optionArgsWith "-S" startLine+ <>+ optionArgsWith "-E" endLine+ <>+ cmdArgs target
+ lib/Chiasma/Data/Cmd.hs view
@@ -0,0 +1,26 @@+module Chiasma.Data.Cmd(+ CmdName(..),+ CmdArgs(..),+ Cmd(..),+ Cmds(..),+ cmd,+) where++newtype CmdName =+ CmdName Text+ deriving stock (Eq, Show)++newtype CmdArgs =+ CmdArgs [Text]+ deriving stock (Eq, Show)++data Cmd =+ Cmd CmdName CmdArgs+ deriving stock (Eq, Show)++newtype Cmds =+ Cmds [Cmd]+ deriving stock (Eq, Show)++cmd :: Text -> [Text] -> Cmd+cmd name args = Cmd (CmdName name) (CmdArgs args)
+ lib/Chiasma/Data/CodecError.hs view
@@ -0,0 +1,8 @@+module Chiasma.Data.CodecError where++import Chiasma.Data.DecodeError (DecodeError)+import Chiasma.Data.TmuxRequest (TmuxRequest)++data CodecError =+ CodecError TmuxRequest DecodeError+ deriving stock (Eq, Show)
+ lib/Chiasma/Data/CopyModeParams.hs view
@@ -0,0 +1,32 @@+module Chiasma.Data.CopyModeParams where++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), flag1)+import Chiasma.Data.Target (Target)++data CopyModeParams =+ CopyModeParams {+ mouseDrag :: Bool,+ scrollUp :: Bool,+ exitBottom :: Bool,+ target :: Target+ }+ deriving stock (Eq, Show)++instance Default CopyModeParams where+ def =+ CopyModeParams {+ mouseDrag = False,+ scrollUp = False,+ exitBottom = False,+ target = def+ }++instance CmdArgs CopyModeParams where+ cmdArgs CopyModeParams {..} =+ flag1 "-M" mouseDrag+ <>+ flag1 "-u" scrollUp+ <>+ flag1 "-e" exitBottom+ <>+ cmdArgs target
+ lib/Chiasma/Data/DecodeError.hs view
@@ -0,0 +1,26 @@+module Chiasma.Data.DecodeError where++import Text.ParserCombinators.Parsec (ParseError)++data DecodeFailure =+ ParseFailure Text ParseError+ |+ IntParsingFailure Text+ |+ BoolParsingFailure Text+ |+ TooFewFields+ |+ TooManyFields [Text]+ |+ TooManyRecords [Text]+ |+ TargetMissing+ deriving stock (Eq, Show)++data DecodeError =+ DecodeError {+ output :: [Text],+ failure :: DecodeFailure+ }+ deriving stock (Eq, Show)
+ lib/Chiasma/Data/Direction.hs view
@@ -0,0 +1,22 @@+module Chiasma.Data.Direction where++import Prelude hiding (Down, Left, Right)++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs))++data Direction =+ Up+ |+ Down+ |+ Left+ |+ Right+ deriving stock (Eq, Show)++instance CmdArgs Direction where+ cmdArgs = \case+ Up -> ["-U"]+ Down -> ["-D"]+ Left -> ["-L"]+ Right -> ["-R"]
+ lib/Chiasma/Data/Ident.hs view
@@ -0,0 +1,55 @@+module Chiasma.Data.Ident where++import Data.Data (Data)+import Data.UUID (UUID)+import qualified Data.UUID as UUID (fromText, toText)+import Prettyprinter (Pretty (..))+import System.Random (randomIO)++data Ident =+ Str Text+ |+ Uuid UUID+ deriving stock (Eq, Show, Ord, Generic, Data)++json ''Ident++class Identifiable a where+ identify :: a -> Ident++instance Identifiable Ident where+ identify = id++instance Pretty Ident where+ pretty =+ pretty . \case+ Str s -> s+ Uuid u -> UUID.toText u++instance Default Ident where+ def =+ Str ""++instance IsString Ident where+ fromString =+ Str . toText++sameIdent ::+ Identifiable a =>+ Identifiable b =>+ a ->+ b ->+ Bool+sameIdent target b =+ identify target == identify b++identText :: Ident -> Text+identText (Str a) = a+identText (Uuid a) = UUID.toText a++generateIdent :: MonadIO m => m Ident+generateIdent = liftIO $ Uuid <$> randomIO++parseIdent :: Text -> Ident+parseIdent text =+ maybe (Str text) Uuid (UUID.fromText text)
+ lib/Chiasma/Data/KillPaneParams.hs view
@@ -0,0 +1,24 @@+module Chiasma.Data.KillPaneParams where++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), flag1)+import Chiasma.Data.Target (Target)++data KillPaneParams =+ KillPaneParams {+ allbut :: Bool,+ target :: Target+ }+ deriving stock (Eq, Show)++instance Default KillPaneParams where+ def =+ KillPaneParams {+ allbut = False,+ target = def+ }++instance CmdArgs KillPaneParams where+ cmdArgs KillPaneParams {..} =+ flag1 "-a" allbut+ <>+ cmdArgs target
+ lib/Chiasma/Data/LayoutError.hs view
@@ -0,0 +1,6 @@+module Chiasma.Data.LayoutError where++newtype LayoutError =+ LayoutError { unLayoutError :: Text }+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString)
+ lib/Chiasma/Data/List.hs view
@@ -0,0 +1,16 @@+module Chiasma.Data.List(+ head',+ tail',+ last',+) where++head' :: [a] -> Maybe a+head' (a : _) = Just a+head' _ = Nothing++tail' :: [a] -> Maybe [a]+tail' (_ : as) = Just as+tail' _ = Nothing++last' :: [a] -> Maybe a+last' = head' . reverse
− lib/Chiasma/Data/Pane.hs
@@ -1,23 +0,0 @@-module Chiasma.Data.Pane(- Pane(..),- PaneId(..),-) where--import GHC.Generics (Generic)-import Chiasma.Codec (TmuxCodec)-import Chiasma.Codec.Decode (TmuxPrimDecode(..), parseId)--newtype PaneId =- PaneId Int- deriving (Eq, Show)--instance TmuxPrimDecode PaneId where- primDecode = parseId PaneId '%'--data Pane =- Pane {- paneId :: PaneId,- paneWidth :: Int,- paneHeight :: Int- }- deriving (Eq, Show, Generic, TmuxCodec)
+ lib/Chiasma/Data/PaneSelection.hs view
@@ -0,0 +1,22 @@+module Chiasma.Data.PaneSelection where++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs))+import Chiasma.Data.Target (Target (Current))++data PaneSelection =+ All+ |+ InSession Target+ |+ InWindow Target+ deriving stock (Eq, Show)++instance CmdArgs PaneSelection where+ cmdArgs = \case+ All -> ["-a"]+ InSession target -> ["-s"] <> cmdArgs target+ InWindow target -> cmdArgs target++instance Default PaneSelection where+ def =+ InWindow Current
+ lib/Chiasma/Data/Panes.hs view
@@ -0,0 +1,105 @@+module Chiasma.Data.Panes where++import Chiasma.Class.CmdArgs (cmdArgs)+import qualified Chiasma.Codec as Codec+import Chiasma.Codec (TmuxCodec, multi, single)+import qualified Chiasma.Data.DecodeError as DecodeFailure+import Chiasma.Data.DecodeError (DecodeError (DecodeError))+import qualified Chiasma.Data.PaneSelection as PaneSelection+import Chiasma.Data.PaneSelection (PaneSelection)+import qualified Chiasma.Data.Target as Target+import Chiasma.Data.TmuxId (PaneId)+import Chiasma.Data.TmuxQuery (TmuxQuery)+import Chiasma.Data.TmuxRequest (TmuxRequest (TmuxRequest))+import Chiasma.Data.TmuxResponse (TmuxResponse (TmuxResponse))+import Chiasma.Data.WithPaneId (WithPaneId (WithPaneId))+import Chiasma.Effect.TmuxApi (TmuxApi)++-- | A 'TmuxApi' command for listing panes, with different query criteria.+-- The constructors taking a 'PaneSelection' list all panes that are present in the selected scope, but may constrain+-- the return value.+-- The constructors 'Get' and 'Find' return only the pane with the requested ID.+data Panes (p :: Type) (a :: Type) :: Type where+ -- | Return all panes covered by the selection.+ List :: PaneSelection -> Panes p [p]+ -- | Return one pane covered by the selection, fail if there is none.+ First :: PaneSelection -> Panes p p+ -- | Return one pane covered by the selection, fail if there is none or more than one.+ One :: PaneSelection -> Panes p p+ -- | Return the pane with the specified ID, fail if there is none.+ Get :: PaneId -> Panes p p+ -- | Return the pane with the specified ID if it exists.+ Find :: PaneId -> Panes p (Maybe p)++type TmuxPanes p =+ TmuxApi (Panes p)++query ::+ ∀ p a .+ TmuxCodec p =>+ Panes p a ->+ TmuxQuery+query _ =+ Codec.query @p++selection :: Panes p a -> PaneSelection+selection = \case+ List ps -> ps+ First ps -> ps+ One ps -> ps+ Get i -> PaneSelection.InWindow (Target.Pane i)+ Find _ -> PaneSelection.All++request ::+ Panes p a ->+ TmuxQuery ->+ TmuxRequest+request (selection -> s) =+ TmuxRequest "list-panes" (cmdArgs s) . Just++encode ::+ ∀ p a .+ TmuxCodec p =>+ Panes p a ->+ TmuxRequest+encode (Get i) =+ request (Get i) (Codec.query @(WithPaneId p))+encode (Find i) =+ request (Find i) (Codec.query @(WithPaneId p))+encode cmd =+ request cmd (query cmd)++sameId :: PaneId -> WithPaneId a -> Maybe a+sameId target (WithPaneId paneId p)+ | target == paneId = Just p+ | otherwise = Nothing++paneById ::+ TmuxCodec p =>+ PaneId ->+ [Text] ->+ Either DecodeError (Maybe p)+paneById paneId out = do+ firstJust (sameId paneId) <$> multi out++decode ::+ ∀ p a .+ TmuxCodec p =>+ TmuxResponse ->+ Panes p a ->+ Either DecodeError a+decode (TmuxResponse out) = \case+ List _ ->+ multi out+ First _ ->+ multi out >>= \case+ [] -> Left (DecodeError out DecodeFailure.TooFewFields)+ a : _ -> Right a+ One _ ->+ single out+ Get paneId -> do+ ps <- multi @(WithPaneId p) out+ maybeToRight (DecodeError out DecodeFailure.TargetMissing) (firstJust (sameId paneId) ps)+ Find paneId -> do+ ps <- multi @(WithPaneId p) out+ pure (firstJust (sameId paneId) ps)
+ lib/Chiasma/Data/PipePaneParams.hs view
@@ -0,0 +1,38 @@+module Chiasma.Data.PipePaneParams where++import Prelude hiding (input, output)++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), arg, flag1)+import Chiasma.Data.Target (Target (Current))++data PipePaneParams =+ PipePaneParams {+ input :: Bool,+ output :: Bool,+ onlyNew :: Bool,+ target :: Target,+ command :: Maybe Text+ }+ deriving stock (Eq, Show)++instance Default PipePaneParams where+ def =+ PipePaneParams {+ input = False,+ output = False,+ onlyNew = False,+ target = Current,+ command = Nothing+ }++instance CmdArgs PipePaneParams where+ cmdArgs PipePaneParams {..} =+ flag1 "-I" input+ <>+ flag1 "-O" output+ <>+ flag1 "-o" onlyNew+ <>+ cmdArgs target+ <>+ arg command
+ lib/Chiasma/Data/ProcessError.hs view
@@ -0,0 +1,5 @@+module Chiasma.Data.ProcessError where++data ProcessError =+ Terminated Text+ deriving stock (Eq, Show)
+ lib/Chiasma/Data/RenderError.hs view
@@ -0,0 +1,21 @@+module Chiasma.Data.RenderError where++import Chiasma.Data.CodecError (CodecError)+import Chiasma.Data.Ident (Ident)+import Chiasma.Data.LayoutError (LayoutError)+import Chiasma.Data.TmuxError (TmuxError)+import Chiasma.Data.Views (ViewsError)++data RenderError =+ NoPrincipal Ident+ |+ Views ViewsError+ |+ Layout LayoutError+ |+ Pack Text+ |+ Fatal TmuxError+ |+ Codec CodecError+ deriving stock (Eq, Show)
+ lib/Chiasma/Data/ResizePaneParams.hs view
@@ -0,0 +1,58 @@+module Chiasma.Data.ResizePaneParams where++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), arg, flag1, optionArgs)+import Chiasma.Data.Axis (Axis (Horizontal, Vertical))+import Chiasma.Data.Direction (Direction)+import Chiasma.Data.Target (Target (Current))++data ResizeAbsolute =+ ResizeAbsolute Axis Int+ deriving stock (Eq, Show)++instance CmdArgs ResizeAbsolute where+ cmdArgs (ResizeAbsolute axis amount) =+ [axisArg axis, show amount]+ where+ axisArg = \case+ Horizontal -> "-x"+ Vertical -> "-y"++data Adjustment =+ Adjustment (Maybe Direction) (Maybe Int)+ deriving stock (Eq, Show)++instance CmdArgs Adjustment where+ cmdArgs (Adjustment dir amount) =+ optionArgs dir <> arg (show <$> amount)++data ResizePaneParams =+ ResizePaneParams {+ absolute :: Maybe ResizeAbsolute,+ adjustment :: Maybe Adjustment,+ zoom :: Bool,+ mouse :: Bool,+ target :: Target+ }+ deriving stock (Eq, Show)++instance Default ResizePaneParams where+ def =+ ResizePaneParams {+ absolute = Nothing,+ adjustment = Nothing,+ zoom = False,+ mouse = False,+ target = Current+ }++instance CmdArgs ResizePaneParams where+ cmdArgs ResizePaneParams {..} =+ optionArgs absolute+ <>+ flag1 "-Z" zoom+ <>+ flag1 "-M" mouse+ <>+ optionArgs adjustment+ <>+ cmdArgs target
+ lib/Chiasma/Data/SelectParams.hs view
@@ -0,0 +1,65 @@+module Chiasma.Data.SelectParams where++import Prelude hiding (input, last)++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), flag1, option, optionArgs)+import Chiasma.Data.Direction (Direction)+import Chiasma.Data.Target (Target)++data SelectInput =+ EnableInput+ |+ DisableInput+ deriving stock (Eq, Show)++instance CmdArgs SelectInput where+ cmdArgs = \case+ EnableInput -> ["-e"]+ DisableInput -> ["-d"]++data SelectMark =+ SelectMark+ |+ SelectUnmark+ deriving stock (Eq, Show)++instance CmdArgs SelectMark where+ cmdArgs = \case+ SelectMark -> ["-m"]+ SelectUnmark -> ["-M"]++data SelectParams =+ SelectParams {+ neighbor :: Maybe Direction,+ last :: Bool,+ input :: Maybe SelectInput,+ mark :: Maybe SelectMark,+ title :: Maybe Text,+ target :: Target+ }+ deriving stock (Eq, Show)++instance Default SelectParams where+ def =+ SelectParams {+ neighbor = Nothing,+ last = False,+ input = Nothing,+ mark = Nothing,+ title = Nothing,+ target = def+ }++instance CmdArgs SelectParams where+ cmdArgs SelectParams {..} =+ optionArgs neighbor+ <>+ flag1 "-l" last+ <>+ optionArgs input+ <>+ optionArgs mark+ <>+ option "-T" title+ <>+ cmdArgs target
+ lib/Chiasma/Data/SelectWindowParams.hs view
@@ -0,0 +1,38 @@+module Chiasma.Data.SelectWindowParams where++import Prelude hiding (last)++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), flag1)+import Chiasma.Data.Target (Target)++data SelectWindowParams =+ SelectWindowParams {+ last :: Bool,+ next :: Bool,+ previous :: Bool,+ toggle :: Bool,+ target :: Target+ }+ deriving stock (Eq, Show)++instance Default SelectWindowParams where+ def =+ SelectWindowParams {+ last = False,+ next = False,+ previous = False,+ toggle = False,+ target = def+ }++instance CmdArgs SelectWindowParams where+ cmdArgs SelectWindowParams {..} =+ flag1 "-l" last+ <>+ flag1 "-n" next+ <>+ flag1 "-p" previous+ <>+ flag1 "-T" toggle+ <>+ cmdArgs target
+ lib/Chiasma/Data/SendKeysParams.hs view
@@ -0,0 +1,78 @@+module Chiasma.Data.SendKeysParams where++import qualified Data.Text as Text+import Exon (exon)+import Prelude hiding (repeat)++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), flag1, optionWith)+import Chiasma.Data.Target (Target)++escape :: Text -> Text+escape fragment =+ [exon|"#{escapeQuotes}"|]+ where+ escapeQuotes =+ Text.replace [exon|"|] [exon|\"|] fragment++data Key =+ Key Text+ |+ Lit Text+ deriving stock (Eq, Show)++instance IsString Key where+ fromString =+ Lit . toText++instance CmdArgs Key where+ cmdArgs = \case+ Key k -> [k]+ Lit s -> [escape s]++data SendKeysParams =+ SendKeysParams {+ enter :: Bool,+ literal :: Bool,+ hex :: Bool,+ reset :: Bool,+ mouse :: Bool,+ copyMode :: Bool,+ repeat :: Maybe Int,+ keys :: [Key],+ target :: Target+ }+ deriving stock (Eq, Show)++instance Default SendKeysParams where+ def =+ SendKeysParams {+ enter = True,+ literal = False,+ hex = False,+ reset = False,+ mouse = False,+ copyMode = False,+ repeat = Nothing,+ keys = mempty,+ target = def+ }++instance CmdArgs SendKeysParams where+ cmdArgs SendKeysParams {..} =+ flag1 "-l" literal+ <>+ flag1 "-H" hex+ <>+ flag1 "-R" reset+ <>+ flag1 "-M" mouse+ <>+ flag1 "-X" copyMode+ <>+ optionWith "-N" show repeat+ <>+ cmdArgs target+ <>+ (cmdArgs =<< keys)+ <>+ flag1 "enter" (enter && not copyMode)
+ lib/Chiasma/Data/SessionGroupId.hs view
@@ -0,0 +1,6 @@+module Chiasma.Data.SessionGroupId where++newtype SessionGroupId =+ SessionGroupId { unSessionGroupId :: Text }+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString)
+ lib/Chiasma/Data/SessionParams.hs view
@@ -0,0 +1,72 @@+module Chiasma.Data.SessionParams where++import Path (Abs, Dir, Path)++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), arg, envVars, flag1, identOption, optionWith)+import Chiasma.Data.Ident (Ident)+import Chiasma.Data.SessionGroupId (SessionGroupId (unSessionGroupId))+import Chiasma.Path (pathText)++data SessionParams =+ SessionParams {+ attach :: Bool,+ defaultSize :: Bool,+ detach :: Bool,+ exitClient :: Bool,+ printInfo :: Bool,+ cwd :: Maybe (Path Abs Dir),+ environment :: Map Text Text,+ name :: Maybe Ident,+ windowName :: Maybe Ident,+ target :: Maybe SessionGroupId,+ width :: Maybe Int,+ height :: Maybe Int,+ command :: Maybe Text+ }+ deriving stock (Eq, Show)++instance Default SessionParams where+ def =+ SessionParams {+ attach = False,+ defaultSize = False,+ detach = False,+ exitClient = False,+ printInfo = True,+ cwd = Nothing,+ environment = mempty,+ name = Nothing,+ windowName = Nothing,+ target = Nothing,+ width = Nothing,+ height = Nothing,+ command = Nothing+ }++instance CmdArgs SessionParams where+ cmdArgs SessionParams {..} =+ flag1 "-A" attach+ <>+ flag1 "-d" defaultSize+ <>+ flag1 "-D" detach+ <>+ envVars environment+ <>+ flag1 "-P" printInfo+ <>+ flag1 "-X" exitClient+ <>+ optionWith "-c" pathText cwd+ <>+ identOption "-n" windowName+ <>+ identOption "-s" name+ <>+ optionWith "-t" (.unSessionGroupId) target+ <>+ optionWith "-x" show width+ <>+ optionWith "-y" show height+ <>+ arg command
+ lib/Chiasma/Data/SplitParams.hs view
@@ -0,0 +1,84 @@+module Chiasma.Data.SplitParams where++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), flag1, optionArgs)+import Chiasma.Data.Axis (Axis)+import Chiasma.Data.Target (Target (Current), formatTarget)++data SplitSize =+ Units Int+ |+ Percentage Int+ deriving stock (Eq, Show)++instance CmdArgs SplitSize where+ cmdArgs = \case+ Units n -> ["-l", show n]+ Percentage n -> ["-p", show n]++data SplitWindowParams =+ SplitWindowParams {+ axis :: Maybe Axis,+ size :: Maybe SplitSize,+ before :: Bool,+ fullSize :: Bool,+ readStdin :: Bool+ }+ deriving stock (Eq, Show)++instance Default SplitWindowParams where+ def =+ SplitWindowParams {+ axis = Nothing,+ size = Nothing,+ before = False,+ fullSize = False,+ readStdin = False+ }++instance CmdArgs SplitWindowParams where+ cmdArgs SplitWindowParams {..} =+ optionArgs axis+ <>+ optionArgs size+ <>+ flag1 "-b" before+ <>+ flag1 "-f" fullSize+ <>+ flag1 "-K" readStdin++data JoinPaneParams =+ JoinPaneParams {+ axis :: Maybe Axis,+ size :: Maybe SplitSize,+ before :: Bool,+ detach :: Bool,+ source :: Maybe Target,+ target :: Target+ }+ deriving stock (Eq, Show)++instance Default JoinPaneParams where+ def =+ JoinPaneParams {+ axis = Nothing,+ size = Nothing,+ before = False,+ detach = False,+ source = Nothing,+ target = Current+ }++instance CmdArgs JoinPaneParams where+ cmdArgs JoinPaneParams {..} =+ optionArgs axis+ <>+ optionArgs size+ <>+ flag1 "-b" before+ <>+ flag1 "-d" detach+ <>+ foldMap (formatTarget ["-s"]) source+ <>+ cmdArgs target
+ lib/Chiasma/Data/Target.hs view
@@ -0,0 +1,32 @@+module Chiasma.Data.Target where++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs))+import Chiasma.Data.TmuxId (PaneId, SessionId, WindowId, formatId)++data Target =+ Pane PaneId+ |+ Window WindowId+ |+ Session SessionId+ |+ Current+ deriving stock (Eq, Show)++formatTarget :: [Text] -> Target -> [Text]+formatTarget pre = \case+ Pane i -> pre <> [formatId i]+ Window i -> pre <> [formatId i]+ Session i -> pre <> [formatId i]+ Current -> []++instance CmdArgs Target where+ cmdArgs = \case+ Pane i -> ["-t", formatId i]+ Window i -> ["-t", formatId i]+ Session i -> ["-t", formatId i]+ Current -> []++instance Default Target where+ def =+ Current
+ lib/Chiasma/Data/TmuxCommand.hs view
@@ -0,0 +1,213 @@+module Chiasma.Data.TmuxCommand where++import Data.List (dropWhileEnd)+import qualified Data.Text as Text+import Exon (exon)+import Text.Show (shows)++import Chiasma.Class.CmdArgs (cmdArgs)+import qualified Chiasma.Codec as Codec+import Chiasma.Codec (multi, single)+import Chiasma.Codec.Data.Client (Client)+import Chiasma.Codec.Data.Pane (Pane)+import Chiasma.Codec.Data.Session (Session)+import Chiasma.Codec.Data.Window (Window)+import Chiasma.Data.CapturePaneParams (CapturePaneParams (..))+import Chiasma.Data.CopyModeParams (CopyModeParams)+import Chiasma.Data.DecodeError (DecodeError)+import Chiasma.Data.KillPaneParams (KillPaneParams)+import Chiasma.Data.PaneSelection (PaneSelection)+import Chiasma.Data.PipePaneParams (PipePaneParams)+import Chiasma.Data.ResizePaneParams (ResizePaneParams)+import Chiasma.Data.SelectParams (SelectParams)+import Chiasma.Data.SelectWindowParams (SelectWindowParams)+import Chiasma.Data.SendKeysParams (SendKeysParams)+import Chiasma.Data.SessionParams (SessionParams)+import Chiasma.Data.SplitParams (JoinPaneParams, SplitWindowParams)+import Chiasma.Data.Target (Target)+import Chiasma.Data.TmuxId (ClientId (ClientId))+import Chiasma.Data.TmuxQuery (TmuxQuery)+import Chiasma.Data.TmuxRequest (TmuxRequest (TmuxRequest))+import Chiasma.Data.TmuxResponse (TmuxResponse (TmuxResponse))+import Chiasma.Data.WindowParams (WindowParams)+import Chiasma.Data.WindowSelection (WindowSelection)+import Chiasma.Function (applyWhen)++data TmuxCommand :: Type -> Type where+ Fmap :: (a -> b) -> TmuxCommand a -> TmuxCommand b+ ListPanes :: PaneSelection -> TmuxCommand [Pane]+ ListWindows :: WindowSelection -> TmuxCommand [Window]+ ListSessions :: TmuxCommand [Session]+ ListClients :: TmuxCommand [Client]+ SwitchClient :: ClientId -> Target -> TmuxCommand ()+ NewWindow :: WindowParams -> TmuxCommand Window+ SplitWindow :: WindowParams -> SplitWindowParams -> TmuxCommand Pane+ SelectWindow :: SelectWindowParams -> TmuxCommand ()+ NewSession :: SessionParams -> TmuxCommand Session+ CopyMode :: CopyModeParams -> TmuxCommand ()+ SendKeys :: SendKeysParams -> TmuxCommand ()+ SelectPane :: SelectParams -> TmuxCommand ()+ KillPane :: KillPaneParams -> TmuxCommand ()+ MovePane :: JoinPaneParams -> TmuxCommand ()+ ResizePane :: ResizePaneParams -> TmuxCommand ()+ PipePane :: PipePaneParams -> TmuxCommand ()+ CapturePane :: CapturePaneParams -> TmuxCommand [Text]+ KillServer :: TmuxCommand ()++instance Functor TmuxCommand where+ fmap = Fmap++instance Show (TmuxCommand a) where+ showsPrec d = \case+ Fmap _ cmd ->+ showParen (d > 10) [exon|Fmap #{showsPrec 11 cmd}|]+ ListPanes sel ->+ showParen (d > 10) [exon|ListPanes #{showsPrec 11 sel}|]+ ListWindows sel ->+ showParen (d > 10) [exon|ListWindows #{showsPrec 11 sel}|]+ ListClients ->+ showString "ListClients"+ ListSessions ->+ showString "ListSessions"+ SwitchClient c t ->+ showParen (d > 10) [exon|SwitchClient #{showsPrec 11 c} #{showsPrec 11 t}|]+ NewWindow params ->+ showParen (d > 10) [exon|NewWindow #{showsPrec 11 params}|]+ SplitWindow wParams sParams ->+ showParen (d > 10) [exon|SplitWindow #{showsPrec 11 wParams} #{showsPrec 11 sParams}|]+ SelectWindow params ->+ showParen (d > 10) [exon|SelectWindow #{showsPrec 11 params}|]+ NewSession params ->+ showParen (d > 10) [exon|NewSession #{showsPrec 11 params}|]+ CopyMode params ->+ showParen (d > 10) [exon|SelectPane #{showsPrec 11 params}|]+ SendKeys params ->+ showParen (d > 10) [exon|SendKeys #{showsPrec 11 params}|]+ SelectPane paneId ->+ showParen (d > 10) [exon|SelectPane #{shows paneId}|]+ KillPane params ->+ showParen (d > 10) [exon|KillPane #{showsPrec 11 params}|]+ MovePane params ->+ showParen (d > 10) [exon|MovePane #{showsPrec 11 params}|]+ ResizePane params ->+ showParen (d > 10) [exon|ResizePane #{showsPrec 11 params}|]+ PipePane params ->+ showParen (d > 10) [exon|PipePane #{showsPrec 11 params}|]+ CapturePane params ->+ showParen (d > 10) [exon|CapturePane #{showsPrec 11 params}|]+ KillServer ->+ showString "KillServer"++query ::+ ∀ a .+ TmuxCommand a ->+ Maybe TmuxQuery+query = \case+ Fmap _ cmd -> query cmd+ ListPanes _ -> Just (Codec.query @Pane)+ ListWindows _ -> Just (Codec.query @Window)+ ListSessions -> Just (Codec.query @Session)+ ListClients -> Just (Codec.query @Client)+ SwitchClient _ _ -> Nothing+ NewWindow _ -> Just (Codec.query @Window)+ SplitWindow _ _ -> Just (Codec.query @Pane)+ SelectWindow _ -> Nothing+ NewSession _ -> Just (Codec.query @Session)+ CopyMode _ -> Nothing+ SendKeys _ -> Nothing+ SelectPane _ -> Nothing+ KillPane _ -> Nothing+ MovePane _ -> Nothing+ ResizePane _ -> Nothing+ PipePane _ -> Nothing+ CapturePane _ -> Nothing+ KillServer -> Nothing++request :: TmuxCommand a -> Maybe TmuxQuery -> TmuxRequest+request = \case+ Fmap _ c ->+ request c+ ListPanes selection ->+ TmuxRequest "list-panes" (cmdArgs selection)+ ListWindows selection ->+ TmuxRequest "list-windows" (cmdArgs selection)+ ListSessions ->+ TmuxRequest "list-sessions" []+ ListClients ->+ TmuxRequest "list-clients" []+ SwitchClient (ClientId client) target ->+ TmuxRequest "switch-client" (["-c", client] <> cmdArgs target)+ NewWindow params ->+ TmuxRequest "new-window" (cmdArgs params)+ SplitWindow wParams sParams ->+ TmuxRequest "split-window" (cmdArgs wParams <> cmdArgs sParams)+ SelectWindow params ->+ TmuxRequest "select-window" (cmdArgs params)+ NewSession params ->+ TmuxRequest "new-session" (cmdArgs params)+ CopyMode params ->+ TmuxRequest "copy-mode" (cmdArgs params)+ SendKeys params ->+ TmuxRequest "send-keys" (cmdArgs params)+ SelectPane params ->+ TmuxRequest "select-pane" (cmdArgs params)+ KillPane params ->+ TmuxRequest "kill-pane" (cmdArgs params)+ MovePane params ->+ TmuxRequest "move-pane" (cmdArgs params)+ ResizePane params ->+ TmuxRequest "resize-pane" (cmdArgs params)+ PipePane params ->+ TmuxRequest "pipe-pane" (cmdArgs params)+ CapturePane params ->+ TmuxRequest "capture-pane" (cmdArgs params)+ KillServer ->+ TmuxRequest "kill-server" []++encode :: TmuxCommand a -> TmuxRequest+encode cmd =+ request cmd (query cmd)++decode :: TmuxResponse -> TmuxCommand a -> Either DecodeError a+decode (TmuxResponse out) = \case+ Fmap f cmd ->+ f <$> decode (TmuxResponse out) cmd+ ListPanes _ ->+ multi out+ ListWindows _ ->+ multi out+ ListSessions ->+ multi out+ ListClients ->+ multi out+ SwitchClient _ _ ->+ unit+ NewWindow _ ->+ single out+ SplitWindow _ _ ->+ single out+ SelectWindow _ ->+ unit+ NewSession _ ->+ single out+ CopyMode _ ->+ unit+ SendKeys _ ->+ unit+ SelectPane _ ->+ unit+ KillPane _ ->+ unit+ MovePane _ ->+ unit+ ResizePane _ ->+ unit+ PipePane _ ->+ unit+ CapturePane CapturePaneParams {stripBlank, stripTrailingWs} ->+ pure $+ applyWhen stripBlank (dropWhileEnd ("" ==)) $+ applyWhen stripTrailingWs (fmap Text.stripEnd) $+ out+ KillServer ->+ unit
+ lib/Chiasma/Data/TmuxError.hs view
@@ -0,0 +1,23 @@+module Chiasma.Data.TmuxError where++import Polysemy.Process.Data.ProcessError (ProcessError)++import Chiasma.Data.CodecError (CodecError (CodecError))+import Chiasma.Data.DecodeError (DecodeError)+import Chiasma.Data.TmuxRequest (TmuxRequest)++data TmuxError =+ ProcessFailed ProcessError+ |+ RequestFailed TmuxRequest [Text]+ |+ DecodeFailed TmuxRequest DecodeError+ |+ NoClients+ |+ NoExe+ deriving stock (Eq, Show)++codec :: CodecError -> TmuxError+codec (CodecError req err) =+ DecodeFailed req err
+ lib/Chiasma/Data/TmuxEvent.hs view
@@ -0,0 +1,10 @@+module Chiasma.Data.TmuxEvent where++import Chiasma.Data.TmuxNotification (TmuxNotification)+import Chiasma.Data.TmuxOutputBlock (TmuxOutputBlock)++data TmuxEvent =+ Response TmuxOutputBlock+ |+ Notification TmuxNotification+ deriving stock (Eq, Show)
+ lib/Chiasma/Data/TmuxId.hs view
@@ -0,0 +1,75 @@+module Chiasma.Data.TmuxId where++import Data.Data (Data)+import Prettyprinter (Pretty (..))++newtype ClientId =+ ClientId { unClientId :: Text }+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString)++instance Pretty ClientId where+ pretty = pretty . (.unClientId)++sessionPrefix :: Text+sessionPrefix = "$"++newtype SessionId =+ SessionId Int+ deriving stock (Eq, Show, Generic)+ deriving newtype (Num, Ord)++instance Pretty SessionId where+ pretty = pretty . formatId++windowPrefix :: Text+windowPrefix = "@"++newtype WindowId =+ WindowId Int+ deriving stock (Eq, Show, Generic)+ deriving newtype (Num, Ord)++instance Pretty WindowId where+ pretty = pretty . formatId++panePrefix :: Text+panePrefix = "%"++newtype PaneId =+ PaneId Int+ deriving stock (Eq, Show, Generic, Data)+ deriving newtype (Num, Ord)++instance Pretty PaneId where+ pretty = pretty . formatId++class HasPaneId a where+ paneId :: a -> PaneId++newtype TmuxIdPrefix a =+ TmuxIdPrefix { unTmuxIdPrefix :: Text }+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString)++class TmuxId a where+ prefix :: TmuxIdPrefix a+ number :: a -> Int++ formatId :: a -> Text+ formatId a =+ p <> show (number a)+ where+ (TmuxIdPrefix p) = prefix @a++instance TmuxId SessionId where+ prefix = TmuxIdPrefix sessionPrefix+ number (SessionId i) = i++instance TmuxId WindowId where+ prefix = TmuxIdPrefix windowPrefix+ number (WindowId i) = i++instance TmuxId PaneId where+ prefix = TmuxIdPrefix panePrefix+ number (PaneId i) = i
+ lib/Chiasma/Data/TmuxNative.hs view
@@ -0,0 +1,10 @@+module Chiasma.Data.TmuxNative where++import Path (Abs, File, Path)++data TmuxNative =+ TmuxNative {+ executable :: Path Abs File,+ tmuxServerSocket :: Maybe (Path Abs File)+ }+ deriving stock (Eq, Show)
+ lib/Chiasma/Data/TmuxNotification.hs view
@@ -0,0 +1,8 @@+module Chiasma.Data.TmuxNotification where++data TmuxNotification =+ TmuxNotification {+ name :: Text,+ args :: [Text]+ }+ deriving stock (Eq, Show, Ord)
+ lib/Chiasma/Data/TmuxOutputBlock.hs view
@@ -0,0 +1,13 @@+module Chiasma.Data.TmuxOutputBlock where++data End =+ EndSuccess+ |+ EndError+ deriving stock (Eq, Show)++data TmuxOutputBlock =+ Success [Text]+ |+ Error [Text]+ deriving stock (Eq, Show)
+ lib/Chiasma/Data/TmuxQuery.hs view
@@ -0,0 +1,6 @@+module Chiasma.Data.TmuxQuery where++newtype TmuxQuery =+ TmuxQuery { unTmuxQuery :: Text }+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString, Semigroup, Monoid)
+ lib/Chiasma/Data/TmuxRequest.hs view
@@ -0,0 +1,24 @@+module Chiasma.Data.TmuxRequest where++import qualified Data.Text as Text+import Chiasma.Data.TmuxQuery (TmuxQuery (TmuxQuery))++data TmuxRequest =+ TmuxRequest {+ cmd :: Text,+ args :: [Text],+ query :: Maybe TmuxQuery+ }+ deriving stock (Eq, Show)++queryArgs :: TmuxQuery -> [Text]+queryArgs (TmuxQuery q) =+ ["-F", "'", q, "'"]++cmdline :: TmuxRequest -> [Text]+cmdline TmuxRequest { ..} =+ cmd : args ++ foldMap queryArgs query ++ ["\n"]++encode :: TmuxRequest -> ByteString+encode req =+ encodeUtf8 (Text.unwords (cmdline req))
+ lib/Chiasma/Data/TmuxResponse.hs view
@@ -0,0 +1,6 @@+module Chiasma.Data.TmuxResponse where++newtype TmuxResponse =+ TmuxResponse { unTmuxResponse :: [Text] }+ deriving stock (Eq, Show)+ deriving newtype (Semigroup, Monoid)
− lib/Chiasma/Data/TmuxThunk.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE StandaloneDeriving #-}--module Chiasma.Data.TmuxThunk(- CmdName(..),- CmdArgs(..),- TmuxThunk(..),- TmuxError(..),- Cmd(..),- Cmds(..),- cmd,-) where--import Text.ParserCombinators.Parsec (ParseError)-import Chiasma.Codec.Decode (TmuxDecodeError)--newtype CmdName =- CmdName String- deriving (Eq, Show)--newtype CmdArgs =- CmdArgs [String]- deriving (Eq, Show)--data Cmd =- Cmd CmdName CmdArgs- deriving (Eq, Show)--newtype Cmds =- Cmds [Cmd]- deriving (Eq, Show)--data TmuxError =- ProcessFailed Cmds String- |- OutputParsingFailed Cmds [String] ParseError- |- NoOutput Cmds- |- DecodingFailed Cmds String TmuxDecodeError- deriving (Eq, Show)--data TmuxThunk next =- ∀ a . Read Cmd ([String] -> Either TmuxDecodeError a) ([a] -> next)- |- Write Cmd (() -> next)- |- Failed TmuxError--deriving instance Functor TmuxThunk--cmd :: String -> [String] -> Cmd-cmd name args = Cmd (CmdName name) (CmdArgs args)
+ lib/Chiasma/Data/View.hs view
@@ -0,0 +1,19 @@+module Chiasma.Data.View where++import qualified Control.Lens as Lens (set)++import Chiasma.Data.Ident (Ident, Identifiable (..))++data View a =+ View {+ ident :: Ident,+ id :: Maybe a+ }+ deriving stock (Eq, Show, Generic)++instance Identifiable (View a) where+ identify = (.ident)++setViewId :: a -> View a -> View a+setViewId =+ Lens.set #id . Just
+ lib/Chiasma/Data/Views.hs view
@@ -0,0 +1,35 @@+module Chiasma.Data.Views where++import Control.Lens (makeClassy)+import Prettyprinter (Doc)+import Prettyprinter.Render.Terminal (AnsiStyle)++import Chiasma.Data.Ident (Ident)+import Chiasma.Data.TmuxId (PaneId, SessionId, WindowId)+import Chiasma.Data.View (View)++data ViewsError =+ NoSuchSession Ident+ |+ NoSuchWindow Ident+ |+ NoSuchPane Ident+ |+ NoPaneId Ident+ deriving stock (Eq, Show)++data Views =+ Views {+ _sessions :: [View SessionId],+ _windows :: [View WindowId],+ _panes :: [View PaneId],+ _log :: [Doc AnsiStyle]+ }+ deriving stock (Show, Generic)+ deriving anyclass (Default)++makeClassy ''Views++instance Eq Views where+ (Views sa wa pa _) == (Views sb wb pb _) =+ (sa == sb) && (wa == wb) && (pa == pb)
− lib/Chiasma/Data/Window.hs
@@ -1,23 +0,0 @@-module Chiasma.Data.Window(- Window(..),- WindowId(..),-) where--import GHC.Generics (Generic)-import Chiasma.Codec (TmuxCodec)-import Chiasma.Codec.Decode (TmuxPrimDecode(..), parseId)--newtype WindowId =- WindowId Int- deriving (Eq, Show)--instance TmuxPrimDecode WindowId where- primDecode = parseId WindowId '@'--data Window =- Window {- windowId :: WindowId,- windowWidth :: Int,- windowHeight :: Int- }- deriving (Eq, Show, Generic, TmuxCodec)
+ lib/Chiasma/Data/WindowParams.hs view
@@ -0,0 +1,56 @@+module Chiasma.Data.WindowParams where++import Path (Abs, Dir, Path)++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs), arg, envVars, flag1, identOption, optionWith)+import Chiasma.Data.Ident (Ident)+import Chiasma.Data.Target (Target)+import Chiasma.Path (pathText')++data WindowParams =+ WindowParams {+ after :: Bool,+ detach :: Bool,+ killExisting :: Bool,+ printInfo :: Bool,+ cwd :: Maybe (Path Abs Dir),+ environment :: Map Text Text,+ name :: Maybe Ident,+ target :: Target,+ command :: Maybe Text+ }+ deriving stock (Eq, Show)++instance Default WindowParams where+ def =+ WindowParams {+ after = False,+ detach = False,+ killExisting = False,+ printInfo = True,+ cwd = Nothing,+ environment = mempty,+ name = Nothing,+ target = def,+ command = Nothing+ }++instance CmdArgs WindowParams where+ cmdArgs WindowParams {..} =+ flag1 "-a" after+ <>+ flag1 "-d" detach+ <>+ flag1 "-k" killExisting+ <>+ flag1 "-P" printInfo+ <>+ optionWith "-c" pathText' cwd+ <>+ envVars environment+ <>+ identOption "-n" name+ <>+ cmdArgs target+ <>+ arg command
+ lib/Chiasma/Data/WindowSelection.hs view
@@ -0,0 +1,19 @@+module Chiasma.Data.WindowSelection where++import Chiasma.Class.CmdArgs (CmdArgs (cmdArgs))+import Chiasma.Data.Target (Target (Current))++data WindowSelection =+ All+ |+ InSession Target+ deriving stock (Eq, Show)++instance CmdArgs WindowSelection where+ cmdArgs = \case+ All -> ["-a"]+ InSession target -> cmdArgs target++instance Default WindowSelection where+ def =+ InSession Current
+ lib/Chiasma/Data/WindowState.hs view
@@ -0,0 +1,18 @@+module Chiasma.Data.WindowState(+ WindowState(..),+) where++import qualified Chiasma.Codec.Data as Codec (Window, Pane)+import Chiasma.Data.Ident (Ident)+import Chiasma.Data.TmuxId (PaneId)+import Chiasma.Ui.Data.RenderableTree (RenderableTree)++data WindowState =+ WindowState {+ wsNativeWindow :: Codec.Window,+ wsNativeRefPane :: Codec.Pane,+ wsWindowIdent :: Ident,+ wsLayout :: RenderableTree,+ wsReferencePane :: PaneId+ }+ deriving stock (Eq, Show)
+ lib/Chiasma/Data/WithPaneId.hs view
@@ -0,0 +1,39 @@+module Chiasma.Data.WithPaneId where++import qualified Data.Text as Text++import Chiasma.Codec (TmuxCodec (decode, query), trim)+import Chiasma.Codec.Decode (primDecode)+import Chiasma.Data.DecodeError (DecodeError (DecodeError), DecodeFailure (TooFewFields))+import qualified Chiasma.Data.TmuxId as TmuxId+import Chiasma.Data.TmuxId (HasPaneId, PaneId)+import Chiasma.Data.TmuxQuery (TmuxQuery (TmuxQuery))++data WithPaneId a =+ WithPaneId {+ paneId :: PaneId,+ pane :: a+ }+ deriving stock (Eq, Show, Generic)++instance HasPaneId (WithPaneId a) where+ paneId = (.paneId)++safeBreakOn :: Text -> Text -> Maybe (Text, Text)+safeBreakOn n = \case+ "" -> Nothing+ t -> Just (second (Text.drop 1) (Text.breakOn n t))++instance TmuxCodec a => TmuxCodec (WithPaneId a) where+ decode payload =+ case safeBreakOn " " (trim payload) of+ Just (idField, rest) -> do+ pane <- decode rest+ paneId <- first (DecodeError [payload]) (primDecode idField)+ pure WithPaneId {..}+ Nothing ->+ Left (DecodeError [payload] TooFewFields)++ query =+ let TmuxQuery paneQuery = query @a+ in TmuxQuery ("#{pane_id} " <> paneQuery)
+ lib/Chiasma/Effect/Codec.hs view
@@ -0,0 +1,32 @@+module Chiasma.Effect.Codec where++import Chiasma.Data.CodecError (CodecError)+import Chiasma.Data.TmuxCommand (TmuxCommand)+import Chiasma.Data.TmuxRequest (TmuxRequest)+import Chiasma.Data.TmuxResponse (TmuxResponse)++data Codec (command :: Type -> Type) (i :: Type) (o :: Type) :: Effect where+ WithCodec :: command a -> (i -> m o) -> Codec command i o m a+ Encode :: command a -> Codec command i o m i++makeSem ''Codec++type NativeCodec command =+ Codec command TmuxRequest TmuxResponse++type NativeCodecE command =+ NativeCodec command !! CodecError++type NativeCommandCodec =+ NativeCodec TmuxCommand++type NativeCommandCodecE =+ NativeCodecE TmuxCommand++type family NativeCodecs (cs :: [Type -> Type]) :: [Effect] where+ NativeCodecs '[] = '[]+ NativeCodecs (c : cs) = NativeCodec c : NativeCodecs cs++type family NativeCodecsE (cs :: [Type -> Type]) :: [Effect] where+ NativeCodecsE '[] = '[]+ NativeCodecsE (c : cs) = NativeCodecE c : NativeCodecsE cs
+ lib/Chiasma/Effect/TmuxApi.hs view
@@ -0,0 +1,15 @@+module Chiasma.Effect.TmuxApi where++import Chiasma.Data.TmuxCommand (TmuxCommand)+import Chiasma.Data.TmuxNotification (TmuxNotification)++data TmuxApi (command :: Type -> Type) :: Effect where+ Send :: command a -> TmuxApi command m a+ Schedule :: command a -> TmuxApi command m ()+ -- | Block until the next tmux control mode notification (e.g. @%window-add@, @%layout-changed@).+ ReceiveNotification :: TmuxApi command m TmuxNotification++makeSem ''TmuxApi++type Tmux =+ TmuxApi TmuxCommand
+ lib/Chiasma/Effect/TmuxClient.hs view
@@ -0,0 +1,21 @@+module Chiasma.Effect.TmuxClient where++import Prelude hiding (send)++import Chiasma.Data.TmuxNotification (TmuxNotification)+import Chiasma.Data.TmuxRequest (TmuxRequest)+import Chiasma.Data.TmuxResponse (TmuxResponse)++data TmuxClient (i :: Type) (o :: Type) :: Effect where+ Send :: i -> TmuxClient i o m o+ Schedule :: i -> TmuxClient i o m ()+ -- | Block until the next tmux control mode notification (e.g. @%window-add@, @%layout-changed@).+ ReceiveNotification :: TmuxClient i o m TmuxNotification++makeSem ''TmuxClient++type ScopedTmux i o =+ Scoped_ (TmuxClient i o)++type NativeTmux =+ ScopedTmux TmuxRequest TmuxResponse
+ lib/Chiasma/Function.hs view
@@ -0,0 +1,7 @@+module Chiasma.Function where++applyWhen :: Bool -> (a -> a) -> a -> a+applyWhen True f x =+ f x+applyWhen False _ x =+ x
+ lib/Chiasma/Interpreter/Codec.hs view
@@ -0,0 +1,48 @@+module Chiasma.Interpreter.Codec where++import Chiasma.Codec (TmuxCodec)+import Chiasma.Data.CodecError (CodecError (CodecError))+import Chiasma.Data.DecodeError (DecodeError)+import qualified Chiasma.Data.Panes as Panes+import Chiasma.Data.Panes (Panes)+import qualified Chiasma.Data.TmuxCommand as TmuxCommand+import Chiasma.Data.TmuxCommand (TmuxCommand)+import Chiasma.Data.TmuxRequest (TmuxRequest)+import Chiasma.Data.TmuxResponse (TmuxResponse)+import qualified Chiasma.Effect.Codec as Codec+import Chiasma.Effect.Codec (Codec)++interpretCodecNative ::+ (∀ x . cmd x -> TmuxRequest) ->+ (∀ x . TmuxResponse -> cmd x -> Either DecodeError x) ->+ InterpreterFor (Codec cmd TmuxRequest TmuxResponse !! CodecError) r+interpretCodecNative enc dec =+ interpretResumableH \case+ Codec.Encode cmd ->+ pureT (enc cmd)+ Codec.WithCodec cmd use -> do+ let req = enc cmd+ out <- runTSimple (use req)+ Inspector ins <- getInspectorT+ pureT =<< stopEitherWith (CodecError req) (dec (fold (ins out)) cmd)++interpretCodecTmuxCommand ::+ InterpreterFor (Codec TmuxCommand TmuxRequest TmuxResponse !! CodecError) r+interpretCodecTmuxCommand =+ interpretCodecNative TmuxCommand.encode TmuxCommand.decode++interpretCodecPanes ::+ TmuxCodec p =>+ InterpreterFor (Codec (Panes p) TmuxRequest TmuxResponse !! CodecError) r+interpretCodecPanes =+ interpretCodecNative Panes.encode Panes.decode++interpretCodecPure ::+ (∀ a . command a -> Sem r (Either Text a)) ->+ InterpreterFor (Codec command () decode !! Text) r+interpretCodecPure run =+ interpretResumableH \case+ Codec.Encode _ ->+ pureT ()+ Codec.WithCodec cmd _ ->+ either stop pureT =<< raise (raise (run cmd))
+ lib/Chiasma/Interpreter/ProcessOutput.hs view
@@ -0,0 +1,24 @@+module Chiasma.Interpreter.ProcessOutput where++import Data.Attoparsec.ByteString (parse)+import qualified Data.Attoparsec.Types as Attoparsec+import qualified Polysemy.Process.Data.ProcessOutputParseResult as ProcessOutputParseResult+import Polysemy.Process.Data.ProcessOutputParseResult (ProcessOutputParseResult)+import Polysemy.Process.Effect.ProcessOutput (ProcessOutput)+import Polysemy.Process.Interpreter.ProcessOutput (interpretProcessOutputIncremental)++import Chiasma.Data.TmuxEvent (TmuxEvent)+import Chiasma.Native.TmuxOutputBlock (messageParser)++-- | Convert an attoparsec 'Attoparsec.IResult' to 'ProcessOutputParseResult'.+fromAttoparsec :: Attoparsec.IResult ByteString TmuxEvent -> ProcessOutputParseResult TmuxEvent+fromAttoparsec = \case+ Attoparsec.Fail _ _ err -> ProcessOutputParseResult.Fail (toText err)+ Attoparsec.Partial c -> ProcessOutputParseResult.Partial (fromAttoparsec . c)+ Attoparsec.Done rest a -> ProcessOutputParseResult.Done a rest++interpretProcessOutputTmuxEvent ::+ ∀ p r .+ InterpreterFor (ProcessOutput p (Either Text TmuxEvent)) r+interpretProcessOutputTmuxEvent =+ interpretProcessOutputIncremental (fromAttoparsec . parse messageParser)
+ lib/Chiasma/Interpreter/Pure.hs view
@@ -0,0 +1,13 @@+module Chiasma.Interpreter.Pure where++import Chiasma.Data.TmuxError (TmuxError)+import Chiasma.Effect.Codec (Codec)+import Chiasma.Effect.TmuxClient (TmuxClient)+import Chiasma.Interpreter.Codec (interpretCodecPure)+import Chiasma.Interpreter.TmuxClient (interpretTmuxClientNull)++interpretTmuxPure ::+ (∀ a . command a -> Sem r (Either Text a)) ->+ InterpretersFor [Scoped_ (TmuxClient () ()) !! TmuxError, Codec command () () !! Text] r+interpretTmuxPure run =+ interpretCodecPure run . interpretTmuxClientNull
+ lib/Chiasma/Interpreter/TmuxApi.hs view
@@ -0,0 +1,82 @@+module Chiasma.Interpreter.TmuxApi where++import Fcf (Eval, Exp, Pure1, type (@@))+import Fcf.Class.Functor (FMap)+import Prelude hiding (send, type (@@))++import Chiasma.Data.CodecError (CodecError)+import Chiasma.Data.TmuxRequest (TmuxRequest)+import Chiasma.Data.TmuxResponse (TmuxResponse)+import Chiasma.Effect.Codec (Codec, encode, withCodec)+import Chiasma.Effect.TmuxApi (TmuxApi (..))+import qualified Chiasma.Effect.TmuxClient as TmuxClient+import Chiasma.Effect.TmuxClient (TmuxClient)++type family (f :: l -> k) <$> (fa :: [l]) :: [k] where+ f <$> fa =+ FMap (Pure1 f) @@ fa++interpretTmuxApi ::+ ∀ command i o err r .+ Members [TmuxClient i o, Codec command i o !! err] r =>+ InterpreterFor (TmuxApi command !! err) r+interpretTmuxApi =+ interpretResumable \case+ Send cmd -> do+ restop @_ @(Codec _ _ _) $ withCodec cmd \ encoded -> do+ TmuxClient.send encoded+ Schedule cmd -> do+ encoded <- restop (encode cmd)+ TmuxClient.schedule encoded+ ReceiveNotification ->+ TmuxClient.receiveNotification++data TmuxApiEffect :: Type -> (Type -> Type) -> Exp Effect++type instance Eval (TmuxApiEffect err command) =+ TmuxApi command !! err++type family TmuxApis (commands :: [Type -> Type]) (err :: Type) :: EffectRow where+ TmuxApis commands err =+ FMap (TmuxApiEffect err) @@ commands++class InterpretApis (commands :: [Type -> Type]) err i o r where+ interpretApis :: InterpretersFor (TmuxApis commands err) (TmuxClient i o : r)++instance InterpretApis '[] err i o r where+ interpretApis =+ id++instance (+ r1 ~ (TmuxApis commands err ++ TmuxClient i o : r),+ Member (TmuxClient i o) r1,+ Member (Codec command i o !! err) r1,+ InterpretApis commands err i o r+ ) => InterpretApis (command : commands) err i o r where+ interpretApis =+ interpretApis @commands @err . interpretTmuxApi++type InterpretApisNative commands r =+ InterpretApis commands CodecError TmuxRequest TmuxResponse r++class RestopApis (commands :: [Type -> Type]) err i o r where+ restopApis :: InterpretersFor (TmuxApi <$> commands) (TmuxClient i o : r)++instance RestopApis '[] err i o r where+ restopApis =+ id++instance (+ r1 ~ (TmuxApi <$> commands ++ TmuxClient i o : r),+ Members [TmuxClient i o, Stop err] r1,+ Member (Codec command i o !! err) r1,+ RestopApis commands err i o r+ ) => RestopApis (command : commands) err i o r where+ restopApis =+ restopApis @commands @err @i @o .+ interpretTmuxApi @command @i @o .+ restop @err @(TmuxApi command) .+ raiseUnder++type RestopApisNative commands r =+ RestopApis commands CodecError TmuxRequest TmuxResponse r
+ lib/Chiasma/Interpreter/TmuxClient.hs view
@@ -0,0 +1,246 @@+module Chiasma.Interpreter.TmuxClient where++import qualified Conc+import Conc (Consume, Lock, interpretAtomic, interpretLockReentrant, lock, withAsync_)+import Data.Sequence ((|>))+import qualified Data.Text as Text+import Exon (exon)+import qualified Log as Log+import Path (Abs, File, Path, relfile, toFilePath)+import Polysemy.Conc.Interpreter.Mask (interpretMaskFinal)+import Polysemy.Process.Interpreter.Process (ProcessQueues)+import qualified Process as Process+import Process (+ OutputPipe (Stderr, Stdout),+ Process,+ ProcessError,+ SystemProcess,+ SystemProcessError,+ SystemProcessScopeError,+ interpretProcessInputId,+ interpretProcessOutputLeft,+ interpretProcessOutputTextLines,+ interpretProcess_,+ interpretSystemProcessNative_,+ resolveExecutable,+ withProcess_,+ )+import System.Process.Typed (ProcessConfig, proc)++import qualified Chiasma.Data.TmuxError as TmuxError+import Chiasma.Data.TmuxError (TmuxError (NoExe))+import qualified Chiasma.Data.TmuxEvent as TmuxEvent+import Chiasma.Data.TmuxEvent (TmuxEvent)+import Chiasma.Data.TmuxNative (TmuxNative (TmuxNative))+import Chiasma.Data.TmuxNotification (TmuxNotification (..))+import qualified Chiasma.Data.TmuxOutputBlock as TmuxOutputBlock+import Chiasma.Data.TmuxOutputBlock (TmuxOutputBlock)+import qualified Chiasma.Data.TmuxRequest as TmuxRequest+import Chiasma.Data.TmuxRequest (TmuxRequest (TmuxRequest))+import Chiasma.Data.TmuxResponse (TmuxResponse (TmuxResponse))+import qualified Chiasma.Effect.TmuxClient as TmuxClient+import Chiasma.Effect.TmuxClient (TmuxClient)+import Chiasma.Interpreter.ProcessOutput (interpretProcessOutputTmuxEvent)++type TmuxQueues =+ ProcessQueues (Either Text TmuxEvent) Text++type TmuxProc =+ Process ByteString (Either Text TmuxEvent)++validate :: TmuxRequest -> TmuxOutputBlock -> Either TmuxError TmuxResponse+validate request = \case+ TmuxOutputBlock.Success a ->+ Right (TmuxResponse a)+ TmuxOutputBlock.Error a ->+ Left (TmuxError.RequestFailed request a)++-- | Send a command and wait for the response.+-- The lock ensures only one request is in flight at a time (tmux control mode responses are ordered).+-- Opens a fresh subscription so only messages arriving after the send are seen.+tmuxRequest ::+ Members [TmuxProc, EventConsumer TmuxEvent, Lock, Log, Stop TmuxError] r =>+ TmuxRequest ->+ Sem r TmuxResponse+tmuxRequest request =+ lock $ subscribe do+ Log.trace [exon|tmux request: #{Text.stripEnd (decodeUtf8 cmdline)}|]+ Process.send cmdline+ stopEither =<< Conc.consumeFirstJust \case+ TmuxEvent.Response block -> pure (Just (validate request block))+ TmuxEvent.Notification _ -> pure Nothing+ where+ cmdline =+ TmuxRequest.encode request++socketArg :: Path Abs File -> [String]+socketArg socket =+ ["-S", toFilePath socket]++tmuxProc ::+ TmuxNative ->+ ProcessConfig () () ()+tmuxProc (TmuxNative exe socket) =+ proc (toFilePath exe) (foldMap socketArg socket <> ["-C", "-u", "attach-session", "-f", "ignore-size,no-output"])++interpretSystemProcessTmux ::+ Members [Reader TmuxNative, Resource, Race, Async, Embed IO] r =>+ InterpreterFor (Scoped_ (SystemProcess !! SystemProcessError) !! SystemProcessScopeError) r+interpretSystemProcessTmux sem = do+ conf <- tmuxProc <$> ask+ interpretSystemProcessNative_ conf sem++interpretProcessTmux ::+ Member (Scoped_ (SystemProcess !! SystemProcessError) !! SystemProcessScopeError) r =>+ Members [Resource, Race, Async, Embed IO] r =>+ InterpreterFor (Scoped_ TmuxProc !! ProcessError) r+interpretProcessTmux sem = do+ interpretProcessOutputTmuxEvent @'Stdout $+ interpretProcessOutputTextLines @'Stderr $+ interpretProcessOutputLeft @'Stderr $+ interpretProcessInputId $+ interpretProcess_ def $+ insertAt @1 sem++-- | Consume messages from the process until the first command response block.+-- Tmux emits a response block for the implicit attach-session command on connect.+-- Notification lines are discarded during this phase.+drainInitial ::+ Members [TmuxProc, Log] r =>+ Sem r ()+drainInitial =+ Process.recv >>= \case+ Right (TmuxEvent.Response _) ->+ Log.trace "tmux: drained initial response"+ Right (TmuxEvent.Notification n) -> do+ Log.trace [exon|tmux: initial notification: #{n.name}|]+ drainInitial+ Left err -> do+ Log.warn [exon|tmux: initial recv error: #{err}|]+ drainInitial++-- | Background receiver loop: reads from the tmux process and publishes each message.+receiverLoop ::+ Members [Events TmuxEvent, TmuxProc, Log] r =>+ Sem r ()+receiverLoop =+ forever do+ Process.recv >>= \case+ Left err ->+ Log.warn [exon|tmux recv error: #{err}|]+ Right msg -> do+ Log.trace [exon|tmux recv message: #{show msg}|]+ Conc.publish msg++-- | Send all scheduled requests and discard their responses.+flush ::+ Members [EventConsumer TmuxEvent, TmuxProc, AtomicState (Seq TmuxRequest), Lock, Log, Stop TmuxError] r =>+ Sem r ()+flush =+ traverse_ tmuxRequest =<< atomicState' (mempty,)++tmuxSession ::+ ∀ r a .+ Members [Scoped_ TmuxProc !! ProcessError, AtomicState (Seq TmuxRequest), Stop TmuxError] r =>+ Members [Lock, Log, Resource, Race, Async, Embed IO] r =>+ Sem (Consume TmuxEvent : EventConsumer TmuxEvent : TmuxProc : r) a ->+ Sem r a+tmuxSession action =+ resumeHoist TmuxError.ProcessFailed $ withProcess_ do+ drainInitial+ Conc.interpretEventsChan do+ withAsync_ receiverLoop do+ subscribe do+ void $ tmuxRequest (TmuxRequest "refresh-client" ["-C", "200x1000"] Nothing)+ subsume_ action <* flush++interpretTmuxProcessBuffered ::+ Members [AtomicState (Seq TmuxRequest), Scoped_ TmuxProc !! ProcessError] r =>+ Members [Lock, Log, Resource, Race, Async, Embed IO] r =>+ InterpreterFor (Scoped_ (TmuxClient TmuxRequest TmuxResponse) !! TmuxError) r+interpretTmuxProcessBuffered =+ interpretScopedResumableWith_ @'[Consume TmuxEvent, EventConsumer TmuxEvent, TmuxProc] (const tmuxSession) \case+ TmuxClient.Schedule request ->+ atomicModify' (|> request)+ TmuxClient.Send cmd -> do+ flush+ tmuxRequest cmd+ TmuxClient.ReceiveNotification ->+ Conc.consumeFirstJust $ pure . \case+ TmuxEvent.Notification n -> Just n+ TmuxEvent.Response _ -> Nothing++interpretTmuxWithProcess ::+ Members [Scoped_ TmuxProc !! ProcessError, Log, Resource, Race, Async, Final IO, Embed IO] r =>+ InterpreterFor (Scoped_ (TmuxClient TmuxRequest TmuxResponse) !! TmuxError) r+interpretTmuxWithProcess =+ interpretAtomic mempty .+ interpretMaskFinal .+ interpretLockReentrant .+ interpretTmuxProcessBuffered .+ raiseUnder3++interpretTmuxNative ::+ ∀ r .+ Members [Reader TmuxNative, Log, Resource, Race, Async, Final IO, Embed IO] r =>+ InterpreterFor (Scoped_ (TmuxClient TmuxRequest TmuxResponse) !! TmuxError) r+interpretTmuxNative =+ interpretSystemProcessTmux .+ interpretProcessTmux .+ interpretTmuxWithProcess .+ raiseUnder2++interpretTmuxFailing ::+ TmuxError ->+ InterpreterFor (Scoped_ (TmuxClient TmuxRequest TmuxResponse) !! TmuxError) r+interpretTmuxFailing err =+ interpretScopedResumable_ mempty \ () -> \case+ TmuxClient.Schedule _ ->+ stop err+ TmuxClient.Send _ ->+ stop err+ TmuxClient.ReceiveNotification ->+ stop err++withTmuxNativeEnv ::+ Member (Embed IO) r =>+ Maybe (Path Abs File) ->+ (Maybe TmuxNative -> Sem r a) ->+ Sem r a+withTmuxNativeEnv socket use =+ use . fmap (flip TmuxNative socket) . rightToMaybe =<< resolveExecutable [relfile|tmux|] Nothing++runReaderTmuxNativeEnv ::+ Members [Error TmuxError, Embed IO] r =>+ Maybe (Path Abs File) ->+ InterpreterFor (Reader TmuxNative) r+runReaderTmuxNativeEnv socket sem = do+ tn <- withTmuxNativeEnv socket (note NoExe)+ runReader tn sem++interpretTmuxNativeEnv ::+ Members [Error TmuxError, Log, Resource, Race, Async, Final IO, Embed IO] r =>+ Maybe (Path Abs File) ->+ InterpreterFor (Scoped_ (TmuxClient TmuxRequest TmuxResponse) !! TmuxError) r+interpretTmuxNativeEnv socket =+ runReaderTmuxNativeEnv socket . interpretTmuxNative . raiseUnder++interpretTmuxNativeEnvGraceful ::+ Members [Log, Resource, Race, Async, Final IO, Embed IO] r =>+ Maybe (Path Abs File) ->+ InterpreterFor (Scoped_ (TmuxClient TmuxRequest TmuxResponse) !! TmuxError) r+interpretTmuxNativeEnvGraceful socket sem =+ withTmuxNativeEnv socket \case+ Just tn -> runReader tn (interpretTmuxNative (raiseUnder sem))+ Nothing -> interpretTmuxFailing NoExe sem++interpretTmuxClientNull ::+ InterpreterFor (Scoped_ (TmuxClient i ()) !! TmuxError) r+interpretTmuxClientNull =+ interpretScopedResumable_ mempty \ () -> \case+ TmuxClient.Schedule _ ->+ unit+ TmuxClient.Send _ ->+ unit+ TmuxClient.ReceiveNotification ->+ pure (TmuxNotification {name = "null", args = []})
+ lib/Chiasma/Lens/Tree.hs view
@@ -0,0 +1,178 @@+module Chiasma.Lens.Tree where++import Control.Lens (Fold, Index, IxValue, Ixed (ix), Plated (..), cosmos, makeClassy_, preview, transform, lens)+import Data.Data (Data)+import Data.Foldable (foldrM)+import Prelude hiding (ix, transform)++import Chiasma.Data.Ident (Ident, Identifiable (..))+import Chiasma.Ui.Data.View (LayoutView, PaneView, Tree (Tree), TreeSub (TreeNode))+import Chiasma.Ui.Lens.Ident (matchIdentP)++newtype NodeIndexTree l p =+ NodeIndexTree {+ nitTree :: Tree l p+ }+ deriving stock (Eq, Show)++makeClassy_ ''NodeIndexTree++newtype LeafIndexTree l p =+ LeafIndexTree {+ litTree :: Tree l p+ }+ deriving stock (Eq, Show)++makeClassy_ ''LeafIndexTree++plateWrap :: (Data l, Data p) => (Tree l p -> t l p) -> (t l p -> Tree l p) -> Traversal' (t l p) (t l p)+plateWrap consWrapper unconsWrapper f wrappedTree =+ consWrapper <$> plate g (unconsWrapper wrappedTree)+ where+ g tree' = unconsWrapper <$> f (consWrapper tree')++instance (Data l, Data p) => Plated (NodeIndexTree l p) where+ plate = plateWrap NodeIndexTree (.nitTree)++instance (Data l, Data p) => Plated (LeafIndexTree l p) where+ plate = plateWrap LeafIndexTree (.litTree)++type LayoutIndexTree = NodeIndexTree LayoutView PaneView+type PaneIndexTree = LeafIndexTree LayoutView PaneView++type instance Index (NodeIndexTree _ _) = Ident+type instance Index (LeafIndexTree _ _) = Ident++type instance IxValue (NodeIndexTree l _) = l+type instance IxValue (LeafIndexTree _ p) = p++nodeTraversal :: Traversal' (Tree l p) l+nodeTraversal = #treeSubs . each . #_TreeNode . #treeData++nodeByIdentTraversal :: Identifiable l => Ident -> Traversal' (Tree l p) l+nodeByIdentTraversal ident = nodeTraversal . matchIdentP ident++leafDataTraversal :: Traversal' (Tree l p) p+leafDataTraversal = #treeSubs . each . #_TreeLeaf++leafByIdentTraversal :: Identifiable p => Ident -> Traversal' (Tree l p) p+leafByIdentTraversal ident = leafDataTraversal . matchIdentP ident++instance Identifiable l => Ixed (NodeIndexTree l p) where+ ix ident = _nitTree . nodeByIdentTraversal ident++nodesByIdentRecursive :: (Identifiable l, Data l, Data p) => Ident -> Fold (NodeIndexTree l p) l+nodesByIdentRecursive ident = cosmos . ix ident++nodesIdent ::+ ∀ l p .+ Identifiable l =>+ Data l =>+ Data p =>+ Ident ->+ Fold (Tree l p) l+nodesIdent ident = lens coerce (const (.nitTree)) . nodesByIdentRecursive ident++nodeByIdent ::+ ∀ l p .+ Identifiable l =>+ Data l =>+ Data p =>+ Ident ->+ Tree l p ->+ Maybe l+nodeByIdent ident = preview (nodesIdent ident)++nodesByIdent ::+ ∀ l p .+ Identifiable l =>+ Data l =>+ Data p =>+ Ident ->+ Tree l p ->+ [l]+nodesByIdent ident = toListOf (nodesIdent ident)++instance Identifiable p => Ixed (LeafIndexTree l p) where+ ix ident = _litTree . leafByIdentTraversal ident++leavesByIdentRecursive ::+ ∀ l p .+ Identifiable p =>+ Data l =>+ Data p =>+ Ident ->+ Fold (LeafIndexTree l p) p+leavesByIdentRecursive ident = cosmos . ix ident++leavesIdent ::+ ∀ l p .+ Identifiable p =>+ Data l =>+ Data p =>+ Ident ->+ Fold (Tree l p) p+leavesIdent ident = lens coerce (const (.litTree)) . leavesByIdentRecursive ident++leafByIdent ::+ ∀ l p .+ Identifiable p =>+ Data l =>+ Data p =>+ Ident ->+ Tree l p ->+ Maybe p+leafByIdent ident = preview (leavesIdent ident)++leavesByIdent ::+ ∀ l p .+ Identifiable p =>+ Data l =>+ Data p =>+ Ident ->+ Tree l p ->+ [p]+leavesByIdent ident = toListOf (leavesIdent ident)++modifyLeafByIdent :: (Identifiable p, Data l, Data p) => Ident -> (p -> p) -> Tree l p -> Tree l p+modifyLeafByIdent ident f tree' =+ (.litTree) $ (transform $ over (ix ident) f) (LeafIndexTree tree')++subtreesWithLayout :: ∀ l p m. Monad m => ((l, TreeSub l p) -> m (l, TreeSub l p)) -> Tree l p -> m (Tree l p)+subtreesWithLayout f (Tree l0 sub) = do+ (newL, newSub) <- foldrM applySub (l0, []) sub+ pure (Tree newL newSub)+ where+ prependSub s (newL, newN) = (newL, newN : s)+ applySub :: TreeSub l p -> (l, [TreeSub l p]) -> m (l, [TreeSub l p])+ applySub (TreeNode t) (l, s) = do+ recur <- (\rsub -> (l, TreeNode rsub)) <$> subtreesWithLayout f t+ (fmap (prependSub s) . f) recur+ applySub p (l, s) =+ (fmap (prependSub s) . f) (l, p)++subtrees :: ∀ l p m. Monad m => (TreeSub l p -> m (TreeSub l p)) -> Tree l p -> m (Tree l p)+subtrees f (Tree l sub) = do+ newSub <- mapM applySub sub+ pure (Tree l newSub)+ where+ applySub :: TreeSub l p -> m (TreeSub l p)+ applySub (TreeNode t) = do+ recur <- subtrees f t+ f (TreeNode recur)+ applySub p = f p++treesAndSubs ::+ Monad m =>+ (Tree l p -> m (Tree l p)) ->+ (TreeSub l p -> m (TreeSub l p)) ->+ Tree l p ->+ m (Tree l p)+treesAndSubs ft fs (Tree l sub) = do+ treeResult <- mapM applySub sub+ ft (Tree l treeResult)+ where+ applySub (TreeNode t) = do+ recur <- treesAndSubs ft fs t+ fs (TreeNode recur)+ applySub p = fs p
+ lib/Chiasma/Lens/Where.hs view
@@ -0,0 +1,6 @@+module Chiasma.Lens.Where where++import Control.Lens (Over, taking)++where1 :: (Applicative f, Traversable t) => (a -> Bool) -> Over (->) f (t a) (t a) a a+where1 predicate = taking 1 $ traverse . filtered predicate
− lib/Chiasma/Monad/Buffered.hs
@@ -1,29 +0,0 @@-module Chiasma.Monad.Buffered(- runTmux,-) where--import Control.Monad.Free (Free(..))-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)-import Data.Default.Class (Default(def))-import Chiasma.Api.Class (TmuxApi(..))-import Chiasma.Data.TmuxThunk (Cmd(..), Cmds(..), TmuxThunk(..), TmuxError)-import Chiasma.Monad.Tmux (TmuxProg)--newtype TmuxState = TmuxState [Cmd]--instance Default TmuxState where- def = TmuxState def--interpret :: (MonadIO m, TmuxApi api) => TmuxState -> api -> TmuxProg b -> ExceptT TmuxError m b-interpret (TmuxState cmds) api (Pure a) = a <$ runCommands api (const $ Right ()) (Cmds cmds)-interpret (TmuxState cmds) api (Free (Read cmd decode next)) = do- a <- runCommands api decode $ Cmds (cmd : cmds)- interpret def api (next a)-interpret (TmuxState cmds) api (Free (Write cmd next)) =- interpret (TmuxState (cmd : cmds)) api (next ())-interpret _ _ (Free (Failed err)) =- throwE err--runTmux :: (MonadIO m, TmuxApi api) => api -> TmuxProg b -> m (Either TmuxError b)-runTmux api prog = runExceptT $ interpret def api prog
− lib/Chiasma/Monad/Simple.hs
@@ -1,38 +0,0 @@-module Chiasma.Monad.Simple(- -- tmuxProcessConfig,- -- tmuxProcess,- -- interpret,- -- runTmux,-) where---- import GHC.IO.Exception (ExitCode(ExitSuccess))--- import Control.Monad (when)--- import Control.Monad.Free (foldFree)--- import Control.Monad.IO.Class (MonadIO)--- import Control.Monad.Trans.Except (ExceptT(ExceptT), catchE, runExceptT)--- import qualified Data.ByteString.Lazy.Internal as B (unpackChars)--- import Data.Functor (void)--- import Data.List.Split (linesBy)--- import System.Process.Typed (ProcessConfig, readProcessStdout, proc)--- import UnliftIO (throwIO)--- import Chiasma.Data.TmuxThunk (Cmd(..), CmdName(..), CmdArgs(..), Cmds(..), TmuxThunk(..), TmuxError(..))--- import Chiasma.Monad.Tmux (TmuxProg)---- tmuxProcessConfig :: CmdName -> CmdArgs -> ProcessConfig () () ()--- tmuxProcessConfig (CmdName cmd) (CmdArgs args) =--- proc "tmux" (["-C", cmd] ++ args)---- tmuxProcess :: MonadIO m => Cmd -> m (Either TmuxError [String])--- tmuxProcess cmd@(Cmd name args) = do--- (code, out) <- readProcessStdout $ tmuxProcessConfig name args--- let outLines = linesBy (=='\n') $ B.unpackChars out--- return $ case code of--- ExitSuccess -> Right outLines--- _ -> Left $ TmuxProcessFailed (Cmds [cmd]) outLines---- interpret :: MonadIO m => TmuxThunk a next -> ExceptT TmuxError m next--- interpret (Read cmd next) = next <$> tmuxProcess cmd--- interpret (Write cmd next) = next <$> void (tmuxProcess cmd)---- runTmux :: MonadIO m => TmuxProg a next -> m (Either TmuxError next)--- runTmux = runExceptT . foldFree interpret
− lib/Chiasma/Monad/Tmux.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Chiasma.Monad.Tmux(- Chiasma.Monad.Tmux.read,- write,- TmuxProg,-) where--import Control.Monad.Free (Free, liftF)-import Chiasma.Codec (TmuxCodec, TmuxQuery(unQ))-import qualified Chiasma.Codec as TmuxCodec (TmuxCodec(decode, query))-import Chiasma.Data.TmuxThunk (TmuxThunk(..), cmd)--type TmuxProg = Free TmuxThunk--read :: ∀ a . TmuxCodec a => String -> [String] -> TmuxProg [a]-read name args =- liftF $ Read (cmd name (args ++ ["-F", "'" ++ unQ (TmuxCodec.query @a) ++ "'"])) TmuxCodec.decode id--write :: String -> [String] -> TmuxProg ()-write name args = liftF $ Write (cmd name args) id
− lib/Chiasma/Native/Api.hs
@@ -1,15 +0,0 @@-module Chiasma.Native.Api(- TmuxApi(..),- TmuxNative(..),-) where--import Control.Monad.Trans.Except (ExceptT(ExceptT))-import Text.ParserCombinators.Parsec ()-import Chiasma.Api.Class (TmuxApi(..))-import Chiasma.Native.Process (nativeTmuxProcess)--newtype TmuxNative =- TmuxNative FilePath--instance TmuxApi TmuxNative where- runCommands (TmuxNative socket) decode cmds = ExceptT $ nativeTmuxProcess socket decode cmds
lib/Chiasma/Native/Parse.hs view
@@ -1,43 +1,35 @@-module Chiasma.Native.Parse(- resultParser,- resultLines,-) where+module Chiasma.Native.Parse where -import Text.ParserCombinators.Parsec (- GenParser,+import qualified Data.Text as T (pack)+import Prelude hiding (many, try)+import Text.Parsec ( ParseError,- parse, many,- skipMany, manyTill,- notFollowedBy,+ parse,+ skipMany, try, )-import Text.Parsec.Char (endOfLine, string, anyChar)+import Text.Parsec.Char (anyChar, endOfLine, string)+import Text.Parsec.Text (GenParser) -tillEol :: GenParser Char st String-tillEol = manyTill anyChar endOfLine+tillEol :: GenParser st Text+tillEol = T.pack <$> manyTill anyChar endOfLine -beginLine :: GenParser Char st String+beginLine :: GenParser st Text beginLine = string "%begin" >> tillEol -endLine :: GenParser Char st String+endLine :: GenParser st Text endLine = string "%end" >> tillEol -notBeginLine :: GenParser Char st String-notBeginLine = notFollowedBy (string "%begin") >> tillEol--parseBlock :: GenParser Char st [String]+parseBlock :: GenParser st [Text] parseBlock = do- _ <- skipMany notBeginLine- _ <- beginLine+ _ <- manyTill tillEol (try beginLine) manyTill tillEol (try endLine) -resultParser :: GenParser Char st [[String]]-resultParser = do- result <- many (try parseBlock)- skipMany tillEol- return result+resultParser :: GenParser st [[Text]]+resultParser =+ many (try parseBlock) <* skipMany tillEol -resultLines :: String -> Either ParseError [[String]]+resultLines :: Text -> Either ParseError [[Text]] resultLines = parse resultParser "tmux output"
− lib/Chiasma/Native/Process.hs
@@ -1,45 +0,0 @@-module Chiasma.Native.Process(- tmuxProcessConfig,- nativeTmuxProcess,-) where--import GHC.IO.Exception (ExitCode(ExitSuccess))-import Control.Monad.IO.Class (MonadIO)-import Data.ByteString.Lazy (ByteString)-import Data.ByteString.Lazy.Internal (packChars, unpackChars)-import Data.Either.Combinators (mapLeft)-import Data.List (intercalate)-import System.Process.Typed (ProcessConfig, readProcessStdout, proc, setStdin, byteStringInput)-import Chiasma.Codec.Decode (TmuxDecodeError)-import Chiasma.Data.TmuxThunk (CmdName(..), Cmd(..), CmdArgs(..), Cmds(..), TmuxError(..))-import qualified Chiasma.Data.TmuxThunk as TmuxError (- TmuxError(OutputParsingFailed, NoOutput, ProcessFailed, DecodingFailed)- )-import Chiasma.Native.Parse (resultLines)--cmdBytes :: [String] -> ByteString-cmdBytes cmds = packChars $ intercalate "\n" $ reverse $ "" : cmds--tmuxProcessConfig :: FilePath -> [String] -> ProcessConfig () () ()-tmuxProcessConfig socket cmds =- setStdin (byteStringInput $ cmdBytes cmds) $ proc "tmux" ["-S", socket, "-C", "attach"]--handleProcessOutput :: Cmds -> ExitCode -> ([String] -> Either TmuxDecodeError a) -> String -> Either TmuxError [a]-handleProcessOutput cmds ExitSuccess decode out = do- outputs <- mapLeft (TmuxError.OutputParsingFailed cmds (lines out)) $ resultLines out- case reverse outputs of- output : _ -> traverse decode' output- _ -> Left $ TmuxError.NoOutput cmds- where- decode' = mapLeft (TmuxError.DecodingFailed cmds out) . decode . words-handleProcessOutput cmds _ _ out =- Left $ TmuxError.ProcessFailed cmds out--formatCmd :: Cmd -> String-formatCmd (Cmd (CmdName name) (CmdArgs args)) = unwords $ name : args--nativeTmuxProcess :: MonadIO m => FilePath -> ([String] -> Either TmuxDecodeError a) -> Cmds -> m (Either TmuxError [a])-nativeTmuxProcess socket decode cmds@(Cmds cmds') = do- let cmdLines = fmap formatCmd cmds'- (code, out) <- readProcessStdout $ tmuxProcessConfig socket cmdLines- return $ handleProcessOutput cmds code decode $ unpackChars out
+ lib/Chiasma/Native/TmuxOutputBlock.hs view
@@ -0,0 +1,71 @@+module Chiasma.Native.TmuxOutputBlock where++import Data.Attoparsec.ByteString (Parser)+import Data.ByteString.Internal (packChars)+import Prelude hiding (noneOf, try)+import Text.Parser.Char (CharParsing, anyChar, char, newline, noneOf, string)+import Text.Parser.Combinators (choice, manyTill, notFollowedBy, skipMany, try)+import Text.Parser.LookAhead (LookAheadParsing, lookAhead)++import qualified Chiasma.Data.TmuxEvent as TmuxEvent+import Chiasma.Data.TmuxEvent (TmuxEvent)+import Chiasma.Data.TmuxNotification (TmuxNotification (..))+import Chiasma.Data.TmuxOutputBlock (End (EndError, EndSuccess), TmuxOutputBlock (Error, Success))++tillEol :: (CharParsing m) => m Text+tillEol = decodeUtf8 . packChars <$> manyTill anyChar newline++beginLine :: (CharParsing m, Monad m) => m ()+beginLine = void $ string "%begin" >> tillEol++endLine :: (CharParsing m) => m End+endLine = do+ end <- choice [EndSuccess <$ string "%end", EndError <$ string "%error"]+ _ <- tillEol+ pure end++notBeginLine :: (CharParsing m, Monad m) => m ()+notBeginLine = void $ notFollowedBy (string "%begin") >> tillEol++word :: CharParsing m => m Text+word = toText <$> some (noneOf " \n")++notificationLine :: (CharParsing m, Monad m) => m TmuxNotification+notificationLine = do+ notFollowedBy (string "%begin")+ _ <- char '%'+ name <- word+ args <- many (char ' ' *> word)+ _ <- newline+ pure TmuxNotification {name, args}++-- | Parse a sequence of lines between a %start and a %end line.+-- Tmux pads output lines with a single space on both sides, so strip those if the leading one is present.+parseBlock :: (CharParsing m, Monad m, LookAheadParsing m) => m TmuxOutputBlock+parseBlock = do+ _ <- skipMany notBeginLine+ _ <- beginLine+ dataLines <- manyTill tillEol $ try (lookAhead endLine)+ endLine <&> \case+ EndSuccess -> Success dataLines+ EndError -> Error dataLines++parseBlocks :: (CharParsing m, Monad m, LookAheadParsing m) => m [TmuxOutputBlock]+parseBlocks = do+ result <- many (try parseBlock)+ skipMany tillEol+ pure result++-- | Parse either a notification line or a command response block.+parseMessage :: (CharParsing m, Monad m, LookAheadParsing m) => m TmuxEvent+parseMessage =+ choice+ [ TmuxEvent.Notification <$> try notificationLine+ , TmuxEvent.Response <$> parseBlock+ ]++parser :: Parser TmuxOutputBlock+parser = parseBlock++messageParser :: Parser TmuxEvent+messageParser = parseMessage
+ lib/Chiasma/Pack.hs view
@@ -0,0 +1,112 @@+module Chiasma.Pack where++import Control.Lens (mapMOf_)+import qualified Data.List.NonEmpty as NonEmpty (reverse, toList)+import qualified Data.Set as Set (fromList, size)+import Prettyprinter (Doc, line, pretty, (<+>))++import qualified Chiasma.Codec.Data.Window as Codec (Window (Window))+import Chiasma.Command.Pane (movePane, resizePane)+import Chiasma.Data.Axis (Axis (Horizontal, Vertical))+import Chiasma.Data.TmuxId (PaneId)+import Chiasma.Data.Views (Views)+import Chiasma.Data.WindowState (WindowState (..))+import Chiasma.Effect.TmuxApi (Tmux)+import Chiasma.Ui.Data.Measure (MLayout (..), MPane (..), MeasureTree, MeasureTreeSub, Measured (Measured))+import Chiasma.Ui.Data.Tree (Node (Leaf, Sub), Tree (Tree))+import qualified Chiasma.Ui.Data.Tree as Tree (subTree)+import Chiasma.Ui.Measure (measureTree)+import Chiasma.View (viewsLog)++packPane ::+ Members [AtomicState Views, Tmux] r =>+ PaneId ->+ Axis ->+ PaneId ->+ Sem r ()+packPane refId axis paneId =+ when (paneId /= refId) do+ movePane paneId refId axis++positionView ::+ Members [AtomicState Views, Tmux] r =>+ Axis ->+ PaneId ->+ MeasureTreeSub ->+ Sem r ()+positionView axis refId =+ position+ where+ position (Sub (Tree (Measured _ (MLayout layoutRef _ _ _)) _)) =+ packPane refId axis layoutRef+ position (Leaf (Measured _ (MPane paneId _ _))) =+ packPane refId axis paneId++describeAxis :: Axis -> Doc a+describeAxis = \case+ Vertical -> "vertically"+ Horizontal -> "horizontally"++resizeView ::+ Members [AtomicState Views, Tmux] r =>+ Axis ->+ MeasureTreeSub ->+ Sem r ()+resizeView axis = \case+ Sub (Tree (Measured size (MLayout refId _ _ _)) _) -> do+ viewsLog ("resizing layout with ref" <+> pretty refId <+> "to" <+> pretty size <+> describeAxis axis)+ resizePane refId axis size+ Leaf (Measured size (MPane paneId _ _)) -> do+ viewsLog $ "resizing pane" <+> pretty paneId <+> "to" <+> pretty size <+> describeAxis axis+ resizePane paneId axis size++needPositioning ::+ NonEmpty MeasureTreeSub ->+ Bool+needPositioning sub =+ wrongOrder || wrongDirection || unaligned+ where+ wrongOrder =+ sort positions /= positions+ wrongDirection =+ Set.size (Set.fromList positions) /= length positions+ unaligned =+ length sub > 1 && Set.size (Set.fromList offPositions) > 1+ positions =+ NonEmpty.toList $ position <$> sub+ position (Sub (Tree (Measured _ (MLayout _ mainPos _ _)) _)) =+ mainPos+ position (Leaf (Measured _ (MPane _ mainPos _))) =+ mainPos+ offPositions =+ NonEmpty.toList $ offPosition <$> sub+ offPosition (Sub (Tree (Measured _ (MLayout _ _ offPos _)) _)) =+ offPos+ offPosition (Leaf (Measured _ (MPane _ _ offPos))) =+ offPos++packTree ::+ Members [AtomicState Views, Tmux] r =>+ MeasureTree ->+ Sem r ()+packTree =+ pack+ where+ pack (Tree (Measured _ (MLayout ref _ _ axis)) sub) = do+ when needPos runPos+ mapMOf_ (each . Tree.subTree) pack sub+ traverse_ (resizeView axis) sub+ where+ needPos = needPositioning sub+ runPos = do+ viewsLog $ "repositioning views" <+> pretty sub+ traverse_ (positionView axis ref) (NonEmpty.reverse sub)++packWindow ::+ Members [AtomicState Views, Tmux] r =>+ WindowState ->+ Sem r ()+packWindow (WindowState (Codec.Window _ width height) _ _ tree _) = do+ let measures = measureTree tree width height+ viewsLog $ "measured tree:" <> line <> pretty measures+ packTree measures
+ lib/Chiasma/Pane.hs view
@@ -0,0 +1,17 @@+module Chiasma.Pane where++import Chiasma.Data.Ident (Ident)+import Chiasma.Data.TmuxId (PaneId)+import qualified Chiasma.Data.View as Tmux (View (View))+import Chiasma.Data.Views (Views)+import qualified Chiasma.View as Views (insertPane)++addPane ::+ Member (AtomicState Views) r =>+ Ident ->+ Sem r (Tmux.View PaneId)+addPane ident =+ pane <$ atomicModify' (Views.insertPane pane)+ where+ pane =+ Tmux.View ident Nothing
+ lib/Chiasma/Path.hs view
@@ -0,0 +1,14 @@+module Chiasma.Path where++import qualified Data.Text as Text+import Path (Path, toFilePath)++pathText :: Path b t -> Text+pathText =+ toText . toFilePath++pathText' :: Path b t -> Text+pathText' p =+ case pathText p of+ "/" -> "/"+ t -> Text.dropWhileEnd (== '/') t
+ lib/Chiasma/Render.hs view
@@ -0,0 +1,47 @@+module Chiasma.Render where++import Path (Abs, Dir, Path)+import Prettyprinter (line, pretty)++import Chiasma.Codec.Data.Pane (Pane)+import qualified Chiasma.Codec.Data.Window as Codec (Window (Window))+import Chiasma.Data.CodecError (CodecError)+import Chiasma.Data.Ident (Ident, identText)+import Chiasma.Data.Panes (TmuxPanes)+import qualified Chiasma.Data.RenderError as RenderError+import Chiasma.Data.RenderError (RenderError)+import Chiasma.Data.Views (Views)+import Chiasma.Effect.TmuxApi (Tmux)+import Chiasma.Pack (packWindow)+import Chiasma.Session (ensureSession, findOrCreateSession)+import Chiasma.Ui.Data.RenderableTree (RenderableTree)+import Chiasma.Ui.Data.View (ViewTree)+import Chiasma.View (viewsLog)+import Chiasma.Window (ensureView, ensureWindow, findOrCreateWindow, windowState)++renderTree ::+ Members [TmuxPanes Pane, AtomicState Views, Tmux] r =>+ Ident ->+ Codec.Window ->+ RenderableTree ->+ Sem r ()+renderTree windowIdent window tree = do+ viewsLog $ pretty ("rendering tree in window " <> identText windowIdent <> ":") <> line <> pretty tree+ wState <- windowState windowIdent window tree+ packWindow wState++render ::+ Members [TmuxPanes Pane !! CodecError, AtomicState Views, Tmux !! CodecError, Stop RenderError] r =>+ Path Abs Dir ->+ Ident ->+ Ident ->+ ViewTree ->+ Sem r ()+render cwd sessionIdent windowIdent tree = do+ resumeHoist @_ @(TmuxPanes _) RenderError.Codec do+ resumeHoist @_ @Tmux RenderError.Codec do+ initialSession <- findOrCreateSession sessionIdent+ initialWindow <- findOrCreateWindow windowIdent+ (sid, newSessionWid) <- mapStop RenderError.Layout (ensureSession initialSession initialWindow)+ window@(Codec.Window windowId _ _) <- ensureWindow sid initialWindow newSessionWid tree+ traverse_ (renderTree windowIdent window) =<< ensureView cwd windowId tree
+ lib/Chiasma/Session.hs view
@@ -0,0 +1,47 @@+module Chiasma.Session where++import Exon (exon)++import qualified Chiasma.Codec.Data.Session as Codec (Session (Session))+import qualified Chiasma.Codec.Data.Window as Codec (Window (Window))+import Chiasma.Command.Session (existingSessionId, newSession)+import Chiasma.Command.Window (newSessionWindow)+import Chiasma.Data.Ident (Ident)+import Chiasma.Data.LayoutError (LayoutError)+import Chiasma.Data.TmuxId (SessionId, WindowId)+import qualified Chiasma.Data.View as Tmux+import Chiasma.Data.Views (Views)+import Chiasma.Effect.TmuxApi (Tmux)+import Chiasma.View (findOrCreateView, viewsLogS)+import qualified Chiasma.View as Views (insertSession, session, updateSession, updateWindow)++findOrCreateSession ::+ Member (AtomicState Views) r =>+ Ident ->+ Sem r (Tmux.View SessionId)+findOrCreateSession =+ findOrCreateView Views.session Views.insertSession++spawnSession ::+ Members [AtomicState Views, Tmux, Stop LayoutError] r =>+ Tmux.View SessionId ->+ Tmux.View WindowId ->+ Sem r (SessionId, WindowId)+spawnSession session' window = do+ Codec.Session sid _ <- newSession session'.ident+ atomicModify' (Views.updateSession (Tmux.setViewId sid session'))+ Codec.Window wid _ _ <- newSessionWindow sid+ atomicModify' (Views.updateWindow (Tmux.setViewId wid window))+ viewsLogS [exon|spawned session #{show session'} with id #{show sid} and window id #{show wid}|]+ pure (sid, wid)++ensureSession ::+ Members [AtomicState Views, Tmux, Stop LayoutError] r =>+ Tmux.View SessionId ->+ Tmux.View WindowId ->+ Sem r (SessionId, Maybe WindowId)+ensureSession session' window = do+ existing <- join <$> traverse existingSessionId session'.id+ case existing of+ Just sid -> pure (sid, Nothing)+ Nothing -> second Just <$> spawnSession session' window
− lib/Chiasma/Test/File.hs
@@ -1,32 +0,0 @@-module Chiasma.Test.File(- tempDirIO,- tempDir,- fixture,-) where--import Control.Monad.IO.Class (liftIO, MonadIO)-import System.Directory (canonicalizePath, createDirectoryIfMissing, removePathForcibly)-import System.FilePath ((</>))--testDir :: String -> IO FilePath-testDir prefix = canonicalizePath $ "test" </> prefix---- raises exception if cwd is not the package root so we don't damage anything-tempDirIO :: String -> FilePath -> IO FilePath-tempDirIO prefix path = do- base <- testDir prefix- let dir = base </> "temp"- removePathForcibly dir- createDirectoryIfMissing False dir- let absPath = dir </> path- createDirectoryIfMissing True absPath- return absPath--tempDir :: MonadIO m => String -> FilePath -> m FilePath-tempDir prefix path =- liftIO $ tempDirIO prefix path--fixture :: MonadIO m => String -> FilePath -> m FilePath-fixture prefix path = do- base <- liftIO $ testDir prefix- return $ base </> "fixtures" </> path
− lib/Chiasma/Test/Tmux.hs
@@ -1,71 +0,0 @@-module Chiasma.Test.Tmux(- withTestTmux,- tmuxSpec,-) where--import GHC.Real (fromIntegral)-import GHC.IO.Handle (Handle)-import System.FilePath ((</>))-import System.Posix.Pty (Pty, resizePty, createPty)-import System.Posix.Terminal (openPseudoTerminal)-import System.Posix.IO (fdToHandle)-import qualified System.Posix.Signals as Signal (signalProcess, killProcess)-import System.Process (getPid)-import System.Process.Typed (- ProcessConfig,- Process,- withProcess,- proc,- setStdin,- setStdout,- setStderr,- useHandleClose,- unsafeProcessHandle,- )-import UnliftIO (finally)-import UnliftIO.Temporary (withSystemTempDirectory)-import Chiasma.Native.Api (TmuxNative(..))-import Chiasma.Test.File (fixture)--data Terminal = Terminal Handle Pty--unsafeTerminal :: IO Terminal-unsafeTerminal = do- (_, slave) <- openPseudoTerminal- mayPty <- createPty slave- handle <- fdToHandle slave- pty <- maybe (error "couldn't spawn pty") return mayPty- return $ Terminal handle pty--testTmuxProcessConfig :: FilePath -> FilePath -> Terminal -> IO (ProcessConfig () () ())-testTmuxProcessConfig socket confFile (Terminal handle pty) = do- resizePty pty (1000, 1000)- let stream = useHandleClose handle- let stdio = setStdin stream . setStdout stream . setStderr stream- return $ stdio $ proc "tmux" ["-S", socket, "-f", confFile]--killPid :: Integral a => a -> IO ()-killPid =- Signal.signalProcess Signal.killProcess . fromIntegral--killProcess :: Process () () () -> IO ()-killProcess prc = do- let handle = unsafeProcessHandle prc- mayPid <- getPid handle- maybe (return ()) killPid mayPid--runAndKillTmux :: (TmuxNative -> IO a) -> TmuxNative -> Process () () () -> IO a-runAndKillTmux thunk api prc =- finally (thunk api) (killProcess prc)--withTestTmux :: (TmuxNative -> IO a) -> FilePath -> IO a-withTestTmux thunk tempDir = do- let socket = tempDir </> "tmux_socket"- conf <- fixture "u" "tmux.conf"- terminal <- unsafeTerminal- pc <- testTmuxProcessConfig socket conf terminal- withProcess pc $ runAndKillTmux thunk (TmuxNative socket)--tmuxSpec :: (TmuxNative -> IO a) -> IO a-tmuxSpec thunk =- withSystemTempDirectory "chiasma-test" $ withTestTmux thunk
+ lib/Chiasma/Tmux.hs view
@@ -0,0 +1,89 @@+module Chiasma.Tmux where++import Polysemy.Internal (hoistSem)+import Polysemy.Internal.Sing (KnownList (singList))+import Polysemy.Internal.Union (hoist, weakenMid)++import Chiasma.Data.Panes (Panes, TmuxPanes)+import Chiasma.Effect.Codec (Codec)+import Chiasma.Effect.TmuxApi (TmuxApi)+import Chiasma.Effect.TmuxClient (ScopedTmux, TmuxClient)+import Chiasma.Interpreter.TmuxApi (+ InterpretApis (interpretApis),+ RestopApis (restopApis),+ TmuxApis,+ interpretTmuxApi,+ type (<$>),+ )++withTmuxApis' ::+ ∀ commands err i o r a .+ InterpretApis commands err i o r =>+ Member (ScopedTmux i o) r =>+ Sem (TmuxApis commands err ++ TmuxClient i o : r) a ->+ Sem r a+withTmuxApis' =+ scoped_ . interpretApis @commands @err++insertAfter ::+ ∀ left e r a .+ KnownList left =>+ Sem (left ++ r) a ->+ Sem (left ++ e : r) a+insertAfter =+ hoistSem $ hoist (insertAfter @left @e @r) . weakenMid @r (singList @left) (singList @'[e])++withTmuxApis ::+ ∀ commands err i o r .+ KnownList (TmuxApis commands err) =>+ InterpretApis commands err i o r =>+ Member (ScopedTmux i o) r =>+ InterpretersFor (TmuxApis commands err) r+withTmuxApis =+ scoped_ .+ interpretApis @commands @err .+ insertAfter @(TmuxApis commands err) @(TmuxClient i o) @r++withTmuxApis_ ::+ ∀ commands err i o apis r .+ apis ~ TmuxApi <$> commands =>+ KnownList apis =>+ RestopApis commands err i o r =>+ Member (ScopedTmux i o) r =>+ InterpretersFor apis r+withTmuxApis_ =+ scoped_ .+ restopApis @commands @err .+ insertAfter @apis @(TmuxClient i o) @r++withTmux ::+ ∀ command err i o r .+ Members [ScopedTmux i o, Codec command i o !! err] r =>+ InterpreterFor (TmuxApi command !! err) r+withTmux =+ scoped_ . interpretTmuxApi . raiseUnder++withTmux_ ::+ ∀ command err i o r .+ Members [ScopedTmux i o, Codec command i o !! err, Stop err] r =>+ InterpreterFor (TmuxApi command) r+withTmux_ =+ scoped_ .+ interpretTmuxApi .+ raiseUnder .+ restop @err @(TmuxApi command) .+ raiseUnder++withPanes ::+ ∀ p err i o r .+ Members [ScopedTmux i o, Codec (Panes p) i o !! err] r =>+ InterpreterFor (TmuxPanes p !! err) r+withPanes =+ withTmux++withPanes_ ::+ ∀ p err i o r .+ Members [ScopedTmux i o, Codec (Panes p) i o !! err, Stop err] r =>+ InterpreterFor (TmuxPanes p) r+withPanes_ =+ withTmux_
+ lib/Chiasma/TmuxApi.hs view
@@ -0,0 +1,7 @@+module Chiasma.TmuxApi (+ module Chiasma.Effect.TmuxApi,+ module Chiasma.Interpreter.TmuxApi,+) where++import Chiasma.Effect.TmuxApi+import Chiasma.Interpreter.TmuxApi
+ lib/Chiasma/TmuxNative.hs view
@@ -0,0 +1,68 @@+module Chiasma.TmuxNative where++import Polysemy.Internal.Sing (KnownList)++import Chiasma.Data.CodecError (CodecError)+import Chiasma.Data.Panes (Panes, TmuxPanes)+import Chiasma.Data.TmuxRequest (TmuxRequest)+import Chiasma.Data.TmuxResponse (TmuxResponse)+import Chiasma.Effect.Codec (NativeCodecE)+import Chiasma.Effect.TmuxApi (TmuxApi)+import Chiasma.Effect.TmuxClient (NativeTmux, TmuxClient)+import Chiasma.Interpreter.TmuxApi (InterpretApisNative, RestopApisNative, TmuxApis, type (<$>))+import Chiasma.Tmux (withTmux, withTmuxApis, withTmuxApis', withTmuxApis_, withTmux_)++withTmuxApisNative' ::+ ∀ commands r a .+ InterpretApisNative commands r =>+ Member NativeTmux r =>+ Sem (TmuxApis commands CodecError ++ TmuxClient TmuxRequest TmuxResponse : r) a ->+ Sem r a+withTmuxApisNative' =+ withTmuxApis' @commands @CodecError++withTmuxApisNative ::+ ∀ commands r .+ KnownList (TmuxApis commands CodecError) =>+ InterpretApisNative commands r =>+ Member NativeTmux r =>+ InterpretersFor (TmuxApis commands CodecError) r+withTmuxApisNative =+ withTmuxApis @commands @CodecError++withTmuxApisNative_ ::+ ∀ commands r .+ KnownList (TmuxApi <$> commands) =>+ RestopApisNative commands r =>+ Member NativeTmux r =>+ InterpretersFor (TmuxApi <$> commands) r+withTmuxApisNative_ =+ withTmuxApis_ @commands @CodecError++withTmuxNative ::+ ∀ command r .+ Members [NativeTmux, NativeCodecE command] r =>+ InterpreterFor (TmuxApi command !! CodecError) r+withTmuxNative =+ withTmux++withTmuxNative_ ::+ ∀ command r .+ Members [NativeTmux, NativeCodecE command, Stop CodecError] r =>+ InterpreterFor (TmuxApi command) r+withTmuxNative_ =+ withTmux_++withPanesNative ::+ ∀ p r .+ Members [NativeTmux, NativeCodecE (Panes p)] r =>+ InterpreterFor (TmuxPanes p !! CodecError) r+withPanesNative =+ withTmuxNative++withPanesNative_ ::+ ∀ p r .+ Members [NativeTmux, NativeCodecE (Panes p), Stop CodecError] r =>+ InterpreterFor (TmuxPanes p) r+withPanesNative_ =+ withTmuxNative_
+ lib/Chiasma/Ui/Data/Measure.hs view
@@ -0,0 +1,53 @@+module Chiasma.Ui.Data.Measure where++import Control.Lens (makeClassy)+import Prettyprinter (Pretty (..), (<+>))++import Chiasma.Data.Axis (Axis)+import Chiasma.Data.TmuxId (PaneId (..))+import Chiasma.Ui.Data.Tree (NNode, NTree)++data MPane =+ MPane {+ _paneId :: PaneId,+ _mainPosition :: Int,+ _offPosition :: Int+ }+ deriving stock (Eq, Show)++makeClassy ''MPane++data MLayout =+ MLayout {+ _reference :: PaneId,+ _lMainPosition :: Int,+ _lOffPosition :: Int,+ _axis :: Axis+ }+ deriving stock (Eq, Show)++makeClassy ''MLayout++data Measured a =+ Measured {+ _size :: Int,+ _view :: a+ }+ deriving stock (Eq, Show)++makeClassy ''Measured++type MeasureTree = NTree (Measured MLayout) (Measured MPane)+type MeasureTreeSub = NNode (Measured MLayout) (Measured MPane)++instance Pretty MLayout where+ pretty (MLayout (PaneId refId) mainPos offPos axis') =+ "l –" <+> "ref:" <+> pretty refId <+> "pos:" <+> pretty mainPos <+> "(" <> pretty offPos <> ")" <+> pretty axis'++instance Pretty MPane where+ pretty (MPane (PaneId paneId') mainPos offPos) =+ "p –" <+> pretty paneId' <+> "pos:" <+> pretty mainPos <+> "(" <> pretty offPos <> ")"++instance Pretty a => Pretty (Measured a) where+ pretty (Measured size' a) =+ pretty a <+> "size:" <+> pretty size'
+ lib/Chiasma/Ui/Data/RenderableTree.hs view
@@ -0,0 +1,55 @@+module Chiasma.Ui.Data.RenderableTree where++import Prettyprinter (Doc, Pretty (..), emptyDoc, space, (<+>))++import Chiasma.Data.Axis (Axis)+import Chiasma.Data.TmuxId (PaneId (..))+import Chiasma.Ui.Data.Tree (NNode, NTree)+import Chiasma.Ui.Data.ViewGeometry (ViewGeometry (ViewGeometry))+import Chiasma.Ui.Data.ViewState (ViewState)++data RLayout =+ RLayout {+ _ref :: RPane,+ _axis :: Axis+ }+ deriving stock (Eq, Show)++data RPane =+ RPane {+ _id :: PaneId,+ _top :: Int,+ _left :: Int+ }+ deriving stock (Eq, Show)++data Renderable a =+ Renderable {+ _state :: ViewState,+ _geometry :: ViewGeometry,+ _view :: a+ }+ deriving stock (Eq, Show)++type RenderableLayout = Renderable RLayout+type RenderablePane = Renderable RPane+type RenderableTree = NTree RenderableLayout RenderablePane+type RenderableNode = NNode RenderableLayout RenderablePane++instance Pretty RLayout where+ pretty (RLayout (RPane (PaneId refId) _ _) axis) =+ "l –" <+> "ref:" <+> pretty refId <+> "pos:" <+> pretty axis++instance Pretty RPane where+ pretty (RPane (PaneId paneId) top left) =+ "p –" <+> pretty paneId <+> pretty top <+> pretty left++mayPretty :: Text -> Maybe Float -> Doc a+mayPretty prefix (Just a) =+ space <> pretty (prefix <> ":") <+> pretty a+mayPretty _ Nothing =+ emptyDoc++instance Pretty a => Pretty (Renderable a) where+ pretty (Renderable _ (ViewGeometry minSize maxSize fixedSize _ _ _) a) =+ pretty a <> mayPretty "min" minSize <> mayPretty "max" maxSize <> mayPretty "fixed" fixedSize
+ lib/Chiasma/Ui/Data/Tree.hs view
@@ -0,0 +1,44 @@+module Chiasma.Ui.Data.Tree where++import Control.Lens (makeClassy)+import Prettyprinter (Pretty (..), nest, vsep)++data Tree f l p =+ Tree {+ _treeData :: l,+ _forest :: f (Node f l p)+ }++deriving stock instance (Eq l, Eq (Node [] l p)) => Eq (Tree [] l p)+deriving stock instance (Show l, Show (Node [] l p)) => Show (Tree [] l p)++deriving stock instance (Eq l, Eq (Node NonEmpty l p)) => Eq (Tree NonEmpty l p)+deriving stock instance (Show l, Show (Node NonEmpty l p)) => Show (Tree NonEmpty l p)++data Node f l p =+ Sub { _subTree :: Tree f l p }+ |+ Leaf { _leafData :: p }++makeClassy ''Tree+makeClassy ''Node++deriving stock instance (Eq l, Eq p) => Eq (Node [] l p)+deriving stock instance (Show l, Show p) => Show (Node [] l p)++deriving stock instance (Eq l, Eq p) => Eq (Node NonEmpty l p)+deriving stock instance (Show l, Show p) => Show (Node NonEmpty l p)++type LTree l p = Tree [] l p+type LNode l p = Node [] l p++type NTree l p = Tree NonEmpty l p+type NNode l p = Node NonEmpty l p++instance (Foldable f, Pretty l, Pretty p) => Pretty (Tree f l p) where+ pretty (Tree l sub) =+ nest 2 $ vsep $ pretty l : (pretty <$> toList sub)++instance (Foldable f, Pretty l, Pretty p) => Pretty (Node f l p) where+ pretty (Sub tree') = pretty tree'+ pretty (Leaf a) = pretty a
+ lib/Chiasma/Ui/Data/TreeModError.hs view
@@ -0,0 +1,21 @@+module Chiasma.Ui.Data.TreeModError where++import Chiasma.Data.Ident (Ident)++import Chiasma.Ui.Data.View (LayoutView, PaneView)++data TreeModError =+ PaneExists PaneView+ |+ LayoutExists LayoutView+ |+ PaneMissing Ident+ |+ LayoutMissing Ident+ |+ AmbiguousPane Ident Int+ |+ AmbiguousLayout Ident Int+ |+ NoTrees+ deriving stock (Eq, Show)
+ lib/Chiasma/Ui/Data/View.hs view
@@ -0,0 +1,198 @@+module Chiasma.Ui.Data.View where++import Control.Lens (Fold, Index, IxValue, Ixed (ix), cosmos, preview)+import Control.Lens.Plated (Plated)+import Data.Bifoldable (Bifoldable (bifoldMap))+import Data.Data (Data)+import Prelude hiding (ix)+import Prettyprinter (Doc, Pretty (..), emptyDoc, nest, space, vsep, (<+>))++import Chiasma.Data.Axis (Axis (Horizontal, Vertical))+import Chiasma.Data.Ident (Ident, Identifiable (..))+import Chiasma.Ui.Data.ViewGeometry (ViewGeometry)+import Chiasma.Ui.Data.ViewState (ViewState (ViewState))+import Chiasma.Ui.Lens.Ident (matchIdentP)++data Pane =+ Pane {+ open :: Bool,+ pin :: Bool,+ cwd :: Maybe Text+ }+ deriving stock (Eq, Show, Data, Generic)++instance Default Pane where+ def = Pane False False Nothing++newtype Layout =+ Layout {+ axis :: Axis+ }+ deriving stock (Eq, Show, Data, Generic)+ deriving newtype (Default)++data View a =+ View {+ ident :: Ident,+ state :: ViewState,+ geometry :: ViewGeometry,+ extra :: a+ }+ deriving stock (Eq, Show, Data, Generic)++instance Default a => Default (View a) where+ def = View def def def def++type PaneView = View Pane+type LayoutView = View Layout++instance Pretty Layout where+ pretty = \case+ Layout Vertical ->+ "➡"+ Layout Horizontal ->+ "⬇"++instance Pretty Pane where+ pretty (Pane open' pin' _) =+ (if open' then "🔓" else "🔒") <+> (if pin' then "📌" else emptyDoc)++prettyView :: Doc a -> Ident -> ViewState -> ViewGeometry -> Doc a+prettyView sym ident' (ViewState minimized) geo =+ sym <+> pretty ident' <+> "⎸" <+> (if minimized then "▂" <> space else emptyDoc) <> pretty geo++instance Pretty (View Pane) where+ pretty (View ident' st geo a) =+ prettyView "◳" ident' st geo <> pretty a++instance Pretty (View Layout) where+ pretty (View ident' st geo a) =+ prettyView (pretty a) ident' st geo++consPane :: Ident -> PaneView+consPane ident' = View ident' (ViewState False) def (Pane False False Nothing)++consLayoutAs :: Axis -> Ident -> LayoutView+consLayoutAs axis ident' = View ident' (ViewState False) def (Layout axis)++consLayout :: Ident -> LayoutView+consLayout =+ consLayoutAs Horizontal++consLayoutVertical :: Ident -> LayoutView+consLayoutVertical =+ consLayoutAs Vertical++instance Identifiable (View a) where+ identify = (.ident)++-- split in two so there can be no lone leaves (panes without layout) as type 'Tree'+data Tree l p =+ Tree {+ treeData :: l,+ treeSubs :: [TreeSub l p]+ }+ deriving stock (Eq, Show, Data, Generic)++instance Bifunctor Tree where+ first f (Tree l sub) = Tree (f l) (fmap (first f) sub)++ second f (Tree l sub) =+ Tree l (fmap (second f) sub)++instance Functor (Tree l) where+ fmap = second++instance Bifoldable Tree where+ bifoldMap fl fr (Tree l sub) = mappend (fl l) (foldMap (bifoldMap fl fr) sub)++data TreeSub l p =+ TreeNode { subTree :: Tree l p }+ |+ TreeLeaf { leafData :: p }+ deriving stock (Eq, Show, Data, Generic)++instance Bifunctor TreeSub where+ first f (TreeNode t) = TreeNode (first f t)+ first _ (TreeLeaf p) = TreeLeaf p++ second f (TreeNode t) = TreeNode (second f t)+ second f (TreeLeaf p) = TreeLeaf (f p)++instance Functor (TreeSub l) where+ fmap = second++instance Bifoldable TreeSub where+ bifoldMap fl fr (TreeNode t) = bifoldMap fl fr t+ bifoldMap _ fr (TreeLeaf p) = fr p++instance (Data l, Data p) => Plated (Tree l p)++type ViewTree = Tree LayoutView PaneView+type ViewTreeSub = TreeSub LayoutView PaneView++instance Identifiable l => Identifiable (Tree l p) where+ identify (Tree l _) = identify l++type instance Index (Tree _ _) = Ident+type instance IxValue (Tree l p) = Tree l p++instance Identifiable l => Ixed (Tree l p) where+ ix i = matchIdentP i++instance (Pretty l, Pretty p) => Pretty (TreeSub l p) where+ pretty (TreeNode a) =+ pretty a+ pretty (TreeLeaf a) =+ pretty a++instance (Pretty l, Pretty p) => Pretty (Tree l p) where+ pretty (Tree l sub) =+ nest 2 . vsep $ pretty l : (pretty <$> sub)++treeTraversal :: Traversal' (Tree l p) (Tree l p)+treeTraversal = #treeSubs . each . #_TreeNode++treeByIdentTraversal :: Identifiable l => Ident -> Traversal' (Tree l p) (Tree l p)+treeByIdentTraversal ident' = treeTraversal . ix ident'++treesIdent ::+ ∀ l p .+ Identifiable l =>+ Data l =>+ Data p =>+ Ident ->+ Fold (Tree l p) (Tree l p)+treesIdent ident' = cosmos . ix ident'++treeByIdent ::+ ∀ l p .+ Identifiable l =>+ Data l =>+ Data p =>+ Ident ->+ Tree l p ->+ Maybe (Tree l p)+treeByIdent ident' = preview (treesIdent ident')++treesByIdent ::+ ∀ l p .+ Identifiable l =>+ Data l =>+ Data p =>+ Ident ->+ Tree l p ->+ [Tree l p]+treesByIdent ident' = toListOf (treesIdent ident')++-- | All subtrees including self.+trees :: (Data l, Data p) => Fold (Tree l p) (Tree l p)+trees = cosmos++-- | All transitive leaves in the tree.+leaves :: (Data l, Data p) => Fold (Tree l p) p+leaves = cosmos . #treeSubs . each . #_TreeLeaf++-- | All transitive nodes in the tree.+nodes :: (Data l, Data p) => Fold (Tree l p) l+nodes = cosmos . #treeData
+ lib/Chiasma/Ui/Data/ViewGeometry.hs view
@@ -0,0 +1,26 @@+module Chiasma.Ui.Data.ViewGeometry where++import Data.Data (Data)+import Prettyprinter (Doc, Pretty (..), emptyDoc, space, (<+>))++data ViewGeometry =+ ViewGeometry {+ minSize :: Maybe Float,+ maxSize :: Maybe Float,+ fixedSize :: Maybe Float,+ minimizedSize :: Maybe Float,+ weight :: Maybe Float,+ position :: Maybe Float+ }+ deriving stock (Eq, Show, Data, Generic)+ deriving anyclass (Default)++mayPretty :: Text -> Maybe Float -> Doc a+mayPretty prefix (Just a) =+ space <> pretty prefix <> ":" <+> pretty a+mayPretty _ Nothing =+ emptyDoc++instance Pretty ViewGeometry where+ pretty (ViewGeometry minSize maxSize fixedSize _ _ _) =+ foldl @[] (<>) emptyDoc (uncurry mayPretty <$> [("min", minSize), ("max", maxSize), ("fixed", fixedSize)])
+ lib/Chiasma/Ui/Data/ViewState.hs view
@@ -0,0 +1,12 @@+module Chiasma.Ui.Data.ViewState where++import Data.Data (Data)++newtype ViewState =+ ViewState {+ minimized :: Bool+ }+ deriving stock (Eq, Show, Data, Generic)++instance Default ViewState where+ def = ViewState False
+ lib/Chiasma/Ui/Lens/Ident.hs view
@@ -0,0 +1,21 @@+module Chiasma.Ui.Lens.Ident where++import Control.Lens (Prism', prism)++import Chiasma.Data.Ident (Ident, Identifiable (..), sameIdent)++matchIdent :: Identifiable a => Ident -> Traversal' a a+matchIdent i =+ filtered (sameIdent i)++matchIdentL :: Identifiable a => Ident -> Traversal' [a] a+matchIdentL ident =+ each . matchIdent ident++identEither :: Identifiable a => Ident -> a -> Either a a+identEither target a =+ if sameIdent target a then Right a else Left a++matchIdentP :: Identifiable a => Ident -> Prism' a a+matchIdentP ident =+ prism id (identEither ident)
+ lib/Chiasma/Ui/Measure.hs view
@@ -0,0 +1,79 @@+module Chiasma.Ui.Measure where++import qualified Data.List.NonEmpty as NonEmpty (zip)++import qualified Chiasma.Data.Axis as Axis+import Chiasma.Data.Axis (Axis (Horizontal, Vertical))+import Chiasma.Ui.Data.Measure (MLayout (..), MPane (..), MeasureTree, MeasureTreeSub, Measured (..))+import Chiasma.Ui.Data.RenderableTree (RLayout (..), RPane (..), Renderable (..), RenderableNode, RenderableTree)+import Chiasma.Ui.Data.Tree (Tree (..))+import qualified Chiasma.Ui.Data.Tree as Tree (Node (..))+import Chiasma.Ui.Data.ViewGeometry (ViewGeometry (fixedSize, maxSize, minSize))+import Chiasma.Ui.Data.ViewState (ViewState (ViewState))+import Chiasma.Ui.Measure.Balance (balanceSizes)+import Chiasma.Ui.Measure.Weights (viewWeights)++minimizedSizeOrDefault :: ViewGeometry -> Float+minimizedSizeOrDefault = fromMaybe 2 . (.minSize)++effectiveFixedSize :: ViewState -> ViewGeometry -> Maybe Float+effectiveFixedSize (ViewState minimized) viewGeom =+ if minimized then Just (minimizedSizeOrDefault viewGeom) else viewGeom.fixedSize++actualSize :: (ViewGeometry -> Maybe Float) -> ViewState -> ViewGeometry -> Maybe Float+actualSize getter viewState viewGeom =+ getter viewGeom <|> effectiveFixedSize viewState viewGeom++actualMinSizes :: NonEmpty (ViewState, ViewGeometry) -> NonEmpty Float+actualMinSizes =+ fmap (fromMaybe 0.0 . uncurry (actualSize (.minSize)))++actualMaxSizes :: NonEmpty (ViewState, ViewGeometry) -> NonEmpty (Maybe Float)+actualMaxSizes =+ fmap (uncurry $ actualSize (.maxSize))++isMinimized :: ViewState -> ViewGeometry -> Bool+isMinimized (ViewState minimized) _ = minimized++subMeasureData :: RenderableNode -> (ViewState, ViewGeometry)+subMeasureData (Tree.Sub (Tree (Renderable s g _) _)) = (s, g)+subMeasureData (Tree.Leaf (Renderable s g _)) = (s, g)++measureLayoutViews :: Float -> NonEmpty RenderableNode -> NonEmpty Int+measureLayoutViews total views =+ balanceSizes minSizes maxSizes weights minimized cells+ where+ measureData = fmap subMeasureData views+ paneSpacers = fromIntegral (length views) - 1.0+ cells = total - paneSpacers+ sizesInCells s = if s > 1 then s else s * cells+ minSizes = fmap sizesInCells (actualMinSizes measureData)+ maxSizes = fmap (fmap sizesInCells) (actualMaxSizes measureData)+ minimized = fmap (uncurry isMinimized) measureData+ weights = viewWeights measureData++measureSub :: Int -> Int -> Axis -> RenderableNode -> Int -> MeasureTreeSub+measureSub width height axis (Tree.Sub tree) size =+ Tree.Sub (measureLayout tree newWidth newHeight axis)+ where+ (newWidth, newHeight) =+ case axis of+ Vertical -> (width, size)+ Horizontal -> (size, height)+measureSub _ _ (Axis.vertical -> vertical) (Tree.Leaf (Renderable _ _ (RPane paneId top left))) size =+ Tree.Leaf (Measured size (MPane paneId (if vertical then top else left) (if vertical then left else top)))++measureLayout :: RenderableTree -> Int -> Int -> Axis -> MeasureTree+measureLayout (Tree (Renderable _ _ (RLayout (RPane refId refTop refLeft) axis)) sub) width height (Axis.vertical -> parentVertical) =+ Tree (Measured sizeInParent (MLayout refId mainPos offPos axis)) measuredSub+ where+ sizeInParent = if parentVertical then height else width+ mainPos = if parentVertical then refTop else refLeft+ offPos = if parentVertical then refLeft else refTop+ subTotalSize = if Axis.vertical axis then height else width+ sizes = measureLayoutViews (fromIntegral subTotalSize) sub+ measuredSub = uncurry (measureSub width height axis) <$> NonEmpty.zip sub sizes++measureTree :: RenderableTree -> Int -> Int -> MeasureTree+measureTree tree width height =+ measureLayout tree width height Horizontal
+ lib/Chiasma/Ui/Measure/Balance.hs view
@@ -0,0 +1,169 @@+module Chiasma.Ui.Measure.Balance where++import Data.List (zipWith3)+import qualified Data.List.NonEmpty as NonEmpty++import Chiasma.Ui.Measure.Weights (amendAndNormalizeWeights, normalizeWeights)++zipWith3NE :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d+zipWith3NE z ~(a :| as) ~(b :| bs) ~(c :| cs) =+ z a b c :| zipWith3 z as bs cs++data Balance =+ Balance {+ balanceMin :: NonEmpty Float,+ balanceMax :: NonEmpty (Maybe Float),+ balanceWeights :: NonEmpty Float,+ balanceMinimized :: NonEmpty Bool,+ balanceTotal :: Float+ }++reverseWeights :: NonEmpty Float -> NonEmpty Float+reverseWeights weights =+ rev <$> r+ where+ rev a =+ fromMaybe a (a / norm)+ r =+ fmap (1 -) weights+ norm =+ sum r++cutSizes :: Balance -> NonEmpty Float+cutSizes (Balance minSizes _ weights _ total) =+ addNegatives <$> truncatedWeighted+ where+ surplus =+ sum minSizes - total+ surplusDistWeighted =+ fmap (surplus *) (reverseWeights weights)+ truncatedWeighted =+ fmap (uncurry (-)) (NonEmpty.zip minSizes surplusDistWeighted)+ negOrZero a =+ if a < 0 then a else 0+ neg =+ fmap negOrZero truncatedWeighted+ negTotal =+ sum neg+ negCount =+ length (NonEmpty.filter (< 0) neg)+ negativesDist =+ fromMaybe 0 (negTotal / realToFrac (length minSizes - negCount))+ addNegatives a =+ if a < 0 then 0 else a + negativesDist++distributeOnUnbounded :: Balance -> NonEmpty Float+distributeOnUnbounded (Balance min' max' weights _ total) =+ NonEmpty.zipWith addWeights initial newWeights+ where+ initial = NonEmpty.zipWith fromMaybe min' max'+ newWeights = normalizeWeights $ NonEmpty.zipWith weightOrZeroIfMax weights max'+ addWeights i w = i + (w * surplus)+ surplus = total - sum initial+ weightOrZeroIfMax w = maybe w (const 0)++weightsWithoutMinimized :: Balance -> NonEmpty Float+weightsWithoutMinimized (Balance _ _ weights minimized _) =+ normalizeWeights zeroIfMinimizedWeights+ where+ zeroIfMinimizedWeights = NonEmpty.zipWith zeroIfMinimized weights minimized+ zeroIfMinimized w m = if m then 0 else w++trimWeights :: NonEmpty Bool -> NonEmpty Float -> NonEmpty Float+trimWeights unsat withoutMinimized =+ amendAndNormalizeWeights onlyUnsat+ where+ onlyUnsat = NonEmpty.zipWith weightIfUnsat unsat withoutMinimized+ weightIfUnsat s w = if s then Just w else Nothing++distRest :: Balance -> Float -> NonEmpty Float -> NonEmpty Float -> NonEmpty Float+distRest balance rest sizes effectiveMax =+ NonEmpty.zipWith addRestWeights sizes restW+ where+ unsat = NonEmpty.zipWith (>) effectiveMax sizes+ unsatLeft = or unsat+ withoutMinimized = weightsWithoutMinimized balance+ restW =+ if unsatLeft+ then trimWeights unsat withoutMinimized+ else withoutMinimized+ addRestWeights s w = s + w * rest++saturate :: NonEmpty Float -> NonEmpty Float -> NonEmpty Float -> Float -> NonEmpty Float+saturate initial max' initialWeights total =+ loop initial initialWeights+ where+ loop current weights =+ if new == current || rest <= 0 then new else loop new newWeights+ where+ rest = total - sum current+ unsatWeights = zipWith3NE (\s m w -> if s >= m then 0 else w) current max' weights+ newWeights = normalizeWeights unsatWeights+ new = zipWith3NE (\l h w -> min (l + w * rest) h) current max' newWeights++distributeOnAll :: Balance -> NonEmpty Float+distributeOnAll balance@(Balance min' max' weights _ total) =+ if rest <= 0 then sizes else distRest balance rest sizes effectiveMax+ where+ effectiveMax = fromMaybe 1e6 <$> max'+ sizes = saturate min' effectiveMax weights total+ rest = total - sum sizes++hasUnbounded :: Balance -> Bool+hasUnbounded =+ any isNothing . (.balanceMax)++distributeSizes :: Balance -> NonEmpty Float+distributeSizes balance =+ handler balance+ where+ handler =+ if (maxTotal < balance.balanceTotal) && hasUnbounded balance+ then distributeOnUnbounded+ else distributeOnAll+ maxTotal = sum (catMaybes $ NonEmpty.toList $ (.balanceMax) balance)++roundSizes :: NonEmpty Float -> NonEmpty Int+roundSizes (h :| t) =+ roundedHead + round surplus :| roundedTail+ where+ (surplus, roundedTail) = mapAccumL folder diff0 t+ (roundedHead, diff0) = diff h+ folder z a =+ (z + z1, a1)+ where+ (a1, z1) = diff a+ diff a = (floor a, a - fromIntegral (floor a :: Int))++-- | Tmux doesn't render panes smaller than two cells.+ensureMinimum2 :: NonEmpty Float -> NonEmpty Float+ensureMinimum2 sizes =+ choose <$> positives+ where+ positive =+ max 0+ positives =+ positive <$> sizes+ overTwoCount =+ length (NonEmpty.filter (>= 2) sizes)+ unders =+ amountUnderTwo <$> positives+ -- If no sizes are larger than 2, nothing will have to be subtracted, all sizes will be clamped to 2+ amountUnderTwoDist =+ fromMaybe 0 (sum unders / realToFrac overTwoCount)+ amountUnderTwo a =+ positive (2 - a)+ choose a =+ max 2 (a - amountUnderTwoDist)++rectifySizes :: NonEmpty Float -> NonEmpty Int+rectifySizes =+ roundSizes . ensureMinimum2++-- FIXME need to round manually, keeping track of the surplus, in order to achieve determinism+balanceSizes :: NonEmpty Float -> NonEmpty (Maybe Float) -> NonEmpty Float -> NonEmpty Bool -> Float -> NonEmpty Int+balanceSizes minSizes maxSizes weights minimized total =+ rectifySizes (fit balance)+ where+ fit = if sum minSizes > total then cutSizes else distributeSizes+ balance = Balance minSizes maxSizes weights minimized total
+ lib/Chiasma/Ui/Measure/Weights.hs view
@@ -0,0 +1,36 @@+module Chiasma.Ui.Measure.Weights where++import qualified Data.List.NonEmpty as NonEmpty (filter, toList)++import Chiasma.Ui.Data.ViewGeometry (ViewGeometry (ViewGeometry))+import Chiasma.Ui.Data.ViewState (ViewState (ViewState))++effectiveWeight :: ViewState -> ViewGeometry -> Maybe Float+effectiveWeight (ViewState minimized) (ViewGeometry _ _ fixedSize _ weight _) =+ if isJust fixedSize || minimized then Just 0 else weight++amendWeights :: NonEmpty (Maybe Float) -> NonEmpty Float+amendWeights weights =+ fmap (fromMaybe emptyWeight) weights+ where+ total =+ sum (catMaybes (NonEmpty.toList weights))+ normTotal =+ if total == 0 then 1 else total+ empties =+ length (NonEmpty.filter isNothing weights)+ emptyWeight =+ fromMaybe normTotal (normTotal / realToFrac empties)++normalizeWeights :: NonEmpty Float -> NonEmpty Float+normalizeWeights weights =+ fmap norm weights+ where+ norm a =+ fromMaybe a (a / sum weights)++amendAndNormalizeWeights :: NonEmpty (Maybe Float) -> NonEmpty Float+amendAndNormalizeWeights = normalizeWeights . amendWeights++viewWeights :: NonEmpty (ViewState, ViewGeometry) -> NonEmpty Float+viewWeights = amendAndNormalizeWeights . fmap (uncurry effectiveWeight)
+ lib/Chiasma/Ui/Pane.hs view
@@ -0,0 +1,17 @@+module Chiasma.Ui.Pane(+ paneToggleOpen,+ paneSetOpen,+) where++import Chiasma.Ui.Data.View (View(View), PaneView, Pane(Pane))+import Chiasma.Ui.Data.ViewState (ViewState(ViewState))++paneToggleOpen :: PaneView -> PaneView+paneToggleOpen (View i s g (Pane False pin cwd)) =+ View i s g (Pane True pin cwd)+paneToggleOpen (View i (ViewState m) g e) =+ View i (ViewState (not m)) g e++paneSetOpen :: PaneView -> PaneView+paneSetOpen (View i s g (Pane _ pin cwd)) =+ View i s g (Pane True pin cwd)
+ lib/Chiasma/Ui/ShowTree.hs view
@@ -0,0 +1,45 @@+module Chiasma.Ui.ShowTree where++import Chiasma.Data.Ident (identText)+import Chiasma.Ui.Data.View (+ LayoutView,+ Pane (Pane),+ PaneView,+ Tree (Tree),+ TreeSub (TreeLeaf, TreeNode),+ View (View),+ ViewTree,+ )++formatLayout :: LayoutView -> Text+formatLayout (View ident _ _ _) = "l: " <> identText ident++formatPane :: PaneView -> Text+formatPane (View ident _ _ (Pane open _ _)) =+ "p: " <> identText ident <> openFrag+ where+ openFrag = " " <> if open then "open" else "closed"++formatViewTree :: ViewTree -> Tree Text Text+formatViewTree = bimap formatLayout formatPane++indent :: [Text] -> [Text]+indent = fmap (" " <>)++showTreeSub :: TreeSub Text Text -> [Text]+showTreeSub (TreeNode tree) = showTree tree+showTreeSub (TreeLeaf pane) = [pane]++showTree :: Tree Text Text -> [Text]+showTree (Tree l sub) =+ l : indent (sub >>= showTreeSub)++showViewTree :: ViewTree -> [Text]+showViewTree = showTree . formatViewTree++printViewTree :: MonadIO m => ViewTree -> m ()+printViewTree =+ liftIO .+ traverse_ putStrLn .+ fmap toString .+ showViewTree
+ lib/Chiasma/Ui/ViewTree.hs view
@@ -0,0 +1,306 @@+module Chiasma.Ui.ViewTree where++import Control.Lens (cosmos, ix, transformM)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)+import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)+import Data.Composition ((.:))+import Data.Semigroup (Sum (Sum))+import Exon (exon)+import Prelude hiding (ix, tell)++import Chiasma.Data.Ident (Ident)+import Chiasma.Lens.Tree (LeafIndexTree (..), _litTree, leafDataTraversal)+import Chiasma.Ui.Data.TreeModError (TreeModError (AmbiguousLayout, AmbiguousPane, LayoutMissing, PaneMissing))+import Chiasma.Ui.Data.View (+ Pane (Pane),+ PaneView,+ Tree (Tree),+ TreeSub (TreeLeaf, TreeNode),+ View (View),+ ViewTree,+ ViewTreeSub,+ )+import Chiasma.Ui.Data.ViewState (ViewState (ViewState))+import Chiasma.Ui.Pane (paneSetOpen, paneToggleOpen)++modCounted :: Monad m => (a -> m a) -> a -> WriterT (Sum Int) m a+modCounted f a = do+ tell (Sum 1)+ lift $ f a++treeToggleOpen :: ViewTree -> ViewTree+treeToggleOpen (Tree l sub) =+ Tree l (snd $ mapAccumL toggle False sub)+ where+ toggle False (TreeLeaf p) = (True, TreeLeaf (paneToggleOpen p))+ toggle a b = (a, b)++modifyTreeUniqueM :: Monad m => (ViewTree -> m ViewTree) -> Ident -> ViewTree -> ExceptT TreeModError m ViewTree+modifyTreeUniqueM f ident tree = do+ let st = (transformM $ mapMOf (ix ident) (modCounted f)) tree+ (result, Sum count) <- lift $ runWriterT st+ case count of+ 1 -> pure result+ 0 -> ExceptT (pure (Left (LayoutMissing ident)))+ n -> ExceptT (pure (Left (AmbiguousLayout ident n)))++toggleLayout1 :: Ident -> ViewTree -> Either TreeModError ViewTree+toggleLayout1 ident tree =+ runIdentity $ runExceptT $ modifyTreeUniqueM (Identity . treeToggleOpen) ident tree++modifyPaneUniqueM :: Monad m => (PaneView -> m PaneView) -> Ident -> ViewTree -> ExceptT TreeModError m ViewTree+modifyPaneUniqueM f ident tree = do+ let st = (transformM $ mapMOf (ix ident) (modCounted f)) (LeafIndexTree tree)+ (result, Sum count) <- lift $ runWriterT st+ case count of+ 1 -> pure $ (.litTree) result+ 0 -> ExceptT (pure (Left (PaneMissing ident)))+ n -> ExceptT (pure (Left (AmbiguousPane ident n)))++modifyPane :: (PaneView -> PaneView) -> Ident -> ViewTree -> Either TreeModError ViewTree+modifyPane modification ident tree =+ runIdentity $ runExceptT $ modifyPaneUniqueM (Identity . modification) ident tree++openPane :: Ident -> ViewTree -> Either TreeModError ViewTree+openPane =+ modifyPane paneSetOpen++hasOpenPanes :: ViewTree -> Bool+hasOpenPanes tree =+ has (cosmos . _litTree . leafDataTraversal . filtered isOpen) (LeafIndexTree tree)+ where+ isOpen (View _ _ _ (Pane open _ _)) = open++depthTraverseTree ::+ ∀ a.+ Monoid a =>+ (a -> ViewTree -> (a, ViewTree)) ->+ (PaneView -> (a, PaneView)) ->+ ViewTree ->+ (a, ViewTree)+depthTraverseTree transformNode transformLeaf =+ recur+ where+ recur :: ViewTree -> (a, ViewTree)+ recur (Tree l sub) =+ uncurry transformNode . bimap fold (Tree l) . unzip $ (recSub <$> sub)+ recSub :: ViewTreeSub -> (a, ViewTreeSub)+ recSub (TreeNode t) =+ second TreeNode $ recur t+ recSub (TreeLeaf l) =+ second TreeLeaf $ transformLeaf l++data ToggleStatus =+ Minimized+ |+ Opened+ |+ Pristine+ |+ Multiple Int+ |+ Consistent+ deriving stock (Eq, Show)++instance Semigroup ToggleStatus where+ Pristine <> a = a+ a <> Pristine = a+ Multiple a <> Multiple b = Multiple (a + b)+ Multiple a <> _ = Multiple (a + 1)+ _ <> Multiple a = Multiple (a + 1)+ _ <> _ = Multiple 2++instance Monoid ToggleStatus where+ mempty = Pristine++data ToggleResult a =+ Success a+ |+ NotFound+ |+ Ambiguous Int+ deriving stock (Eq, Show, Functor)++instance Semigroup (ToggleResult a) where+ NotFound <> a = a+ a <> NotFound = a+ Ambiguous a <> Ambiguous b = Ambiguous (a + b)+ Ambiguous a <> _ = Ambiguous (a + 1)+ _ <> Ambiguous a = Ambiguous (a + 1)+ _ <> _ = Ambiguous 2++instance Monoid (ToggleResult a) where+ mempty = NotFound++instance Applicative ToggleResult where+ pure = Success+ (Success f) <*> fa = fmap f fa+ NotFound <*> _ = NotFound+ Ambiguous n <*> _ = Ambiguous n++instance Monad ToggleResult where+ Success a >>= f = f a+ NotFound >>= _ = NotFound+ Ambiguous n >>= _ = Ambiguous n++toggleResultEither :: ToggleResult a -> Either Text a+toggleResultEither = \case+ Success a -> Right a+ NotFound -> Left "not found"+ Ambiguous n -> Left [exon|ambiguous: #{show n}|]++openPinnedSubs :: ToggleStatus -> ViewTree -> (ToggleStatus, ViewTree)+openPinnedSubs Pristine t =+ (Pristine, t)+openPinnedSubs Opened (Tree l sub) =+ (Opened, Tree l (openPinnedPane <$> sub))+ where+ openPinnedPane :: ViewTreeSub -> ViewTreeSub+ openPinnedPane (TreeLeaf (View i s g (Pane False True cwd))) =+ TreeLeaf $ View i s g (Pane True True cwd)+ openPinnedPane v =+ v+openPinnedSubs a t =+ (a, t)++checkToggleResult ::+ ToggleStatus ->+ a ->+ ToggleResult a+checkToggleResult =+ checkResult+ where+ checkResult Pristine _ = NotFound+ checkResult (Multiple n) _ = Ambiguous n+ checkResult _ result = Success result++togglePaneView :: Ident -> PaneView -> (ToggleStatus, PaneView)+togglePaneView ident (View i s g (Pane False p c)) | ident == i =+ (Opened, View i s g (Pane True p c))+togglePaneView ident (View i (ViewState minimized) g (Pane True p c)) | ident == i =+ (Minimized, View i (ViewState (not minimized)) g (Pane False p c))+togglePaneView _ v =+ (Pristine, v)++togglePaneNode :: Ident -> ViewTreeSub -> (ToggleStatus, ViewTreeSub)+togglePaneNode ident (TreeLeaf v) =+ second TreeLeaf (togglePaneView ident v)+togglePaneNode _ t =+ (Pristine, t)++togglePane :: Ident -> ViewTree -> ToggleResult ViewTree+togglePane ident =+ uncurry checkToggleResult . depthTraverseTree openPinnedSubs (togglePaneView ident)++togglePaneOpenTraversal' ::+ Traversal' a ViewTree ->+ Ident ->+ a ->+ ToggleResult a+togglePaneOpenTraversal' lens =+ mapMOf lens . togglePane++ensurePaneViewOpen :: Ident -> PaneView -> (ToggleStatus, PaneView)+ensurePaneViewOpen ident (View i s g (Pane False p c)) | ident == i =+ (Opened, View i s g (Pane True p c))+ensurePaneViewOpen ident v@(View i _ _ _) | ident == i =+ (Consistent, v)+ensurePaneViewOpen _ v =+ (Pristine, v)++ensurePaneOpen :: Ident -> ViewTree -> ToggleResult ViewTree+ensurePaneOpen ident =+ uncurry checkToggleResult . depthTraverseTree openPinnedSubs (ensurePaneViewOpen ident)++ensurePaneOpenTraversal ::+ Traversal a (ToggleResult a) ViewTree (ToggleResult ViewTree) ->+ Ident ->+ a ->+ ToggleResult a+ensurePaneOpenTraversal lens =+ over lens . ensurePaneOpen++ensurePaneOpenTraversal' ::+ Traversal' a ViewTree ->+ Ident ->+ a ->+ ToggleResult a+ensurePaneOpenTraversal' lens =+ mapMOf lens . ensurePaneOpen++skipFold ::+ Traversable t =>+ (a -> (ToggleStatus, a)) ->+ ToggleStatus ->+ t a ->+ (ToggleStatus, t a)+skipFold f =+ mapAccumL skipper+ where+ skipper Pristine a =+ f a+ skipper status a =+ (status, a)++isOpenPaneNode :: ViewTreeSub -> Bool+isOpenPaneNode =+ anyOf (#_TreeLeaf . #extra . #open) id++openPinnedPaneView :: PaneView -> (ToggleStatus, PaneView)+openPinnedPaneView (View i s g (Pane False True c)) =+ (Opened, View i s g (Pane True True c))+openPinnedPaneView v =+ (Pristine, v)++openFirstPinnedPaneNode :: ViewTreeSub -> (ToggleStatus, ViewTreeSub)+openFirstPinnedPaneNode (TreeLeaf v) =+ second TreeLeaf (openPinnedPaneView v)+openFirstPinnedPaneNode a =+ (Pristine, a)++openPaneView :: PaneView -> (ToggleStatus, PaneView)+openPaneView (View i s g (Pane False p c)) =+ (Opened, View i s g (Pane True p c))+openPaneView v =+ (Pristine, v)++openFirstPaneNode :: ViewTreeSub -> (ToggleStatus, ViewTreeSub)+openFirstPaneNode (TreeLeaf v) =+ second TreeLeaf (openPaneView v)+openFirstPaneNode a =+ (Pristine, a)++-- TODO recurse when opening pane+toggleLayoutNode :: Ident -> ToggleStatus -> ViewTree -> (ToggleStatus, ViewTree)+toggleLayoutNode ident previous (Tree v@(View i (ViewState minimized) g l) sub) | ident == i =+ first (previous <>) (if open then toggleMinimized else openPane')+ where+ open =+ any isOpenPaneNode sub+ toggleMinimized =+ (Minimized, Tree (View i (ViewState (not minimized)) g l) sub)+ openPane' =+ second (Tree v) (uncurry regularIfPristine openFirstPinned)+ openFirstPinned =+ skipFold openFirstPinnedPaneNode Pristine sub+ openFirstRegular =+ skipFold openFirstPaneNode Pristine sub+ regularIfPristine Pristine _ =+ openFirstRegular+ regularIfPristine status a =+ (status, a)+toggleLayoutNode _ a t =+ (a, t)++toggleLayout :: Ident -> ViewTree -> ToggleResult ViewTree+toggleLayout ident =+ uncurry checkToggleResult . depthTraverseTree (uncurry openPinnedSubs .: toggleLayoutNode ident) (Pristine,)++toggleLayoutOpenTraversal' ::+ Traversal' a ViewTree ->+ Ident ->+ a ->+ ToggleResult a+toggleLayoutOpenTraversal' lens =+ mapMOf lens . toggleLayout
+ lib/Chiasma/View.hs view
@@ -0,0 +1,125 @@+module Chiasma.View where++import qualified Control.Lens as Lens+import Exon (exon)+import Prettyprinter (Doc, pretty)+import Prettyprinter.Render.Terminal (AnsiStyle)++import Chiasma.Data.Ident (Ident, identText, sameIdent)+import Chiasma.Data.TmuxId (PaneId, SessionId, WindowId)+import qualified Chiasma.Data.View+import Chiasma.Data.View (View (View))+import Chiasma.Data.Views (Views, ViewsError (..))+import qualified Chiasma.Data.Views as Views (log, panes, sessions, windows)+import Chiasma.Lens.Where (where1)++sameId :: Eq a => a -> View a -> Bool+sameId id' (View _ (Just vid)) = id' == vid+sameId _ _ = False++view :: Lens' Views [View a] -> (Ident -> ViewsError) -> Ident -> Views -> Either ViewsError (View a)+view viewsL consError ident =+ maybeToRight (consError ident) . find (sameIdent ident) . Lens.view viewsL++viewById :: Eq a => Lens' Views [View a] -> a -> Views -> Maybe (View a)+viewById viewsL id' =+ find (sameId id') . Lens.view viewsL++insertView :: Lens' Views [View a] -> View a -> Views -> Views+insertView viewsL newView = over viewsL (newView :)++updateView ::+ ∀ a .+ Lens' Views [View a] ->+ (Ident -> ViewsError) ->+ View a ->+ Views ->+ Views+updateView viewsL _ newView =+ set (viewsL . where1 (sameIdent newView.ident)) newView++session :: Ident -> Views -> Either ViewsError (View SessionId)+session = view Views.sessions NoSuchSession++sessionById :: SessionId -> Views -> Maybe (View SessionId)+sessionById = viewById Views.sessions++insertSession :: View SessionId -> Views -> Views+insertSession = insertView Views.sessions++updateSession :: View SessionId -> Views -> Views+updateSession = updateView Views.sessions NoSuchSession++window :: Ident -> Views -> Either ViewsError (View WindowId)+window = view Views.windows NoSuchWindow++windowById :: WindowId -> Views -> Maybe (View WindowId)+windowById = viewById Views.windows++insertWindow :: View WindowId -> Views -> Views+insertWindow = insertView Views.windows++updateWindow :: View WindowId -> Views -> Views+updateWindow = updateView Views.windows NoSuchWindow++pane :: Ident -> Views -> Either ViewsError (View PaneId)+pane = view Views.panes NoSuchPane++paneById :: PaneId -> Views -> Maybe (View PaneId)+paneById = viewById Views.panes++paneId :: Ident -> Views -> Either ViewsError PaneId+paneId paneIdent views =+ pane paneIdent views >>= trans+ where+ trans (View _ (Just paneId')) = Right paneId'+ trans _ = Left $ NoPaneId paneIdent++insertPane :: View PaneId -> Views -> Views+insertPane = insertView Views.panes++updatePane :: View PaneId -> Views -> Views+updatePane = updateView Views.panes NoSuchPane++type Getter a = Ident -> Views -> Either ViewsError (View a)+type Setter a = View a -> Views -> Views++viewsLog ::+ Member (AtomicState Views) r =>+ Doc AnsiStyle ->+ Sem r ()+viewsLog message =+ atomicModify' f+ where+ f :: Views -> Views+ f = over Views.log (message :)++viewsLogS ::+ Member (AtomicState Views) r =>+ Text ->+ Sem r ()+viewsLogS =+ viewsLog . pretty++addView ::+ Member (AtomicState Views) r =>+ Setter a ->+ Ident ->+ Sem r (View a)+addView setter ident = do+ atomicModify' (setter newView)+ viewsLogS [exon|added tmux view #{identText ident}|]+ pure newView+ where+ newView =+ View ident Nothing++findOrCreateView ::+ Member (AtomicState Views) r =>+ Getter a ->+ Setter a ->+ Ident ->+ Sem r (View a)+findOrCreateView getter setter ident = do+ existing <- atomicGets (getter ident)+ either (const (addView setter ident)) pure existing
+ lib/Chiasma/View/State.hs view
@@ -0,0 +1,13 @@+module Chiasma.View.State where++import Chiasma.Data.Ident (Ident)+import Chiasma.Data.TmuxId (PaneId)+import Chiasma.Data.Views (Views, ViewsError)+import qualified Chiasma.View as Views (paneId)++paneId ::+ Members [AtomicState Views, Stop ViewsError] r =>+ Ident ->+ Sem r PaneId+paneId paneIdent =+ stopEither =<< atomicGets (Views.paneId paneIdent)
+ lib/Chiasma/Window.hs view
@@ -0,0 +1,224 @@+module Chiasma.Window where++import qualified Data.List.NonEmpty as NonEmpty (head, nonEmpty)+import Path (Abs, Dir, Path, parseAbsDir)+import Prettyprinter (line, pretty, vsep, (<+>))++import qualified Chiasma.Codec.Data.Pane as Pane+import qualified Chiasma.Codec.Data.Pane as Codec (Pane (Pane))+import Chiasma.Codec.Data.Pane (Pane (Pane))+import qualified Chiasma.Codec.Data.Window as Codec (Window (Window, windowId))+import qualified Chiasma.Command.Pane as Cmd (closePane, firstWindowPane, windowPanes)+import qualified Chiasma.Command.Window as Cmd (newWindow, splitWindowInDir, window)+import Chiasma.Data.Axis (Axis)+import Chiasma.Data.Ident (Ident, identText, identify)+import Chiasma.Data.Panes (TmuxPanes)+import Chiasma.Data.RenderError (RenderError)+import qualified Chiasma.Data.RenderError as RenderError (RenderError (NoPrincipal))+import Chiasma.Data.TmuxId (PaneId, SessionId, WindowId)+import qualified Chiasma.Data.View as Tmux (View (View))+import Chiasma.Data.Views (Views)+import Chiasma.Data.WindowState (WindowState (..))+import Chiasma.Effect.TmuxApi (Tmux)+import Chiasma.Pane (addPane)+import Chiasma.Ui.Data.RenderableTree (RLayout (..), RPane (..), Renderable (..), RenderableNode, RenderableTree)+import qualified Chiasma.Ui.Data.Tree as Tree (Node (Leaf, Sub), Tree (Tree))+import Chiasma.Ui.Data.View (Tree (..), TreeSub (..), ViewTree, ViewTreeSub)+import qualified Chiasma.Ui.Data.View as Ui (Layout (..), Pane (Pane), PaneView, View (View))+import Chiasma.Ui.Data.ViewGeometry (ViewGeometry (ViewGeometry, position))+import Chiasma.Ui.Data.ViewState (ViewState)+import Chiasma.View (findOrCreateView, viewsLog, viewsLogS)+import qualified Chiasma.View as Views (insertPane, insertWindow, pane, paneById, updatePane, updateWindow, window)++findOrCreateWindow ::+ Member (AtomicState Views) r =>+ Ident ->+ Sem r (Tmux.View WindowId)+findOrCreateWindow =+ findOrCreateView Views.window Views.insertWindow++registerWindowId ::+ Member (AtomicState Views) r =>+ Ident ->+ WindowId ->+ Sem r ()+registerWindowId ident windowId =+ atomicModify' (Views.updateWindow (Tmux.View ident (Just windowId)))++spawnWindow ::+ Members [AtomicState Views, Tmux] r =>+ SessionId ->+ Ident ->+ Sem r Codec.Window+spawnWindow sid ident = do+ win@(Codec.Window windowId _ _) <- Cmd.newWindow sid ident+ registerWindowId ident windowId+ viewsLogS $ "spawned window in session " <> show sid <> " with id " <> show windowId+ pure win++findPrincipalSub :: ViewTreeSub -> Maybe Ui.PaneView+findPrincipalSub (TreeNode t) = findPrincipal t+findPrincipalSub (TreeLeaf p@(Ui.View _ _ _ (Ui.Pane True _ _))) = Just p+findPrincipalSub _ = Nothing++findPrincipal :: ViewTree -> Maybe Ui.PaneView+findPrincipal (Tree _ sub) =+ firstJust findPrincipalSub sub++principalPane ::+ Members [AtomicState Views, Tmux, Stop RenderError] r =>+ ViewTree ->+ Sem r (Ui.PaneView, Tmux.View PaneId)+principalPane tree = do+ uiPane@(Ui.View uiPaneIdent _ _ _) <- stopNote (RenderError.NoPrincipal (identify tree)) $ (findPrincipal tree)+ existingTmuxPane <- atomicGets (Views.pane uiPaneIdent)+ tmuxPane <- either (const $ addPane uiPaneIdent) pure existingTmuxPane+ pure (uiPane, tmuxPane)++syncPrincipal ::+ Members [TmuxPanes Pane, AtomicState Views, Tmux, Stop RenderError] r =>+ WindowId ->+ ViewTree ->+ Sem r ()+syncPrincipal windowId tree@(Tree (Ui.View layoutIdent _ _ _) _) = do+ (Codec.Pane paneId _ _ _ _) <- Cmd.firstWindowPane windowId+ existing <- atomicGets (Views.paneById paneId)+ case existing of+ Nothing -> do+ (_, Tmux.View paneIdent _) <- principalPane tree+ viewsLog $ "setting principal of layout" <+> pretty layoutIdent <+> " to pane " <+> pretty paneIdent <+> "/" <+>+ pretty paneId+ atomicModify' $ Views.updatePane (Tmux.View paneIdent (Just paneId))+ _ -> pure ()++ensureWindow ::+ Members [TmuxPanes Pane, AtomicState Views, Tmux, Stop RenderError] r =>+ SessionId ->+ Tmux.View WindowId ->+ Maybe WindowId ->+ ViewTree ->+ Sem r Codec.Window+ensureWindow sid (Tmux.View ident mayWid) newSessionWid tree = do+ preexisting <- join <$> traverse Cmd.window (newSessionWid <|> mayWid)+ window <- maybe (spawnWindow sid ident) pure preexisting+ syncPrincipal ((.windowId) window) tree+ pure window++findOrCreatePane ::+ Member (AtomicState Views) r =>+ Ident ->+ Sem r (Tmux.View PaneId)+findOrCreatePane =+ findOrCreateView Views.pane Views.insertPane++nativePane ::+ Member (TmuxPanes Pane) r =>+ WindowId ->+ Tmux.View PaneId ->+ Sem r (Maybe Pane)+nativePane windowId (Tmux.View _ (Just paneId)) =+ find sameId <$> Cmd.windowPanes windowId+ where+ sameId (Pane i _ _ _ _) = i == paneId+nativePane _ _ = pure Nothing++openPane ::+ Members [AtomicState Views, Tmux] r =>+ Path Abs Dir ->+ WindowId ->+ Sem r Pane+openPane dir windowId = do+ detail <- Cmd.splitWindowInDir dir windowId+ viewsLogS $ "opened pane " <> show ((.paneId) detail) <> " in window " <> show windowId+ pure detail++ensurePaneOpen ::+ Members [AtomicState Views, Tmux] r =>+ Path Abs Dir ->+ Maybe Pane ->+ WindowId ->+ Sem r Pane+ensurePaneOpen _ (Just detail) _ =+ pure detail+ensurePaneOpen dir Nothing windowId =+ openPane dir windowId++ensurePaneClosed ::+ Members [AtomicState Views, Tmux] r =>+ Maybe Pane ->+ Sem r ()+ensurePaneClosed (Just (Pane i _ _ _ _)) = do+ viewsLogS $ "closing pane " <> show i+ Cmd.closePane i+ensurePaneClosed _ = pure ()++ensurePane ::+ Members [TmuxPanes Pane, AtomicState Views, Tmux] r =>+ Path Abs Dir ->+ WindowId ->+ Ui.PaneView ->+ Sem r (Maybe RenderableNode)+ensurePane cwd windowId (Ui.View paneIdent vState geometry (Ui.Pane open _ customDir)) = do+ tmuxPane <- findOrCreatePane paneIdent+ existingPane <- nativePane windowId tmuxPane+ updatedPane <-+ if open then Just <$> ensurePaneOpen dir existingPane windowId+ else Nothing <$ ensurePaneClosed existingPane+ atomicModify' $ Views.updatePane (Tmux.View paneIdent ((.paneId) <$> updatedPane))+ pure $ cons <$> updatedPane+ where+ dir = fromMaybe cwd (parseAbsDir . toString =<< customDir)+ cons (Pane i _ _ top left) =+ Tree.Leaf . Renderable vState geometry $ RPane i top left++refPane :: RenderableNode -> RPane+refPane (Tree.Sub (Tree.Tree (Renderable _ _ (RLayout ref _)) _)) = ref+refPane (Tree.Leaf (Renderable _ _ pane)) = pane++renderableTree ::+ ViewState ->+ ViewGeometry ->+ Axis ->+ [RenderableNode] ->+ Maybe RenderableTree+renderableTree vState geometry axis sub = do+ sub' <- NonEmpty.nonEmpty sub+ pure $ Tree.Tree (Renderable vState geometry (RLayout (refPane $ NonEmpty.head sub') axis)) sub'++viewPosition :: ViewTreeSub -> Float+viewPosition (TreeNode (Tree (Ui.View _ _ ViewGeometry { position = pos } _) _)) =+ fromMaybe 0.5 pos+viewPosition (TreeLeaf (Ui.View _ _ ViewGeometry { position = pos } _)) =+ fromMaybe 0.5 pos++ensureView ::+ Members [TmuxPanes Pane, AtomicState Views, Tmux] r =>+ Path Abs Dir ->+ WindowId ->+ ViewTree ->+ Sem r (Maybe RenderableTree)+ensureView cwd windowId =+ ensureTree+ where+ ensureTree (Tree (Ui.View layoutIdent vState geometry (Ui.Layout axis)) sub) = do+ ensuredSub <- traverse ensureNode sortedSub+ viewsLog $ pretty ("new sub for layout `" <> identText layoutIdent <> "`:") <> line <>+ vsep (pretty <$> ensuredSub)+ pure $ renderableTree vState geometry axis $ catMaybes ensuredSub+ where+ sortedSub = sortOn viewPosition sub+ ensureNode (TreeNode t) = do+ newTree <- ensureTree t+ pure $ Tree.Sub <$> newTree+ ensureNode (TreeLeaf v) =+ ensurePane cwd windowId v++windowState ::+ Member (TmuxPanes Pane) r =>+ Ident ->+ Codec.Window ->+ RenderableTree ->+ Sem r WindowState+windowState windowIdent window tree = do+ nativeRef <- Cmd.firstWindowPane window.windowId+ pure $ WindowState window nativeRef windowIdent tree nativeRef.paneId
+ readme.md view
@@ -0,0 +1,3 @@+# Intro++**Chiasma** is a [tmux](https://github.com/tmux/tmux) api client for [Haskell](https://www.haskell.org/).
− test/u/BufferedSpec.hs
@@ -1,45 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module BufferedSpec(- htf_thisModulesTests-) where--import Test.Framework-import Chiasma.Native.Api (TmuxNative(..))-import Chiasma.Data.Pane (Pane(Pane), PaneId(..))-import Chiasma.Data.Window (Window(Window), WindowId(..))-import Chiasma.Data.TmuxThunk (TmuxError)-import Chiasma.Monad.Buffered (runTmux)-import Chiasma.Monad.Tmux (TmuxProg)-import qualified Chiasma.Monad.Tmux as Tmux (read, write)-import Chiasma.Test.Tmux (tmuxSpec)--prog :: TmuxProg ([Pane], [Pane], [Window])-prog = do- panes1 <- Tmux.read "list-panes" ["-t", "%0"]- Tmux.write "new-window" []- Tmux.write "new-window" []- wins <- Tmux.read @Window "list-windows" []- panes <- Tmux.read "list-panes" ["-a"]- return (panes1, panes, wins)--p :: Int -> Pane-p i = Pane (PaneId i) 1000 999--w :: Int -> Window-w i = Window (WindowId i) 1000 999--runProg :: TmuxNative -> IO (Either TmuxError ([Pane], [Pane], [Window]))-runProg api = runTmux api prog--test_buffered :: IO ()-test_buffered = do- result <- tmuxSpec runProg- assertEqual (Right ([p0], [p0, p1, p2], [w0, w1, w2])) result- where- p0 = p 0- p1 = p 1- p2 = p 2- w0 = w 0- w1 = w 1- w2 = w 2
− test/u/CodecSpec.hs
@@ -1,27 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module CodecSpec(- htf_thisModulesTests,-) where-import GHC.Generics (Generic)-import Test.Framework-import Chiasma.Data.Pane (PaneId(..))-import Chiasma.Data.Window (WindowId(..))-import Chiasma.Codec (TmuxCodec(decode, query), TmuxQuery(TmuxQuery))--data Dat =- Dat {- paneId :: PaneId,- windowId :: WindowId- }- deriving (Eq, Show, Generic)--instance TmuxCodec Dat--test_decode :: IO ()-test_decode =- assertEqual (Right $ Dat (PaneId 1) (WindowId 2)) $ decode ["%1", "@2"]--test_query :: IO ()-test_query =- assertEqual (TmuxQuery "#{pane_id} #{window_id}") (query @Dat)
− test/u/OutputParseSpec.hs
@@ -1,30 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module OutputParseSpec(- htf_thisModulesTests-) where--import Test.Framework-import Chiasma.Native.Parse (resultLines)--paneLine :: String-paneLine = "%0 100 100"--tmuxOutput :: String-tmuxOutput = unlines [- "%begin 123",- "%end 123",- "%session-changed $0 0",- "%begin 234",- paneLine,- "b",- "%end 234",- "%begin 345",- "c",- "d",- "%end 345"- ]--test_outputParse :: IO ()-test_outputParse =- assertEqual (Right [[], [paneLine, "b"], ["c", "d"]]) (resultLines tmuxOutput)
− test/u/SimpleSpec.hs
@@ -1,32 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module SimpleSpec(- htf_thisModulesTests-) where---- import Data.Either (isLeft)-import Test.Framework--- import UnliftIO (try)--- import Chiasma.Data.TmuxThunk (TmuxError)--- import Chiasma.Monad.Simple (runTmux)--- import Chiasma.Monad.Tmux (TmuxProg)--- import qualified Chiasma.Monad.Tmux as Tmux (read, write)---- number :: TmuxProg a String--- number = return "1"---- prog :: TmuxProg a [String]--- prog = do--- a <- number--- out <- Tmux.read "list-panes" ["-t", "%" ++ a]--- Tmux.write "new-windowXXX" []--- return out---- runProg :: IO [String]--- runProg = runTmux prog--test_simple :: IO ()-test_simple =- return ()- -- result <- try runProg- -- assertEqual True (isLeft (result :: Either TmuxError [String]))
− test/u/SpecMain.hs
@@ -1,12 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module Main where--import {-@ HTF_TESTS @-} BufferedSpec-import {-@ HTF_TESTS @-} OutputParseSpec-import {-@ HTF_TESTS @-} CodecSpec-import Test.Framework-import Test.Framework.BlackBoxTest ()--main :: IO ()-main = htfMain htf_importedTests