diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 10aa222..d01883a 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -5,25 +5,21 @@ on: [push, pull_request] jobs: build: strategy: + fail-fast: false matrix: - ghc: ['8.0.2', '8.2.2', '8.4.4', '8.6.5', '8.8.4', '8.10.7', '9.0.1', '9.2.2'] + ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.7', '9.0.1', '9.2.5', '9.4.5', '9.6.1', '9.8.2', '9.10.1'] os: ['ubuntu-latest', 'macos-latest'] - exclude: - # There are some linker warnings in 802 on darwin that - # cause compilation to fail - # See https://github.com/NixOS/nixpkgs/issues/25139 - - ghc: '8.0.2' - os: 'macos-latest' runs-on: ${{ matrix.os }} name: GHC ${{ matrix.ghc }} on ${{ matrix.os }} steps: - - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v1 + - uses: actions/checkout@v3 + - uses: haskell/actions/setup@v2 with: ghc-version: ${{ matrix.ghc }} + cabal-version: '3.10.1.0' - name: Cache - uses: actions/cache@v1 + uses: actions/cache@v3 env: cache-name: cache-cabal with: @@ -36,12 +32,13 @@ jobs: ${{ runner.os }} - name: Install dependencies - run: | - cabal update - cabal build --only-dependencies --enable-tests --enable-benchmarks + run: cabal build --only-dependencies --enable-tests --enable-benchmarks - name: Build run: cabal build --enable-tests --enable-benchmarks all - name: Run tests - run: cabal test --enable-tests all - - name: Build Docs + # We don't run hlint tests, because different versions of hlint have different suggestions, and we don't want to worry about satisfying them all. + run: cabal test --enable-tests -f-hlint all + - if: matrix.ghc != '8.4.4' + # docs aren't built on ghc 8.4.4 because some dependency docs don't build on older GHCs + name: Build Docs run: cabal haddock diff --git a/.gitignore b/.gitignore index 7823a5f..88ce923 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ dist cabal.sandbox.config +cabal.project.local .cabal-sandbox/ dist-* cabal-dev @@ -32,7 +33,7 @@ tags hsenv.log \#*# .#* -/shell.nix /ghci-tmp *.dump-* *.verbose-core2core +.nix diff --git a/ChangeLog.md b/ChangeLog.md index 100237f..350d6bf 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -9,6 +9,25 @@ orphan for backwards compat, temporarily, but it should eventually be removed everywhere. +* Add support for GHC 9.8 and 9.10 + +* Replace partial `Map.lookup` with proper custom error for internal error. + (This would make debugging a bug in the implementation easier.) + +## 0.0.8.2 + +* Add support for GHC 9.6 + +## 0.0.8.1 + +* Add support for GHC 9.2 and 9.4 + +## 0.0.8.0 - 2022-12-09 + +* Drop support for GHC 8.0 and 8.2. It may still be possible to use this library with those versions of GHC, but we do not guarantee or test it anymore. +* Fix an issue where (<>) crashed for some `PatchMapWithPatchingMove`s. +* Change `DecidablyEmpty` for `Sum` and `Product` to use `Num` and `Eq` rather than delegating to the argument type's `DecidablyEmpty` class. Since `Sum` and `Product` have `Monoid` actions and units that are inherently based on `Num`, it makes sense to have a `DecidablyEmpty` instances that inherently agree with that. Also, since `Int` and other numeric types don't have (and can't reasonably have) `DecidablyEmpty` instances, this is necessary to make them actually usable in this context. + ## 0.0.7.0 - 2022-06-23 * Use `commutative-semigroups` for `Commutative`, making `Additive` a diff --git a/README.md b/README.md index 61148a8..6440763 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # patch -[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/patch.svg)](https://hackage.haskell.org/package/patch) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/patch/badge)](https://matrix.hackage.haskell.org/#/package/patch) [![Travis CI](https://api.travis-ci.org/reflex-frp/patch.svg?branch=develop)](https://travis-ci.org/reflex-frp/patch) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/patch/LICENSE) +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/patch.svg)](https://hackage.haskell.org/package/patch) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/patch/LICENSE) Data structures for describing changes to other data structures. diff --git a/cabal.project b/cabal.project index e6fdbad..6210c00 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,4 @@ packages: . + +if arch(javascript) + extra-packages: ghci diff --git a/dep/reflex-platform/github.json b/dep/reflex-platform/github.json deleted file mode 100644 index 9f4cbaa..0000000 --- a/dep/reflex-platform/github.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "owner": "reflex-frp", - "repo": "reflex-platform", - "branch": "develop", - "private": false, - "rev": "ac66356c8839d1dc16cc60887c2db5988a60e6c4", - "sha256": "0zk8pf72lid6cqq4mlr1mcwh6zd5lz9i83kw519aci6mfba1afvq" -} diff --git a/dep/reflex-platform/default.nix b/nix/deps/nix-haskell-ci/default.nix similarity index 100% rename from dep/reflex-platform/default.nix rename to nix/deps/nix-haskell-ci/default.nix diff --git a/nix/deps/nix-haskell-ci/github.json b/nix/deps/nix-haskell-ci/github.json new file mode 100644 index 0000000..a49c4d7 --- /dev/null +++ b/nix/deps/nix-haskell-ci/github.json @@ -0,0 +1,8 @@ +{ + "owner": "reflex-frp", + "repo": "nix-haskell-ci", + "branch": "main", + "private": false, + "rev": "17d1de24e89b9ca2c769d467b093d9c7fe58854e", + "sha256": "01f0dm2rjyiz6dfx8sshdyipmp6vvzx671qnvv88sk6947l0v3cr" +} diff --git a/dep/reflex-platform/thunk.nix b/nix/deps/nix-haskell-ci/thunk.nix similarity index 63% rename from dep/reflex-platform/thunk.nix rename to nix/deps/nix-haskell-ci/thunk.nix index bbf2dc1..20f2d28 100644 --- a/dep/reflex-platform/thunk.nix +++ b/nix/deps/nix-haskell-ci/thunk.nix @@ -2,7 +2,10 @@ let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: if !fetchSubmodules && !private then builtins.fetchTarball { url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; - } else (import {}).fetchFromGitHub { + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { inherit owner repo rev sha256 fetchSubmodules private; }; json = builtins.fromJSON (builtins.readFile ./github.json); diff --git a/nix/deps/nixpkgs/default.nix b/nix/deps/nixpkgs/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/nix/deps/nixpkgs/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/nix/deps/nixpkgs/github.json b/nix/deps/nixpkgs/github.json new file mode 100644 index 0000000..89cfe00 --- /dev/null +++ b/nix/deps/nixpkgs/github.json @@ -0,0 +1,8 @@ +{ + "owner": "NixOS", + "repo": "nixpkgs", + "branch": "nixpkgs-unstable", + "private": false, + "rev": "c7eb65213bd7d95eafb8c5e2e181f04da103d054", + "sha256": "1glf6j13hbwi459qrc8kkkhfw27a08vdg17sr3zwhadg4bkxz5ia" +} diff --git a/nix/deps/nixpkgs/thunk.nix b/nix/deps/nixpkgs/thunk.nix new file mode 100644 index 0000000..20f2d28 --- /dev/null +++ b/nix/deps/nixpkgs/thunk.nix @@ -0,0 +1,12 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/nix/deps/reflex-platform/default.nix b/nix/deps/reflex-platform/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/nix/deps/reflex-platform/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/nix/deps/reflex-platform/github.json b/nix/deps/reflex-platform/github.json new file mode 100644 index 0000000..d5fc383 --- /dev/null +++ b/nix/deps/reflex-platform/github.json @@ -0,0 +1,8 @@ +{ + "owner": "reflex-frp", + "repo": "reflex-platform", + "branch": "develop", + "private": false, + "rev": "34c75631e7f2dd1409847b9df57252b96737e73a", + "sha256": "1nwyybjy65b7qnb62wcm74nqfndr8prr2xsfvaianps0yzm366d0" +} diff --git a/nix/deps/reflex-platform/thunk.nix b/nix/deps/reflex-platform/thunk.nix new file mode 100644 index 0000000..20f2d28 --- /dev/null +++ b/nix/deps/reflex-platform/thunk.nix @@ -0,0 +1,12 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/nix/project/haskell.nix b/nix/project/haskell.nix new file mode 100644 index 0000000..ee8946c --- /dev/null +++ b/nix/project/haskell.nix @@ -0,0 +1,8 @@ +{ compiler ? "ghc910" }: + +{ + project = { + src = ../../.; + compiler-nix-name = compiler; + }; +} diff --git a/nix/release/haskell.nix b/nix/release/haskell.nix new file mode 100644 index 0000000..325d6a4 --- /dev/null +++ b/nix/release/haskell.nix @@ -0,0 +1,5 @@ +{ haskellNix ? null }: + +let ci = import ../deps/nix-haskell-ci (if haskellNix != null then { inherit haskellNix; } else {}); + project = import ../project/haskell.nix {}; +in with ci.haskell-nix; buildMatrix { inherit project; targets = matrix.default; } diff --git a/nix/release/reflex-platform.nix b/nix/release/reflex-platform.nix new file mode 100644 index 0000000..6446822 --- /dev/null +++ b/nix/release/reflex-platform.nix @@ -0,0 +1,66 @@ +{ reflex-platform-fun ? import ../deps/reflex-platform +}: + +let native-reflex-platform = reflex-platform-fun { __useNewerCompiler = true; }; + inherit (native-reflex-platform.nixpkgs) lib; + systems = [ + "x86_64-linux" + # "x86_64-darwin" + ]; + + perPlatform = lib.genAttrs systems (system: let + srcFilter = + builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ + "release.nix" + ".git" + "dist" + "dist-newstyle" + "cabal.haskell-ci" + "cabal.project" + ".travis.yml" + ])); + reflex-platform = reflex-platform-fun { inherit system; __useNewerCompiler = true; }; + compilers = [ + "ghc" + "ghcjs" + ] ++ lib.optionals (reflex-platform.androidSupport) [ + "ghcAndroidAarch64" + "ghcAndroidAarch32" + ] ++ lib.optionals (reflex-platform.iosSupport) [ + "ghcIosAarch64" + ]; + nixpkgsGhcs = + let + pkgs = import ../deps/nixpkgs { inherit system; }; + nixGhc945 = pkgs.haskell.packages.ghc945.override { + }; + nixGhc961 = pkgs.haskell.packages.ghc961.override { + }; + in + { + ghc945 = nixGhc945.callCabal2nix "patch" srcFilter {}; + ghc961 = nixGhc961.callCabal2nix "patch" srcFilter {}; + }; + compilerPkgs = lib.genAttrs compilers (ghc: let + reflex-platform = reflex-platform-fun { + inherit system; + __useNewerCompiler = true; + haskellOverlays = [ + # Use this package's source for reflex + (self: super: { + _dep = super._dep // { + patch = srcFilter ../../.; + }; + }) + ]; + }; + in reflex-platform.${ghc}.patch); + in compilerPkgs // nixpkgsGhcs // { + cache = reflex-platform.pinBuildInputs "patch-${system}" + (builtins.attrValues compilerPkgs); + }); + + metaCache = native-reflex-platform.pinBuildInputs "patch-everywhere" + (map (a: a.cache) (builtins.attrValues perPlatform)); + +in perPlatform // { inherit metaCache; } diff --git a/nix/shell/haskell.nix b/nix/shell/haskell.nix new file mode 100644 index 0000000..e0e2d76 --- /dev/null +++ b/nix/shell/haskell.nix @@ -0,0 +1,6 @@ +{ haskellNix ? null }: + +let ci = import ../deps/nix-haskell-ci (if haskellNix != null then { inherit haskellNix; } else {}); + haskell = ci.nix-haskell; + project = import ../project/haskell.nix {}; +in haskell.project project diff --git a/nix/shell/reflex-platform.nix b/nix/shell/reflex-platform.nix new file mode 100644 index 0000000..426976a --- /dev/null +++ b/nix/shell/reflex-platform.nix @@ -0,0 +1,15 @@ +let + rp = import ../deps/reflex-platform { __useNewerCompiler = true; }; + pkgs = rp.nixpkgs; + system = builtins.currentSystem; +in + pkgs.mkShell { + name = "shell"; + buildInputs = [ + pkgs.cabal-install + pkgs.ghcid + ]; + inputsFrom = [ + (import ../release/reflex-platform.nix {}).${system}.ghc.env + ]; + } diff --git a/patch.cabal b/patch.cabal index dea0d01..7b8b52c 100644 --- a/patch.cabal +++ b/patch.cabal @@ -1,101 +1,121 @@ -Name: patch -Version: 0.0.7.0 -Synopsis: Data structures for describing changes to other data structures. -Description: - Data structures for describing changes to other data structures. - . - In this library, a patch is something which can be applied, analogous to a - function, and which distinguishes returning the argument it was provided from - returning something else. -License: BSD3 -License-file: LICENSE -Author: Ryan Trinkle -Maintainer: maintainer@obsidian.systems -Stability: Experimental -Category: FRP -Build-type: Simple -Cabal-version: >=1.10 -homepage: https://obsidian.systems -bug-reports: https://github.com/reflex-frp/patch/issues +cabal-version: >=1.10 +name: patch +version: 0.0.8.2 +license: BSD3 +license-file: LICENSE +maintainer: maintainer@obsidian.systems +author: Ryan Trinkle +stability: Experimental +tested-with: + ghc ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.5 || ==9.4.5 || ==9.6.1 || ==9.8.2 || ==9.10.1 + ghcjs ==8.6 || ==8.10 + +homepage: https://obsidian.systems +bug-reports: https://github.com/reflex-frp/patch/issues +synopsis: + Data structures for describing changes to other data structures. + +description: + Data structures for describing changes to other data structures. + . + In this library, a patch is something which can be applied, analogous to a + function, and which distinguishes returning the argument it was provided from + returning something else. + +category: FRP +build-type: Simple extra-source-files: - README.md - ChangeLog.md + README.md + ChangeLog.md -tested-with: - GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.2 - GHCJS ==8.4 +source-repository head + type: git + location: https://github.com/reflex-frp/patch flag split-these - description: Use split these/semialign packages - manual: False - default: True + description: Use split these/semialign packages + +flag hlint + description: Enable hlint test library - hs-source-dirs: src - default-language: Haskell2010 - build-depends: base >= 4.9 && < 4.17 - , constraints-extras >= 0.3 && < 0.4 - , commutative-semigroups >= 0.0 && < 0.2 - , containers >= 0.6 && < 0.7 - , dependent-map >= 0.3 && < 0.5 - , dependent-sum >= 0.6 && < 0.8 - , lens >= 4.7 && < 5.2 - , indexed-traversable >= 0.1 && < 0.2 - , semigroupoids >= 4.0 && < 6 - , transformers >= 0.5.6.0 && < 0.7 - , witherable >= 0.3 && < 0.5 - - if impl(ghc < 8.6) -- really, if base < 8.12 - build-depends: base-orphans >= 0.8 && < 0.9 - - exposed-modules: Data.Functor.Misc - , Data.Monoid.DecidablyEmpty - , Data.Patch - , Data.Patch.Class - , Data.Patch.DMap - , Data.Patch.DMapWithMove - , Data.Patch.IntMap - , Data.Patch.Map - , Data.Patch.MapWithMove - , Data.Patch.MapWithPatchingMove - , Data.Patch.PatchOrReplacement - , Data.Semigroup.Additive - - ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs - default-extensions: PolyKinds - - if flag(split-these) - build-depends: these >= 1 && <1.2 - , semialign >=1 && <1.3 - else - build-depends: these >= 0.4 && <0.9 + exposed-modules: + Data.Functor.Misc + Data.Monoid.DecidablyEmpty + Data.Patch + Data.Patch.Class + Data.Patch.DMap + Data.Patch.DMapWithMove + Data.Patch.IntMap + Data.Patch.Map + Data.Patch.MapWithMove + Data.Patch.MapWithPatchingMove + Data.Patch.PatchOrReplacement + Data.Semigroup.Additive + + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: PolyKinds + ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs + build-depends: + base >=4.9 && <=4.21, + constraints-extras >=0.3 && <0.5, + commutative-semigroups >=0.0 && <0.3, + containers >=0.6 && <0.8, + dependent-map >=0.3 && <0.5, + dependent-sum >=0.6 && <0.8, + lens >=4.7 && <5.4, + indexed-traversable >=0.1 && <0.2, + semigroupoids >=4.0 && <7, + transformers >=0.5.6.0 && <0.7, + witherable >=0.3 && <0.6 + + if impl(ghc <8.6) + build-depends: base-orphans >=0.8 && <0.10 + + if flag(split-these) + build-depends: + these >=1 && <1.3, + semialign >=1 && <1.4 + + else + build-depends: + these >=0.4 && <0.9 test-suite tests - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: tests.hs - hs-source-dirs: test - build-depends: base - , patch - , containers - , hedgehog - , HUnit - if impl(ghcjs) - buildable: False + type: exitcode-stdio-1.0 + main-is: tests.hs + hs-source-dirs: test + default-language: Haskell2010 + build-depends: + base, + patch, + containers, + hedgehog <1.6, + HUnit <1.7 + + if (impl(ghcjs >=0) || arch(javascript)) + buildable: False test-suite hlint - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: hlint.hs - hs-source-dirs: test - build-depends: base - , directory - , filepath - , filemanip - , hlint (< 2.1 || >= 2.2.2) && < 3.5 - if impl(ghcjs) - buildable: False + type: exitcode-stdio-1.0 + main-is: hlint.hs + hs-source-dirs: test + default-language: Haskell2010 + build-depends: + base, + directory, + filepath, + filemanip -source-repository head - type: git - location: https://github.com/reflex-frp/patch + if impl(ghc >=9.6) + buildable: False + + if impl(ghc <9.2) + build-depends: hlint (<2.1 || >=2.2.2) && <3.5 + + else + build-depends: hlint >=3.5 && <3.6 + + if ((impl(ghcjs >=0) || arch(javascript)) || !flag(hlint)) + buildable: False diff --git a/release.nix b/release.nix index addf765..1ec7dcc 100644 --- a/release.nix +++ b/release.nix @@ -1,49 +1,11 @@ -{ reflex-platform-fun ? import ./dep/reflex-platform -}: +{ pkgs ? import {} }: -let - native-reflex-platform = reflex-platform-fun {}; - inherit (native-reflex-platform.nixpkgs) lib; - systems = ["x86_64-linux" "x86_64-darwin"]; +let reflex-platform-release = import ./nix/release/reflex-platform.nix {}; + haskell-nix-release = import ./nix/release/haskell.nix {}; - perPlatform = lib.genAttrs systems (system: let - reflex-platform = reflex-platform-fun { inherit system; }; - compilers = [ - "ghc" - "ghcjs" - ] ++ lib.optionals (reflex-platform.androidSupport) [ - "ghcAndroidAarch64" - "ghcAndroidAarch32" - ] ++ lib.optionals (reflex-platform.iosSupport) [ - "ghcIosAarch64" - ]; - compilerPkgs = lib.genAttrs compilers (ghc: let - reflex-platform = reflex-platform-fun { - inherit system; - haskellOverlays = [ - # Use this package's source for reflex - (self: super: { - _dep = super._dep // { - patch = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ - "release.nix" - ".git" - "dist" - "dist-newstyle" - "cabal.haskell-ci" - "cabal.project" - ".travis.yml" - ])) ./.; - }; - }) - ]; - }; - in reflex-platform.${ghc}.patch); - in compilerPkgs // { - cache = reflex-platform.pinBuildInputs "patch-${system}" - (builtins.attrValues compilerPkgs); - }); +in pkgs.runCommand "release" {} '' + mkdir -p $out - metaCache = native-reflex-platform.pinBuildInputs "patch-everywhere" - (map (a: a.cache) (builtins.attrValues perPlatform)); - -in perPlatform // { inherit metaCache; } + ln -s ${reflex-platform-release.metaCache} $out/reflex-platform + ln -s ${haskell-nix-release} $out/haskell-nix +'' diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..234896a --- /dev/null +++ b/shell.nix @@ -0,0 +1,9 @@ +{ pkgs ? import {} }: + +let reflex-platform-shell = import ./nix/shell/reflex-platform.nix; + haskell-nix-shell = import ./nix/shell/haskell.nix {}; + +in { + inherit reflex-platform-shell; + inherit haskell-nix-shell; +} diff --git a/src/Data/Monoid/DecidablyEmpty.hs b/src/Data/Monoid/DecidablyEmpty.hs index 3685a0d..e007253 100644 --- a/src/Data/Monoid/DecidablyEmpty.hs +++ b/src/Data/Monoid/DecidablyEmpty.hs @@ -61,8 +61,10 @@ instance #endif => DecidablyEmpty (Maybe a) where isEmpty = isNothing -deriving instance (Num a, DecidablyEmpty a) => DecidablyEmpty (Product a) -deriving instance (DecidablyEmpty a, Num a) => DecidablyEmpty (Sum a) +instance (Num a, Eq a) => DecidablyEmpty (Product a) where + isEmpty = (== 1) +instance (Num a, Eq a) => DecidablyEmpty (Sum a) where + isEmpty = (== 0) deriving instance DecidablyEmpty a => DecidablyEmpty (Dual a) instance DecidablyEmpty (First a) where isEmpty (First a) = isNothing a diff --git a/src/Data/Patch.hs b/src/Data/Patch.hs index c4ef11c..16a8da5 100644 --- a/src/Data/Patch.hs +++ b/src/Data/Patch.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-| Description: @@ -15,7 +15,7 @@ module Data.Patch import Data.Semigroup (Semigroup (..)) #endif -import qualified Data.Semigroup.Additive as X +import Data.Semigroup.Commutative as X import Data.Patch.Class as X import Data.Patch.DMap as X hiding (getDeletions) import Data.Patch.DMapWithMove as X diff --git a/src/Data/Patch/Class.hs b/src/Data/Patch/Class.hs index 55c512f..6bfb03a 100644 --- a/src/Data/Patch/Class.hs +++ b/src/Data/Patch/Class.hs @@ -12,9 +12,13 @@ module Data.Patch.Class where import Data.Functor.Identity import Data.Kind (Type) import Data.Maybe +import Data.Semigroup + ( Sum (..) + , Product (..) #if !MIN_VERSION_base(4,11,0) -import Data.Semigroup (Semigroup(..)) + , Semigroup(..) #endif + ) import Data.Proxy -- | A 'Patch' type represents a kind of change made to a datastructure. @@ -41,6 +45,14 @@ instance forall (a :: Type). Patch (Proxy a) where type PatchTarget (Proxy a) = a apply ~Proxy _ = Nothing +instance (Num a, Eq a) => Patch (Sum a) where + type PatchTarget (Sum a) = a + apply (Sum a) b = if a == 0 then Nothing else Just $ a + b + +instance (Num a, Eq a) => Patch (Product a) where + type PatchTarget (Product a) = a + apply (Product a) b = if a == 1 then Nothing else Just $ a * b + -- | Like '(.)', but composes functions that return patches rather than -- functions that return new values. The Semigroup instance for patches must -- apply patches right-to-left, like '(.)'. diff --git a/src/Data/Patch/IntMap.hs b/src/Data/Patch/IntMap.hs index 9866596..f483f7f 100644 --- a/src/Data/Patch/IntMap.hs +++ b/src/Data/Patch/IntMap.hs @@ -6,6 +6,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-| Description: Module containing 'PatchIntMap', a 'Patch' for 'IntMap'. diff --git a/src/Data/Patch/Map.hs b/src/Data/Patch/Map.hs index c971255..c240460 100644 --- a/src/Data/Patch/Map.hs +++ b/src/Data/Patch/Map.hs @@ -7,6 +7,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-| Description: A basic 'Patch' on 'Map' diff --git a/src/Data/Patch/MapWithMove.hs b/src/Data/Patch/MapWithMove.hs index d0c834e..5a9aa81 100644 --- a/src/Data/Patch/MapWithMove.hs +++ b/src/Data/Patch/MapWithMove.hs @@ -12,6 +12,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-| diff --git a/src/Data/Patch/MapWithPatchingMove.hs b/src/Data/Patch/MapWithPatchingMove.hs index 2202ed6..82aaf26 100644 --- a/src/Data/Patch/MapWithPatchingMove.hs +++ b/src/Data/Patch/MapWithPatchingMove.hs @@ -9,6 +9,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-| @@ -23,6 +24,7 @@ module Data.Patch.MapWithPatchingMove , patchMapWithPatchingMoveInsertAll , insertMapKey , moveMapKey + , patchMapKey , swapMapKey , deleteMapKey , unsafePatchMapWithPatchingMove @@ -135,6 +137,18 @@ moveMapKey src dst , (src, NodeInfo From_Delete (Just dst)) ] +patchMapKey + :: ( DecidablyEmpty p +#if !MIN_VERSION_base(4,11,0) + , Semigroup p +#endif + ) + => k -> p -> PatchMapWithPatchingMove k p +patchMapKey k p + | isEmpty p = PatchMapWithPatchingMove Map.empty + | otherwise = + PatchMapWithPatchingMove $ Map.singleton k $ NodeInfo (From_Move k p) (Just k) + -- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to: -- -- @ @@ -217,8 +231,9 @@ patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybe Just (from, to) reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted g (to, _) (from, _) = if to == from then Nothing else - let Just movingTo = Map.lookup from reverseMapping + let movingTo = fromMaybe err $ Map.lookup from reverseMapping in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo) + err = error "IMPOSSIBLE happens in patchThatSortsMapWith" -- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided, -- will produce a 'Map' with the same values as the second 'Map' but with the @@ -369,46 +384,78 @@ instance ( Ord k , DecidablyEmpty p , Patch p ) => Semigroup (PatchMapWithPatchingMove k p) where - PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m + PatchMapWithPatchingMove mNew <> PatchMapWithPatchingMove mOld = PatchMapWithPatchingMove m where - connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb - h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)] - h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of + connections = Map.elems $ Map.intersectionWithKey (\_ new old -> (_nodeInfo_to new, _nodeInfo_from old)) mNew mOld + h :: (Maybe k, From k p) -> [(k, Fixup k p)] + h = \case (Just toAfter, From_Move fromBefore p) | fromBefore == toAfter && isEmpty p - -> [(toAfter, Fixup_Delete)] + -> [ (toAfter, Fixup_Delete) + ] | otherwise - -> [ (toAfter, Fixup_Update (This editBefore)) - , (fromBefore, Fixup_Update (That mToAfter)) + -> [ (toAfter, Fixup_Update (This (From_Move fromBefore p))) + , (fromBefore, Fixup_Update (That (Just toAfter))) ] - (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map - (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))] + (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That Nothing))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map + (Just toAfter, editBefore) -> [(toAfter, Fixup_Update (This editBefore))] (Nothing, _) -> [] - mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete - mergeFixups _ (Fixup_Update a) (Fixup_Update b) + mergeFixups Fixup_Delete Fixup_Delete = Fixup_Delete + mergeFixups (Fixup_Update a) (Fixup_Update b) | This x <- a, That y <- b = Fixup_Update $ These x y | That y <- a, This x <- b = Fixup_Update $ These x y - mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups" - fixups = Map.fromListWithKey mergeFixups $ concatMap h connections - combineNodeInfos _ nia nib = NodeInfo - { _nodeInfo_from = _nodeInfo_from nia - , _nodeInfo_to = _nodeInfo_to nib + mergeFixups _ _ = error "PatchMapWithPatchingMove: incompatible fixups" + fixups = Map.fromListWithKey (\_ -> mergeFixups) $ concatMap h connections + combineNodeInfos niNew niOld = NodeInfo + { _nodeInfo_from = _nodeInfo_from niNew + , _nodeInfo_to = _nodeInfo_to niOld } - applyFixup _ ni = \case + applyFixup ni = \case Fixup_Delete -> Nothing Fixup_Update u -> Just $ NodeInfo { _nodeInfo_from = case _nodeInfo_from ni of - f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch - Nothing -> f -- If there's no `from` fixup, just use the "new" `from` + -- The new patch has a Move, so it could be affected by the + -- corresponding From in the old patch. If that From exists, then + -- it is in the fixup here. + f@(From_Move _ p') -> case getHere u of + -- If there's no `From` fixup, just use the "new" `From` + Nothing -> f + -- If there's a `From` fixup which is an Insert, we can just apply + -- our patch to that and turn ourselves into an insert. Just (From_Insert v) -> From_Insert $ applyAlways p' v + -- If there's a `From` fixup which is a Delete, then we can throw + -- our patch away because there's nothing to apply it to and + -- become a Delete ourselves. Just From_Delete -> From_Delete + -- If there's a `From` fixup which is a Move, we need to apply + -- both the old patch and the new patch (in that order) to the + -- value, so we append the patches here. Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p - _ -> error "PatchMapWithPatchingMove: fixup for non-move From" - , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u + -- If the new patch has an Insert, it doesn't care what the fixup + -- value is, because it will overwrite it anyway. + f@(From_Insert _) -> f + -- If the new patch has an Delete, it doesn't care what the fixup + -- value is, because it will overwrite it anyway. + f@From_Delete -> f + , _nodeInfo_to = case _nodeInfo_to ni of + -- The old patch deletes this data, so we must delete it as well. + -- According to the code above, any time we have this situation we + -- should also have `getThere u == Nothing` because a fixup + -- shouldn't be generated. + Nothing -> Nothing + -- The old patch sends the value to oldToAfter + Just oldToAfter -> case getThere u of + -- If there is no fixup, that should mean that the new patch + -- doesn't do anything with the value in oldToAfter, so we still + -- send it to oldToAfter + Nothing -> Just oldToAfter + -- If there is a fixup, it should tell us where the new patch + -- sends the value at key oldToAfter. We send our value there. + Just mNewToAfter -> mNewToAfter } - m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups + m = Map.differenceWithKey (\_ -> applyFixup) (Map.unionWith combineNodeInfos mNew mOld) fixups getHere :: These a b -> Maybe a getHere = \case This a -> Just a diff --git a/test/tests.hs b/test/tests.hs index 7094bb2..fd061c3 100644 --- a/test/tests.hs +++ b/test/tests.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Main where import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test) import Data.Patch ( Patch(apply) ) import Data.Patch.MapWithMove ( patchThatChangesMap ) +import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove) +import qualified Data.Patch.MapWithPatchingMove as PatchMapWithPatchingMove import Data.Map as Map ( Map, fromList, singleton ) import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===)) import Hedgehog.Gen as Gen ( int ) @@ -11,18 +14,31 @@ import Hedgehog.Range as Range ( linear ) import Control.Monad (replicateM) import System.Exit (exitFailure, exitSuccess) import Data.Sequence as Seq ( foldMapWithIndex, replicateM ) +import Data.Semigroup + ( Sum (..) +#if !MIN_VERSION_base(4,11,0) + , Semigroup(..) +#endif + ) main :: IO () main = do - counts <- runTestTT $ test [ - "Simple Move" ~: (do + counts <- runTestTT $ test + [ "Simple Move" ~: do let mapBefore = Map.fromList [(0,1)] mapAfter = Map.fromList [(0,0),(1,1)] patch = patchThatChangesMap mapBefore mapAfter afterPatch = apply patch mapBefore - assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch), - "Property Checks" ~: propertyChecks - ] + assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch + , "Property Checks" ~: propertyChecks + , "Insert and Patch" ~: do + let i :: PatchMapWithPatchingMove () (Sum Int) + i = PatchMapWithPatchingMove.insertMapKey () 1 + p = PatchMapWithPatchingMove.patchMapKey () (Sum 2) + pAfterI = PatchMapWithPatchingMove.insertMapKey () 3 + assertEqual "Insert after patch is the same as insert" (i <> p) i + assertEqual "Patch after insert is a patched insert" (p <> i) pAfterI + ] if errors counts + failures counts == 0 then exitSuccess else exitFailure propertyChecks :: IO Bool