From dd620addd7508c3386d1ec86cde62e2159f76311 Mon Sep 17 00:00:00 2001 From: Richard Marko Date: Wed, 8 Apr 2020 14:00:34 +0200 Subject: [PATCH] initial --- .gitignore | 8 + LICENSE | 30 +++ README.md | 96 ++++++++++ Setup.hs | 2 + app/HtopDemo.hs | 12 ++ cabal.project | 2 + default.nix | 2 + polytype.cabal | 151 +++++++++++++++ shell.nix | 2 + src/Polysemy/Input/Streaming.hs | 111 +++++++++++ src/Polysemy/Output/Streaming.hs | 25 +++ src/Polytype.hs | 76 ++++++++ src/Polytype/Ansi.hs | 161 ++++++++++++++++ src/Polytype/Asciinema.hs | 148 +++++++++++++++ src/Polytype/Combinators.hs | 45 +++++ src/Polytype/Debug.hs | 46 +++++ src/Polytype/Delay.hs | 58 ++++++ src/Polytype/Env.hs | 49 +++++ src/Polytype/Examples/Bash.hs | 37 ++++ src/Polytype/Examples/Echo.hs | 12 ++ src/Polytype/Examples/HtopAsciinema.hs | 98 ++++++++++ src/Polytype/Examples/IRCBridge.hs | 43 +++++ src/Polytype/Examples/Process.hs | 31 ++++ src/Polytype/Examples/SafeProcess.hs | 27 +++ src/Polytype/Examples/Streaming.hs | 20 ++ src/Polytype/Experiments.hs | 24 +++ src/Polytype/Log.hs | 116 ++++++++++++ src/Polytype/Process.hs | 95 ++++++++++ src/Polytype/Pty.hs | 97 ++++++++++ src/Polytype/Race.hs | 52 ++++++ src/Polytype/Readline.hs | 53 ++++++ src/Polytype/Serial.hs | 61 ++++++ src/Polytype/StdStreams.hs | 120 ++++++++++++ src/Polytype/Teletype.hs | 245 +++++++++++++++++++++++++ src/Polytype/Teletype/String.hs | 36 ++++ src/Polytype/Teletype/Text.hs | 37 ++++ src/Polytype/Test.hs | 66 +++++++ src/Polytype/Timeout.hs | 41 +++++ src/Polytype/Types.hs | 5 + src/Polytype/Types/Time.hs | 43 +++++ src/Polytype/Util.hs | 53 ++++++ test/PtySpec.hs | 17 ++ test/SerialSpec.hs | 10 + test/Spec.hs | 1 + test/SpecHelper.hs | 16 ++ test/StdStreamsSpec.hs | 15 ++ test/TeletypeSpec.hs | 56 ++++++ 47 files changed, 2551 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/HtopDemo.hs create mode 100644 cabal.project create mode 100644 default.nix create mode 100644 polytype.cabal create mode 100644 shell.nix create mode 100644 src/Polysemy/Input/Streaming.hs create mode 100644 src/Polysemy/Output/Streaming.hs create mode 100644 src/Polytype.hs create mode 100644 src/Polytype/Ansi.hs create mode 100644 src/Polytype/Asciinema.hs create mode 100644 src/Polytype/Combinators.hs create mode 100644 src/Polytype/Debug.hs create mode 100644 src/Polytype/Delay.hs create mode 100644 src/Polytype/Env.hs create mode 100644 src/Polytype/Examples/Bash.hs create mode 100644 src/Polytype/Examples/Echo.hs create mode 100644 src/Polytype/Examples/HtopAsciinema.hs create mode 100644 src/Polytype/Examples/IRCBridge.hs create mode 100644 src/Polytype/Examples/Process.hs create mode 100644 src/Polytype/Examples/SafeProcess.hs create mode 100644 src/Polytype/Examples/Streaming.hs create mode 100644 src/Polytype/Experiments.hs create mode 100644 src/Polytype/Log.hs create mode 100644 src/Polytype/Process.hs create mode 100644 src/Polytype/Pty.hs create mode 100644 src/Polytype/Race.hs create mode 100644 src/Polytype/Readline.hs create mode 100644 src/Polytype/Serial.hs create mode 100644 src/Polytype/StdStreams.hs create mode 100644 src/Polytype/Teletype.hs create mode 100644 src/Polytype/Teletype/String.hs create mode 100644 src/Polytype/Teletype/Text.hs create mode 100644 src/Polytype/Test.hs create mode 100644 src/Polytype/Timeout.hs create mode 100644 src/Polytype/Types.hs create mode 100644 src/Polytype/Types/Time.hs create mode 100644 src/Polytype/Util.hs create mode 100644 test/PtySpec.hs create mode 100644 test/SerialSpec.hs create mode 100644 test/Spec.hs create mode 100644 test/SpecHelper.hs create mode 100644 test/StdStreamsSpec.hs create mode 100644 test/TeletypeSpec.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c6c9291 --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +attic/* +dist +dist-newstyle +result* +.stack-work +.ghc.environment* +cabal.project.local +*.cast diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..433fadd --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Richard Marko (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..4ca6f19 --- /dev/null +++ b/README.md @@ -0,0 +1,96 @@ +# polytype + +**🚧 Work in progress 🚧** + +## What is this? + +* Polymorphic [Teletype][teletype] +* Library for interacting with + * programs + * programs running in POXIS pseudo terminals via [posix-pty][hackage:posix-pty] + * serial terminals via [serialport][hackage:serialport] +* Expect on steroids +* Program interaction library with [Asciinema][asciinema] recorder +* My first [polysemy] endeavour and a playground (for now) +* Collection of useful effects related to the topic + +## What is it good for? + +* Interacting with and testing other programs +* Testing of terminal UIs +* Making demos of terminal UIs with [Asciinema][asciinema] [asciicast][asciicast] output +* Testing hardware (or virtual machines) over serial connection +* Streaming inputs and outputs of programs, terminals, serial connections +* Variations of the previous ones + +## Why? + +To explore effect systems and polymorphic IO automation framework. Originally the project +was called `multitype`, based on `Free` monads which proved difficult to interpret with +all the required bits like `async` and `timeout`. +Later it was rewritten using `transformers` but never released because it still felt too +opinionated about the use of e.g. character vs line based input or `Text` vs `ByteString` +specialization. + +This library tries to be much less picky about the type of its inputs and outputs +allowing the user to choose what types to work with or convert between different +[Teletypes](src/Polytype/Teletype.hs). +[polysemy]s effect system allows the user to write programs using +the same eDSL and choosing interpreters according to the target environment. + +## Examples + +```haskell +import Polytype + +main :: IO () +main = + . runM + . teletypeToIO + . runLogShow + . teletypeLog + $ do + writeTTY "Type something" + i <- readTTY + writeTTY $ "You wrote: " ++ i +``` + +### Provided examples + +* [bash](src/Polytype/Examples/Bash.hs) +* [echo](src/Polytype/Examples/Echo.hs) +* [htop demo](src/Polytype/Examples/HtopAsciinema.hs) +* [ircbridge test](src/Polytype/Examples/IRCBridge.hs) +* [process](src/Polytype/Examples/Process.hs) +* [safe process](src/Polytype/Examples/SafeProcess.hs) +* [streaming](src/Polytype/Examples/Streaming.hs) + +### Asciinema output + +* Watch the htop demo [recording](https://asciinema.org/a/343380) + +## Development status + +Types of effects are in pretty good shape. Names and interpreters are subject to change. + +The library grew quite a bit since the work started and some parts will be split into +sub-packages. + +## Related work + +Inspired by: + +* [teletype] +* [polysemy] +* [polysemys Teletype example][hackage:polysemy] +* [co-log]s polymorphic logger effect +* and few other bits credited in source files + +[co-log]: https://github.com/kowainik/co-log/ +[polysemy]: https://github.com/polysemy-research/polysemy +[hackage:polysemy]: https://github.com/polysemy-research/polysemy +[hackage:serialport]: https://hackage.haskell.org/package/serialport +[hackage:posix-pty]: https://hackage.haskell.org/package/posix-pty +[teletype]: http://www.haskellforall.com/2012/07/purify-code-using-free-monads.html +[asciinema]: https://asciinema.org/ +[asciicast]: https://github.com/asciinema/asciinema/blob/master/doc/asciicast-v2.md diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/HtopDemo.hs b/app/HtopDemo.hs new file mode 100644 index 0000000..9b4a6c8 --- /dev/null +++ b/app/HtopDemo.hs @@ -0,0 +1,12 @@ +module Main where + +import Options.Applicative + +import Polytype +import Polytype.Examples.HtopAsciinema + +main = execParser opts >>= htopAsciinemaExample + where + opts = info (argument str (metavar "FILE") <**> helper) + ( fullDesc + <> progDesc "Record htop demo using asciicast output") diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..bb4bd77 --- /dev/null +++ b/cabal.project @@ -0,0 +1,2 @@ +packages: + ./polytype.cabal diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..9b462bf --- /dev/null +++ b/default.nix @@ -0,0 +1,2 @@ +{ nixpkgs ? import {} }: +nixpkgs.haskellPackages.callCabal2nix "polytype" ./. { } diff --git a/polytype.cabal b/polytype.cabal new file mode 100644 index 0000000..28c7a3f --- /dev/null +++ b/polytype.cabal @@ -0,0 +1,151 @@ +name: polytype +version: 0.1.0.0 +synopsis: Polymorphic teletype +description: Library and tooling for interacting with character devices +homepage: https://github.com/sorki/polytype +license: BSD3 +license-file: LICENSE +author: Richard Marko +maintainer: srk@48.io +copyright: 2020 Richard Marko +category: System +build-type: Simple +cabal-version: >=1.10 +extra-source-files: + CHANGELOG.md + LICENSE + README.md + +flag examples + default: + False + description: + Builds example applications + +library + ghc-options: + -Wall + -Wunused-packages + -O2 + -flate-specialise + -fspecialise-aggressively + -- -fplugin=Polysemy.Plugin + -- plugin is not enabled globally + -- as it causes trouble for some files + default-extensions: + DataKinds + FlexibleContexts + GADTs + LambdaCase + BlockArguments + PolyKinds + RecordWildCards + RankNTypes + ScopedTypeVariables + TypeApplications + TypeOperators + TypeFamilies + TemplateHaskell + NumericUnderscores + QuantifiedConstraints + FlexibleInstances + hs-source-dirs: src + exposed-modules: Polytype + , Polytype.Ansi + , Polytype.Asciinema + , Polytype.Combinators + , Polytype.Debug + , Polytype.Delay + , Polytype.Env + , Polytype.Examples.Bash + , Polytype.Examples.Echo + , Polytype.Examples.HtopAsciinema + , Polytype.Examples.IRCBridge + , Polytype.Examples.Process + , Polytype.Examples.SafeProcess + , Polytype.Examples.Streaming + , Polytype.Experiments + , Polytype.Log + , Polytype.Process + , Polytype.Pty + , Polytype.Race + , Polytype.Readline + , Polytype.Serial + , Polytype.StdStreams + , Polytype.Teletype + , Polytype.Teletype.String + , Polytype.Teletype.Text + , Polytype.Test + , Polytype.Timeout + , Polytype.Types + , Polytype.Types.Time + , Polytype.Util + , Polysemy.Input.Streaming + , Polysemy.Output.Streaming + build-depends: base >= 4.7 && < 5 + , attoparsec + , bytestring + , aeson + , scientific + , containers + , vector + , data-default + , text + , async + , process + , polysemy + , polysemy-plugin + , posix-pty + , streaming + , serialport + , string-conversions + , time + , haskeline + , co-log-core + , co-log-polysemy + default-language: Haskell2010 + +executable polytype-htop-demo + if !flag(examples) + buildable: False + hs-source-dirs: app + main-is: HtopDemo.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , bytestring + , text + , polysemy-plugin + , polysemy + , polytype + , optparse-applicative + default-language: Haskell2010 + +test-suite polytype-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: SpecHelper + PtySpec + SerialSpec + StdStreamsSpec + TeletypeSpec + build-depends: base >= 4.7 && < 5 + , attoparsec + , bytestring + , data-default + , text + , polysemy + , polysemy-plugin + , polytype + , hspec + , hspec-discover + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-extensions: + DataKinds + TypeApplications + TypeOperators + +source-repository head + type: git + location: https://github.com/sorki/polytype diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..29cc2c9 --- /dev/null +++ b/shell.nix @@ -0,0 +1,2 @@ +{ nixpkgs ? import {} }: +(import ./default.nix { inherit nixpkgs; }).env diff --git a/src/Polysemy/Input/Streaming.hs b/src/Polysemy/Input/Streaming.hs new file mode 100644 index 0000000..33e88e1 --- /dev/null +++ b/src/Polysemy/Input/Streaming.hs @@ -0,0 +1,111 @@ +-- borrowed from polysemy-zoo +-- until https://github.com/polysemy-research/polysemy-zoo/issues/65 +-- +module Polysemy.Input.Streaming + ( -- * Underlying Effect + module Polysemy.Input + + -- * Actions + , yieldInput + , yieldRace + , exhaust + + -- * Intepretations + , runInputViaStream + , runInputViaInfiniteStream + + , runOutputStream + , runOutputStreamStdout + ) where + +import qualified Control.Concurrent.Async as A +import Data.Functor.Of +import Data.Void +import Polysemy +import Polysemy.Final +import Polysemy.Input +import Polysemy.Output +import Polysemy.State +import Streaming (Stream) +import qualified Streaming as S +import qualified Streaming.Prelude as S +import qualified Streaming.Prelude + + +-- runM . runOutputSem (\s -> Streaming.Prelude.stdoutLn (Streaming.Prelude.yield s)) . runInputViaStream Streaming.Prelude.stdinLn . runTeletypeInputOutput @String $ readTTY @String +-- +--runOutputStream :: Member (Embed IO) r => InterpreterFor (Output String) r +runOutputStream :: forall stringy m r a . Monad m + => (Stream (Of stringy) m () -> Sem r ()) + -> Sem (Output stringy ': r) a + -> Sem r a +runOutputStream f = runOutputSem $ f . Streaming.Prelude.yield + +runOutputStreamStdout :: Member (Embed IO) r => InterpreterFor (Output String) r +runOutputStreamStdout = runOutputSem (\s -> + Streaming.Prelude.stdoutLn (Streaming.Prelude.yield s)) +{-- +runOutputViaStream + :: forall r i . (i -> Sem r ()) -- (S.Stream (Of i) (Sem r) () -> Sem r ()) + -> InterpreterFor (Output i) r +--} + +runInputViaStream + :: S.Stream (Of i) (Sem r) () + -> InterpreterFor (Input (Maybe i)) r +runInputViaStream stream + = evalState (Just stream) + . reinterpret ( \Input -> + get >>= \case + Nothing -> pure Nothing + Just s -> + raise (S.inspect s) >>= \case + Left () -> pure Nothing + Right (i :> s') -> do + put $ Just s' + pure $ Just i + ) + + +runInputViaInfiniteStream + :: forall i r + . S.Stream (Of i) (Sem r) Void + -> InterpreterFor (Input i) r +runInputViaInfiniteStream stream + = evalState stream + . reinterpret ( \Input -> do + s <- get + raise (S.inspect s) >>= \case + Left g -> absurd g + Right (i :> s') -> do + put s' + pure i + ) + + +yieldRace + :: Members + '[ Final IO + , Input i1 + , Input i2 + ] r + => S.Stream (S.Of (Either i1 i2)) (Sem r) () +yieldRace = do + z <- S.lift $ withStrategicToFinal $ do + input1 <- runS input + input2 <- runS input + pure $ fmap sequenceEither $ A.race input1 input2 + S.yield z + + +sequenceEither :: Functor f => Either (f a) (f b) -> f (Either a b) +sequenceEither (Left fa) = Left <$> fa +sequenceEither (Right fb) = Right <$> fb + + +yieldInput :: Member (Input i) r => S.Stream (Of i) (Sem r) () +yieldInput = S.lift input >>= S.yield + + +exhaust :: Member (Input i) r => S.Stream (Of i) (Sem r) a +exhaust = S.repeatM input diff --git a/src/Polysemy/Output/Streaming.hs b/src/Polysemy/Output/Streaming.hs new file mode 100644 index 0000000..4391d8d --- /dev/null +++ b/src/Polysemy/Output/Streaming.hs @@ -0,0 +1,25 @@ +-- bit contrived +-- +module Polysemy.Output.Streaming + ( -- * Underlying Effect + module Polysemy.Output + + , runOutputStream + , runOutputStreamStdout + ) where + +import Polysemy +import Polysemy.Output + +import Streaming.Prelude (Stream, Of) +import qualified Streaming.Prelude + +runOutputStream :: forall stringy m r a . Monad m + => (Stream (Of stringy) m () -> Sem r ()) + -> Sem (Output stringy ': r) a + -> Sem r a +runOutputStream f = runOutputSem $ f . Streaming.Prelude.yield + +runOutputStreamStdout :: Member (Embed IO) r => InterpreterFor (Output String) r +runOutputStreamStdout = runOutputSem (\s -> + Streaming.Prelude.stdoutLn (Streaming.Prelude.yield s)) diff --git a/src/Polytype.hs b/src/Polytype.hs new file mode 100644 index 0000000..61cf80b --- /dev/null +++ b/src/Polytype.hs @@ -0,0 +1,76 @@ +{-| +Description : Polytype prelude +-} + + +module Polytype ( + module Polytype.Ansi + , module Polytype.Asciinema + , module Polytype.Combinators + , module Polytype.Debug + , module Polytype.Delay + , module Polytype.Env + , module Polytype.Log + , module Polytype.Process + , module Polytype.Pty + , module Polytype.Race + , module Polytype.Readline + , module Polytype.Serial + , module Polytype.StdStreams + , module Polytype.Teletype + , module Polytype.Teletype.String + , module Polytype.Teletype.Text + , module Polytype.Test + , module Polytype.Timeout + , module Polytype.Types + , module Polytype.Util + + -- re-exports + , module Polysemy + , module Polysemy.Async + , module Polysemy.Resource + , module Polysemy.Error + , module Polysemy.Input + , module Polysemy.Input.Streaming + , module Polysemy.Output + , module Polysemy.State + , module Polysemy.Tagged + , module Polysemy.Trace + + , Control.Monad.forever + , Control.Monad.void + ) where + +import Control.Monad + +import Polysemy +import Polysemy.Async +import Polysemy.Error +import Polysemy.Input +import Polysemy.Input.Streaming +import Polysemy.Output +import Polysemy.Resource +import Polysemy.State +import Polysemy.Tagged +import Polysemy.Trace + +import Polytype.Ansi +import Polytype.Asciinema +import Polytype.Combinators +import Polytype.Debug +import Polytype.Delay +import Polytype.Env +import Polytype.Log +import Polytype.Process +import Polytype.Pty +import Polytype.Race +import Polytype.Readline +import Polytype.Serial +import Polytype.StdStreams +import Polytype.Teletype +import Polytype.Teletype.String +import Polytype.Teletype.Text +import Polytype.Test +import Polytype.Timeout +import Polytype.Types +import Polytype.Util diff --git a/src/Polytype/Ansi.hs b/src/Polytype/Ansi.hs new file mode 100644 index 0000000..34dc850 --- /dev/null +++ b/src/Polytype/Ansi.hs @@ -0,0 +1,161 @@ +{-| +Description : Functionality for stripping ANSI escape sequences from Teletypes + +From https://hackage.haskell.org/package/strip-ansi-escape +* adjusted for streaming so it doesn't expect @endOfInput@ +* fixed few unhandled sequences + +XXX: submit PR + +-} + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Polytype.Ansi + ( teletypeStripAnsi + , skipEscapeSequence + , isEsc + , textEnv + , ParserEnv (..) + ) where + +import Control.Applicative (optional, (<|>)) +import Control.Monad (void) +import Data.Attoparsec.Internal.Types (ChunkElem) +import Data.Attoparsec.Types (Chunk, Parser) +import Data.Char (isDigit) +import Data.Text (Text) + +import qualified Data.Attoparsec.Combinator as AC +import qualified Data.Attoparsec.Text + +import Polysemy +import Polysemy.Error + +import Polytype.Teletype + +-- | Strip ANSI escape sequences from Teletype input +teletypeStripAnsi :: Sem (Teletype Text : r) a + -> Sem (Error String : Teletype Text : r) a +teletypeStripAnsi = + teletypeParseWith + Data.Attoparsec.Text.parse + (skipEscapeSequence textEnv + *> Data.Attoparsec.Text.takeWhile (not . isEsc) + ) + id + +textEnv :: ParserEnv Char Text +textEnv = ParserEnv + Data.Attoparsec.Text.skipWhile + Data.Attoparsec.Text.takeWhile1 + +{- +-- From: https://github.com/chalk/ansi-regex/blob/166a0d5eddedacf0db7ccd7ee137b862ab1dae70/index.js + [\x001B\x009B] + [[\]()#;?]* + (?: + (?: + (?: + [a-zA-Z\d]* + (?: + ;[-a-zA-Z\d\/#&.:=?%@~_]* + )* + )? + \x0007 + ) + | + (?: + (?: + \d{1,4} + (?:;\d{0,4})* + )? + [\dA-PR-TZcf-ntqry=><~] + ) + ) +-} + +isEsc :: Char -> Bool +isEsc = (== '\x001B') + +type ChunkParser str = (Chunk str, ChunkElem str ~ Char) => Parser str () + +esc :: ChunkParser str +esc = skip isEsc + +skipEscapeSequence :: ParserEnv (ChunkElem str) str -> ChunkParser str +skipEscapeSequence e = AC.skipMany $ do + esc + beginsWithOpenSquareBracket + <|> beginsWithClosingSquareBracket + <|> beginsWithParenthesis + <|> beginsWithHash + <|> singleChar + <|> beginsWithDigit + + where + singleChar = + skip (`elem` ("ABCDHIJKSTZ=>12<78HcNOME" :: String)) + + beginsWithDigit = do + skip (`elem` ("5036" :: String)) + skip (== 'n') + + beginsWithClosingSquareBracket = do + skip (== ']') + skipWhile e (/= '\x0007') <* skipAny + + beginsWithOpenSquareBracket = do + skip (== '[') + _ <- optional $ skip (`elem` ("?;" :: String)) + AC.skipMany $ do + AC.skipMany1 digit + AC.skipMany $ do + skip (== ';') + AC.skipMany1 digit + skip isEndChar + + where + isEndChar c = + isDigit c + || between 'A' 'P' + || between 'R' 'T' + || c == 'Z' + || c == 'X' -- added by srk + || c == 'c' + || c == 'd' + || between 'f' 'n' + || c `elem` ("tqry=><~" :: String) + where + between x y = x <= c && c <= y + + beginsWithParenthesis = do + skipElems "()" + skipElems "AB012" + + beginsWithHash = do + skip (== '#') + skip (`elem` ("34568" :: String)) + +skipElems :: (Chunk str, ChunkElem str ~ Char) => String -> Parser str () +skipElems s = skip (`elem` s) + +data ParserEnv c str = ParserEnv + { skipWhile :: (c -> Bool) -> Parser str () + , takeWhile1 :: (c-> Bool) -> Parser str str + } + +{-# INLINE skip #-} +skip :: Chunk str => (ChunkElem str -> Bool) -> Parser str () +skip = void . AC.satisfyElem + + +{-# INLINE skipAny #-} +skipAny :: Chunk str => Parser str () +skipAny = skip (const True) + + +{-# INLINE digit #-} +digit :: (Chunk str, ChunkElem str ~ Char) => Parser str () +digit = skip $ \c -> '0' <= c && c <= '9' diff --git a/src/Polytype/Asciinema.hs b/src/Polytype/Asciinema.hs new file mode 100644 index 0000000..b89793c --- /dev/null +++ b/src/Polytype/Asciinema.hs @@ -0,0 +1,148 @@ +{-| +Description : Asciinema compatibility and asciicast v2 implementation +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Polytype.Asciinema where + +import Data.Aeson (ToJSON(..), Value(..)) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Map (Map) +import GHC.Generics (Generic) + +import qualified Data.Aeson.Text +import qualified Data.Map +import qualified Data.Scientific +import qualified Data.Text.Lazy +import qualified Data.Text.IO +import qualified Data.Time +import qualified Data.Time.Clock.POSIX +import qualified Data.Vector +import qualified System.IO + +import Polysemy +import Polysemy.Input +import Polysemy.Output +import Polysemy.Resource + +import Polytype.Env +import Polytype.Log +import Polytype.Pty (PtyOpts(..)) +import Polytype.Util (mapMOutput) + +data AsciicastVersion = Version1 | Version2 + deriving (Show, Eq, Ord) + +instance ToJSON AsciicastVersion where + toJSON Version1 = Number 1 + toJSON Version2 = Number 2 + +data AsciicastMeta = AsciicastMeta { + version :: AsciicastVersion -- ^ Version of the asciicast file format + , width :: Int -- ^ Terminal width used during recording + , height :: Int -- ^ Terminal height used during recording + , timestamp :: Int -- ^ UNIX timestamp marking the start of the session + , title :: Text -- ^ Title of the session + , env :: Map String String + } deriving (Generic, ToJSON, Show, Eq, Ord) + +data AsciicastRecord = AsciicastRecord { + timeDiffSeconds :: Float -- ^ How long it took since the start of the session + , isInput :: Bool -- ^ Input from user or output from program + , contents :: Text + } deriving (Eq, Show, Ord) + +instance ToJSON AsciicastRecord where + toJSON AsciicastRecord{..} = + Array $ Data.Vector.fromList [ + (Number $ Data.Scientific.fromFloatDigits timeDiffSeconds) + , (String $ if isInput then "i" else "o") + , (String contents) + ] + +data AsciinemaOpts = AsciinemaOpts { + aoTitle :: Text -- ^ Title of the session + , aoOutputFile :: FilePath -- ^ Output file path + , aoPtyOpts :: PtyOpts -- ^ `PtyOpts` used for recording - + -- width, height and environment variables are stored in metadata header + } deriving (Eq, Show, Ord) + +-- | Interpret `Log (TelMsg Text)` as file output using @asciicast@ v2 format +-- +-- `Input AsciinemaOpts` is used to configure output file path and +-- meta data for Asciinema header. +runLogAsciinema :: Members '[Embed IO, Resource, Input AsciinemaOpts] r + => Sem (Log (TelMsg Text) ': r) a + -> Sem r a +runLogAsciinema = + runOutAsciinema + . mapMOutput @(TelMsg Text) @(Stamp (TelMsg Text)) + (\o -> embed Data.Time.getCurrentTime >>= \t -> pure $ Stamp o t) + . reinterpretLogAsOutput + +-- | Interpreter for `Output` containing time-stamped `Teletype` `TelMsg`s +-- which are written to file using `asAsciicast`. +runOutAsciinema :: Members '[Embed IO, Resource, Input AsciinemaOpts] r + => Sem (Output (Stamp (TelMsg Text)) ': r) a + -> Sem r a +runOutAsciinema foo = do + AsciinemaOpts{..} <- input @AsciinemaOpts + let PtyOpts{..} = aoPtyOpts + + bracket + (embed do + (h, t) <- (,) + <$> System.IO.openFile aoOutputFile System.IO.WriteMode + <*> Data.Time.getCurrentTime + + posixTime <- Data.Time.Clock.POSIX.getPOSIXTime + env <- computeEnv ptyEnv + + -- output header + Data.Text.IO.hPutStrLn h + $ Data.Text.Lazy.toStrict + $ Data.Aeson.Text.encodeToLazyText + $ AsciicastMeta + Version2 + ptyWidth + ptyHeight + (round posixTime) + aoTitle + (Data.Map.fromList env) + + pure (h, t) + ) + (embed . System.IO.hClose . fst) + \(h, t) -> interpret (\case + Output o -> embed $ Data.Text.IO.hPutStrLn h (asAsciicast t o) + ) foo + +diffUTCTimeFloatSeconds :: UTCTime -> UTCTime -> Float +diffUTCTimeFloatSeconds t start = + realToFrac + $ Data.Time.diffUTCTime t start + +-- | Marshall `Stamp (TelMsg Text)` to `AsciicastRecord` +-- into JSON output `Text`. +-- +-- Requires `UTCTime` of the start of the recorded session. +-- +-- Uses asciicast v2 format: https://github.com/asciinema/asciinema/blob/master/doc/asciicast-v2.md +-- +asAsciicast :: UTCTime -> Stamp (TelMsg Text) -> Text +asAsciicast start (Stamp o t) = + Data.Text.Lazy.toStrict + . Data.Aeson.Text.encodeToLazyText + $ AsciicastRecord + (diffUTCTimeFloatSeconds t start) + (isInput o) + (unMsg o) + where + isInput (Write _) = True + isInput _ = False + unMsg (Read m) = m + unMsg (Write m) = m diff --git a/src/Polytype/Combinators.hs b/src/Polytype/Combinators.hs new file mode 100644 index 0000000..6c32c85 --- /dev/null +++ b/src/Polytype/Combinators.hs @@ -0,0 +1,45 @@ +{-| +Description : Higher level compositions +-} + +module Polytype.Combinators ( + runTeletypeAsciinema + ) where + +import Data.Text (Text) +import Data.ByteString (ByteString) + +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.Resource + +import Polytype.Ansi +import Polytype.Asciinema +import Polytype.Log +import Polytype.Pty +import Polytype.Teletype + +-- | Run `Teletype` with Asciinema asciicast output logger and +-- output forwarding to stdout. +runTeletypeAsciinema :: Members '[Embed IO, Resource] r + => Text + -> FilePath + -> PtyOpts + -> Sem (Teletype String : Input PtyOpts : Input AsciinemaOpts : r) a + -> Sem r (Either String a) +runTeletypeAsciinema title outputFile ptyOpts = + runInputConst @AsciinemaOpts (AsciinemaOpts title outputFile ptyOpts) + . runInputConst @PtyOpts ptyOpts + -- here we are done handling teletype and need to handle "ambient" effects + . runPtyOpts + . convertTeletypeStrings @Text @ByteString + . runLogAsciinema + . teletypeLog -- for asciinema logger + . runLogForward' + . teletypeLog -- for forwarding to stdOut + . runError @String + . teletypeStripAnsi + . convertTeletypeStrings @String @Text + + diff --git a/src/Polytype/Debug.hs b/src/Polytype/Debug.hs new file mode 100644 index 0000000..c574464 --- /dev/null +++ b/src/Polytype/Debug.hs @@ -0,0 +1,46 @@ +{-| +Description : Debug effect for tracing other effects + +From https://github.com/polysemy-research/polysemy/issues/287 +by @isovector. +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Polytype.Debug ( + debugTraceEffect + , debugTraceEffectWith + ) where + +import Polysemy.Trace +import Polysemy.Internal +import Polysemy.Internal.Union + +-- | Trace calls to some effect, requires `Show` instance for the effect data type. +debugTraceEffect + :: forall e r a + . ( Members '[e, Trace] r + , forall m x. Show (e m x) + ) + => Sem r a + -> Sem r a +debugTraceEffect (Sem m) = Sem $ \k -> m $ \u -> + case prj @e u of + Just (Weaving e _ _ _ _) -> do + usingSem k $ trace $ show e + k u + Nothing -> k $ hoist (debugTraceEffect @e) u + +-- | Version of `debugTraceEffect` accepting rendering function directly +debugTraceEffectWith + :: forall e r a + . Members '[e, Trace] r + => (forall m x . e m x -> String) + -> Sem r a + -> Sem r a +debugTraceEffectWith showFn (Sem m) = Sem $ \k -> m $ \u -> + case prj @e u of + Just (Weaving e _ _ _ _) -> do + usingSem k $ trace $ showFn e + k u + Nothing -> k $ hoist (debugTraceEffectWith @e showFn) u diff --git a/src/Polytype/Delay.hs b/src/Polytype/Delay.hs new file mode 100644 index 0000000..1e5a0ae --- /dev/null +++ b/src/Polytype/Delay.hs @@ -0,0 +1,58 @@ +{-| +Description : Polymorphic Delay effect +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Polytype.Delay ( + Delay(..) + , delay + , runDelayAsync + , runDelayIO + ) where + +import Data.Kind (Type) +import qualified Control.Concurrent + +import Polysemy +import Polysemy.Async + +import Polytype.Types.Time (ToMicros(..)) + +data Delay (delayUnit :: Type) m a where + Delay :: Int -> Delay delayUnit m () + +makeSem_ ''Delay + +delay :: forall delayUnit r . Member (Delay delayUnit) r + => Int + -> Sem r () + +-- Has to run via Final interpret as `asyncToIO` is not +-- safe when using nested `await` +runDelayAsync :: forall delayUnit r a + . ( Members '[Embed IO, Async] r + , ToMicros delayUnit) + => Sem (Delay delayUnit ': r) a + -> Sem r a +runDelayAsync = interpret $ \case + Delay dt -> do + a <- async $ embed $ Control.Concurrent.threadDelay $ scaleMicros @delayUnit dt + _ <- await a + pure () + +runDelayIO :: forall delayUnit r a . (Member (Embed IO) r, ToMicros delayUnit) + => Sem (Delay delayUnit ': Async ': r) a + -> Sem r a +runDelayIO = asyncToIO . runDelayAsync + +-- this is broken and blocks even when wrapped in async +{-- +runDelayBroken :: forall delayUnit r a + . ( Member (Embed IO) r + , ToMicros delayUnit) + => Sem (Delay delayUnit ': r) a + -> Sem r a +runDelayBroken = interpret $ \case + Delay dt -> embed $ Control.Concurrent.threadDelay $ scaleMicros @delayUnit dt +--} diff --git a/src/Polytype/Env.hs b/src/Polytype/Env.hs new file mode 100644 index 0000000..e3e45ac --- /dev/null +++ b/src/Polytype/Env.hs @@ -0,0 +1,49 @@ +{-| +Description : Handling of system environment variables +-} + +module Polytype.Env + ( Env(..) + , mkEnv + , computeEnv + ) where + +import Data.Default (Default(def)) +import Data.Map (Map) +import Data.Set (Set) + +import qualified Data.Maybe +import qualified Data.Map +import qualified Data.Set +import qualified System.Environment + +data Env = Env { + envData :: Map String String -- ^ Environment variables, can be used to override pass-thru variables + , envPassthru :: Set String -- ^ Environment variables to pass-thru from parent environment + } deriving (Eq, Show, Ord) + +instance Default Env where + def = mkEnv [("POLYTYPE", "true")] ["PATH"] + +-- | Create new `Env` from pairs of variable -> value +-- and a list of variables to copy from system environment. +mkEnv :: [(String, String)] -> [String] -> Env +mkEnv edata pass = Env (Data.Map.fromList edata) (Data.Set.fromList pass) + +-- | Lookup environments variable to copy from system. +systemEnvPassthru :: [String] -> IO (Map String String) +systemEnvPassthru pt = + Data.Map.fromList . Data.Maybe.catMaybes + <$> mapM + (\name -> fmap (\x -> (name, x)) + <$> System.Environment.lookupEnv name) + pt + +-- | Compute environment in the form accepted +-- by standard functions from provided `Env` data. +computeEnv :: Env -> IO [(String, String)] +computeEnv Env{..} = do + p <- systemEnvPassthru $ Data.Set.toList envPassthru + return $ Data.Map.toList (envData `Data.Map.union` p) + + diff --git a/src/Polytype/Examples/Bash.hs b/src/Polytype/Examples/Bash.hs new file mode 100644 index 0000000..f5acf77 --- /dev/null +++ b/src/Polytype/Examples/Bash.hs @@ -0,0 +1,37 @@ + +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Polytype.Examples.Bash where + +import Polytype + +import Data.Text (Text) + +-- | Example of interacting with bash running in PTY +-- with prompt effect. +bashExample :: IO String +bashExample = + runM + . runLogShow + . untag @"test" + . runPty "bash" ["--norc", "--noprofile"] + . convertTeletypeStrings + . runLogShow + . teletypeLog + . convertTeletypeStrings @String @Text + . teletypeLogTagged @"test" + . runReadlineHaskeline + $ do + waitString "$" + writeLine "export" + waitString "$" + writeLine "export PS1='+[bashproxy e:$? ${BASH_SOURCE}:${LINENO}:${FUNCNAME[0]:+${FUNCNAME[0]}}:${BASH_SUBSHELL}] '" + waitString "bashproxy" + writeLine "echo $(( 2 + 2 ))" + waitString "4" + writeLine "false" + waitString "e:1" + cmd <- prompt ">" + maybe (pure ()) writeLine cmd + _ <- readTTY @String + readTTY @String diff --git a/src/Polytype/Examples/Echo.hs b/src/Polytype/Examples/Echo.hs new file mode 100644 index 0000000..34b64c8 --- /dev/null +++ b/src/Polytype/Examples/Echo.hs @@ -0,0 +1,12 @@ +module Polytype.Examples.Echo where + +import Polytype + +-- | Simple echo +echoExample :: IO () +echoExample = + runM + . teletypeToIO + . runLogShow + . teletypeLog + $ echo @String diff --git a/src/Polytype/Examples/HtopAsciinema.hs b/src/Polytype/Examples/HtopAsciinema.hs new file mode 100644 index 0000000..85fe171 --- /dev/null +++ b/src/Polytype/Examples/HtopAsciinema.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Polytype.Examples.HtopAsciinema where + +import Polytype + +-- | Record a demo of htop interaction +-- using asciicast logger. +htopAsciinemaExample :: FilePath -> IO () +htopAsciinemaExample outputFile = + void + . runFinal + . embedToFinal @IO + . resourceToIO + . runTeletypeAsciinema "htop demo" outputFile (ptyOptsExeArgs "htop" []) +-- . runLogShow +-- . teletypeLog -- enable for debugging raw input / output + . asyncToIOFinal + . runDelayAsync @MilliSeconds + . runDelayAsync @Seconds + . runDelayAsync @Minutes + $ do + waitString "Load average" + waitString "Help" + writeTTY "\ESC[11~" -- F1 + waitString "incremental" + writeTTY "\ESC[11~" + waitString "Uptime" + + delay @Seconds 2 + + void $ async $ forever $ readTTY >> pure () + + void $ async $ do + --writeTTY "\ESC[13~" + display "Welcome to htop demo!" + display "Recorded with polytype" + display "Press h or F1 for help" + writeTTY "h" + delay @Seconds 5 + writeTTY "h" + delay @Seconds 2 + + display "Search feature - F3" + writeTTY "\ESC[13~" + writeLineSlowly "htop" + delay @Seconds 5 + + display "Filtering feature - F4" + writeTTY "\ESC[14~" + writeLineSlowly "polytype" + delay @Seconds 5 + + display "" + + writeTTY "\ESC[14~" + writeLineSlowly "htop" + delay @Seconds 5 + + display "Sorted - F5" + writeTTY "\ESC[15~" + delay @Seconds 5 + + display "Toggle program path - p" + writeTTY "p" + delay @Seconds 5 + + display "That's all for now!" + display "Lets toggle program path for a bit" + forever $ do + writeTTY "p" + delay @Seconds 5 + + delay @Minutes 2 + display "Thanks for watching" + writeTTY "q" + readTTY + where + writeSlowly [] = delay @Seconds 1 + writeSlowly (x:xs) = do + writeTTY [x] + delay @MilliSeconds 100 + writeSlowly xs + + writeLineSlowly msg = writeSlowly msg >> writeLine "" + + display :: Members '[Teletype String, Delay Seconds, Delay MilliSeconds] r + => String + -> Sem r () + display msg = do + writeTTY "\ESC[14~" + writeTTY "\ESC~" + writeTTY "\ESC[14~" + writeSlowly msg + writeTTY "\ESC~" diff --git a/src/Polytype/Examples/IRCBridge.hs b/src/Polytype/Examples/IRCBridge.hs new file mode 100644 index 0000000..64cefac --- /dev/null +++ b/src/Polytype/Examples/IRCBridge.hs @@ -0,0 +1,43 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Polytype.Examples.IRCBridge where + +import Polytype + +-- | Actual test for ircbridge package utilizing `ircbridge-zre-cat` +-- and `ircbridge-zre-pretty` executables to test loopback of +-- IRC forwarding. +-- +-- Requires two forwarders running so one can see the messages +-- of the other one. +testIrcbridgeZre :: IO () +testIrcbridgeZre = + runFinal + . asyncToIOFinal + . embedToFinal @IO + . runLogStrings + . runDelayIO @Seconds + $ repeats_ 10 $ do + logs "Start" + logs "Pty" + a <- async + $ runPty "ircbridge-zre-pretty" [] + . convertTeletypeStrings + . runLogStrings + . runDelayAsync @Seconds + $ do + logs "waiting for HelloWorld" + waitString "HelloWorld" + + delay 1 + logs "Proc" + e <- runProc "ircbridge-zre-cat" ["--chan", "#bottest", "HelloWorld"] + logs $ "ExitCode:" ++ (show e) + logs "Await" + b <- await a + logs (show b) + logs "Done" + where + runProc exe args = runProcessIO $ do + (_i, _o, _e, h) <- createProcess exe args + waitProcess h diff --git a/src/Polytype/Examples/Process.hs b/src/Polytype/Examples/Process.hs new file mode 100644 index 0000000..2e1ab6a --- /dev/null +++ b/src/Polytype/Examples/Process.hs @@ -0,0 +1,31 @@ +module Polytype.Examples.Process where + +import System.Exit (ExitCode) + +import Polytype + +import qualified Streaming.Prelude + +-- | Example of `Process` effect, for safe variant +-- using `Polysemy.bracket` and `withProcess` +-- see `Polytype.Examples.SafeProcess`. +processExample :: IO (Maybe (String, ExitCode)) +processExample = + runFinal + . runTimeoutToIO @Seconds + . runProcessIOFinal + $ timeout @Seconds 2 $ do + (i, o, e, h) <- createProcess "echo" ["polytype"] + + x <- + runOutputStream (Streaming.Prelude.toHandle i) + . runInputViaStream (Streaming.Prelude.fromHandle e) + . untag @"err" + . runInputViaStream (Streaming.Prelude.fromHandle o) + . untag @"out" + . stdStreamsAsInputOutput @String @"out" @"err" + . teletypeAsStdStreams + $ readTTY + + ex <- waitProcess h + return (x, ex) diff --git a/src/Polytype/Examples/SafeProcess.hs b/src/Polytype/Examples/SafeProcess.hs new file mode 100644 index 0000000..8c35b91 --- /dev/null +++ b/src/Polytype/Examples/SafeProcess.hs @@ -0,0 +1,27 @@ +module Polytype.Examples.SafeProcess where + +import Polytype + +import qualified Streaming.Prelude + +-- | Example of running system process safely. +safeProcess :: IO (Maybe String) +safeProcess = + runFinal + . resourceToIOFinal + . runTimeoutToIO @Seconds + . runProcessIOFinal + . runProcessOverSSH "localhost" + . runDelayIO @Seconds + $ timeout @Seconds 2 + $ withProcess "sleep" ["3"] $ \(i, o, e, _p) -> do + runOutputStream (Streaming.Prelude.toHandle i) + . runInputViaStream (Streaming.Prelude.fromHandle e) + . untag @"err" + . runInputViaStream (Streaming.Prelude.fromHandle o) + . untag @"out" + . stdStreamsAsInputOutput @String @"out" @"err" + . teletypeAsStdStreams + . runLogShow + . teletypeLog + $ readTTY diff --git a/src/Polytype/Examples/Streaming.hs b/src/Polytype/Examples/Streaming.hs new file mode 100644 index 0000000..f260427 --- /dev/null +++ b/src/Polytype/Examples/Streaming.hs @@ -0,0 +1,20 @@ +module Polytype.Examples.Streaming where + +import Polytype + +import qualified System.IO + +-- | Contrived example using `Teletype` for interaction +-- with current processes standard streams using `stdStreamsIO`. +streamingTeletypeExample :: IO (Either ProcException String) +streamingTeletypeExample = + runFinal + . embedToFinal @IO + . errorToIOFinal @ProcException + . traceToIO + . stdStreamsIO (Just System.IO.stdin, Just System.IO.stdout, Just System.IO.stderr) + . teletypeAsStdStreams @String + $ do + z <- readTTY @String + writeTTY z + return z diff --git a/src/Polytype/Experiments.hs b/src/Polytype/Experiments.hs new file mode 100644 index 0000000..0c6627f --- /dev/null +++ b/src/Polytype/Experiments.hs @@ -0,0 +1,24 @@ +{-| +Description : Experiments, mostly incomplete +-} +module Polytype.Experiments where + +import Polysemy +import Control.Monad.Fix + +import Polytype.Teletype + +ask :: Sem (Teletype String ': r) () +ask = writeTTY @String "asking" >> readTTY @String >>= writeTTY @String + +respond :: Sem (Teletype String ': r) () +respond = readTTY @String >> writeTTY @String "responding" + +-- | Attempt to loop two `Teletype`s (`ask` & `respond`). +runTeletypeLoop :: Monoid stringy + => Sem '[Teletype stringy] a + -> Sem '[Teletype stringy] b + -> ([stringy], [stringy]) +runTeletypeLoop second first = fix $ \f -> + ( fst . run $ runTeletypePure [] $ second -- this should get snd f as input but it loops + , fst . run $ runTeletypePure (fst f) $ first) diff --git a/src/Polytype/Log.hs b/src/Polytype/Log.hs new file mode 100644 index 0000000..7a877e9 --- /dev/null +++ b/src/Polytype/Log.hs @@ -0,0 +1,116 @@ +{-| +Description : Teletype logging helpers +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Polytype.Log ( + Log(..) + , logs + , Stamp(..) + , stampLogs + , TelMsg(..) + , teletypeLog + , teletypeLogTagged + , reinterpretLogAsOutput + , runLogShow + , runLogStrings + , runLogForward + , runLogForward' + ) where + +import Prelude hiding (log) + +import Polysemy +import Polysemy.Output +import Polysemy.Tagged + +import Polytype.Teletype + +import Data.Functor.Contravariant (contramap) +import Data.Text (Text) +import Data.Time (UTCTime) +import Colog.Core (LogAction, cmapM) +import Colog.Core.IO (logStringStdout) +import Colog.Polysemy (Log(Log), log, runLogAction) + +import qualified Data.Text +import qualified Data.Time + +logs :: Member (Log msg) r => msg -> Sem r () +logs = log + +data TelMsg stringy = Read stringy | Write stringy + deriving (Show, Eq, Ord) + +data Stamp a = Stamp + { stampData :: a + , stampTime :: UTCTime + } deriving (Show, Eq, Ord) + +stampLogs + :: LogAction IO (Stamp (TelMsg stringy)) -> LogAction IO (TelMsg stringy) +stampLogs = cmapM toStamp + where + toStamp :: TelMsg stringy -> IO (Stamp (TelMsg stringy)) + toStamp msg = do + time <- Data.Time.getCurrentTime + pure $ Stamp msg time + +teletypeLog + :: forall stringy r a + . Monoid stringy + => Sem (Teletype stringy ': r) a + -> Sem (Log (TelMsg stringy) ': Teletype stringy ':r) a +teletypeLog = reinterpret2 $ \case + ReadTTY -> do + x <- readTTY + log (Read x) + return x + WriteTTY msg -> log (Write msg) >> writeTTY msg + +teletypeLogTagged + :: forall t stringy r a + . (Monoid stringy, Member (Tagged t (Log (TelMsg stringy))) r) + => Sem (Teletype stringy ': r) a + -> Sem (Teletype stringy ': r) a +teletypeLogTagged = tag @t @(Log (TelMsg stringy)) . reinterpret2 \case + ReadTTY -> do + x <- readTTY + log (Read x) + return x + WriteTTY msg -> log (Write msg) >> writeTTY msg + +-- | Forward teletype output to standard output +-- XXX convertible +runLogForward :: Member (Embed IO) r + => Sem (Log (TelMsg String) ': r) a + -> Sem r a +runLogForward = runLogAction @IO (contramap ex logStringStdout) + where + ex (Read r) = r + ex (Write _) = "" + +runLogForward' :: Member (Embed IO) r + => Sem (Log (TelMsg Text) ': r) a + -> Sem r a +runLogForward' = runLogAction @IO (contramap ex logStringStdout) + where + ex (Read r) = Data.Text.unpack r + ex (Write _) = "" + +runLogShow + :: (Member (Embed IO) r, Show stringy) + => Sem (Log (TelMsg stringy) ': r) a + -> Sem r a +runLogShow = runLogAction @IO (stampLogs $ contramap show logStringStdout) + +runLogStrings :: (Member (Embed IO) r) => Sem (Log String ': r) a -> Sem r a +runLogStrings = runLogAction @IO logStringStdout + +-- | Reinterpret `Log` as `Output` +reinterpretLogAsOutput :: + Sem (Log msg ': r) a + -> Sem (Output msg ': r) a +reinterpretLogAsOutput = reinterpret $ \case + Log msg -> output msg diff --git a/src/Polytype/Process.hs b/src/Polytype/Process.hs new file mode 100644 index 0000000..baea2a4 --- /dev/null +++ b/src/Polytype/Process.hs @@ -0,0 +1,95 @@ +{-| +Description : Process control effect +-} + +module Polytype.Process ( + Process(..) + , createProcess + , waitProcess + , terminateProcess + + , withProcess + + , runProcessIO + , runProcessIOFinal + , runProcessOverSSH + ) where + +import Polysemy +import Polysemy.Resource + +import System.Exit (ExitCode) +import System.IO (Handle) +import System.Process (ProcessHandle) + +import qualified System.Process + +data Process m a where + CreateProcess + :: String + -> [String] + -> Process m ( Handle + , Handle + , Handle + , ProcessHandle) + WaitProcess + :: ProcessHandle + -> Process m ExitCode + + TerminateProcess + :: ProcessHandle + -> Process m () + +makeSem ''Process + +-- | Interpret process in terms of `IO` +runProcessIO :: Member (Embed IO) r + => Sem (Process ': r) a + -> Sem r a +runProcessIO = interpret $ \case + CreateProcess exe args -> embed + $ (\(Just i, Just o, Just e, ph) -> (i, o, e, ph)) + <$> System.Process.createProcess (System.Process.proc exe args) + { System.Process.std_in = System.Process.CreatePipe + , System.Process.std_out = System.Process.CreatePipe + , System.Process.std_err = System.Process.CreatePipe + } + + WaitProcess handle -> embed $ System.Process.waitForProcess handle + TerminateProcess handle -> embed $ System.Process.terminateProcess handle + +-- | Interpret process in term of `Final IO` +runProcessIOFinal :: Member (Final IO) r + => Sem (Process ': Embed IO ': r) a + -> Sem r a +runProcessIOFinal = embedToFinal @IO . runProcessIO + +-- | Reinterpret process in term of process running over ssh +runProcessOverSSH :: Member (Embed IO) r + => String -- host? + -> Sem (Process ': r) a + -> Sem (Process ': r) a +runProcessOverSSH host = reinterpret $ \case + CreateProcess exe args -> createProcess "ssh" (host:exe:args) + WaitProcess handle -> waitProcess handle + TerminateProcess handle -> terminateProcess handle + +-- | Spawn a process and run another `Sem r a` computation +-- interacting with it. +-- +-- Safely terminates the process in case of failure and completion +-- of the nested computation. +withProcess :: Members '[Resource, Process] r + => String + -> [String] + -> ((Handle, Handle, Handle, ProcessHandle) -> Sem r a) + -> Sem r a +withProcess exe args rest = do + bracket + (createProcess exe args) + (\(_, _, _, h) -> terminateProcess h) + (\p@(_, _, _, h) -> do + x <- rest p + terminateProcess h + pure x + ) diff --git a/src/Polytype/Pty.hs b/src/Polytype/Pty.hs new file mode 100644 index 0000000..04eebae --- /dev/null +++ b/src/Polytype/Pty.hs @@ -0,0 +1,97 @@ +{-| +Description : Teletype interpreters for interacting with programs spawned with TTY +-} + +module Polytype.Pty where + +import Polysemy +import Polysemy.Input + +import Polytype.Env +import Polytype.Teletype + +import Data.ByteString (ByteString) +import Data.Default (Default(def)) +import System.Process (ProcessHandle) +import System.Posix.Pty (Pty) + +import qualified System.Posix.Pty + +-- | Reinterpret `Teletype ByteString` in terms +-- of `Input (Pty, ProcessHandle)`. +runTeletypePtyOpts :: Member (Embed IO) r + => Sem (Teletype ByteString ': r) a + -> Sem (Input (Pty, ProcessHandle) ': r) a +runTeletypePtyOpts = reinterpret \case + ReadTTY -> do + (pty, _handle) <- input @(Pty, ProcessHandle) + embed $ System.Posix.Pty.readPty pty + WriteTTY msg -> do + (pty, _handle) <- input @(Pty, ProcessHandle) + embed $ System.Posix.Pty.writePty pty msg + +data PtyOpts = PtyOpts { + ptyEnv :: Env -- Environment variables to add and pass-thru from system + , ptySearchPath :: Bool -- Search $PATH environment variable + , ptyExecutable :: FilePath -- Executable name or path + , ptyArgs :: [String] -- Arguments for the executable + , ptyWidth :: Int -- Width of the spawned PTY in characters + , ptyHeight :: Int -- Height of the spawned PTY + } deriving (Eq, Show, Ord) + +instance Default PtyOpts where + def = PtyOpts { + ptyEnv = mkEnv + [ + ("POLYTYPE", "true") + , ("TERM", "rxvt-unicode-256color") + ] + ["PATH", "SHELL", "TERMINFO", "TERMINFO_DIRS"] + , ptySearchPath = True + , ptyExecutable = mempty + , ptyArgs = mempty + , ptyWidth = 80 + , ptyHeight = 40 + } + +-- Create `PtyOpts` with executable name or path ad its arguments +-- using defaults for the rest of `PtyOpts`. +ptyOptsExeArgs :: FilePath -> [String] -> PtyOpts +ptyOptsExeArgs exe args = def { + ptyExecutable = exe + , ptyArgs = args + } + +-- | `System.Posix.Pty.spawnWithPty` variant accepting `PtyOpts` +spawnWithPtyOpts :: PtyOpts -> IO (Pty, ProcessHandle) +spawnWithPtyOpts PtyOpts{..} = do + env <- computeEnv ptyEnv + System.Posix.Pty.spawnWithPty + (Just env) + ptySearchPath + ptyExecutable + ptyArgs + (ptyWidth, ptyHeight) + +-- | Run `Teletype ByteString` using `System.Posix.Pty.spawnWithPty`. +-- +-- Requires `PtyOpts` `Input` as its configuration. +runPtyOpts :: (Members '[Embed IO, Input PtyOpts] r) + => Sem (Teletype ByteString ': r) a + -> Sem r a +runPtyOpts rest = do + opts <- input @PtyOpts + i <- embed $ spawnWithPtyOpts opts + runInputConst i $ runTeletypePtyOpts $ rest + +-- | Run `Teletype ByteString` using `System.Posix.Pty.spawnWithPty`. +-- +-- Requires `PtyOpts` `Input` effect handled next. +runPty :: (Member (Embed IO) r) + => FilePath + -> [String] + -> Sem (Teletype ByteString ': Input PtyOpts ': r) b + -> Sem r b +runPty exe args = + runInputConst @PtyOpts (ptyOptsExeArgs exe args) + . runPtyOpts diff --git a/src/Polytype/Race.hs b/src/Polytype/Race.hs new file mode 100644 index 0000000..bfecc90 --- /dev/null +++ b/src/Polytype/Race.hs @@ -0,0 +1,52 @@ +{-| +Description : Race effect + +Slightly adjusted code from +https://github.com/polysemy-research/polysemy/issues/252 +by @KingoftheHomeless +* (currently unused) +-} + +module Polytype.Race where + + +import Polysemy +import Polysemy.Input +import Polysemy.Final +import Polysemy.Tagged + +import qualified Control.Concurrent.Async + +data Race m a where + Race :: m a -> m b -> Race m (Either a b) + +makeSem ''Race + +raceToIOFinal + :: Member (Final IO) r + => Sem (Race ': r) a + -> Sem r a +raceToIOFinal = interpretFinal @IO $ \case + Race left right -> do + left' <- runS left + right' <- runS right + pure + $ either + (fmap Left) + (fmap Right) + <$> Control.Concurrent.Async.race left' right' + +raceInput + :: forall i r + . Member (Final IO) r + => InterpreterFor (Input i) r + -> InterpreterFor (Input i) (Tagged "intr1" (Input i) ': r) + -> InterpreterFor (Input i) r +raceInput intr1 intr2 = + intr1 . untag @"intr1" + . intr2 . untag @"intr2" + . (reinterpret2 $ \Input -> withStrategicToFinal $ do + input1 <- runS (tag @"intr1" @(Input i) input) + input2 <- runS (tag @"intr2" @(Input i) input) + pure $ either id id <$> Control.Concurrent.Async.race input1 input2 + ) diff --git a/src/Polytype/Readline.hs b/src/Polytype/Readline.hs new file mode 100644 index 0000000..920e25f --- /dev/null +++ b/src/Polytype/Readline.hs @@ -0,0 +1,53 @@ +{-| +Description : Readline effect + +Like `Control.Effect.Readline` from fused-effects-readline +.. but wannabe polymorphic +* XXX: haskeline-polysemy /o\ \o/ /o\ \o/ +-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Polytype.Readline where + +--import Data.Text.Prettyprint.Doc (Doc) +--import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle) +import Prelude hiding (print) + +import Polysemy +import Data.Kind (Type) + +import System.Console.Haskeline + +data Readline (stringy :: Type) (m :: Type -> Type) (a :: Type) where + Prompt :: stringy -> Readline stringy m (Maybe stringy) + Print :: stringy -> Readline stringy m () + --Print :: (Doc AnsiStyle) -> Readline stringy m (Doc AnsiStyle) + +makeSem_ ''Readline + +prompt :: forall stringy r . Member (Readline stringy) r + => stringy -- ^ Prompt string + -> Sem r (Maybe stringy) -- ^ User input + +print :: forall stringy r . Member (Readline stringy) r + => stringy -- ^ Ouput message + -> Sem r () + +runReadlineHaskeline :: Member (Embed IO) r + => Sem (Readline String ': r) a + -> Sem r a +runReadlineHaskeline = interpret $ \case + Prompt p -> embed $ runInputT defaultSettings + $ getInputLine p + Print p -> embed $ runInputT defaultSettings $ outputStrLn p + + +test_repl :: IO () +test_repl = runM . runReadlineHaskeline $ do + mu <- prompt "Username: " + case mu of + Nothing -> print "No input :(" + Just u -> do + print $ "o/ " ++ u + _ <- prompt ("[" ++ u ++ "]> ") + return () diff --git a/src/Polytype/Serial.hs b/src/Polytype/Serial.hs new file mode 100644 index 0000000..85418ee --- /dev/null +++ b/src/Polytype/Serial.hs @@ -0,0 +1,61 @@ +{-| +Description : Teletype interpreters for interacting with POSIX serial terminals +-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Polytype.Serial ( + runTeletypeAsSerial + , unsafeRunTeletypeAsSerial + , defaultSerialSettings + ) where + +import Polysemy +import Polysemy.Resource +import Polysemy.Input.Streaming + +import Polytype.Teletype + +import Data.Default (Default(def)) +import System.Hardware.Serialport (SerialPortSettings(..), CommSpeed(..), FlowControl(..), Parity(..), StopBits(..)) + +import qualified Streaming.Prelude +import qualified System.IO +import qualified System.Hardware.Serialport + +-- | Run `Teletype String` via `System.Hardware.Serialport` +runTeletypeAsSerial :: (Member (Embed IO) r, Member Resource r) + => FilePath + -> SerialPortSettings + -> Sem (Teletype String ': r) b + -> Sem r b +runTeletypeAsSerial dev opts rest = bracket + (embed $ System.Hardware.Serialport.hOpenSerial dev opts) + (embed . System.IO.hClose) + (\h -> + runOutputStream (Streaming.Prelude.toHandle h) + . runInputViaStream (Streaming.Prelude.fromHandle h) + . runTeletypeAsInputOutput $ rest) + +-- | Like `runTeletypeAsSerial` without `Resource` +unsafeRunTeletypeAsSerial :: Member (Embed IO) r + => FilePath + -> SerialPortSettings + -> Sem (Teletype String : r) b + -> Sem r b +unsafeRunTeletypeAsSerial dev opts rest = do + h <- embed $ System.Hardware.Serialport.hOpenSerial dev opts + ret <- runOutputStream (Streaming.Prelude.toHandle h) + . runInputViaStream (Streaming.Prelude.fromHandle h) + . runTeletypeAsInputOutput + $ rest + embed $ System.IO.hClose h + pure ret + +-- | Opinionated `SerialPortSettings` defaults +defaultSerialSettings :: SerialPortSettings +defaultSerialSettings = SerialPortSettings + CS115200 8 One NoParity NoFlowControl 1 + +instance Default SerialPortSettings where + def = defaultSerialSettings diff --git a/src/Polytype/StdStreams.hs b/src/Polytype/StdStreams.hs new file mode 100644 index 0000000..e6469ce --- /dev/null +++ b/src/Polytype/StdStreams.hs @@ -0,0 +1,120 @@ +{-| +Description : Standard process streams effect +-} + +module Polytype.StdStreams ( + StdStreams(..) + , writeStdin + , readStdout + , readStderr + , teletypeAsStdStreams + , stdStreamsAsTeletype + , stdStreamsAsInputOutput + , stdStreamsIO + , ProcException(..) + , streamStdStreams + ) where + +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.Output +import Polysemy.Tagged + +import Polysemy.Input.Streaming + +import Data.Kind (Type) + +import System.IO (Handle) +import qualified System.IO + +import Streaming (Stream, Of) + +import Polytype.Teletype (Teletype) +import qualified Polytype.Teletype + +data StdStreams (stringy :: Type) m a where + WriteStdin :: stringy -> StdStreams stringy m () + ReadStdout :: StdStreams stringy m stringy + ReadStderr :: StdStreams stringy m stringy + +makeSem_ ''StdStreams + +writeStdin :: forall stringy r . Member (StdStreams stringy) r + => stringy -- ^ Message to write + -> Sem r () -- ^ Effectful computation with no result + +readStdout :: forall stringy r . Member (StdStreams stringy) r + => Sem r stringy + +readStderr :: forall stringy r . Member (StdStreams stringy) r + => Sem r stringy + +instance Show (StdStreams String m x) where + show (ReadStdout) = "read out" + show (ReadStderr) = "read err" + show (WriteStdin z) = "write in: [" ++ z ++ "]" + +-- | Reinterpret `Teletype stringy` as `StdStreams stringy` +-- utilizing only stdout but not stderr. +teletypeAsStdStreams :: forall stringy r a . + Sem (Teletype stringy ': r) a + -> Sem (StdStreams stringy ': r) a +teletypeAsStdStreams = reinterpret $ \case + Polytype.Teletype.ReadTTY -> readStdout -- <|> readStderr -- possible with NonDet + Polytype.Teletype.WriteTTY s -> writeStdin s + +-- | Inverse of `teletypeAsStdStreams` +stdStreamsAsTeletype :: forall stringy r a . + Sem (StdStreams stringy ': r) a + -> Sem (Teletype stringy ': r) a +stdStreamsAsTeletype = reinterpret $ \case + WriteStdin s -> Polytype.Teletype.writeTTY s + ReadStdout -> Polytype.Teletype.readTTY + ReadStderr -> Polytype.Teletype.readTTY + +-- | Reinterpret `StdStreams` as `Tagged` `Input`s and `Output`. +stdStreamsAsInputOutput :: forall stringy hOut hErr r a . Monoid stringy => + Sem (StdStreams stringy ': r) a + -> Sem ( Tagged hOut (Input (Maybe stringy)) + ': Tagged hErr (Input (Maybe stringy)) + ': Output stringy ': r + ) + a +stdStreamsAsInputOutput = reinterpret3 $ \case + WriteStdin msg -> output msg + ReadStdout -> maybe mempty id <$> tagged @hOut input + ReadStderr -> maybe mempty id <$> tagged input + +-- | Run `StdStreams` using `Streaming` +streamStdStreams :: Monad m + => Stream (Of String) + (Sem (Tagged "err" (Input (Maybe String)) : Output String : r)) () + -> Stream (Of String) + (Sem (Output String : r)) () + -> (Stream (Of String) + m () -> Sem r ()) + -> Sem (StdStreams String : r) a + -> Sem r a +streamStdStreams sOut sErr sIn = + runOutputStream sIn + . runInputViaStream sErr + . untag @"err" + . runInputViaStream sOut + . untag @"out" + . stdStreamsAsInputOutput @String @"out" @"err" + +data ProcException = StdoutNotAvailable | StderrNotAvailable + deriving (Show, Eq, Ord) + +-- | Run `StdStreams` via handles +-- treating `ReadStdout` and `ReadStderr` as readlines from stdin +-- and `WriteStdin`s as writes to stdout +stdStreamsIO :: Members '[Embed IO, Error ProcException] r + => (Maybe Handle, Maybe Handle, Maybe Handle) + -> Sem (StdStreams String ': r) a + -> Sem r a +stdStreamsIO (stdin, stdout, _stderr) = interpret $ \case + WriteStdin str -> embed $ maybe (pure ()) (flip System.IO.hPutStr str) stdout + ReadStdout -> maybe (throw StdoutNotAvailable) (embed . System.IO.hGetLine) stdin + ReadStderr -> maybe (throw StderrNotAvailable) (embed . System.IO.hGetLine) stdin diff --git a/src/Polytype/Teletype.hs b/src/Polytype/Teletype.hs new file mode 100644 index 0000000..2f60de7 --- /dev/null +++ b/src/Polytype/Teletype.hs @@ -0,0 +1,245 @@ +{-| +Description : Polymorphic Teletype effect + +Polymorphic Teletype so we can use different kinds of terminals + * line based + * character based + * ByteString/Text based +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Polytype.Teletype ( + Teletype(..) + , readTTY + , writeTTY + + , echo + + , teletypeToIO + , runTeletypePure + , runTeletypeAsInputOutput + , runTeletypeStreaming + , runTeletypeStreaming' + , runTeletypeStreamingStdio + + , convertTeletypeStrings + , bufferBy + , mapTeletype + , mapMTeletype + , teletypeReadOnly + , teletypeParseWith + + , streamingInteract + , streamingEcho + ) where + +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.Output +import Polysemy.State + +import Polysemy.Input.Streaming + +import Data.Attoparsec.Types (Parser, IResult(..)) +import Data.Kind (Type) +import Data.String.Conversions (ConvertibleStrings) +import Streaming (Stream, Of) + +import qualified Control.Monad +import qualified Data.String.Conversions +import qualified Streaming.Prelude + +data Teletype (stringy :: Type) (m :: Type -> Type) (a :: Type) where + ReadTTY :: Teletype stringy m stringy + WriteTTY :: stringy -> Teletype stringy m () + +makeSem_ ''Teletype + +writeTTY :: forall stringy r + . Member (Teletype stringy) r + => stringy -- ^ Message to write + -> Sem r () -- ^ Effectful computation with no result + +readTTY :: forall stringy r . Member (Teletype stringy) r + => Sem r stringy + +-- | Run `Teletype` using line based IO. +teletypeToIO :: Member (Embed IO) r + => Sem (Teletype String ': r) a + -> Sem r a +teletypeToIO = interpret $ \case + ReadTTY -> embed getLine + WriteTTY msg -> embed $ putStrLn msg + +-- | Run `Teletype` purely. +-- +-- >>> fst . run $ runTeletypePure ["ab", "cd"] $ echo @String +-- ["ab","cd"] +runTeletypePure :: forall stringy r a . Monoid stringy + => [stringy] + -> Sem (Teletype stringy ': r) a + -> Sem r ([stringy], a) +runTeletypePure i + = runOutputMonoid @stringy pure + . runInputList i + . runTeletypeAsInputOutput + +-- | Run `Teletype` utilizing `Streaming`. +runTeletypeStreaming :: forall stringy r m a . (Monad m, Monoid stringy) + => (Stream (Of stringy) m () -> Sem r ()) + -> Stream (Of stringy) (Sem (Output stringy ': r)) () + -> Sem (Teletype stringy ': r) a + -> Sem r a +runTeletypeStreaming out instream = + runOutputStream out + . runInputViaStream @stringy instream + . runTeletypeAsInputOutput @stringy + +-- | Like `runTeletypeStreaming` but only with streaming input, +-- while output is collected via `runOutputList`. +runTeletypeStreaming' :: forall stringy r a . Monoid stringy + => Stream (Of stringy) (Sem (Output stringy ': r)) () + -> Sem (Teletype stringy ': r) a + -> Sem r ([stringy], a) +runTeletypeStreaming' s + = runOutputList + . runInputViaStream s + . runTeletypeAsInputOutput + +-- | Run `Teletype` using `Streaming.Prelude.stdoutLn` +-- and `Streaming.Prelude.stdinLn`. +runTeletypeStreamingStdio :: forall r a + . Member (Embed IO) r + => Sem (Teletype String ': r) a + -> Sem r a +runTeletypeStreamingStdio = runTeletypeStreaming + Streaming.Prelude.stdoutLn + Streaming.Prelude.stdinLn + +-- Like `interact` but on top of teletype utilizing Streaming +streamingInteract :: forall a . + ( ConvertibleStrings String a + , ConvertibleStrings a String) + => (a -> a) + -> IO a +streamingInteract f = + runM + . runTeletypeStreaming Streaming.Prelude.stdoutLn Streaming.Prelude.stdinLn + . convertTeletypeStrings @a @String + $ Control.Monad.forever $ readTTY @a >>= writeTTY @a . f + +-- | Like `echo` but implemented using `streamingInteract` without termination. +streamingEcho :: IO String +streamingEcho = streamingInteract @String id + +-- | Echo `Teletype` reads as writes, terminate on empty read. +echo :: forall stringy r + . (Eq stringy, Monoid stringy, Member (Teletype stringy) r) + => Sem r () +echo = do + x <- readTTY @stringy + case x of + y | y == mempty -> pure () + _ -> do + writeTTY x + -- when we enable recursion we get + -- ghc: panic! (the 'impossible' happened) + -- (GHC version 8.10.1: mergeSATInfo + -- Left:STSTSVSVSVSVSTSVSVSV, Right:STSTSVSVSVSCSTSVSVSV + -- + echo @stringy + +-- | Reinterpret `Teletype` in form of `Input` and `Output` +runTeletypeAsInputOutput :: forall stringy r a . Monoid stringy + => Sem (Teletype stringy ': r) a + -> Sem (Input (Maybe stringy) ': Output stringy ': r) a +runTeletypeAsInputOutput = reinterpret2 $ \case + ReadTTY -> maybe mempty id <$> input -- @stringy + WriteTTY msg -> output msg + +-- | Convert from one string like `Teletype` to another utilizing +-- `Data.String.Conversions.convertString`. +convertTeletypeStrings :: forall stringy strlike r a . + ( ConvertibleStrings stringy strlike + , ConvertibleStrings strlike stringy) + => Sem (Teletype stringy ': r) a + -> Sem (Teletype strlike ': r) a +convertTeletypeStrings = reinterpret $ \case + ReadTTY -> Data.String.Conversions.convertString <$> readTTY @strlike + WriteTTY msg -> writeTTY @strlike $ Data.String.Conversions.convertString msg + +-- | Provided a function like `lines` or `words` split the reads and writes +-- using state as a buffer internally. +bufferBy :: forall stringy r a . + ( Eq stringy + , Monoid stringy + , Member (State [stringy]) r + ) + => (stringy -> [stringy]) + -> Sem (Teletype stringy ': r) a + -> Sem (Teletype stringy ': r) a +bufferBy splitter = reinterpret $ \case + ReadTTY -> do + c <- gets id + case c of + [] -> do + new <- readTTY + case splitter new of + [] -> return mempty + (x:xs) -> put xs >> return x + (x:xs) -> put xs >> return x + WriteTTY msg -> mapM_ writeTTY $ splitter msg + +-- | Convert the type carried by `Teletype` to another type purely. +mapTeletype :: (b -> a) + -> (a -> b) + -> Sem (Teletype a ': r) c + -> Sem (Teletype b ': r) c +mapTeletype fReads fWrites = reinterpret $ \case + ReadTTY -> fReads <$> readTTY + WriteTTY msg -> writeTTY $ fWrites msg + +-- | Convert the type carried by `Teletype` to another type +-- utilizing `Sem` monadic functions. +mapMTeletype :: (stringy -> Sem r strlike) + -> (strlike -> Sem r stringy) + -> Sem (Teletype stringy ': r) a + -> Sem (Teletype strlike ': r) a +mapMTeletype fWrites fReads = reinterpret $ \case + ReadTTY -> readTTY >>= raise . fReads + WriteTTY msg -> raise (fWrites msg) >>= writeTTY + +-- | Pass only reads, writes are replaced by `mempty` +teletypeReadOnly :: (Monoid s) + => Sem (Teletype s ': r) a + -> Sem (Teletype s ': r) a +teletypeReadOnly = mapTeletype id (pure mempty) + +-- | Run `Teletype a` trying to parse elements utilizing attoparsec `Parser` +-- in streaming fashion +teletypeParseWith :: forall stringy a b r . (Eq stringy, Monoid stringy) + => (Parser stringy a -> stringy -> IResult stringy a) + -> (Parser stringy a) + -> (a -> stringy) + -> Sem (Teletype a ': r) b + -> Sem (Error String ': Teletype stringy ': r) b +teletypeParseWith parsefn parser builder = + fmap snd + . runState @stringy mempty + . reinterpret3 \case + + ReadTTY -> do + let lo :: IResult stringy a + -> Sem (State stringy ': Error String : Teletype stringy : r) a + lo (Done rest a) = put rest >> return a + lo (Partial f) = f <$> readTTY >>= lo + lo (Fail _unconsumed _context err) = throw err + + get @stringy >>= \case + x | x /= mempty -> lo $ parsefn parser x + _ | otherwise -> parsefn parser <$> readTTY >>= lo + + WriteTTY msg -> writeTTY $ builder msg + diff --git a/src/Polytype/Teletype/String.hs b/src/Polytype/Teletype/String.hs new file mode 100644 index 0000000..79c6ddf --- /dev/null +++ b/src/Polytype/Teletype/String.hs @@ -0,0 +1,36 @@ +module Polytype.Teletype.String ( + waitString + , waitString' + , writeLine + ) where + +import Polysemy +import Polytype.Teletype + +import qualified Data.List + +-- | Wait for a `String` to appear on `Teletype` +waitString :: Member (Teletype String) r + => String + -> Sem r () +waitString s = go + where + go = do + x <- readTTY + if (s `Data.List.isInfixOf` x) then return () else go + +-- | Variant of `waitString` returning matched `String` +waitString' :: Member (Teletype String) r + => String + -> Sem r String +waitString' s = go + where + go = do + x <- readTTY + if (s `Data.List.isInfixOf` x) then return x else go + +-- | Write `String` terminated by newline to `Teletype` +writeLine :: Member (Teletype String) r + => String + -> Sem r () +writeLine x = writeTTY (x ++ "\n") diff --git a/src/Polytype/Teletype/Text.hs b/src/Polytype/Teletype/Text.hs new file mode 100644 index 0000000..334a94d --- /dev/null +++ b/src/Polytype/Teletype/Text.hs @@ -0,0 +1,37 @@ +module Polytype.Teletype.Text ( + waitText + , waitText' + , writeTextLine + ) where + +import Data.Text (Text) +import qualified Data.Text + +import Polysemy +import Polytype.Teletype + +-- | Wait for a `Text` to appear on `Teletype` +waitText :: Member (Teletype Text) r + => Text + -> Sem r () +waitText s = go + where + go = do + x <- readTTY + if (s `Data.Text.isInfixOf` x) then return () else go + +-- | Variant of `waitText` returning matched `Text` +waitText' :: Member (Teletype Text) r + => Text + -> Sem r Text +waitText' s = go + where + go = do + x <- readTTY + if (s `Data.Text.isInfixOf` x) then return x else go + +-- | Write `Text` terminated by newline to `Teletype` +writeTextLine :: Member (Teletype Text) r + => Text + -> Sem r () +writeTextLine x = writeTTY (x <> Data.Text.pack "\n") diff --git a/src/Polytype/Test.hs b/src/Polytype/Test.hs new file mode 100644 index 0000000..6db4f7d --- /dev/null +++ b/src/Polytype/Test.hs @@ -0,0 +1,66 @@ +{-| +Description : Test effect + +Contrived, needs work. +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Polytype.Test where + +import Polysemy +import Polysemy.Error +import Data.Kind (Type) +import qualified System.Exit + +data Test (error :: Type) (m :: Type -> Type) (a :: Type) where + TestPass :: z -> Test error m z + TestFail :: error -> Test error m () + +makeSem_ ''Test + +testPass :: forall z error r . Member (Test error) r + => z -> Sem r z + +testFail :: forall error r . Member (Test error) r + => error + -> Sem r () + +-- | Interpret `Test` failure as fatal error resulting +-- in `System.Exit.die`. +runTestIOFatal :: forall error r a . Member (Embed IO) r + => (error -> String) + -> Sem (Test error ': r) a + -> Sem r a +runTestIOFatal fmtError = interpret $ \case + TestFail e -> embed $ System.Exit.die $ fmtError e + TestPass ret -> return ret + +-- | Reinterpret `Test` in terms of `Error` effect +runTestAsError :: forall e r a . Member (Error e) r + => Sem (Test e ': r) a + -> Sem (Error e ': r) a +runTestAsError = reinterpret $ \case + TestFail e -> throw e + TestPass ret -> pure ret + +{-- + - hard +runErrorAsTest :: forall e r a . Member (Test e) r + => Sem (Error e ': r) a + -> Sem (Test e ': r) a +runErrorAsTest = reinterpretH $ \case + Throw e -> testFail e >>= pureT + -- Catch f -> pure ret + +runTestPure :: forall error r a . Show error + => Sem (Test error ': r) a + -> Sem r (Either error a) +runTestPure (Sem sem) = Sem $ \k -> sem $ \u -> + case decomp u of + _ -> undefined +--reinterpret $ \case +-- TestFail e -> pure $ Left e +--} + + diff --git a/src/Polytype/Timeout.hs b/src/Polytype/Timeout.hs new file mode 100644 index 0000000..3f52ea8 --- /dev/null +++ b/src/Polytype/Timeout.hs @@ -0,0 +1,41 @@ +{-| +Description : Polymorphic Timeout effect + +Thanks to @bolt12 + * via https://github.com/polysemy-research/polysemy/issues/342 + * adjusted to accept `timeUnit` +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Polytype.Timeout where + + +import Polysemy +import Polysemy.Final + +import Data.Kind (Type) + +import qualified System.Timeout + +import Polytype.Types.Time (ToMicros(..)) + +data Timeout (timeUnit :: Type) m a where + Timeout :: Int -> m a -> Timeout timeUnit m (Maybe a) + +makeSem_ ''Timeout + +timeout :: forall timeUnit r a . Member (Timeout timeUnit) r + => Int + -> Sem r a + -> Sem r (Maybe a) + +-- | Run `Timeout` in terms of `Final IO`. +runTimeoutToIO :: forall unit r a . (Member (Final IO) r, ToMicros unit) + => Sem (Timeout unit ': r) a + -> Sem r a +runTimeoutToIO = interpretFinal @IO \case + Timeout i ma -> do + n <- pureS Nothing + ma' <- System.Timeout.timeout (scaleMicros @unit i) <$> runS ma + pure $ ma' >>= maybe n (pure . fmap Just) diff --git a/src/Polytype/Types.hs b/src/Polytype/Types.hs new file mode 100644 index 0000000..02ec087 --- /dev/null +++ b/src/Polytype/Types.hs @@ -0,0 +1,5 @@ +module Polytype.Types ( + module Polytype.Types.Time + ) where + +import Polytype.Types.Time diff --git a/src/Polytype/Types/Time.hs b/src/Polytype/Types/Time.hs new file mode 100644 index 0000000..1534ed8 --- /dev/null +++ b/src/Polytype/Types/Time.hs @@ -0,0 +1,43 @@ +{-| +Description : Time unit types +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Polytype.Types.Time ( + MicroSeconds + , MilliSeconds + , Seconds + , Minutes + , Hours + , Days + , ToMicros(..) + ) where + +data MicroSeconds +data MilliSeconds +data Seconds +data Minutes +data Hours +data Days + +class ToMicros a where + scaleMicros :: (Int -> Int) + +instance ToMicros MicroSeconds where + scaleMicros = (*1) + +instance ToMicros MilliSeconds where + scaleMicros = (*1_000) + +instance ToMicros Seconds where + scaleMicros = (*1_000_000) + +instance ToMicros Minutes where + scaleMicros = (*(1_000_000 * 60)) + +instance ToMicros Hours where + scaleMicros = (*(1_000_000 * 60 * 60)) + +instance ToMicros Days where + scaleMicros = (*(1_000_000 * 60 * 60 * 7)) diff --git a/src/Polytype/Util.hs b/src/Polytype/Util.hs new file mode 100644 index 0000000..58b3581 --- /dev/null +++ b/src/Polytype/Util.hs @@ -0,0 +1,53 @@ +{-| +Description : Polytype utilities +-} + +module Polytype.Util where + +import Polysemy +import Polysemy.Output + +import Polytype.Teletype + +import qualified Control.Monad + +-- | Map monadic `Sem` function over `Output` turning it into another output. +mapMOutput :: forall o1 o2 r a . () + => (o1 -> Sem r o2) + -> Sem (Output o1 ': r) a + -> Sem (Output o2 ': r) a +mapMOutput f = reinterpret \case + Output o -> raise (f o) >>= output + +-- | Repeat monadic action N times returning results as a list. +repeats :: (Monad m) => Integer -> (m b) -> m [b] +repeats n a = Control.Monad.forM [0..n] (pure a) + +-- | Repeat monadic action N times returning discarding results. +repeats_ :: (Monad m) => Integer -> (m b) -> m () +repeats_ n a = Control.Monad.forM_ [0..n] (pure a) + +-- | Read multiple messages from `Teletype`. +readMany :: Int -> Sem (Teletype stringy ': r) [stringy] +readMany x = mapM (pure readTTY) [0..x] + +-- | Write multiple messages to `Teletype`. +writeMany :: Member (Teletype stringy) r => [stringy] -> Sem r () +writeMany xs = mapM_ writeTTY xs + +-- | Retry an action until it succeeds. +retry :: Monad m => m (Maybe b) -> m b +retry a = do + r <- a + case r of + Nothing -> retry a + Just v -> return v + +-- | Retry an action until it succeeds or we run out of attempts. +retryCount :: Monad m => Int -> m (Maybe b) -> m (Maybe b) +retryCount 0 _ = return Nothing +retryCount c a = do + r <- a + case r of + Nothing -> retryCount (c - 1) a + v -> return v diff --git a/test/PtySpec.hs b/test/PtySpec.hs new file mode 100644 index 0000000..445f8e5 --- /dev/null +++ b/test/PtySpec.hs @@ -0,0 +1,17 @@ +module PtySpec where + +import Data.ByteString (ByteString) + +import SpecHelper + +spec :: Spec +spec = return () + +-- not implemented yet as it requires some program to interact with + +test :: IO (ByteString, ByteString, ByteString) +test = + runM + . runInputConst @PtyOpts def + . runPtyOpts + $ (,,) <$> readTTY <*> readTTY <*> readTTY diff --git a/test/SerialSpec.hs b/test/SerialSpec.hs new file mode 100644 index 0000000..c799062 --- /dev/null +++ b/test/SerialSpec.hs @@ -0,0 +1,10 @@ +module SerialSpec where + +import SpecHelper + +spec :: Spec +spec = return () + +-- not implemented yet, requires e.g. socat loop of two ttys + +--test_serial = runM . runResource . res "/dev/tty33" defaultSettings $ readTTY diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs new file mode 100644 index 0000000..51b0c3a --- /dev/null +++ b/test/SpecHelper.hs @@ -0,0 +1,16 @@ +module SpecHelper + ( module Control.Monad + , module Test.Hspec + , module Polytype + , ByteString + , Text + , def + ) where + +import Control.Monad +import Test.Hspec +import Polytype +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Default +import Data.Attoparsec.Text diff --git a/test/StdStreamsSpec.hs b/test/StdStreamsSpec.hs new file mode 100644 index 0000000..ed4045e --- /dev/null +++ b/test/StdStreamsSpec.hs @@ -0,0 +1,15 @@ +module StdStreamsSpec where + +import SpecHelper + +spec :: Spec +spec = return () + +testIdentity :: Sem (Teletype stringy : r) a + -> Sem (Teletype stringy : r) a +testIdentity x = + stdStreamsAsTeletype + . teletypeAsStdStreams + $ x + + diff --git a/test/TeletypeSpec.hs b/test/TeletypeSpec.hs new file mode 100644 index 0000000..f5823a3 --- /dev/null +++ b/test/TeletypeSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module TeletypeSpec where + +import SpecHelper +import qualified Data.Attoparsec.Text +import qualified Data.Text + +spec :: Spec +spec = do + it "runs purely" $ do + flip shouldBe (["hello", "world"], ()) + $ run + . runTeletypePure [] + $ writeTTY "hello" >> writeTTY "world" + + it "runs purely buffered by lines" $ do + flip shouldBe ["ab 1", "123", "cd 2", "", "", "", "", "", "", "", ""] + $ snd . snd + . run + . runState [] + . runTeletypePure ["ab 1\n123", "cd 2"] + . bufferBy lines + $ flip mapM [0..10] $ \x -> readTTY + + it "runs purely buffered by words and lines" $ do + flip shouldBe ["ab", "1", "123", "cd", "2", "", "", "", "", "", ""] + $ snd . snd + . run + . runState [] + . runTeletypePure ["ab 1\n123", "cd 2"] + . bufferBy (concatMap words . lines) + $ flip mapM [0..10] $ \x -> readTTY + + it "runs purely with parser" $ do + flip shouldBe (["a"], Right ["test"]) + $ run + . runTeletypePure ["te", "st"] + . runError @String + . teletypeParseWith + Data.Attoparsec.Text.parse + (Data.Attoparsec.Text.many1 $ Data.Attoparsec.Text.string "test") + Data.Text.concat + $ writeTTY ["a"] >> readTTY + + it "runs purely with parser failure" $ do + flip shouldBe ([], Left "not enough input") + $ run + . runTeletypePure ["te", ""] + . runError @String + . teletypeParseWith + Data.Attoparsec.Text.parse + (Data.Attoparsec.Text.many1 $ Data.Attoparsec.Text.string "test") + Data.Text.concat + $ readTTY