diff --git a/pkg/hs/stack.yaml b/pkg/hs/stack.yaml index f860943315..74bad3fe51 100644 --- a/pkg/hs/stack.yaml +++ b/pkg/hs/stack.yaml @@ -9,6 +9,7 @@ packages: - urbit-azimuth - urbit-eventlog-lmdb - urbit-king + - urbit-termsize - urbit-noun - urbit-noun-core diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs index 4d075875d8..78b6d9e5da 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs @@ -21,16 +21,15 @@ import Urbit.Prelude import Control.Monad.Trans.Maybe import RIO.Directory import Urbit.Arvo -import Urbit.King.Config -import Urbit.Vere.Pier.Types import Urbit.King.App +import Urbit.Vere.Pier.Types import Control.Monad.STM (retry) import System.Posix.Files (ownerModes, setFileMode) import Urbit.EventLog.LMDB (EventLog) import Urbit.King.API (TermConn) import Urbit.Noun.Time (Wen) -import Urbit.Vere.Behn (behn') +import Urbit.TermSize (TermSize(..)) import Urbit.Vere.Eyre.Multi (MultiEyreApi) import Urbit.Vere.Serf (Serf) @@ -40,6 +39,7 @@ import qualified Urbit.EventLog.LMDB as Log import qualified Urbit.King.API as King import qualified Urbit.Noun.Time as Time import qualified Urbit.Vere.Ames as Ames +import qualified Urbit.Vere.Behn as Behn import qualified Urbit.Vere.Clay as Clay import qualified Urbit.Vere.Eyre as Eyre import qualified Urbit.Vere.Http.Client as Iris @@ -47,7 +47,6 @@ import qualified Urbit.Vere.Serf as Serf import qualified Urbit.Vere.Term as Term import qualified Urbit.Vere.Term.API as Term import qualified Urbit.Vere.Term.Demux as Term -import qualified Urbit.Vere.Term.Render as Term -- Initialize pier directory. -------------------------------------------------- @@ -254,6 +253,7 @@ acquireWorkerBound nam act = mkRAcquire (asyncBound act) kill cancel tid + -- Run Pier -------------------------------------------------------------------- pier @@ -309,7 +309,7 @@ pier (serf, log) vSlog startedSig multi = do (bootEvents, startDrivers) <- do env <- ask let err = atomically . Term.trace muxed . (<> "\r\n") - let siz = Term.TSize { tsWide = 80, tsTall = 24 } + let siz = TermSize { tsWide = 80, tsTall = 24 } let fak = isFake logId drivers env multi ship fak compute (siz, muxed) err sigint @@ -416,12 +416,12 @@ drivers -> Ship -> Bool -> (RunReq -> STM ()) - -> (Term.TSize, Term.Client) + -> (TermSize, Term.Client) -> (Text -> RIO e ()) -> IO () -> RAcquire e ([Ev], RAcquire e Drivers) drivers env multi who isFake plan termSys stderr serfSIGINT = do - (behnBorn, runBehn) <- rio behn' + (behnBorn, runBehn) <- rio Behn.behn' (termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT) (amesBorn, runAmes) <- rio (Ames.ames' who isFake stderr) (httpBorn, runEyre) <- rio (Eyre.eyre' multi who isFake) diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs index af7bd38815..06082c142d 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs @@ -19,6 +19,7 @@ import RIO.FilePath import System.Posix.IO import System.Posix.Terminal import Urbit.Arvo hiding (Term) +import Urbit.King.App import Urbit.Noun.Time import Urbit.Prelude hiding (getCurrentTime) import Urbit.Vere.Pier.Types @@ -26,12 +27,13 @@ import Urbit.Vere.Pier.Types import Data.List ((!!)) import RIO.Directory (createDirectoryIfMissing) import Urbit.King.API (readPortsFile) -import Urbit.King.App (HasPierPath(..), HasPierEnv, killPierActionL) +import Urbit.TermSize (TermSize(TermSize)) import Urbit.Vere.Term.API (Client(Client)) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.UTF8 as BS import qualified System.Console.ANSI as ANSI +import qualified Urbit.TermSize as T import qualified Urbit.Vere.NounServ as Serv import qualified Urbit.Vere.Term.API as Term import qualified Urbit.Vere.Term.Render as T @@ -172,10 +174,10 @@ _spin_idle_us = 500000 -} localClient :: ∀e. HasLogFunc e => STM () - -> RAcquire e (T.TSize, Client) + -> RAcquire e (TermSize, Client) localClient doneSignal = fst <$> mkRAcquire start stop where - start :: HasLogFunc e => RIO e ((T.TSize, Client), Private) + start :: HasLogFunc e => RIO e ((TermSize, Client), Private) start = do tsWriteQueue <- newTQueueIO :: RIO e (TQueue [Term.Ev]) spinnerMVar <- newEmptyTMVarIO :: RIO e (TMVar ()) @@ -200,12 +202,12 @@ localClient doneSignal = fst <$> mkRAcquire start stop , give = writeTQueue tsWriteQueue } - tsize <- io $ T.tsize + tsize <- io $ T.termSize pure ((tsize, client), Private{..}) stop :: HasLogFunc e - => ((T.TSize, Client), Private) -> RIO e () + => ((TermSize, Client), Private) -> RIO e () stop ((_, Client{..}), Private{..}) = do -- Note that we don't `cancel pReaderThread` here. This is a deliberate -- decision because fdRead calls into a native function which the runtime @@ -510,11 +512,11 @@ localClient doneSignal = fst <$> mkRAcquire start stop -} term' :: HasPierEnv e - => (T.TSize, Client) + => (TermSize, Client) -> IO () -> RIO e ([Ev], RAcquire e (DriverApi TermEf)) term' (tsize, client) serfSIGINT = do - let T.TSize wi hi = tsize + let TermSize wi hi = tsize initEv = [initialBlew wi hi, initialHail] pure (initEv, runDriver) @@ -533,7 +535,7 @@ term' (tsize, client) serfSIGINT = do -} term :: forall e. (HasPierEnv e) => e - -> (T.TSize, Client) + -> (TermSize, Client) -> (EvErr -> STM ()) -> IO () -> RAcquire e (TermEf -> IO ()) diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Term/Render.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Term/Render.hs index 9b805e7b5b..a7751a005f 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Term/Render.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Term/Render.hs @@ -2,9 +2,7 @@ Terminal Driver -} module Urbit.Vere.Term.Render - ( TSize(..) - , tsize - , clearScreen + ( clearScreen , clearLine , cursorRight , cursorLeft @@ -13,29 +11,11 @@ module Urbit.Vere.Term.Render import ClassyPrelude -import qualified System.Console.Terminal.Size as TSize -import qualified System.Console.ANSI as ANSI +import qualified System.Console.ANSI as ANSI -- Types ----------------------------------------------------------------------- -data TSize = TSize - { tsWide ∷ Word - , tsTall ∷ Word - } - - --------------------------------------------------------------------------------- - -{- | - Get terminal size. Produces 80x24 as a fallback if unable to figure - out terminal size. --} -tsize ∷ IO TSize -tsize = do - TSize.Window wi hi <- TSize.size <&> fromMaybe (TSize.Window 80 24) - pure $ TSize { tsWide = wi, tsTall = hi } - clearScreen ∷ MonadIO m ⇒ m () clearScreen = liftIO $ ANSI.clearScreen diff --git a/pkg/hs/urbit-king/package.yaml b/pkg/hs/urbit-king/package.yaml index 3999aeb6bb..e786261e5c 100644 --- a/pkg/hs/urbit-king/package.yaml +++ b/pkg/hs/urbit-king/package.yaml @@ -89,7 +89,6 @@ dependencies: - tasty-th - template-haskell - terminal-progress-bar - - terminal-size - text - these - time @@ -105,6 +104,7 @@ dependencies: - urbit-hob - urbit-noun - urbit-noun-core + - urbit-termsize - utf8-string - vector - wai diff --git a/pkg/hs/urbit-termsize/.gitignore b/pkg/hs/urbit-termsize/.gitignore new file mode 100644 index 0000000000..e5904eabeb --- /dev/null +++ b/pkg/hs/urbit-termsize/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +urbit-termsize.cabal +*~ diff --git a/pkg/hs/urbit-termsize/LICENSE b/pkg/hs/urbit-termsize/LICENSE new file mode 100644 index 0000000000..bf9294e05c --- /dev/null +++ b/pkg/hs/urbit-termsize/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2016 urbit + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/pkg/hs/urbit-termsize/app/Main.hs b/pkg/hs/urbit-termsize/app/Main.hs new file mode 100644 index 0000000000..798ece23fa --- /dev/null +++ b/pkg/hs/urbit-termsize/app/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Prelude + +import Urbit.TermSize (liveTermSize) +import System.IO (getLine) + +main :: IO () +main = do + init <- liveTermSize (putStrLn . ("New Size: " <>) . show) + putStrLn ("Initial Size: " <> show init) + _ <- getLine + pure () diff --git a/pkg/hs/urbit-termsize/lib/Urbit/TermSize.hs b/pkg/hs/urbit-termsize/lib/Urbit/TermSize.hs new file mode 100644 index 0000000000..33f2d78cf6 --- /dev/null +++ b/pkg/hs/urbit-termsize/lib/Urbit/TermSize.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Urbit.TermSize + ( TermSize(..) + , termSize + , liveTermSize + ) +where + +import Prelude + +import Data.Functor ((<&>)) +import System.Console.Terminal.Size (Window(..), size) + +import qualified System.Posix.Signals as Sys +import qualified System.Posix.Signals.Exts as Sys + + +-- Types ----------------------------------------------------------------------- + +data TermSize = TermSize + { tsWide :: !Word + , tsTall :: !Word + } + deriving (Eq, Ord, Show) + + +-- Utilities ------------------------------------------------------------------- + +termSize :: IO TermSize +termSize = size <&> \case + Nothing -> TermSize 80 24 + Just (Window {..}) -> TermSize width height + +liveTermSize :: (TermSize -> IO ()) -> IO TermSize +liveTermSize cb = do + Sys.installHandler Sys.sigWINCH (Sys.Catch (termSize >>= cb)) Nothing + termSize diff --git a/pkg/hs/urbit-termsize/package.yaml b/pkg/hs/urbit-termsize/package.yaml new file mode 100644 index 0000000000..83efc8c17a --- /dev/null +++ b/pkg/hs/urbit-termsize/package.yaml @@ -0,0 +1,25 @@ +name: urbit-termsize +version: 0.1.0 +license: MIT +license-file: LICENSE + +dependencies: + - base + - terminal-size + - unix + +ghc-options: + - -fwarn-incomplete-patterns + - -fwarn-unused-binds + - -fwarn-unused-imports + - -O2 + +library: + source-dirs: lib + +executables: + urbit-test-termsize-updates: + main: Main.hs + source-dirs: app + dependencies: + - urbit-termsize