diff options
| -rw-r--r-- | Alpha.hs | 12 | ||||
| -rw-r--r-- | Biz/Auth.hs | 6 | ||||
| -rw-r--r-- | Biz/Bild.hs | 44 | ||||
| -rw-r--r-- | Biz/Bild.nix | 34 | ||||
| -rw-r--r-- | Biz/Bild/Builder.nix | 2 | ||||
| -rw-r--r-- | Biz/Bild/Constants.nix | 2 | ||||
| -rw-r--r-- | Biz/Bild/Deps.hs | 14 | ||||
| -rw-r--r-- | Biz/Bild/Deps/Haskell.nix | 3 | ||||
| -rw-r--r-- | Biz/Bild/Deps/exllama.nix | 3 | ||||
| -rw-r--r-- | Biz/Bild/Haskell.nix | 40 | ||||
| -rw-r--r-- | Biz/Bild/Meta.hs | 2 | ||||
| -rw-r--r-- | Biz/Bild/Nixpkgs.nix | 25 | ||||
| -rw-r--r-- | Biz/Bild/Python.nix | 8 | ||||
| -rw-r--r-- | Biz/Bild/Sources.json | 24 | ||||
| -rw-r--r-- | Biz/Dev/Beryllium/Configuration.nix | 5 | ||||
| -rw-r--r-- | Biz/Dev/Lithium/Configuration.nix | 9 | ||||
| -rw-r--r-- | Biz/Dragons.hs | 81 | ||||
| -rw-r--r-- | Biz/Lint.hs | 3 | ||||
| -rw-r--r-- | Biz/Log.hs | 6 | ||||
| -rw-r--r-- | Biz/Look.hs | 12 | ||||
| -rw-r--r-- | Biz/Namespace.hs | 42 | ||||
| -rw-r--r-- | Biz/Que/Host.hs | 22 | ||||
| -rw-r--r-- | Biz/Test.hs | 2 | ||||
| -rw-r--r-- | Control/Concurrent/Sema.hs | 2 | ||||
| -rw-r--r-- | System/Random/Shuffle.hs | 6 |
25 files changed, 195 insertions, 214 deletions
@@ -110,7 +110,7 @@ g <. f = compose f g -- | Alias for map, fmap, <$> -- -- Pronunciation: gal-fas -(</) :: Functor f => (a -> b) -> f a -> f b +(</) :: (Functor f) => (a -> b) -> f a -> f b f </ g = fmap f g -- | Double fmap. A function on the right goes "into" two functors @@ -152,17 +152,17 @@ infixl 1 |> -- functor. Could also be defined as `f +> return <. g` -- -- Pronunciation: fas-gar -(/>) :: Functor f => f a -> (a -> b) -> f b +(/>) :: (Functor f) => f a -> (a -> b) -> f b f /> g = fmap g f infixl 1 /> -bind :: Monad m => m a -> (a -> m b) -> m b +bind :: (Monad m) => m a -> (a -> m b) -> m b bind a f = a Prelude.>>= f {- HLINT ignore "Use +>" -} -(+>) :: Monad m => m a -> (a -> m b) -> m b +(+>) :: (Monad m) => m a -> (a -> m b) -> m b a +> b = a Prelude.>>= b infixl 1 +> @@ -189,7 +189,7 @@ _ ?+ [] = panic "wutlus: empty cond list" a ?< f = if not a then f a else panic "wutgal failed" -- | When. wutbar -(?|) :: Applicative f => Bool -> f () -> f () +(?|) :: (Applicative f) => Bool -> f () -> f () a ?| f = when a f -- | Removes newlinse from a string. @@ -253,5 +253,5 @@ str = toS instance StringConv Int String where strConv _ = show -tshow :: Show a => a -> Text +tshow :: (Show a) => a -> Text tshow = show diff --git a/Biz/Auth.hs b/Biz/Auth.hs index 9eb81a8..73022d7 100644 --- a/Biz/Auth.hs +++ b/Biz/Auth.hs @@ -134,8 +134,8 @@ githubOauth (GitHub OAuthArgs {..}) code = <| "client_id" =: clientId <> "client_secret" - =: clientSecret + =: clientSecret <> "code" - =: code + =: code <> "state" - =: clientState + =: clientState diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 1ca0a2c..bae0328 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -198,7 +198,8 @@ test_bildExamples = move :: Cli.Arguments -> IO () move args = IO.hSetBuffering stdout IO.NoBuffering - >> Env.getEnv "CODEROOT" +> \root -> + >> Env.getEnv "CODEROOT" + +> \root -> Cli.getAllArgs args (Cli.argument "target") |> filterM Dir.doesFileExist +> filterM (\x -> isGitIgnored x /> don't) @@ -344,7 +345,7 @@ data Compiler | Sbcl deriving (Eq, Show, Generic) -compilerExe :: IsString a => Compiler -> a +compilerExe :: (IsString a) => Compiler -> a compilerExe = \case Copy -> "cp" CPython -> "python" @@ -534,7 +535,7 @@ analyze hmap ns = case Map.lookup ns hmap of withFile abspath ReadMode <| \h -> IO.hSetEncoding h IO.utf8_bom >> Text.IO.hGetContents h - /> Text.lines + /> Text.lines case ext of -- basically we don't support building these Namespace.Css -> pure Nothing @@ -724,10 +725,10 @@ analyze hmap ns = case Map.lookup ns hmap of "guile -C \"" <> root </> intdir - <> "\" -e main " - <> "-s " - <> Namespace.toPath namespace - <> " \"$@\"" + <> "\" -e main " + <> "-s " + <> Namespace.toPath namespace + <> " \"$@\"" ] |> joinWith "\n" |> Text.pack @@ -950,7 +951,7 @@ data Proc = Proc } -- | Convert minutes to milliseconds. -toMillis :: Num a => a -> a +toMillis :: (Num a) => a -> a toMillis mins = mins * 60_000_000 -- | Run a subprocess, streaming output if --loud is set. @@ -959,23 +960,24 @@ run Proc {..} = do IO.hSetBuffering stdout IO.NoBuffering loud ?| Log.info ["proc", unwords <| map str <| cmd : args] Conduit.proc cmd args - |> (\proc -> proc {Process.create_group = True}) + |> (\proc_ -> proc_ {Process.create_group = True}) |> Conduit.streamingProcess +> \(Conduit.UseProvidedHandle, stdout_, stderr_, hdl) -> - (,,) </ Async.Concurrently (Conduit.waitForStreamingProcess hdl) + (,,) + </ Async.Concurrently (Conduit.waitForStreamingProcess hdl) <*> Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_)) <*> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_)) - |> Async.runConcurrently - +> \case - (Exit.ExitFailure n, output, outerr) -> - Conduit.closeStreamingProcessHandle hdl - >> putStr outerr - >> onFailure - >> pure (Exit.ExitFailure n, output) - (Exit.ExitSuccess, output, _) -> - Conduit.closeStreamingProcessHandle hdl - >> onSuccess - >> pure (Exit.ExitSuccess, output) + |> Async.runConcurrently + +> \case + (Exit.ExitFailure n, output, outerr) -> + Conduit.closeStreamingProcessHandle hdl + >> putStr outerr + >> onFailure + >> pure (Exit.ExitFailure n, output) + (Exit.ExitSuccess, output, _) -> + Conduit.closeStreamingProcessHandle hdl + >> onSuccess + >> pure (Exit.ExitSuccess, output) -- | Helper for running a standard bild subprocess. proc :: diff --git a/Biz/Bild.nix b/Biz/Bild.nix index c92f749..c6e2f27 100644 --- a/Biz/Bild.nix +++ b/Biz/Bild.nix @@ -5,15 +5,12 @@ let # expose some attrs from stable, keep this minimal and simple stable = { - inherit (nixpkgs.nixos-23_05) - sources lib makeWrapper ccacheStdenv haskellPackages haskell - lispPackages_new python3 nixos mkShell dockerTools; - stdenv = nixpkgs.nixos-23_05.ccacheStdenv; + inherit (nixpkgs.nixos-23_11) + sources lib makeWrapper ccacheStdenv haskell lispPackages_new python3 + nixos mkShell dockerTools pkgs; + stdenv = nixpkgs.nixos-23_11.ccacheStdenv; }; - # for exposing packages as bild.pkgs - stable-pkgs = nixpkgs.nixos-23_05.pkgs; - # this is the main library definitions, recursive references can be made with # `self.thing`, like in Python objects self = { @@ -25,9 +22,12 @@ let haskell = rec { inherit (constants) ghcCompiler; + ghcVersion = ghcPackageSetFull.version; + # all available packages deps = import ./Bild/Deps/Haskell.nix; - packages = self.lib.attrsets.getAttrs self.deps stable.haskellPackages; + packages = self.lib.attrsets.getAttrs self.haskell.deps + stable.haskell.packages."${constants.ghcCompiler}"; # make a ghc with dependencies ghcWith = stable.haskell.packages.${ghcCompiler}.ghcWithHoogle; @@ -72,14 +72,15 @@ let # c packages are just stable, filtered to just the list of deps i want c.packages = - self.lib.attrsets.getAttrs (import ./Bild/Deps/C.nix) stable-pkgs; + self.lib.attrsets.getAttrs (import ./Bild/Deps/C.nix) stable.pkgs; # exposed packages for inclusion in builds - pkgs = with stable-pkgs; { + pkgs = with stable.pkgs; { inherit bat bc cmark ctags deadnix fd figlet fzf git git-branchless gitlint guile hlint indent jq lolcat mypy nixfmt ormolu pkg-config - ripgrep rustc shellcheck tree wemux; + ripgrep rustc tree wemux; ruff = nixpkgs.nixos-unstable-small.ruff; + shellcheck = nixpkgs.nixos-unstable-small.shellcheck; }; # a standard nix build for bild, for bootstrapping. this should be the only @@ -101,11 +102,12 @@ let (p: with p; [ asdf alexandria ])) # just enough to build Example.lisp ]; strictDeps = true; + ghcVersion = self.haskell.ghcVersion; buildPhase = '' - mkdir -p $out/bin $out/lib/ghc-${self.haskell.ghcPackageSetFull.version} + mkdir -p $out/bin $out/lib/ghc-$ghcVersion cp -r \ - ${self.haskell.ghcPackageSetFull}/lib/ghc-${self.haskell.ghcPackageSetFull.version}/package.conf.d \ - $out/lib/ghc-${self.haskell.ghcPackageSetFull.version} + ${self.haskell.ghcPackageSetFull}/lib/ghc-$ghcVersion/package.conf.d \ + $out/lib/ghc-$ghcVersion ghc \ -threaded \ -Werror \ @@ -123,7 +125,7 @@ let ] } \ --set GHC_PACKAGE_PATH \ - $out/lib/ghc-${self.haskell.ghcPackageSetFull.version}/package.conf.d + $out/lib/ghc-$ghcVersion/package.conf.d ''; }; @@ -184,7 +186,7 @@ let wemux ]; shellHook = '' - export GHC_PACKAGE_PATH=${self.bild}/lib/ghc-${self.haskell.ghcPackageSetFull.version}/package.conf.d + export GHC_PACKAGE_PATH=${self.bild}/lib/ghc-${self.haskell.ghcVersion}/package.conf.d ''; }; diff --git a/Biz/Bild/Builder.nix b/Biz/Bild/Builder.nix index 1a2460a..cf4d1e0 100644 --- a/Biz/Bild/Builder.nix +++ b/Biz/Bild/Builder.nix @@ -109,7 +109,7 @@ let inherit name src CODEROOT; propagatedBuildInputs = langdeps_ ++ sysdeps_; buildInputs = sysdeps_; - nativeCheckInputs = lib.attrsets.attrVals [ "mypy" "ruff" ] pkgs; + nativeCheckInputs = [ pkgs.ruff python.packages.mypy ]; checkPhase = '' check() { $@ || { echo "fail: $name: $3"; exit 1; } diff --git a/Biz/Bild/Constants.nix b/Biz/Bild/Constants.nix index 35fd880..20c992e 100644 --- a/Biz/Bild/Constants.nix +++ b/Biz/Bild/Constants.nix @@ -1 +1 @@ -{ ghcCompiler = "ghc924"; } +{ ghcCompiler = "ghc948"; } diff --git a/Biz/Bild/Deps.hs b/Biz/Bild/Deps.hs index 08e3ee6..0b57a4f 100644 --- a/Biz/Bild/Deps.hs +++ b/Biz/Bild/Deps.hs @@ -50,7 +50,7 @@ getFindSourcesJson = do root <- li <| getEnv "CODEROOT" pure <| AtPath <| root </> "Biz/Bild/Sources.json" -li :: MonadIO io => IO a -> io a +li :: (MonadIO io) => IO a -> io a li = liftIO main :: IO () @@ -391,7 +391,7 @@ cmdShow = \case sources <- unSources </ li (getSources fsj) forWithKeyM_ sources <| showPackage -showPackage :: MonadIO io => PackageName -> PackageSpec -> io () +showPackage :: (MonadIO io) => PackageName -> PackageSpec -> io () showPackage (PackageName pname) (PackageSpec spec) = do tsay <| tbold pname forM_ (KM.toList spec) <| \(attrName, attrValValue) -> do @@ -684,8 +684,8 @@ abortUpdateFailed errs = abort <| T.unlines <| ["One or more packages failed to update:"] - <> map - ( \(PackageName pname, e) -> - pname <> ": " <> tshow e - ) - errs + <> map + ( \(PackageName pname, e) -> + pname <> ": " <> tshow e + ) + errs diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix index f34bfab..8115688 100644 --- a/Biz/Bild/Deps/Haskell.nix +++ b/Biz/Bild/Deps/Haskell.nix @@ -23,7 +23,6 @@ "fast-logger" "filepath" "github" - "hashids" "haskeline" "hostname" "http-types" @@ -31,7 +30,6 @@ "katip" "lucid" "monad-logger" - "monad-metrics" "mtl" "neat-interpolation" "network-uri" @@ -53,7 +51,6 @@ "servant-server" "split" "stm" - "stripe-haskell" "tasty" "tasty-hunit" "tasty-quickcheck" diff --git a/Biz/Bild/Deps/exllama.nix b/Biz/Bild/Deps/exllama.nix index 51a05e9..434e9a9 100644 --- a/Biz/Bild/Deps/exllama.nix +++ b/Biz/Bild/Deps/exllama.nix @@ -1,7 +1,7 @@ { lib, sources, buildPythonPackage, pythonOlder , torch # tested on 2.0.1 and 2.1.0 (nightly) with cu118 , safetensors, sentencepiece, ninja, cudaPackages, addOpenGLRunpath, which -, gcc11 # cuda 11.7 requires g++ <12 +, libGL, gcc11 # cuda 11.7 requires g++ <12 }: buildPythonPackage rec { @@ -23,6 +23,7 @@ buildPythonPackage rec { nativeBuildInputs = [ gcc11 which + libGL addOpenGLRunpath cudaPackages.cuda_nvcc cudaPackages.cuda_cudart diff --git a/Biz/Bild/Haskell.nix b/Biz/Bild/Haskell.nix index 2c0529a..c744848 100644 --- a/Biz/Bild/Haskell.nix +++ b/Biz/Bild/Haskell.nix @@ -1,11 +1,10 @@ _self: super: let - ghcCompiler = "ghc924"; + inherit (import ./Constants.nix) ghcCompiler; + buildCabal = sel: name: sel.callCabal2nix name super.sources.${name} { }; - buildCabalSubdir = sel: - { name, src ? super.sources.${name}, subdir ? name }: - sel.callCabal2nix name (src + "/${subdir}") { }; + in rec { haskell = super.haskell // { @@ -15,30 +14,23 @@ in rec { overrides = with super.pkgs.haskell.lib; sel: sup: super.overridePinnedDeps (buildCabal sel) // { - acid-state = - dontCheck sup.acid-state; # mac: "too many open files" + ap-normalize = dontCheck sup.ap-normalize; clay = doJailbreak sup.clay; - envy = doJailbreak sup.envy; - fast-tags = - sup.fast-tags.overrideAttrs (old: old // { patches = [ ]; }); - generic-data = dontCheck - sup.generic-data; # https://github.com/Lysxia/generic-data/issues/56 - readable = - doJailbreak sup.readable; # why is this even being built? - servant-auth = doJailbreak (buildCabalSubdir sel { - name = "servant-auth"; - subdir = "servant-auth/servant-auth"; - }); - servant-server = doJailbreak sup.servant-server; - stripe-core = doJailbreak sup.stripe-core; - stripe-haskell = dontCheck sup.stripe-haskell; - stripe-http-client = - doJailbreak (dontCheck sup.stripe-http-client); - temporary = dontCheck sup.temporary; - wai-middleware-metrics = dontCheck sup.wai-middleware-metrics; + cmark = doJailbreak sup.cmark; + docopt = buildCabal sel "docopt"; + linear-generics = doJailbreak sup.linear-generics; + req = doJailbreak sup.req; + servant-auth = doJailbreak sup.servant-auth; + servant-auth-server = dontCheck sup.servant-auth-server; + shellcheck = doJailbreak sup.shellcheck; + string-qq = doJailbreak sup.string-qq; + syb-with-class = doJailbreak sup.syb-with-class; + th-abstraction = doJailbreak sup.th-abstraction; }; }); }; }; + ormolu = super.haskellPackages.ormolu; + } diff --git a/Biz/Bild/Meta.hs b/Biz/Bild/Meta.hs index ad5fdd6..0025d94 100644 --- a/Biz/Bild/Meta.hs +++ b/Biz/Bild/Meta.hs @@ -47,7 +47,7 @@ data Parsed = Parsed prun :: Set Run } -detect :: Ord a => Regex.RE Char a -> [Text] -> Set a +detect :: (Ord a) => Regex.RE Char a -> [Text] -> Set a detect m cl = cl /> Text.unpack diff --git a/Biz/Bild/Nixpkgs.nix b/Biz/Bild/Nixpkgs.nix index 3de56c4..8bc9cad 100644 --- a/Biz/Bild/Nixpkgs.nix +++ b/Biz/Bild/Nixpkgs.nix @@ -11,41 +11,34 @@ let system = __currentSystem; + # override pinned deps with our sources, this must come before other + # package overlays, because of the 'null' from 'overrideSource' + depsOverlay = _: pkgs: pkgs.overridePinnedDeps pkgs.overrideSource; + in { - nixos-23_05 = import sources.nixos-23_05 { + nixos-23_11 = import sources.nixos-23_11 { inherit system config; overlays = [ (_: _: { inherit sources; }) (import ./CcacheWrapper.nix) (import ./Functions.nix) - - # override pinned deps with our sources, this must come before other - # package overlays, because of the 'null' from 'overrideSource' - (_: pkgs: pkgs.overridePinnedDeps pkgs.overrideSource) - + depsOverlay (import ./Deps.nix) (import ./Python.nix) (import ./Haskell.nix) ]; }; - nixos-23_11 = import sources.nixos-23_11 { - inherit system config; - overlays = [ - (_: _: { inherit sources; }) - (import ./CcacheWrapper.nix) - (import ./Functions.nix) - (import ./Deps.nix) - ]; - }; - nixos-unstable-small = import sources.nixos-unstable-small { inherit system config; overlays = [ (_: _: { inherit sources; }) (import ./CcacheWrapper.nix) (import ./Functions.nix) + depsOverlay (import ./Deps.nix) + (import ./Python.nix) + (import ./Haskell.nix) ]; }; diff --git a/Biz/Bild/Python.nix b/Biz/Bild/Python.nix index 51f35f1..5569352 100644 --- a/Biz/Bild/Python.nix +++ b/Biz/Bild/Python.nix @@ -4,12 +4,8 @@ _self: super: { with pysuper.pkgs.python3Packages; let dontCheck = p: p.overridePythonAttrs (_: { doCheck = false; }); in { - exllama = callPackage ./Deps/exllama.nix { - cudaPackages = super.pkgs.cudaPackages_11_7; - }; - exllamav2 = callPackage ./Deps/exllamav2.nix { - cudaPackages = super.pkgs.cudaPackages_11_7; - }; + exllama = callPackage ./Deps/exllama.nix { }; + exllamav2 = callPackage ./Deps/exllamav2.nix { }; interegular = callPackage ./Deps/interegular.nix { }; mypy = dontCheck pysuper.mypy; outlines = callPackage ./Deps/outlines.nix { }; diff --git a/Biz/Bild/Sources.json b/Biz/Bild/Sources.json index ed6b096..40bcdfb 100644 --- a/Biz/Bild/Sources.json +++ b/Biz/Bild/Sources.json @@ -13,16 +13,17 @@ "version": "cc7729b1b42a79e261091ff7835f7fc2a7ae3cee" }, "docopt": { - "branch": "master", + "branch": "main", "description": "A command-line interface description language and parser that will make you smile", "homepage": "http://docopt.org/", "owner": "docopt", "repo": "docopt.hs", - "rev": "cdd32227eaff46fb57330ced96d5c290cbd9e035", - "sha256": "1nfbm7fpmk522n58d52m44y86a7z4nm6gc3m3gc1hb3wac6vmffc", + "rev": "47516acafeae3e1fdc447716e6ea05c2b918ff3a", + "sha256": "07skrfhzx51yn4qvig3ps34qra9s5g6m4k2z42h9ys0ypyk2wf8w", "type": "tarball", - "url": "https://github.com/docopt/docopt.hs/archive/cdd32227eaff46fb57330ced96d5c290cbd9e035.tar.gz", - "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + "url": "https://github.com/docopt/docopt.hs/archive/47516acafeae3e1fdc447716e6ea05c2b918ff3a.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz", + "version": "0.7.0.8" }, "exllama": { "branch": "master", @@ -194,18 +195,5 @@ "url": "https://github.com/feuerbach/regex-applicative/archive/449519c38e65753345e9a008362c011cb7a0a4d9.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz", "version": "0.3.4" - }, - "servant-auth": { - "branch": "master", - "description": null, - "homepage": null, - "owner": "haskell-servant", - "repo": "servant", - "rev": "f0e2316895ee5fda52ba9d5b2b7e10f8a80a9019", - "sha256": "0ndan9zxvg5zvrl42zvppc9vhbn5skgsyqyxp2v685h82lfz74ps", - "type": "tarball", - "url": "https://github.com/haskell-servant/servant/archive/f0e2316895ee5fda52ba9d5b2b7e10f8a80a9019.tar.gz", - "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz", - "version": "0.4.0.0" } } diff --git a/Biz/Dev/Beryllium/Configuration.nix b/Biz/Dev/Beryllium/Configuration.nix index 7699305..e3e4232 100644 --- a/Biz/Dev/Beryllium/Configuration.nix +++ b/Biz/Dev/Beryllium/Configuration.nix @@ -2,7 +2,7 @@ # your system. Help is available in the configuration.nix(5) man page # and in the NixOS manual (accessible by running ‘nixos-help’). -{ config, pkgs, ... }: +{ pkgs, ... }: { imports = [ # Include the results of the hardware scan. @@ -109,9 +109,6 @@ services.eternal-terminal.enable = true; - # Allow unfree packages - nixpkgs.config.allowUnfree = true; - # List packages installed in system profile. To search, run: # $ nix search wget environment.systemPackages = with pkgs; [ diff --git a/Biz/Dev/Lithium/Configuration.nix b/Biz/Dev/Lithium/Configuration.nix index e6cbdfe..b4e0660 100644 --- a/Biz/Dev/Lithium/Configuration.nix +++ b/Biz/Dev/Lithium/Configuration.nix @@ -1,4 +1,4 @@ -{ config, lib, pkgs, ... }: +{ lib, pkgs, ... }: let ghcCompiler = (import ../../Bild/Constants.nix).ghcCompiler; @@ -27,13 +27,6 @@ in { environment.systemPackages = [ pkgs.nvtop pkgs.k3s pkgs.wemux pkgs.tmux pkgs.wireguard-tools ]; - nixpkgs = { - config = { - allowUnfree = true; - allowBroken = true; - }; - }; - hardware = { opengl.enable = true; pulseaudio = { diff --git a/Biz/Dragons.hs b/Biz/Dragons.hs index 22596de..7e626da 100644 --- a/Biz/Dragons.hs +++ b/Biz/Dragons.hs @@ -477,7 +477,10 @@ instance Lucid.ToHtml AnalysisAction where Lucid.td_ [Lucid.style_ <| size n totalCommits] <| do Lucid.span_ [Lucid.class_ "tooltip"] <| Lucid.toHtml - <| path <> ": " <> show n <> " commits" + <| path + <> ": " + <> show n + <> " commits" where simpleBar :: (Show i, Monad m, Num i) => i -> Integer -> Lucid.HtmlT m () simpleBar n total = do @@ -485,7 +488,7 @@ instance Lucid.ToHtml AnalysisAction where Lucid.tr_ <| do Lucid.td_ [Lucid.style_ <| size n total] "" - <> Lucid.td_ [Lucid.style_ <| size total total] "" + <> Lucid.td_ [Lucid.style_ <| size total total] "" len = toInteger <. length slen = tshow <. length @@ -497,7 +500,7 @@ instance Lucid.ToHtml AnalysisAction where percentage_ = div_ "percentage" size n total = "--size: calc(" <> show n <> "/" <> show total <> ")" previewChart = div_ "preview-chart" - desc :: Monad m => Text -> Lucid.HtmlT m () + desc :: (Monad m) => Text -> Lucid.HtmlT m () desc = Lucid.p_ <. Cmark.renderNode [] <. Cmark.commonmarkToNode [] -- | Captures an 'Analysis' with metadata used in the webapp to track who asked @@ -861,64 +864,64 @@ data Paths path = Paths login :: path :- "login" - :> Verb 'GET 301 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent), + :> Verb 'GET 301 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent), githubAuth :: path :- "auth" - :> "github" - :> "callback" - :> QueryParam "code" Text - :> Get '[Lucid.HTML] (Auth.SetCookies (App.Html UserAccount)), + :> "github" + :> "callback" + :> QueryParam "code" Text + :> Get '[Lucid.HTML] (Auth.SetCookies (App.Html UserAccount)), getAccount :: path :- Auth.Auth '[Auth.Cookie] User - :> "account" - :> Get '[Lucid.HTML] (App.Html UserAccount), + :> "account" + :> Get '[Lucid.HTML] (App.Html UserAccount), postAccount :: path :- Auth.Auth '[Auth.Cookie] User - :> "account" - :> ReqBody '[FormUrlEncoded] Subscription - :> Post '[Lucid.HTML] (App.Html UserAccount), + :> "account" + :> ReqBody '[FormUrlEncoded] Subscription + :> Post '[Lucid.HTML] (App.Html UserAccount), postAPIKey :: path :- Auth.Auth '[Auth.Cookie] User - :> "account" - :> "api-key" - :> Post '[Lucid.HTML] (App.Html UserAccount), + :> "account" + :> "api-key" + :> Post '[Lucid.HTML] (App.Html UserAccount), selectRepo :: path :- Auth.Auth '[Auth.Cookie] User - :> "select-repo" - :> Get '[Lucid.HTML] (App.Html SelectRepo), + :> "select-repo" + :> Get '[Lucid.HTML] (App.Html SelectRepo), getAnalyses :: path :- Auth.Auth '[Auth.Cookie] User - :> "analysis" - :> Get '[Lucid.HTML] (App.Html Analyses), + :> "analysis" + :> Get '[Lucid.HTML] (App.Html Analyses), getAnalysis :: path :- Auth.Auth '[Auth.Cookie] User - :> "analysis" - :> Capture "analysisId" (Id.Id AnalysisAction) - :> Get '[Lucid.HTML] (App.Html AnalysisDisplay), + :> "analysis" + :> Capture "analysisId" (Id.Id AnalysisAction) + :> Get '[Lucid.HTML] (App.Html AnalysisDisplay), postAnalysis :: path :- Auth.Auth '[Auth.Cookie] User - :> "analysis" - :> ReqBody '[FormUrlEncoded] SubmitAnalysis - :> Post '[Lucid.HTML] (App.Html AnalysisDisplay), + :> "analysis" + :> ReqBody '[FormUrlEncoded] SubmitAnalysis + :> Post '[Lucid.HTML] (App.Html AnalysisDisplay), putAnalysis :: path :- Auth.Auth '[Auth.JWT] User - :> "analysis" - :> ReqBody '[JSON] Analysis - :> Put '[JSON] NoContent, + :> "analysis" + :> ReqBody '[JSON] Analysis + :> Put '[JSON] NoContent, admin :: path :- Auth.Auth '[Auth.Cookie] User - :> "admin" - :> Get '[Lucid.HTML] (App.Html AdminDashboard) + :> "admin" + :> Get '[Lucid.HTML] (App.Html AdminDashboard) } deriving (Generic) @@ -928,7 +931,7 @@ paths = genericApi (Proxy :: Proxy Paths) -- | Ensures a user is authenticated, then returns the logged-in user for -- authorization. guardAuth :: - MonadError ServerError m => + (MonadError ServerError m) => Auth.AuthResult a -> m a guardAuth = \case @@ -938,7 +941,7 @@ guardAuth = \case Auth.Authenticated user -> pure user guardAdmin :: - MonadError ServerError m => + (MonadError ServerError m) => Auth.AuthResult User -> m User guardAdmin = \case @@ -990,7 +993,7 @@ htmlApp jwtCfg cooks kp cfg oAuthArgs = warn msg = Log.warn [msg] >> Log.br - |> liftIO + |> liftIO >> throwError err502 {errBody = str msg} user <- GitHub.userInfoCurrentR @@ -1354,7 +1357,7 @@ instance Lucid.ToHtml Analyses where [ href analysisId, css <| Biz.Look.marginAll (em 1) - <> Clay.textDecoration Clay.none + <> Clay.textDecoration Clay.none ] <| do Lucid.div_ <| Lucid.toHtml source @@ -1379,7 +1382,7 @@ instance Lucid.ToHtml Subscription where toHtml Free = "Free" toHtml Invoice = "Invoice me" -linkAction_ :: ToHttpApiData a => Text -> a -> Lucid.Attribute +linkAction_ :: (ToHttpApiData a) => Text -> a -> Lucid.Attribute linkAction_ baseUrl = Lucid.action_ <. (baseUrl <>) <. Servant.toUrlPiece instance Lucid.ToHtml UserAccount where @@ -1521,7 +1524,7 @@ tryButton oAuthArgs title subtitle = Lucid.small_ <| Lucid.toHtml subtitle -- | Universal header -header :: Monad m => Maybe User -> Lucid.HtmlT m () +header :: (Monad m) => Maybe User -> Lucid.HtmlT m () header muser = Lucid.header_ <| do Lucid.nav_ <| do @@ -1540,7 +1543,7 @@ header muser = li txt href = Lucid.li_ <| a txt href -- | Universal footer -footer :: Monad m => Lucid.HtmlT m () +footer :: (Monad m) => Lucid.HtmlT m () footer = Lucid.footer_ <| do Lucid.p_ <| Lucid.i_ "Copyright ©2020-2021 Dragons.dev" @@ -1640,7 +1643,7 @@ test_spliceCreds = -- | Clones a repo from GitHub and does the analysis. analyzeGitHub :: - GitHub.AuthMethod ghAuth => + (GitHub.AuthMethod ghAuth) => Acid.AcidState Keep -> -- | The User asking for the analysis, we auth as them User -> diff --git a/Biz/Lint.hs b/Biz/Lint.hs index af285a7..c971c04 100644 --- a/Biz/Lint.hs +++ b/Biz/Lint.hs @@ -293,7 +293,8 @@ runOne mode (ext, ns's) = results +> traverse printResult lint :: Mode -> Linter -> [Namespace] -> IO Result lint mode linter@Linter {..} ns's = Log.info ["lint", exe, (tshow <| length ns's) <> " files"] - >> Process.readProcessWithExitCode (str exe) args "" /> \case + >> Process.readProcessWithExitCode (str exe) args "" + /> \case (Exit.ExitSuccess, _, _) -> Done linter Good (Exit.ExitFailure _, msg, _) -> case decoder of @@ -102,7 +102,7 @@ warn = msg Warn fail = msg Fail -- | Like 'Debug.trace' but follows the patterns in this module -mark :: Show a => Text -> a -> a +mark :: (Show a) => Text -> a -> a mark label val = unsafePerformIO <| do msg Mark [label, tshow val] @@ -114,11 +114,11 @@ mark label val = -- @ -- mark label val = val ~& label -- @ -(~&) :: Show a => a -> Text -> a +(~&) :: (Show a) => a -> Text -> a val ~& label = mark label val -- | Conditional mark. -(~?) :: Show a => a -> (a -> Bool) -> Text -> a +(~?) :: (Show a) => a -> (a -> Bool) -> Text -> a (~?) val test label = if test val then mark label val else val wai :: Wai.Middleware diff --git a/Biz/Look.hs b/Biz/Look.hs index 2e05993..7258375 100644 --- a/Biz/Look.hs +++ b/Biz/Look.hs @@ -126,11 +126,13 @@ fuckingStyle = do ] [sansSerif] "main" ? Flexbox.flex 1 0 auto - "main" <> "header" <> "footer" ? do - maxWidth (px 900) - width (pct 100) - margin (em 1) auto 1 auto - padding (em 0) 0 0 0 + "main" + <> "header" + <> "footer" ? do + maxWidth (px 900) + width (pct 100) + margin (em 1) auto 1 auto + padding (em 0) 0 0 0 "h1" <> "h2" <> "h3" ? lineHeight (em 1.2) query Clay.all [prefersDark] <| do "body" ? do diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs index 8f5058e..aa69a9c 100644 --- a/Biz/Namespace.hs +++ b/Biz/Namespace.hs @@ -130,20 +130,34 @@ rePath = Regex.many (name <* Regex.string "/" <|> name) reExt :: Regex.RE Char Ext reExt = - C <$ Regex.string "c" - <|> Css <$ Regex.string "css" - <|> Hs <$ Regex.string "hs" - <|> Html <$ Regex.string "html" - <|> Json <$ Regex.string "json" - <|> Keys <$ Regex.string "pub" - <|> Lisp <$ Regex.string "lisp" - <|> Md <$ Regex.string "md" - <|> Nix <$ Regex.string "nix" - <|> Py <$ Regex.string "py" - <|> Rs <$ Regex.string "rs" - <|> Scm <$ Regex.string "scm" - <|> Sh <$ Regex.string "sh" - <|> Toml <$ Regex.string "toml" + C + <$ Regex.string "c" + <|> Css + <$ Regex.string "css" + <|> Hs + <$ Regex.string "hs" + <|> Html + <$ Regex.string "html" + <|> Json + <$ Regex.string "json" + <|> Keys + <$ Regex.string "pub" + <|> Lisp + <$ Regex.string "lisp" + <|> Md + <$ Regex.string "md" + <|> Nix + <$ Regex.string "nix" + <|> Py + <$ Regex.string "py" + <|> Rs + <$ Regex.string "rs" + <|> Scm + <$ Regex.string "scm" + <|> Sh + <$ Regex.string "sh" + <|> Toml + <$ Regex.string "toml" -- | The cab dir is for temporary files and build outputs, not for source -- inputs. diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs index 79254ad..f1b986c 100644 --- a/Biz/Que/Host.hs +++ b/Biz/Que/Host.hs @@ -127,25 +127,25 @@ data Paths path = Paths dash :: path :- "_" - :> "dash" - :> Get '[JSON] Ques, + :> "dash" + :> Get '[JSON] Ques, getQue :: path :- Capture "ns" Text - :> Capture "quename" Text - :> Get '[PlainText, HTML, OctetStream] Message, + :> Capture "quename" Text + :> Get '[PlainText, HTML, OctetStream] Message, getStream :: path :- Capture "ns" Text - :> Capture "quename" Text - :> "stream" - :> StreamGet NoFraming OctetStream (SourceIO Message), + :> Capture "quename" Text + :> "stream" + :> StreamGet NoFraming OctetStream (SourceIO Message), putQue :: path :- Capture "ns" Text - :> Capture "quepath" Text - :> ReqBody '[PlainText, HTML, OctetStream] Text - :> Post '[PlainText, HTML, OctetStream] NoContent + :> Capture "quepath" Text + :> ReqBody '[PlainText, HTML, OctetStream] Text + :> Post '[PlainText, HTML, OctetStream] NoContent } deriving (Generic) @@ -183,7 +183,7 @@ paths _ = |> str |> Go.write q >> Go.read q -- flush the que, otherwise msgs never clear - |> liftIO + |> liftIO -- TODO: detect number of readers, respond with "sent to N readers" or -- "no readers, msg lost" >> pure NoContent diff --git a/Biz/Test.hs b/Biz/Test.hs index 508703b..c81c5cf 100644 --- a/Biz/Test.hs +++ b/Biz/Test.hs @@ -45,7 +45,7 @@ group = Tasty.testGroup unit :: Description -> Assertion -> Tree unit = HUnit.testCase -prop :: QuickCheck.Testable a => Description -> a -> Tree +prop :: (QuickCheck.Testable a) => Description -> a -> Tree prop = QuickCheck.testProperty assertFailure :: String -> Assertion diff --git a/Control/Concurrent/Sema.hs b/Control/Concurrent/Sema.hs index 21d4709..7f43bcf 100644 --- a/Control/Concurrent/Sema.hs +++ b/Control/Concurrent/Sema.hs @@ -9,7 +9,7 @@ import Control.Concurrent.Async (mapConcurrently) import qualified Control.Concurrent.MSem as Sem -- | Simaphore-based throttled 'mapConcurrently'. -mapPool :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b) +mapPool :: (Traversable t) => Int -> (a -> IO b) -> t a -> IO (t b) mapPool n f xs = do sima <- Sem.new n mapConcurrently (Sem.with sima <. f) xs diff --git a/System/Random/Shuffle.hs b/System/Random/Shuffle.hs index 1df376f..4cd36eb 100644 --- a/System/Random/Shuffle.hs +++ b/System/Random/Shuffle.hs @@ -94,16 +94,16 @@ shuffle elements = shuffleTree (buildTree elements) -- | Given a sequence (e1,...en) to shuffle, its length, and a random -- generator, compute the corresponding permutation of the input -- sequence. -shuffle' :: RandomGen gen => [a] -> Int -> gen -> [a] +shuffle' :: (RandomGen gen) => [a] -> Int -> gen -> [a] shuffle' elements len = shuffle elements <. rseq len where -- The sequence (r1,...r[n-1]) of numbers such that r[i] is an -- independent sample from a uniform random distribution -- [0..n-i] - rseq :: RandomGen gen => Int -> gen -> [Int] + rseq :: (RandomGen gen) => Int -> gen -> [Int] rseq n = map fst <. rseq' (n - 1) where - rseq' :: RandomGen gen => Int -> gen -> [(Int, gen)] + rseq' :: (RandomGen gen) => Int -> gen -> [(Int, gen)] rseq' 0 _ = [] rseq' i gen = (j, gen) : rseq' (i - 1) gen' where |