From b98c0e762487d9fc11235a8427e7dd3befdbca38 Mon Sep 17 00:00:00 2001 From: Malo Bourgon Date: Mon, 25 Jan 2021 10:39:15 -0800 Subject: [PATCH] Improve watch output, and simplify nix configuration --- .github/workflows/nix.yml | 2 - .gitignore | 2 + app/Main.hs | 20 ++++++---- flake.lock | 52 +++++++++++++++++-------- flake.nix | 54 ++++++++++++++++---------- hie.yaml | 13 +++++++ package.yaml | 6 ++- prefmanager.cabal | 24 ++++++++---- prefmanager.nix | 28 +++++++++++++ src/Defaults.hs | 82 +++++++++++++++++++++------------------ src/Defaults/Pretty.hs | 73 ++++++++++++++++++++++++++++++++++ src/Defaults/Types.hs | 20 ++++++++++ stack.nix | 6 +++ stack.yaml | 12 +++--- stack.yaml.lock | 26 ++++++------- 15 files changed, 307 insertions(+), 113 deletions(-) create mode 100644 hie.yaml create mode 100644 prefmanager.nix create mode 100644 src/Defaults/Pretty.hs create mode 100644 src/Defaults/Types.hs create mode 100644 stack.nix diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml index e7896ba..bd30e28 100644 --- a/.github/workflows/nix.yml +++ b/.github/workflows/nix.yml @@ -14,8 +14,6 @@ jobs: with: install_url: https://github.com/numtide/nix-flakes-installer/releases/download/nix-2.4pre20201221_9fab14a/install extra_nix_config: | - trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= - substituters = https://cache.nixos.org https://hydra.iohk.io https://iohk.cachix.org experimental-features = nix-command flakes - name: Setup Cachix diff --git a/.gitignore b/.gitignore index af87ed4..48813b3 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,5 @@ *~ .envrc result +result-doc +.direnv/ diff --git a/app/Main.hs b/app/Main.hs index 16073f2..072651b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,11 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Monad ( join ) -import Data.Coerce ( coerce ) -import qualified Data.Set as S -import Options.Applicative - import Defaults +import Defaults.Types (DomainName(..)) + +import Control.Monad (join) +import Data.Coerce (coerce) +import Data.Foldable (traverse_) +import qualified Data.Set as S +import qualified Data.Text as T +import Options.Applicative -- | Main main :: IO () @@ -23,9 +27,9 @@ commands = hsubparser ( command "watch" (info ( watch . S.fromList <$> some - (Domain <$> strArgument + (DomainName <$> strArgument ( metavar "DOMAIN..." - <> completer (listIOCompleter $ fmap coerce . S.toList <$> domains) + <> completer (listIOCompleter $ fmap (T.unpack . coerce) . S.toList <$> domains) <> help "Domain(s) that will be watched" ) ) @@ -39,7 +43,7 @@ commands = hsubparser ) <> command "list-domains" (info - (pure $ S.toList <$> domains >>= mapM_ (putStrLn . coerce)) + (pure $ domains >>= traverse_ (putStrLn . T.unpack . coerce) . S.toList) (progDesc "List all domains") ) ) diff --git a/flake.lock b/flake.lock index bd00009..3063a83 100644 --- a/flake.lock +++ b/flake.lock @@ -1,5 +1,20 @@ { "nodes": { + "devshell": { + "locked": { + "lastModified": 1611223133, + "narHash": "sha256-oRipYhMDsu2bUMHXBN5Q06nZhKSYqux0SsBcq+iKyYc=", + "owner": "numtide", + "repo": "devshell", + "rev": "4d217ab9f63da23bc43351c68c2d7dc4fb5d1077", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "devshell", + "type": "github" + } + }, "flake-compat": { "flake": false, "locked": { @@ -31,21 +46,6 @@ "type": "github" } }, - "haskellNix": { - "locked": { - "lastModified": 1610500541, - "narHash": "sha256-XedfI5fERgPeIbJTMkd6AH1lJGXv28CxBYMEjzAfrJc=", - "owner": "input-output-hk", - "repo": "haskell.nix", - "rev": "faaca6735566d8707ffcc812ec0da964cded27f6", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "haskell.nix", - "type": "github" - } - }, "nixpkgs": { "locked": { "lastModified": 1610575970, @@ -61,12 +61,30 @@ "type": "github" } }, + "plist-source": { + "flake": false, + "locked": { + "lastModified": 1611283854, + "narHash": "sha256-7ubuVH6P2uYeCq82/ALd6E5szjBBqEtcO61u+5qRCt0=", + "owner": "malob", + "repo": "plist", + "rev": "5e22be0933bf9a100868b944fa7a8b1236b99255", + "type": "github" + }, + "original": { + "owner": "malob", + "ref": "monadfail", + "repo": "plist", + "type": "github" + } + }, "root": { "inputs": { + "devshell": "devshell", "flake-compat": "flake-compat", "flake-utils": "flake-utils", - "haskellNix": "haskellNix", - "nixpkgs": "nixpkgs" + "nixpkgs": "nixpkgs", + "plist-source": "plist-source" } } }, diff --git a/flake.nix b/flake.nix index 7286f7c..a9ef210 100644 --- a/flake.nix +++ b/flake.nix @@ -3,38 +3,52 @@ inputs = { nixpkgs.url = "github:NixOS/nixpkgs"; - haskellNix.url = "github:input-output-hk/haskell.nix"; + devshell.url = "github:numtide/devshell/"; flake-compat = { url = "github:edolstra/flake-compat"; flake = false; }; flake-utils.url = "github:numtide/flake-utils"; + plist-source = { url = "github:malob/plist/monadfail"; flake = false; }; }; - outputs = { self, nixpkgs, haskellNix, flake-utils, ... }: + outputs = { self, devshell, nixpkgs, flake-utils, plist-source, ... }: flake-utils.lib.eachSystem [ "x86_64-darwin" ] (system: let - pkgs = import nixpkgs { inherit system; overlays = [ haskellNix.overlay ]; }; - name = "prefmanager"; - compiler = "ghc884"; - project = pkgs.haskell-nix.project' { - inherit name; - src = self; - compiler-nix-name = compiler; - }; - components = project.hsPkgs.${name}.components; + pkgs = nixpkgs.legacyPackages.${system}; + compiler = pkgs.haskell.packages.ghc8103; + hlib = pkgs.haskell.lib; + plist = hlib.markUnbroken (hlib.overrideSrc compiler.plist { src = plist-source; }); + prefmanager = compiler.callPackage ./prefmanager.nix { inherit plist; }; + mkShell = devshell.legacyPackages.${system}.mkShell; in rec { # Built by `nix build .` - defaultPackage = components.exes.${name}; - packages.${name} = defaultPackage; + defaultPackage = prefmanager; + packages.prefmanager = defaultPackage; # Run `prefmanager` with `nix run .` - defaultApp = { type = "app"; program = components.exes.${name}.exePath; }; - apps.${name} = defaultApp; + defaultApp = { type = "app"; program = "${prefmanager}/bin/prefmanager"; }; + apps.prefmanager = defaultApp; - # This is used by `nix develop .` - devShell = project.shellFor { - buildInputs = [ - pkgs.haskell.packages.${compiler}.haskell-language-server - pkgs.haskell.packages.${compiler}.implicit-hie + # # This is used by `nix develop .` + devShell = mkShell { + name = "prefmanager"; + packages = [ + compiler.haskell-language-server + compiler.implicit-hie + pkgs.cabal2nix pkgs.stack ]; + commands = [ + { + help = "Regenerate hie.yaml (run from project root)"; + name = "hie"; + category = "project"; + command = "gen-hie > hie.yaml"; + } + { + help = "Update prefmanager.nix (run from project root)"; + name = "2nix"; + category = "project"; + command = "cabal2nix --hpack . > prefmanager.nix"; + } + ]; }; } ); diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..f01f210 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,13 @@ +cradle: + stack: + - path: "./src" + component: "prefmanager:lib" + + - path: "./app/Main.hs" + component: "prefmanager:exe:prefmanager" + + - path: "./app/Paths_prefmanager.hs" + component: "prefmanager:exe:prefmanager" + + - path: "./test" + component: "prefmanager:test:prefmanager-test" diff --git a/package.yaml b/package.yaml index 517ea13..e452d14 100644 --- a/package.yaml +++ b/package.yaml @@ -17,12 +17,14 @@ dependencies: - base >= 4.7 && < 5 - async - containers -- diffmap - hxt - optparse-applicative +- patience - plist -- pretty-show +- prettyprinter +- prettyprinter-ansi-terminal - process +- text library: source-dirs: src diff --git a/prefmanager.cabal b/prefmanager.cabal index b2e525f..d74a6e3 100644 --- a/prefmanager.cabal +++ b/prefmanager.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.3. -- -- see: https://github.com/sol/hpack -- --- hash: 1af3ad98cee7d7fc142970a5965d8baebd3604edff043fae4c2b5d15e4cde1dc +-- hash: e47b42f89876fbc6a9f6ac24c1b66d161577d67abc0267f021a78a23c1ca8389 name: prefmanager version: 0.1.0.0 @@ -29,6 +29,8 @@ source-repository head library exposed-modules: Defaults + Defaults.Pretty + Defaults.Types other-modules: Paths_prefmanager hs-source-dirs: @@ -37,12 +39,14 @@ library async , base >=4.7 && <5 , containers - , diffmap , hxt , optparse-applicative + , patience , plist - , pretty-show + , prettyprinter + , prettyprinter-ansi-terminal , process + , text default-language: Haskell2010 executable prefmanager @@ -56,13 +60,15 @@ executable prefmanager async , base >=4.7 && <5 , containers - , diffmap , hxt , optparse-applicative + , patience , plist , prefmanager - , pretty-show + , prettyprinter + , prettyprinter-ansi-terminal , process + , text default-language: Haskell2010 test-suite prefmanager-test @@ -77,11 +83,13 @@ test-suite prefmanager-test async , base >=4.7 && <5 , containers - , diffmap , hxt , optparse-applicative + , patience , plist , prefmanager - , pretty-show + , prettyprinter + , prettyprinter-ansi-terminal , process + , text default-language: Haskell2010 diff --git a/prefmanager.nix b/prefmanager.nix new file mode 100644 index 0000000..752a5f9 --- /dev/null +++ b/prefmanager.nix @@ -0,0 +1,28 @@ +{ mkDerivation, async, base, containers, hpack, hxt +, optparse-applicative, patience, plist, prettyprinter +, prettyprinter-ansi-terminal, process, stdenv, text +}: +mkDerivation { + pname = "prefmanager"; + version = "0.1.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + async base containers hxt optparse-applicative patience plist + prettyprinter prettyprinter-ansi-terminal process text + ]; + libraryToolDepends = [ hpack ]; + executableHaskellDepends = [ + async base containers hxt optparse-applicative patience plist + prettyprinter prettyprinter-ansi-terminal process text + ]; + testHaskellDepends = [ + async base containers hxt optparse-applicative patience plist + prettyprinter prettyprinter-ansi-terminal process text + ]; + prePatch = "hpack"; + homepage = "https://github.com/malob/prefmanager#readme"; + description = "A CLI utility for managing macOS preferences"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/src/Defaults.hs b/src/Defaults.hs index 8f6aa6b..d8b125d 100644 --- a/src/Defaults.hs +++ b/src/Defaults.hs @@ -1,62 +1,70 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Defaults where -import Control.Concurrent.Async ( mapConcurrently ) -import Data.Coerce ( coerce ) -import Data.List ( delete ) -import Data.Map ( Map(..) ) -import qualified Data.Map as M -import Data.Map.Delta -import Data.Maybe -import Data.Set ( Set(..) ) -import qualified Data.Set as S -import Text.Show.Pretty -import Text.XML.Plist -import Text.XML.HXT.Core -import System.Process ( shell - , readCreateProcess - ) +import Defaults.Pretty (prettyDomainDiffs) +import Defaults.Types (DomainDiff(..), Domains, Domain, DomainName(..)) -newtype Domain = Domain String deriving (Eq, Ord, Show) +import Control.Concurrent.Async (mapConcurrently) +import Data.Coerce (coerce) +import Data.List (delete) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Patience.Map +import Prettyprinter.Render.Terminal (putDoc) +import System.IO (hFlush, stdout) +import System.Process (shell, readCreateProcess) +import Text.XML.HXT.Core (no, withSubstDTDEntities, withValidate) +import Text.XML.Plist (PlObject, fromPlDict, readPlistFromString) -- | Convenience function for running macOS @defaults@ command. -defaultsCmd :: String -> IO String -defaultsCmd s = readCreateProcess (shell $ "defaults " <> s) "" +defaultsCmd :: Text -> IO Text +defaultsCmd (T.unpack -> s) = T.pack <$> readCreateProcess (shell $ "defaults " <> s) "" -- | Convenience function for parsing Plist strings -parsePlist :: String -> IO PlObject -parsePlist = readPlistFromString [withValidate no, withSubstDTDEntities no] +parsePlist :: Text -> IO PlObject +parsePlist = readPlistFromString [withValidate no, withSubstDTDEntities no] . T.unpack -- | Gets list of domains by running @defaults domains@ and adds @NSGlobalDomain@ to the 'Set'. -domains :: IO (Set Domain) +domains :: IO (Set DomainName) domains = S.fromList - . (Domain "NSGlobalDomain" :) - . fmap (Domain . delete ',') - . words + . coerce + . ("NSGlobalDomain" :) + . T.splitOn ", " + . T.stripEnd <$> defaultsCmd "domains" -- | Runs @defaults export [domain] -@ and parses the output. -export :: Domain -> IO (Map String PlObject) +export :: DomainName -> IO Domain export (coerce -> d) - = M.fromList + = coerce + . M.fromList . fromJust . fromPlDict - <$> (defaultsCmd ("export " <> d <> " -") >>= parsePlist) + <$> (defaultsCmd ("export '" <> d <> "' -") >>= parsePlist) -- | Runs 'export' on the 'Set' of provided domains -exports :: Set Domain -> IO (Map Domain (Map String PlObject)) +exports :: Set DomainName -> IO Domains exports = (M.fromList <$>) . mapConcurrently (\d -> (d,) <$> export d) . S.toList --- | Watches a 'Set' of domains for changes. -watch :: Set Domain -> IO () -watch ds = exports ds >>= (putStrLn "Watching..." >>) . go where +diffDomain :: Domain -> Domain -> DomainDiff +diffDomain old new = coerce $ M.filter (not . isSame) $ diff old new + +-- | Watches a 'Set' of domains and prints any changes. +watch :: Set DomainName -> IO () +watch ds = exports ds >>= (putStrLn "Watching..." >>) . go where + go :: Domains -> IO () go old = do new <- exports ds - let plDiffs - = M.filter (not . null) - . toDelta - . (\(DeltaUnit o n) -> diff o n) - <$> toDelta (diff old new) - (if null plDiffs then pure () else pPrint plDiffs) *> go new + let domainDiffs = uncurry diffDomain <$> toDelta (diff old new) + (if null domainDiffs then pure () else putDoc $ prettyDomainDiffs domainDiffs) + *> hFlush stdout + *> go new diff --git a/src/Defaults/Pretty.hs b/src/Defaults/Pretty.hs new file mode 100644 index 0000000..a36571d --- /dev/null +++ b/src/Defaults/Pretty.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Defaults.Pretty where + +import Defaults.Types (DomainDiff(..), DomainName(..), Key) + +import Data.Bool (bool) +import Data.Coerce (coerce) +import Data.Map (Map, foldrWithKey) +import Patience.Map (Delta(..)) +import Prettyprinter +import Prettyprinter.Render.Terminal +import Text.XML.Plist (PlObject(..)) + +prettyDomainDiffs :: Map DomainName DomainDiff -> Doc AnsiStyle +prettyDomainDiffs = foldrWithKey go emptyDoc where + go :: DomainName -> DomainDiff -> Doc AnsiStyle -> Doc AnsiStyle + go (DomainName name) diff doc + = doc + <> hardline + <> hardline + <> annotate (bold <> italicized) (pretty name) + <> hardline + <> indent 2 (prettyDomainDiff diff) + +prettyDomainDiff :: DomainDiff -> Doc AnsiStyle +prettyDomainDiff = foldrWithKey go emptyDoc . coerce where + go :: Key -> Delta PlObject -> Doc AnsiStyle -> Doc AnsiStyle + go key delta doc + = doc + <> hardline + <> case delta of + Delta old new + -> pretty key <+> "(Value changed)" + <> hardline + <> indent 2 (red (pretty old) <> hardline <> green (pretty new)) + New x + -> green + $ pretty key <+> "(Key added)" + <> hardline + <> indent 2 (pretty x) + Old x + -> red + $ pretty key <+> "(Key removed)" + <> hardline + <> indent 2 (pretty x) + Same x + -> pretty key <+> "(No change)" + <> hardline + <> indent 2 (pretty x) + red = annotate $ colorDull Red + green = annotate $ colorDull Green + +instance Pretty PlObject where + pretty = \case + PlString x -> tag "string" $ pretty x + PlBool x -> bool "" "" x + PlInteger x -> tag "integer" $ pretty x + PlReal x -> tag "real" $ pretty x + PlArray x -> tag "array" $ concatWith ((<>) . (<> hardline)) (fmap pretty x) + PlDict x -> tag "dict" $ concatWith ((<>) . (<> hardline)) (fmap prettyDict x) + PlData x -> tag "data" "[binary data]" + PlDate x -> tag "date" $ pretty x + + where + prettyDict (k, o) = tag "key" (pretty k) <> hardline <> pretty o + tag t s = group $ flatAlt + (open <> hardline <> indent 4 s <> hardline <> close) + (open <> s <> close) + where + open = angles t + close = angles ("/" <> t) + diff --git a/src/Defaults/Types.hs b/src/Defaults/Types.hs new file mode 100644 index 0000000..77a72d2 --- /dev/null +++ b/src/Defaults/Types.hs @@ -0,0 +1,20 @@ +module Defaults.Types where + +import Data.Map (Map) +import Data.Text (Text) +import Patience.Map (Delta) +import Text.XML.Plist (PlObject) + +-- | Name of a domain, e.g., @NSGlobalDomain@, @com.apple.finder@, etc. +newtype DomainName = DomainName Text deriving (Eq, Ord, Show) + +type Key = String + +-- | Representation of the settings of a domain. +type Domain = Map Key PlObject + +-- | Map of domains. +type Domains = Map DomainName Domain + +-- | Map representing the change of the values of keys of a domain. +newtype DomainDiff = DomainDiff (Map Key (Delta PlObject)) deriving (Eq, Ord, Show) diff --git a/stack.nix b/stack.nix new file mode 100644 index 0000000..93b1bbd --- /dev/null +++ b/stack.nix @@ -0,0 +1,6 @@ +{ ghc }: +with import (import ./default.nix).inputs.nixpkgs {}; +haskell.lib.buildStackProject { + inherit ghc; + name = "prefmanager"; +} diff --git a/stack.yaml b/stack.yaml index ba5b767..5f93096 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,14 +1,14 @@ -# GHC 8.8.4 -resolver: lts-16.17 +# GHC 8.10.3 +resolver: nightly-2021-01-20 packages: - . extra-deps: -- diffmap-0.1.0.0 +- patience-0.3 # Use fork of plist package that supports MonadFail - github: malob/plist - commit: 4103af23b364c101e44da115367800a2f90cc7c3 - # nix-sha256: 126c52498c89gd015p40hg671dg58j8xq8ggdqfywnkw2c8cjxxr + commit: 5e22be0933bf9a100868b944fa7a8b1236b99255 -allow-newer: true +nix: + shell-file: ./stack.nix diff --git a/stack.yaml.lock b/stack.yaml.lock index b1e1990..443f943 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,26 +5,26 @@ packages: - completed: - hackage: diffmap-0.1.0.0@sha256:27ea8c315b5dbfb243b2c3b61eab2164534e1d02887a05392dda65995cd36c3e,727 + hackage: patience-0.3@sha256:fe3a2c5b1ac4d3425bad3d1ee0b6bb529b6e74ab41151f8526f26fc8dfa1206b,1252 pantry-tree: - size: 264 - sha256: 76ea9b9ad91d113addadf58cb19e289e84347ab667aa5c7feed0a1ccfa4ed613 + size: 368 + sha256: d2ca47451a599605c641b7c353588d7e1ba3d6036c8a52040b7d1b5b1af8959b original: - hackage: diffmap-0.1.0.0 + hackage: patience-0.3 - completed: - size: 4384 - url: https://github.com/malob/plist/archive/4103af23b364c101e44da115367800a2f90cc7c3.tar.gz + size: 4351 + url: https://github.com/malob/plist/archive/5e22be0933bf9a100868b944fa7a8b1236b99255.tar.gz name: plist version: 0.0.6 - sha256: fcc0a7f0dcdb81d379329f5be2af2a566431ed66cbe37e9a1f4101e49b80d4c6 + sha256: 7943778b77d008b8e529035d8a4d42c537ede9efe3d24900eb0d855b4567a892 pantry-tree: size: 512 - sha256: 0ede20c4e670e906987a171721f05c3a3337ed936d5ff84e6fe77c13e2c7fbdf + sha256: 4872e51ef6ab654c99e06f286635fe1c977e165bc38f77c6bfb402e9fbff0559 original: - url: https://github.com/malob/plist/archive/4103af23b364c101e44da115367800a2f90cc7c3.tar.gz + url: https://github.com/malob/plist/archive/5e22be0933bf9a100868b944fa7a8b1236b99255.tar.gz snapshots: - completed: - size: 532386 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/17.yaml - sha256: d3ee1ae797cf63189c95cf27f00700304946c5cb3c1e6a82001cd6584a221e1b - original: lts-16.17 + size: 563098 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/1/20.yaml + sha256: 97841a28b47a29e798aefda350785c31823f64f31c43ba057fc6c707dfb7ead3 + original: nightly-2021-01-20