about summary refs log tree commit diff
path: root/users/Profpatsch
diff options
context:
space:
mode:
authorProfpatsch <mail@profpatsch.de>2023-08-06T10·46+0200
committerclbot <clbot@tvl.fyi>2023-08-06T11·17+0000
commit1fd59f51580244bac8e75b4c08f103daa20674d9 (patch)
tree701df9da2d8ff52f7c881e221b416472b0988be3 /users/Profpatsch
parentce4acc08a53fca8bc00282ca0eb4ca5fc048a222 (diff)
chore(users/Profpatsch): clean up haskell libs a little r/6464
Change-Id: Ia9a6c5a754ca8f2912308feb5a26f5276a08d24c
Reviewed-on: https://cl.tvl.fyi/c/depot/+/9011
Reviewed-by: Profpatsch <mail@profpatsch.de>
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
Diffstat (limited to 'users/Profpatsch')
-rw-r--r--users/Profpatsch/cabal.project2
-rw-r--r--users/Profpatsch/hie.yaml8
-rw-r--r--users/Profpatsch/jbovlaste-sqlite/default.nix2
-rw-r--r--users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal3
-rw-r--r--users/Profpatsch/mailbox-org/MailboxOrg.hs85
-rw-r--r--users/Profpatsch/mailbox-org/default.nix2
-rw-r--r--users/Profpatsch/mailbox-org/mailbox-org.cabal81
-rw-r--r--users/Profpatsch/mailbox-org/src/AesonQQ.hs (renamed from users/Profpatsch/mailbox-org/AesonQQ.hs)7
-rw-r--r--users/Profpatsch/my-prelude/default.nix9
-rw-r--r--users/Profpatsch/my-prelude/my-prelude.cabal7
-rw-r--r--users/Profpatsch/my-prelude/src/Pretty.hs91
-rw-r--r--users/Profpatsch/my-prelude/src/RunCommand.hs162
12 files changed, 123 insertions, 336 deletions
diff --git a/users/Profpatsch/cabal.project b/users/Profpatsch/cabal.project
index d05768a008..ed34b2f282 100644
--- a/users/Profpatsch/cabal.project
+++ b/users/Profpatsch/cabal.project
@@ -4,7 +4,9 @@ packages:
   ./arglib/arglib-netencode.cabal
   ./execline/exec-helpers.cabal
   ./htmx-experiment/htmx-experiment.cabal
+  ./mailbox-org/mailbox-org.cabal
   ./cas-serve/cas-serve.cabal
   ./jbovlaste-sqlite/jbovlaste-sqlite.cabal
   ./whatcd-resolver/whatcd-resolver.cabal
+  ./ircmail/ircmail.cabal
   ./httzip/httzip.cabal
diff --git a/users/Profpatsch/hie.yaml b/users/Profpatsch/hie.yaml
index e22a383216..308fa8fe91 100644
--- a/users/Profpatsch/hie.yaml
+++ b/users/Profpatsch/hie.yaml
@@ -10,15 +10,19 @@ cradle:
       component: "lib:exec-helpers"
     - path: "./htmx-experiment/src"
       component: "lib:htmx-experiment"
-    - path: "./htmx-experiment/src"
-      component: "lib:htmx-experiment"
     - path: "./htmx-experiment/Main.hs"
       component: "htmx-experiment:exe:htmx-experiment"
+    - path: "./mailbox-org/src"
+      component: "lib:mailbox-org"
+    - path: "./mailbox-org/MailboxOrg.hs"
+      component: "mailbox-org:exe:mailbox-org"
     - path: "./cas-serve/CasServe.hs"
       component: "cas-serve:exe:cas-serve"
     - path: "./jbovlaste-sqlite/JbovlasteSqlite.hs"
       component: "jbovlaste-sqlite:exe:jbovlaste-sqlite"
     - path: "./whatcd-resolver/src"
       component: "lib:whatcd-resolver"
