Improve watch output, and simplify nix configuration

.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

.gitignore

@@ -2,3 +2,5 @@
 *~
 .envrc
 result
+result-doc
+.direnv/

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")
        )
   )

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"
       }
     }
   },

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 ]; };
+      pkgs = nixpkgs.legacyPackages.${system};
-      name = "prefmanager";
+      compiler =  pkgs.haskell.packages.ghc8103;
-      compiler = "ghc884";
+      hlib = pkgs.haskell.lib;
-      project = pkgs.haskell-nix.project' {
+      plist = hlib.markUnbroken (hlib.overrideSrc compiler.plist { src = plist-source; });
-        inherit name;
+      prefmanager = compiler.callPackage ./prefmanager.nix { inherit plist; };
-        src = self;
+      mkShell = devshell.legacyPackages.${system}.mkShell;
-        compiler-nix-name = compiler;
-      };
-      components = project.hsPkgs.${name}.components;
     in rec {
       # Built by `nix build .`
-      defaultPackage = components.exes.${name};
+      defaultPackage = prefmanager;
-      packages.${name} = defaultPackage;
+      packages.prefmanager = defaultPackage;
 
       # Run `prefmanager` with `nix run .`
-      defaultApp = { type = "app"; program = components.exes.${name}.exePath; };
+      defaultApp = { type = "app"; program = "${prefmanager}/bin/prefmanager"; };
-      apps.${name} = defaultApp;
+      apps.prefmanager = defaultApp;
 
-      # This is used by `nix develop .`
+      # # This is used by `nix develop .`
-      devShell = project.shellFor {
+      devShell = mkShell {
-        buildInputs = [
+        name = "prefmanager";
-          pkgs.haskell.packages.${compiler}.haskell-language-server
+        packages = [
-          pkgs.haskell.packages.${compiler}.implicit-hie
+          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";
+          }
+        ];
       };
     }
   );

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"

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

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

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;
+}

src/Defaults.hs

@@ -1,62 +1,70 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
 module Defaults where
 
-import           Control.Concurrent.Async       ( mapConcurrently )
+import Defaults.Pretty (prettyDomainDiffs)
-import           Data.Coerce                    ( coerce )
+import Defaults.Types (DomainDiff(..), Domains, Domain, DomainName(..))
-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
-                                                )
 
-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 :: Text -> IO Text
-defaultsCmd s = readCreateProcess (shell $ "defaults " <> s) ""
+defaultsCmd (T.unpack -> s) = T.pack <$> readCreateProcess (shell $ "defaults " <> s) ""
 
 -- | Convenience function for parsing Plist strings
-parsePlist :: String -> IO PlObject
+parsePlist :: Text -> IO PlObject
-parsePlist = readPlistFromString [withValidate no, withSubstDTDEntities no]
+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" :)
+  .   coerce
-  .   fmap (Domain . delete ',')
+  .   ("NSGlobalDomain" :)
-  .   words
+  .   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.
+diffDomain :: Domain -> Domain -> DomainDiff
-watch :: Set Domain -> IO ()
+diffDomain old new = coerce $ M.filter (not . isSame) $ diff old new
-watch ds = exports ds >>= (putStrLn "Watching..." >>) . go where
+
+-- | 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
+    let domainDiffs = uncurry diffDomain <$> toDelta (diff old new)
-          =   M.filter (not . null)
+    (if null domainDiffs then pure () else putDoc $ prettyDomainDiffs domainDiffs)
-          .   toDelta
+      *> hFlush stdout
-          .   (\(DeltaUnit o n) -> diff o n)
+      *> go new
-          <$> toDelta (diff old new)
-    (if null plDiffs then pure () else pPrint plDiffs) *> go new

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 "<false/>" "<true/>" 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)
+

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)

stack.nix

@@ -0,0 +1,6 @@
+{ ghc }:
+with import (import ./default.nix).inputs.nixpkgs {};
+haskell.lib.buildStackProject {
+  inherit ghc;
+  name = "prefmanager";
+}

stack.yaml

@@ -1,14 +1,14 @@
-# GHC 8.8.4
+# GHC 8.10.3
-resolver: lts-16.17
+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
+  commit: 5e22be0933bf9a100868b944fa7a8b1236b99255
-  # nix-sha256: 126c52498c89gd015p40hg671dg58j8xq8ggdqfywnkw2c8cjxxr
 
-allow-newer: true
+nix:
+  shell-file: ./stack.nix

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
+      size: 368
-      sha256: 76ea9b9ad91d113addadf58cb19e289e84347ab667aa5c7feed0a1ccfa4ed613
+      sha256: d2ca47451a599605c641b7c353588d7e1ba3d6036c8a52040b7d1b5b1af8959b
   original:
-    hackage: diffmap-0.1.0.0
+    hackage: patience-0.3
 - completed:
-    size: 4384
+    size: 4351
-    url: https://github.com/malob/plist/archive/4103af23b364c101e44da115367800a2f90cc7c3.tar.gz
+    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
+    size: 563098
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/17.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/1/20.yaml
-    sha256: d3ee1ae797cf63189c95cf27f00700304946c5cb3c1e6a82001cd6584a221e1b
+    sha256: 97841a28b47a29e798aefda350785c31823f64f31c43ba057fc6c707dfb7ead3
-  original: lts-16.17
+  original: nightly-2021-01-20