feat(users/Profpatsch/my-tools): init

It’s kitchen-sink time!

Change-Id: Ieb4f9e642920c3e0619475095e19005bcaf558bc
Reviewed-on: https://cl.tvl.fyi/c/depot/+/13265
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI

users/Profpatsch/cabal.project

@@ -11,3 +11,4 @@ packages:
   ./openlab-tools/openlab-tools.cabal
   ./httzip/httzip.cabal
   ./my-xmonad/my-xmonad.cabal
+  ./my-tools/my-tools.cabal

users/Profpatsch/hie.yaml

@@ -30,3 +30,7 @@ cradle:
       component: "httzip:exe:httzip"
     - path: "./my-xmonad/Xmonad.hs"
       component: "my-xmonad:exe:xmonad"
+    - path: "./my-tools/src"
+      component: "lib:my-tools"
+    - path: "./my-tools/exe/Copy.hs"
+      component: "my-tools:exe:copy"

users/Profpatsch/my-prelude/default.nix

@@ -15,6 +15,7 @@ pkgs.haskellPackages.mkDerivation {
     ./src/Json/Enc.hs
     ./src/Arg.hs
     ./src/AtLeast.hs
+    ./src/MyLabel.hs
     ./src/MyPrelude.hs
     ./src/Test.hs
     ./src/Parse.hs

users/Profpatsch/my-prelude/my-prelude.cabal

@@ -67,6 +67,7 @@ library
       Divisive
       Json
       Json.Enc
+      MyLabel
       Test
       Postgres.Decoder
       Postgres.MonadPostgres

users/Profpatsch/my-prelude/src/MyPrelude.hs

@@ -89,6 +89,7 @@ module MyPrelude
     Proxy (Proxy),
     Map,
     annotate,
+    hush,
     Validation (Success, Failure),
     failure,
     successes,
@@ -488,6 +489,12 @@ annotate err = \case
   Nothing -> Left err
   Just a -> Right a
 
+-- | Turn Either into Maybe, ignoring the error.
+hush :: Either e a -> Maybe a
+hush = \case
+  Left _ -> Nothing
+  Right a -> Just a
+
 -- | Map the same function over both sides of a Bifunctor (e.g. a tuple).
 both :: (Bifunctor bi) => (a -> b) -> bi a a -> bi b b
 both f = bimap f f

users/Profpatsch/my-tools/default.nix

@@ -0,0 +1,48 @@
+{ depot, pkgs, lib, ... }:
+
+let
+  exes = [ "copy" ];
+
+  drv = pkgs.haskellPackages.mkDerivation {
+    pname = "my-tools";
+    version = "0.0.1-unreleased";
+
+    src = depot.users.Profpatsch.exactSource ./. [
+      ./my-tools.cabal
+      ./src/MyTools.hs
+      ./exe/Copy.hs
+    ];
+
+    isLibrary = false;
+
+    libraryHaskellDepends = [
+      depot.users.Profpatsch.my-prelude
+      pkgs.haskellPackages.optparse-simple
+    ];
+
+    # I copied this from `__generateOptparseApplicativeCompletion` because I can’t be bothered
+    # to figure out how the haskellPackages override callPackage bs really works.
+    postInstall = lib.concatMapStringsSep "\n"
+      (exeName: ''
+        bashCompDir="''${!outputBin}/share/bash-completion/completions"
+        zshCompDir="''${!outputBin}/share/zsh/vendor-completions"
+        fishCompDir="''${!outputBin}/share/fish/vendor_completions.d"
+        mkdir -p "$bashCompDir" "$zshCompDir" "$fishCompDir"
+        "''${!outputBin}/bin/${exeName}" --bash-completion-script "''${!outputBin}/bin/${exeName}" >"$bashCompDir/${exeName}"
+        "''${!outputBin}/bin/${exeName}" --zsh-completion-script "''${!outputBin}/bin/${exeName}" >"$zshCompDir/_${exeName}"
+        "''${!outputBin}/bin/${exeName}" --fish-completion-script "''${!outputBin}/bin/${exeName}" >"$fishCompDir/${exeName}.fish"
+
+        # Sanity check
+        grep -F ${exeName} <$bashCompDir/${exeName} >/dev/null || {
+          echo 'Could not find ${exeName} in completion script.'
+          exit 1
+        }
+      '')
+      exes;
+
+    license = lib.licenses.mit;
+
+  };
+
+in
+drv

users/Profpatsch/my-tools/exe/Copy.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import MyTools
+
+main :: IO ()
+main = copyMain

users/Profpatsch/my-tools/my-tools.cabal

@@ -0,0 +1,85 @@
+cabal-version:      3.0
+name:               my-tools
+version:            0.0.1.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
+
+    -- Make #labels available
+    OverloadedLabels
+
+    -- does not export record fields as functions, use OverloadedRecordDot to access instead
+    NoFieldSelectors
+
+    -- Allow the same record field name to be declared twice per module.
+    -- This works, because we use `OverloadedRecordDot` everywhere (enforced by `NoFieldSelectors`).
+    DuplicateRecordFields
+
+    -- Record punning
+    RecordWildCards
+
+    -- Improved Deriving
+    DerivingStrategies
+    DerivingVia
+
+    -- Type-level strings
+    DataKinds
+
+    -- to enable the `type` keyword in import lists (ormolu uses this automatically)
+    ExplicitNamespaces
+
+    -- allows defining pattern synonyms, but also the `import Foo (pattern FooPattern)` import syntax
+    PatternSynonyms
+  default-language: GHC2021
+
+
+library
+    import: common-options
+    hs-source-dirs: src
+    exposed-modules:
+      MyTools
+
+    build-depends:
+       base >=4.15 && <5
+     , my-prelude
+     , filepath
+     , directory
+     , process
+     , optparse-simple
+     , optparse-applicative
+
+
+executable copy
+    import: common-options
+    hs-source-dirs: exe
+    build-depends:
+      base,
+      my-tools
+    main-is: Copy.hs

users/Profpatsch/my-tools/src/MyTools.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module MyTools where
+
+import Control.Exception (IOException)
+import Control.Exception.Base (try)
+import Data.List qualified as List
+import MyLabel
+import MyPrelude
+import Options.Applicative.Builder.Completer (requote)
+import Options.Applicative.Simple (simpleOptions)
+import Options.Applicative.Simple qualified as Opts
+import Options.Applicative.Types qualified as Opts.Types
+import System.Directory qualified as Dir
+import System.Environment qualified
+import System.FilePath.Posix ((</>))
+import System.FilePath.Posix qualified as File
+import System.Process qualified as Proc
+
+copyMain :: IO ()
+copyMain = do
+  ((), run) <-
+    simpleOptions
+      "latest"
+      "copy"
+      "Various ways of copying files"
+      (Opts.flag () () (Opts.long "some-flag"))
+      ( do
+          Opts.addCommand
+            "template"
+            "Use the given file as a template and create new file with the given name in the same directory"
+            copyAsTemplate
+            ( do
+                Opts.strArgument (Opts.metavar "FILE" <> Opts.completer completeFile)
+                  -- TODO: this is a hack to be able to use the file in the next argument (it leads to the argument not being in the usage message)
+                  & thenParser
+                    ( \file -> do
+                        name <-
+                          Opts.strArgument
+                            ( Opts.metavar "NAME"
+                                <> Opts.completer
+                                  ( Opts.listCompleter
+                                      [ File.takeFileName file,
+                                        File.takeFileName file <> ".bak",
+                                        File.takeFileName file <> "_copy"
+                                      ]
+                                  )
+                            )
+                        pure (t2 #file file #name name)
+                    )
+            )
+      )
+  run
+
+completeFile :: Opts.Completer
+completeFile = Opts.mkCompleter $ \word -> do
+  isFish <- System.Environment.getEnv "SHELL" <&> ("fish" `List.isInfixOf`)
+
+  if isFish
+    then do
+      let cmd =
+            unwords
+              [ "complete",
+                "-C",
+                -- loool (via the impl of __fish_complete_path), probably extremely buggy
+                "\"'' " <> requote word <> "\""
+              ]
+      Proc.readProcess "fish" ["--private", "--no-config", "-c", cmd] "" <&> lines & try @IOException <&> hush <&> fromMaybe []
+    else do
+      let cmd = unwords ["compgen", "-A", "file", "--", requote word]
+      Proc.readProcess "bash" ["-c", cmd] "" <&> lines & try @IOException <&> hush <&> fromMaybe []
+
+thenParser :: (a -> Opts.Parser b) -> Opts.Parser a -> Opts.Parser b
+thenParser f a = Opts.Types.BindP a f
+
+assertMsg :: Bool -> Text -> IO ()
+assertMsg b msg = unless b $ exitWithMessage msg
+
+copyAsTemplate :: (HasField "file" r FilePath, HasField "name" r FilePath) => r -> IO ()
+copyAsTemplate opts = do
+  canon <- Dir.canonicalizePath opts.file
+  isFile <- Dir.doesFileExist canon
+  assertMsg isFile $ [fmt|File does not exist or is a directory: {canon}|]
+  let dir = File.takeDirectory canon
+  let finalPath = dir </> opts.name
+  targetExists <- Dir.doesFileExist finalPath
+  assertMsg (not targetExists) $ [fmt|Target file already exists: {finalPath}|]
+  Dir.copyFile canon finalPath

users/Profpatsch/shell.nix

@@ -24,6 +24,7 @@ pkgs.mkShell {
       h.pa-pretty
       h.pa-run-command
       h.ihp-hsx
+      h.optparse-simple
       h.PyF
       h.foldl
       h.unliftio

users/Profpatsch/whatcd-resolver/default.nix

@@ -13,7 +13,6 @@ let
       ./src/WhatcdResolver.hs
       ./src/AppT.hs
       ./src/Bencode.hs
-      ./src/MyLabel.hs
       ./src/JsonLd.hs
       ./src/Optional.hs
       ./src/Html.hs

users/Profpatsch/whatcd-resolver/src/Http.hs

@@ -184,10 +184,6 @@ httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do
             )
         Right a -> pure a
 
-hush :: Either e a -> Maybe a
-hush (Right a) = Just a
-hush _ = Nothing
-
 doRequestJson ::
   (MonadOtel m) =>
   RequestOptions ->

users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal

@@ -71,7 +71,6 @@ library
        Bencode
        JsonLd
        Optional
-       MyLabel
        Http
        Html
        Transmission