+    - path: "./ircmail/src"
+      component: "lib:ircmail"
     - path: "./httzip/Httzip.hs"
       component: "httzip:exe:httzip"
diff --git a/users/Profpatsch/jbovlaste-sqlite/default.nix b/users/Profpatsch/jbovlaste-sqlite/default.nix
index b72143c96d..f04b4ad0b3 100644
--- a/users/Profpatsch/jbovlaste-sqlite/default.nix
+++ b/users/Profpatsch/jbovlaste-sqlite/default.nix
@@ -20,8 +20,6 @@ let
       pkgs.haskellPackages.foldl
       pkgs.haskellPackages.sqlite-simple
       pkgs.haskellPackages.xml-conduit
-      depot.users.Profpatsch.arglib.netencode.haskell
-      depot.users.Profpatsch.netencode.netencode-hs
 
     ];
 
diff --git a/users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal b/users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal
index 4c9707feee..40da320f08 100644
--- a/users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal
+++ b/users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal
@@ -62,7 +62,6 @@ executable jbovlaste-sqlite
         pa-label,
         pa-error-tree,
         pa-field-parser,
-        my-prelude,
         containers,
         selective,
         semigroupoids,
@@ -71,8 +70,6 @@ executable jbovlaste-sqlite
         foldl,
         conduit,
         bytestring,
-        arglib-netencode,
-        netencode,
         text,
         sqlite-simple,
         xml-conduit,
diff --git a/users/Profpatsch/mailbox-org/MailboxOrg.hs b/users/Profpatsch/mailbox-org/MailboxOrg.hs
index c66db49c13..6c5820080c 100644
--- a/users/Profpatsch/mailbox-org/MailboxOrg.hs
+++ b/users/Profpatsch/mailbox-org/MailboxOrg.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GHC2021 #-}
 {-# LANGUAGE LambdaCase #-}
@@ -31,7 +30,6 @@ import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Text qualified as Text
 import ExecHelpers
-import GHC.Records (HasField (..))
 import Label
 import Netencode qualified
 import Netencode.Parse qualified as NetParse
@@ -117,9 +115,7 @@ listFilterConfig session = do
     >>= printPretty
 
 applyFilterRule ::
-  ( HasField "folderId" dat Text,
-    HasField "rulename" dat Text
-  ) =>
+  (HasField "folderId" dat Text) =>
   dat ->
   Session ->
   IO ()
@@ -209,48 +205,47 @@ applyFilters session = do
             <&> mapFromListOn (\dat -> getLabel @"rulename" dat.parsed)
       )
       ([] :: [()])
-  let goal = Map.fromList [(label @"rulename" "another", 32), (label @"rulename" "xyz", 23)]
+  let goal = Map.fromList [(label @"rulename" "another", 32 :: Integer), (label @"rulename" "xyz", 23)]
   let actions = declarativeUpdate goal filters
   log [fmt|To * create: {actions.toCreate & Map.keys & show}, * update: {actions.toUpdate & Map.keys & show}, * delete: {actions.toDelete & Map.keys & show}|]
