diff --git a/users/Profpatsch/cabal.project b/users/Profpatsch/cabal.project index aa8df174a..6a788883b 100644 --- a/users/Profpatsch/cabal.project +++ b/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 diff --git a/users/Profpatsch/hie.yaml b/users/Profpatsch/hie.yaml index 3b67e11b9..879c31dea 100644 --- a/users/Profpatsch/hie.yaml +++ b/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" diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 7755943c4..a29dce8fb 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/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 diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index b4dd64668..04d60ed42 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -67,6 +67,7 @@ library Divisive Json Json.Enc + MyLabel Test Postgres.Decoder Postgres.MonadPostgres diff --git a/users/Profpatsch/whatcd-resolver/src/MyLabel.hs b/users/Profpatsch/my-prelude/src/MyLabel.hs similarity index 100% rename from users/Profpatsch/whatcd-resolver/src/MyLabel.hs rename to users/Profpatsch/my-prelude/src/MyLabel.hs diff --git a/users/Profpatsch/my-prelude/src/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs index 231650b5e..8d248be91 100644 --- a/users/Profpatsch/my-prelude/src/MyPrelude.hs +++ b/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 diff --git a/users/Profpatsch/my-tools/default.nix b/users/Profpatsch/my-tools/default.nix new file mode 100644 index 000000000..75a32a21d --- /dev/null +++ b/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 diff --git a/users/Profpatsch/my-tools/exe/Copy.hs b/users/Profpatsch/my-tools/exe/Copy.hs new file mode 100644 index 000000000..7a8dbbf1c --- /dev/null +++ b/users/Profpatsch/my-tools/exe/Copy.hs @@ -0,0 +1,6 @@ +module Main where + +import MyTools + +main :: IO () +main = copyMain diff --git a/users/Profpatsch/my-tools/my-tools.cabal b/users/Profpatsch/my-tools/my-tools.cabal new file mode 100644 index 000000000..e9c70988a --- /dev/null +++ b/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 diff --git a/users/Profpatsch/my-tools/src/MyTools.hs b/users/Profpatsch/my-tools/src/MyTools.hs new file mode 100644 index 000000000..bb224ff05 --- /dev/null +++ b/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 diff --git a/users/Profpatsch/shell.nix b/users/Profpatsch/shell.nix index da8b2c6d7..90ac1b20e 100644 --- a/users/Profpatsch/shell.nix +++ b/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 diff --git a/users/Profpatsch/whatcd-resolver/default.nix b/users/Profpatsch/whatcd-resolver/default.nix index db8c3b009..ab52c3225 100644 --- a/users/Profpatsch/whatcd-resolver/default.nix +++ b/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 diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs index e13da3e2c..4b1721f20 100644 --- a/users/Profpatsch/whatcd-resolver/src/Http.hs +++ b/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 -> diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index 1d4ee097c..12efac557 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal @@ -71,7 +71,6 @@ library Bencode JsonLd Optional - MyLabel Http Html Transmission