-  where
-    -- filters
-    --   & Map.elems
-    --   & traverse_
-    --     ( updateIfDifferent
-    --         session
-    --         ( \el ->
-    --             pure $
-    --               el.original.mailfilter
-    --                 & KeyMap.insert "active" (Json.Bool False)
-    --         )
-    --         (pure ())
-    --     )
-
-    mapFromListOn :: Ord k => (a -> k) -> [a] -> Map k a
-    mapFromListOn on xs = xs <&> (\x -> (on x, x)) & Map.fromList
-    updateIfDifferent ::
-      forall label parsed.
-      ( HasField "id_" parsed Json.Value,
-        HasField "rulename" parsed Text
-      ) =>
-      Session ->
-      (Dat label Json.Object parsed -> IO Json.Object) ->
-      Json.Parse Error () ->
-      Dat label Json.Object parsed ->
-      IO ()
-    updateIfDifferent session switcheroo parser dat = do
-      new <- switcheroo dat
-      if new /= getField @label dat.original
-        then do
-          log [fmt|Updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value})|]
-          mailfilter
-            session
-            "update"
-            mempty
-            parser
-            new
-        else do
-          log [fmt|Skipping updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value}) because nothing changed.|]
+
+-- where
+-- filters
+--   & Map.elems
+--   & traverse_
+--     ( updateIfDifferent
+--         session
+--         ( \el ->
+--             pure $
+--               el.original.mailfilter
+--                 & KeyMap.insert "active" (Json.Bool False)
+--         )
+--         (pure ())
+--     )
+
+-- updateIfDifferent ::
+--   forall label parsed.
+--   ( HasField "id_" parsed Json.Value,
+--     HasField "rulename" parsed Text
+--   ) =>
+--   Session ->
+--   (Dat label Json.Object parsed -> IO Json.Object) ->
+--   Json.Parse Error () ->
+--   Dat label Json.Object parsed ->
+--   IO ()
+-- updateIfDifferent session switcheroo parser dat = do
+--   new <- switcheroo dat
+--   if new /= getField @label dat.original
+--     then do
+--       log [fmt|Updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value})|]
+--       mailfilter
+--         session
+--         "update"
+--         mempty
+--         parser
+--         new
+--     else do
+--       log [fmt|Skipping updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value}) because nothing changed.|]
 
 -- | https://oxpedia.org/wiki/index.php?title=HTTP_API_MailFilter
 mailfilter ::
diff --git a/users/Profpatsch/mailbox-org/default.nix b/users/Profpatsch/mailbox-org/default.nix
index 2cb4c7af8e..73bd28292d 100644
--- a/users/Profpatsch/mailbox-org/default.nix
+++ b/users/Profpatsch/mailbox-org/default.nix
@@ -7,7 +7,7 @@ let
 
     src = depot.users.Profpatsch.exactSource ./. [
       ./mailbox-org.cabal
-      ./AesonQQ.hs
+      ./src/AesonQQ.hs
       ./MailboxOrg.hs
     ];
 
diff --git a/users/Profpatsch/mailbox-org/mailbox-org.cabal b/users/Profpatsch/mailbox-org/mailbox-org.cabal
index 8125baef71..8e5328907a 100644
--- a/users/Profpatsch/mailbox-org/mailbox-org.cabal
+++ b/users/Profpatsch/mailbox-org/mailbox-org.cabal
@@ -4,38 +4,93 @@ version:            0.1.0.0
 author:             Profpatsch
 maintainer:         mail@profpatsch.de
 
+
+common common-options
+  ghc-options:
+      -Wall
+      -Wno-type-defaults
+      -Wunused-packages
+      -Wredundant-constraints
+      -fwarn-missing-deriving-strategies
+
+  -- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html
+  -- for a description of all these extensions
+  default-extensions:
+      -- Infer Applicative instead of Monad where possible
+    ApplicativeDo
+
+    -- Allow literal strings to be Text
+    OverloadedStrings
+
+    -- Syntactic sugar improvements
+    LambdaCase
+    MultiWayIf
+
+    -- Makes the (deprecated) usage of * instead of Data.Kind.Type an error
+    NoStarIsType
+
+    -- Convenient and crucial to deal with ambiguous field names, commonly
+    -- known as RecordDotSyntax
+    OverloadedRecordDot
+
+    -- does not export record fields as functions, use OverloadedRecordDot to access instead
+    NoFieldSelectors
+
+    -- Record punning
+    RecordWildCards
+
+    -- Improved Deriving
+    DerivingStrategies
+    DerivingVia
+
+    -- Type-level strings
+    DataKinds
+
+    -- to enable the `type` keyword in import lists (ormolu uses this automatically)
+    ExplicitNamespaces
+
+  default-language: GHC2021
+
+
+library
+    import: common-options
+
+    hs-source-dirs: src
+
+    exposed-modules:
+        AesonQQ
+
+    build-depends:
+        base >=4.15 && <5,
+        pa-prelude,
+        aeson,
+        PyF,
+        template-haskell
+
+
+
 executable mailbox-org
+    import: common-options
     main-is: MailboxOrg.hs
 
     build-depends:
         base >=4.15 && <5,
+        mailbox-org,
         my-prelude,
         pa-prelude,
         pa-label,
+        pa-pretty,
         pa-error-tree,
         exec-helpers,
         netencode,
         text,
-        semigroupoids,
-        nonempty-containers,
-        data-fix,
-        selective,
         directory,
-        mtl,
         filepath,
         arglib-netencode,
         random,
         http-conduit,
-        http-client,
         aeson,
         aeson-better-errors,
         bytestring,
-        PyF,
         typed-process,
-        process,
         containers,
-
-    default-language: Haskell2010
-
-    default-extensions:
-        GHC2021
diff --git a/users/Profpatsch/mailbox-org/AesonQQ.hs b/users/Profpatsch/mailbox-org/src/AesonQQ.hs
index f12afdf515..2ac3d533ae 100644
--- a/users/Profpatsch/mailbox-org/AesonQQ.hs
+++ b/users/Profpatsch/mailbox-org/src/AesonQQ.hs
@@ -3,20 +3,21 @@
 module AesonQQ where
 
 import Data.Aeson qualified as Json
-import Data.Either qualified as Either
+import Language.Haskell.TH.Quote (QuasiQuoter)
 import PossehlAnalyticsPrelude
 import PyF qualified
 import PyF.Internal.QQ qualified as PyFConf
 
+aesonQQ :: QuasiQuoter
 aesonQQ =
   PyF.mkFormatter
     "aesonQQ"
     PyF.defaultConfig
       { PyFConf.delimiters = Just ('|', '|'),
-        PyFConf.postProcess = \exp -> do
+        PyFConf.postProcess = \exp_ -> do
           -- TODO: this does not throw an error at compilation time if the json does not parse
           [|
-            case Json.eitherDecodeStrict' @Json.Value $ textToBytesUtf8 $ stringToText $(exp) of
+            case Json.eitherDecodeStrict' @Json.Value $ textToBytesUtf8 $ stringToText $(exp_) of
               Left err -> error err
               Right a -> a
             |]
diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix
index c046c213bd..1c75379d70 100644
--- a/users/Profpatsch/my-prelude/default.nix
+++ b/users/Profpatsch/my-prelude/default.nix
@@ -8,8 +8,6 @@ pkgs.haskellPackages.mkDerivation {
     ./my-prelude.cabal
     ./src/Aeson.hs
     ./src/MyPrelude.hs
-    ./src/Pretty.hs
-    ./src/RunCommand.hs
     ./src/Test.hs
     ./src/Tool.hs
     ./src/ValidationParseT.hs
@@ -24,25 +22,20 @@ pkgs.haskellPackages.mkDerivation {
     pkgs.haskellPackages.pa-label
     pkgs.haskellPackages.pa-error-tree
     pkgs.haskellPackages.pa-json
+    pkgs.haskellPackages.pa-pretty
     pkgs.haskellPackages.aeson-better-errors
-    pkgs.haskellPackages.ansi-terminal
     pkgs.haskellPackages.error
-    pkgs.haskellPackages.hscolour
     pkgs.haskellPackages.hspec
     pkgs.haskellPackages.hspec-expectations-pretty-diff
     pkgs.haskellPackages.monad-logger
-    pkgs.haskellPackages.nicify-lib
     pkgs.haskellPackages.postgresql-simple
     pkgs.haskellPackages.profunctors
     pkgs.haskellPackages.PyF
     pkgs.haskellPackages.semigroupoids
     pkgs.haskellPackages.these
-    pkgs.haskellPackages.typed-process
     pkgs.haskellPackages.unliftio
     pkgs.haskellPackages.validation-selective
     pkgs.haskellPackages.vector
-
-
   ];
 
   license = lib.licenses.mit;
diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal
index 3a4a06d165..4c732bcaf8 100644
--- a/users/Profpatsch/my-prelude/my-prelude.cabal
+++ b/users/Profpatsch/my-prelude/my-prelude.cabal
@@ -56,9 +56,7 @@ library
     hs-source-dirs: src
     exposed-modules:
       MyPrelude
-      Pretty
       Aeson
-      RunCommand
       Test
       Postgres.Decoder
       Postgres.MonadPostgres
@@ -76,20 +74,18 @@ library
      , pa-label
      , pa-error-tree
      , pa-json
+     , pa-pretty
      , aeson
      , aeson-better-errors
-     , ansi-terminal
      , bytestring
      , containers
      , error
      , exceptions
      , filepath
-     , hscolour
      , hspec
      , hspec-expectations-pretty-diff
      , monad-logger
      , mtl
-     , nicify-lib
      , postgresql-simple
      , profunctors
      , PyF
@@ -97,7 +93,6 @@ library
      , selective
      , text
      , these
-     , typed-process
      , unix
      , unliftio
      , validation-selective
diff --git a/users/Profpatsch/my-prelude/src/Pretty.hs b/users/Profpatsch/my-prelude/src/Pretty.hs
deleted file mode 100644
index 8046c83e45..0000000000
--- a/users/Profpatsch/my-prelude/src/Pretty.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE LambdaCase #-}
-
-module Pretty
-  ( -- * Pretty printing for error messages
-    Err,
-    printPretty,
-    showPretty,
-    -- constructors hidden
-    prettyErrs,
-    message,
-    messageString,
-    pretty,
-    prettyString,
-    hscolour',
-  )
-where
-
-import Data.List qualified as List
-import Data.Text qualified as Text
-import Language.Haskell.HsColour
-  ( Output (TTYg),
-    hscolour,
-  )
-import Language.Haskell.HsColour.ANSI (TerminalType (..))
-import Language.Haskell.HsColour.Colourise
-  ( defaultColourPrefs,
-  )
-import MyPrelude
-import System.Console.ANSI (setSGRCode)
-import System.Console.ANSI.Types
-  ( Color (Red),
-    ColorIntensity (Dull),
-    ConsoleLayer (Foreground),
-    SGR (Reset, SetColor),
-  )
-import Text.Nicify (nicify)
-
--- | Print any 'Show'able type to stderr, formatted nicely and in color. Very helpful for debugging.
-printPretty :: Show a => a -> IO ()
-printPretty a =
-  a & pretty & (: []) & prettyErrs & stringToText & putStderrLn
-
-showPretty :: Show a => a -> Text
-showPretty a = a & pretty & (: []) & prettyErrs & stringToText
-
--- | Display a list of 'Err's as a colored error message
--- and abort the test.
-prettyErrs :: [Err] -> String
-prettyErrs errs = res
-  where
-    res = List.intercalate "\n" $ map one errs
-    one = \case
-      ErrMsg s -> color Red s
-      ErrPrettyString s -> prettyShowString s
-    -- Pretty print a String that was produced by 'show'
-    prettyShowString :: String -> String
-    prettyShowString = hscolour' . nicify
-
--- | Small DSL for pretty-printing errors
-data Err
-  = -- | Message to display in the error
-    ErrMsg String
-  | -- | Pretty print a String that was produced by 'show'
-    ErrPrettyString String
-
--- | Plain message to display, as 'Text'
-message :: Text -> Err
-message = ErrMsg . Text.unpack
-
--- | Plain message to display, as 'String'
-messageString :: String -> Err
-messageString = ErrMsg
-
--- | Any 'Show'able to pretty print
-pretty :: Show a => a -> Err
-pretty x = ErrPrettyString $ show x
-
--- | Pretty print a String that was produced by 'show'
-prettyString :: String -> Err
-prettyString s = ErrPrettyString s
-
--- Prettifying Helpers, mostly stolen from
--- https://hackage.haskell.org/package/hspec-expectations-pretty-diff-0.7.2.5/docs/src/Test.Hspec.Expectations.Pretty.html#prettyColor
-
-hscolour' :: String -> String
-hscolour' =
-  hscolour (TTYg Ansi16Colour) defaultColourPrefs False False "" False
-
-color :: Color -> String -> String
-color c s = setSGRCode [SetColor Foreground Dull c] ++ s ++ setSGRCode [Reset]
diff --git a/users/Profpatsch/my-prelude/src/RunCommand.hs b/users/Profpatsch/my-prelude/src/RunCommand.hs
deleted file mode 100644
index 5c80eb3aac..0000000000
--- a/users/Profpatsch/my-prelude/src/RunCommand.hs
+++ /dev/null
@@ -1,162 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module RunCommand where
-
-import Data.ByteString qualified as ByteString
-import Data.ByteString.Lazy qualified as Bytes.Lazy
-import Data.Char qualified as Char
-import Data.List qualified as List
-import Data.Text qualified as Text
-import MyPrelude
-import System.Exit qualified as Exit
-import System.IO (Handle)
-import System.Process.Typed qualified as Process
-import Prelude hiding (log)
-
--- | Given a a command, the executable and arguments,
--- spawn the tool as subprocess and collect its stdout (stderr will go to our stderr).
-
--- Will strip the stdout of trailing newlines.
---
--- If the executable is not a path, it will be resolved via the @PATH@ environment variable.
-runCommand :: MonadIO m => FilePath -> [Text] -> m (Exit.ExitCode, ByteString)
-runCommand executable args = do
-  let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
-  log [fmt|Running: $ {bashArgs}|]
-  Process.proc
-    executable
-    (args <&> textToString)
-    & Process.readProcessStdout
-    <&> second toStrictBytes
-    <&> second stripWhitespaceFromEnd
-
--- | Given a a command, the executable and arguments,
--- spawn the tool as subprocess and run it to conclusion.
---
--- If the executable is not a path, it will be resolved via the @PATH@ environment variable.
-runCommandNoStdout :: MonadIO m => FilePath -> [Text] -> m Exit.ExitCode
-runCommandNoStdout executable args = do
-  let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
-  log [fmt|Running: $ {bashArgs}|]
-  Process.proc
-    executable
-    (args <&> textToString)
-    & Process.runProcess
-
--- TODO: This is reversing the whole string *twice*. Can we strip from end without doing that?
-stripWhitespaceFromEnd :: ByteString -> ByteString
-stripWhitespaceFromEnd = ByteString.reverse . ByteString.dropWhile (\w -> w == charToWordUnsafe '\n') . ByteString.reverse
-
--- | Like `runCommand`, but takes a Bytestring that provides the command with streamed input on stdin.
-runCommandWithStdin :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m (Exit.ExitCode, ByteString)
-runCommandWithStdin executable args stdin = do
-  let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
-  log [fmt|Running: $ {bashArgs}|]
-  Process.proc
-    executable
-    (args <&> textToString)
-    & Process.setStdin (Process.byteStringInput stdin)
-    & Process.readProcessStdout
-    <&> second toStrictBytes
-    <&> second stripWhitespaceFromEnd
-
--- | Like `runCommand`, but takes a Bytestring that provides the command with streamed input on stdin.
-runCommandWithStdinNoStdout :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m Exit.ExitCode
-runCommandWithStdinNoStdout executable args stdin = do
-  let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
-  log [fmt|Running: $ {bashArgs}|]
-  Process.proc
-    executable
-    (args <&> textToString)
-    & Process.setStdin (Process.byteStringInput stdin)
-    & Process.runProcess
-
--- | Like 'runCommandWithStdin' but exit if the command returns a non-0 status.
-runCommandWithStdinExpect0 :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m ByteString
-runCommandWithStdinExpect0 executable args stdin =
-  runCommandWithStdin executable args stdin >>= \case
-    (ex, stdout) -> do
-      checkStatus0 executable ex
-      pure stdout
-
--- | Like 'runCommandWithStdinNoStdout' but exit if the command returns a non-0 status.
-runCommandWithStdinNoStdoutExpect0 :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m ()
-runCommandWithStdinNoStdoutExpect0 executable args stdin =
-  runCommandWithStdinNoStdout executable args stdin
-    >>= checkStatus0 executable
-
--- | Like 'runCommandExpect0', but don’t capture stdout,
--- connect stdin and stdout to the command until it returns.
---
--- This is for interactive subcommands.
-runCommandInteractiveExpect0 :: MonadIO m => FilePath -> [Text] -> m ()
-runCommandInteractiveExpect0 executable args = do
-  let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
-  log [fmt|Running interactively: $ {bashArgs}|]
-  ( liftIO $
-      Process.runProcess $
-        Process.proc
-          executable
-          (args <&> textToString)
-    )
-    >>= checkStatus0 executable
-
--- | Given a name of a command, the executable and arguments,
--- spawn the tool as subprocess and pipe its stdout to the given 'Handle'.
---
--- If the executable is not a path, it will be resolved via the @PATH@ environment variable.
-runCommandPipeToHandle :: MonadIO m => FilePath -> [Text] -> Handle -> m Exit.ExitCode
-runCommandPipeToHandle executable args handle = do
-  -- TODO log the output file?
-  let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
-  log [fmt|Running: $ {bashArgs}|]
-  liftIO $
-    Process.runProcess
-      ( Process.proc
-          executable
-          (args <&> textToString)
-          & Process.setStdout (Process.useHandleClose handle)
-      )
-
--- | Check whether a command exited 0 or crash.
-checkStatus0 :: MonadIO m => FilePath -> Exit.ExitCode -> m ()
-checkStatus0 executable = \case
-  Exit.ExitSuccess -> pure ()
-  Exit.ExitFailure status -> do
-    logCritical [fmt|Command `{executable}` did not exit with status 0 (success), but status {status}|]
-
-log :: MonadIO m => Text -> m ()
-log = liftIO . putStderrLn
-
--- | Log the message on the normal logging level & exit the program
-logCritical :: MonadIO m => Text -> m b
-logCritical msg = do
-  liftIO $ putStderrLn msg
-  liftIO $ Exit.exitWith (Exit.ExitFailure 1)
-
--- | Pretty print a command line in a way that can be copied to bash.
-prettyArgsForBash :: [Text] -> Text
-prettyArgsForBash = Text.intercalate " " . map simpleBashEscape
-
--- | Simple escaping for bash words. If they contain anything that’s not ascii chars
--- and a bunch of often-used special characters, put the word in single quotes.
-simpleBashEscape :: Text -> Text
-simpleBashEscape t = do
-  case Text.find (not . isSimple) t of
-    Just _ -> escapeSingleQuote t
-    Nothing -> t
-  where
-    -- any word that is just ascii characters is simple (no spaces or control characters)
-    -- or contains a few often-used characters like - or .
-    isSimple c =
-      Char.isAsciiLower c
-        || Char.isAsciiUpper c
-        || Char.isDigit c
-        -- These are benign, bash will not interpret them as special characters.
-        || List.elem c ['-', '.', ':', '/']
-    -- Put the word in single quotes
-    -- If there is a single quote in the word,
-    -- close the single quoted word, add a single quote, open the word again
-    escapeSingleQuote t' = "'" <> Text.replace "'" "'\\''" t' <> "'"