From 0829f64ce339a1d1f6f4cc603c5f15075facd20e Mon Sep 17 00:00:00 2001 From: kokobd Date: Mon, 6 Mar 2023 10:19:01 +0800 Subject: [PATCH 01/24] setup project --- CHANGELOG.md | 0 LICENSE | 29 ++++++++++++++++++++++ flake.lock | 59 ++++++++++++++++++++++++++++++++++++++++++++ flake.nix | 43 ++++++++++++++++++++++++++++++++ src/Data/Timeline.hs | 1 + timeline.cabal | 36 +++++++++++++++++++++++++++ timeline.nix | 9 +++++++ 7 files changed, 177 insertions(+) create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 src/Data/Timeline.hs create mode 100644 timeline.cabal create mode 100644 timeline.nix diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..e69de29 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e8308e6 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (C) 2023 Bellroy Pty Ltd + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..60e567b --- /dev/null +++ b/flake.lock @@ -0,0 +1,59 @@ +{ + "nodes": { + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1673956053, + "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-utils": { + "locked": { + "lastModified": 1676283394, + "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1678062977, + "narHash": "sha256-i+wOuZ8arDBldx/5VdhSbv3XoOZsrleaJ/ydP74szIc=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "d154f809e9c3c47fee72186aa3ff6479403435d4", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-compat": "flake-compat", + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..b96d950 --- /dev/null +++ b/flake.nix @@ -0,0 +1,43 @@ +{ + description = "A simple library for handling data that changes over time"; + + inputs = { + flake-compat = { + url = "github:edolstra/flake-compat"; + flake = false; + }; + flake-utils.url = "github:numtide/flake-utils"; + nixpkgs.url = "github:nixos/nixpkgs"; + }; + + outputs = inputs: + inputs.flake-utils.lib.eachDefaultSystem (system: + let + pkgs = import inputs.nixpkgs { inherit system; }; + makePackage = haskellPackages: haskellPackages.callPackage ./timeline.nix { }; + in + rec + { + packages = { + default = makePackage pkgs.haskellPackages; + ghc884 = makePackage pkgs.haskell.packages.ghc884; + ghc8107 = makePackage pkgs.haskell.packages.ghc8107; + ghc902 = makePackage pkgs.haskell.packages.ghc902; + ghc921 = makePackage pkgs.haskell.packages.ghc921; + }; + + devShells = builtins.mapAttrs + (_: v: v.env.overrideAttrs (oldAttrs: { + buildInputs = oldAttrs.buildInputs + ++ [ pkgs.nixpkgs-fmt ] + ++ (with pkgs.haskellPackages; [ + cabal-fmt + cabal-install + doctest + haskell-ci + hlint + ]); + })) + packages; + }); +} \ No newline at end of file diff --git a/src/Data/Timeline.hs b/src/Data/Timeline.hs new file mode 100644 index 0000000..1a18f0a --- /dev/null +++ b/src/Data/Timeline.hs @@ -0,0 +1 @@ +module Data.Timeline where \ No newline at end of file diff --git a/timeline.cabal b/timeline.cabal new file mode 100644 index 0000000..11da7b7 --- /dev/null +++ b/timeline.cabal @@ -0,0 +1,36 @@ +cabal-version: 2.2 +name: timeline +version: 0.1.0.0 +synopsis: A simple library for handling data that changes over time +license: Apache-2.0 +license-file: LICENSE +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +category: Development +build-type: Simple +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/bellroy/timeline.git + +common deps + build-depends: base >=4.13.0.0 && <4.18 + +library + import: deps + exposed-modules: Data.Timeline + hs-source-dirs: src/ + default-language: Haskell2010 + ghc-options: -fwarn-unused-imports -Wall -fno-warn-unused-do-bind + + if flag(developer) + ghc-options: -Werror + +flag developer + manual: True + default: False + description: compile with -Werror to make warnings fatal diff --git a/timeline.nix b/timeline.nix new file mode 100644 index 0000000..e443632 --- /dev/null +++ b/timeline.nix @@ -0,0 +1,9 @@ +{ mkDerivation, base, lib }: +mkDerivation { + pname = "timeline"; + version = "0.1.0.0"; + src = ./.; + libraryHaskellDepends = [ base ]; + description = "A simple library for handling data that changes over time"; + license = lib.licenses.asl20; +} From 22dbdea5eba041fe2689fcb93abcf09e8615f942 Mon Sep 17 00:00:00 2001 From: kokobd Date: Mon, 6 Mar 2023 16:05:13 +0800 Subject: [PATCH 02/24] add timeline packages --- .gitignore | 3 + cabal.project | 5 + flake.lock | 889 +++++++++++++++++- flake.nix | 95 +- src/Data/Timeline.hs | 1 - LICENSE => timeline-hedgehog/LICENSE | 0 .../src/Data/Timeline/Hedgehog.hs | 38 + timeline-hedgehog/timeline-hedgehog.cabal | 29 + timeline-tests/LICENSE | 29 + timeline-tests/test/Main.hs | 1 + timeline-tests/test/Spec/Data/Timeline.hs | 250 +++++ ...ll_non-overlapping_situations_together.txt | 10 + .../golden/one_change,_with_effective_to.txt | 6 + timeline-tests/test/golden/one_change.txt | 5 + timeline-tests/test/golden/overlaps.txt | 6 + .../test/golden/two_groups_of_overlap.txt | 8 + timeline-tests/timeline-tests.cabal | 38 + timeline.cabal | 36 - timeline.nix | 9 - timeline/LICENSE | 29 + timeline/src/Data/Timeline.hs | 21 + timeline/src/Data/Timeline/Internal.hs | 312 ++++++ timeline/timeline.cabal | 33 + 23 files changed, 1771 insertions(+), 82 deletions(-) create mode 100644 .gitignore create mode 100644 cabal.project delete mode 100644 src/Data/Timeline.hs rename LICENSE => timeline-hedgehog/LICENSE (100%) create mode 100644 timeline-hedgehog/src/Data/Timeline/Hedgehog.hs create mode 100644 timeline-hedgehog/timeline-hedgehog.cabal create mode 100644 timeline-tests/LICENSE create mode 100644 timeline-tests/test/Main.hs create mode 100644 timeline-tests/test/Spec/Data/Timeline.hs create mode 100644 timeline-tests/test/golden/all_non-overlapping_situations_together.txt create mode 100644 timeline-tests/test/golden/one_change,_with_effective_to.txt create mode 100644 timeline-tests/test/golden/one_change.txt create mode 100644 timeline-tests/test/golden/overlaps.txt create mode 100644 timeline-tests/test/golden/two_groups_of_overlap.txt create mode 100644 timeline-tests/timeline-tests.cabal delete mode 100644 timeline.cabal delete mode 100644 timeline.nix create mode 100644 timeline/LICENSE create mode 100644 timeline/src/Data/Timeline.hs create mode 100644 timeline/src/Data/Timeline/Internal.hs create mode 100644 timeline/timeline.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..ec1d88b --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.vscode/ +.direnv/ +.envrc \ No newline at end of file diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..6476bb5 --- /dev/null +++ b/cabal.project @@ -0,0 +1,5 @@ +packages: + ./timeline + ./timeline-hedgehog + ./timeline-tests +tests: True \ No newline at end of file diff --git a/flake.lock b/flake.lock index 60e567b..346467a 100644 --- a/flake.lock +++ b/flake.lock @@ -1,5 +1,161 @@ { "nodes": { + "HTTP": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, + "blank": { + "locked": { + "lastModified": 1625557891, + "narHash": "sha256-O8/MWsPBGhhyPoPLHZAuoZiiHo9q6FLlEeIDEXuj6T4=", + "owner": "divnix", + "repo": "blank", + "rev": "5a5d2684073d9f563072ed07c871d577a6c614a8", + "type": "github" + }, + "original": { + "owner": "divnix", + "repo": "blank", + "type": "github" + } + }, + "cabal-32": { + "flake": false, + "locked": { + "lastModified": 1603716527, + "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", + "owner": "haskell", + "repo": "cabal", + "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.2", + "repo": "cabal", + "type": "github" + } + }, + "cabal-34": { + "flake": false, + "locked": { + "lastModified": 1645834128, + "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", + "owner": "haskell", + "repo": "cabal", + "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.4", + "repo": "cabal", + "type": "github" + } + }, + "cabal-36": { + "flake": false, + "locked": { + "lastModified": 1669081697, + "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", + "owner": "haskell", + "repo": "cabal", + "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.6", + "repo": "cabal", + "type": "github" + } + }, + "cardano-shell": { + "flake": false, + "locked": { + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "cardano-shell", + "type": "github" + } + }, + "devshell": { + "inputs": { + "flake-utils": [ + "haskellNix", + "tullia", + "std", + "flake-utils" + ], + "nixpkgs": [ + "haskellNix", + "tullia", + "std", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1663445644, + "narHash": "sha256-+xVlcK60x7VY1vRJbNUEAHi17ZuoQxAIH4S4iUFUGBA=", + "owner": "numtide", + "repo": "devshell", + "rev": "e3dc3e21594fe07bdb24bdf1c8657acaa4cb8f66", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "devshell", + "type": "github" + } + }, + "dmerge": { + "inputs": { + "nixlib": [ + "haskellNix", + "tullia", + "std", + "nixpkgs" + ], + "yants": [ + "haskellNix", + "tullia", + "std", + "yants" + ] + }, + "locked": { + "lastModified": 1659548052, + "narHash": "sha256-fzI2gp1skGA8mQo/FBFrUAtY0GQkAIAaV/V127TJPyY=", + "owner": "divnix", + "repo": "data-merge", + "rev": "d160d18ce7b1a45b88344aa3f13ed1163954b497", + "type": "github" + }, + "original": { + "owner": "divnix", + "repo": "data-merge", + "type": "github" + } + }, "flake-compat": { "flake": false, "locked": { @@ -16,6 +172,39 @@ "type": "github" } }, + "flake-compat_2": { + "flake": false, + "locked": { + "lastModified": 1672831974, + "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", + "owner": "input-output-hk", + "repo": "flake-compat", + "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "hkm/gitlab-fix", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-compat_3": { + "flake": false, + "locked": { + "lastModified": 1650374568, + "narHash": "sha256-Z+s0J8/r907g149rllvwhb4pKi8Wam5ij0st8PwAh+E=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "b4a34015c698c7793d592d66adbab377907a2be8", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, "flake-utils": { "locked": { "lastModified": 1676283394, @@ -31,26 +220,718 @@ "type": "github" } }, + "flake-utils_2": { + "locked": { + "lastModified": 1667395993, + "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_3": { + "locked": { + "lastModified": 1653893745, + "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_4": { + "locked": { + "lastModified": 1659877975, + "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "ghc-8.6.5-iohk": { + "flake": false, + "locked": { + "lastModified": 1600920045, + "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "owner": "input-output-hk", + "repo": "ghc", + "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "release/8.6.5-iohk", + "repo": "ghc", + "type": "github" + } + }, + "gomod2nix": { + "inputs": { + "nixpkgs": "nixpkgs_2", + "utils": "utils" + }, + "locked": { + "lastModified": 1655245309, + "narHash": "sha256-d/YPoQ/vFn1+GTmSdvbSBSTOai61FONxB4+Lt6w/IVI=", + "owner": "tweag", + "repo": "gomod2nix", + "rev": "40d32f82fc60d66402eb0972e6e368aeab3faf58", + "type": "github" + }, + "original": { + "owner": "tweag", + "repo": "gomod2nix", + "type": "github" + } + }, + "hackage": { + "flake": false, + "locked": { + "lastModified": 1677976124, + "narHash": "sha256-tkvipSaI9asnkgrMT0xQfArOQBIR0T4N1B6dBPKy/OM=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "7a4c7ed70e382aaa8fd65cc2af57bdf920320ddc", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "haskellNix": { + "inputs": { + "HTTP": "HTTP", + "cabal-32": "cabal-32", + "cabal-34": "cabal-34", + "cabal-36": "cabal-36", + "cardano-shell": "cardano-shell", + "flake-compat": "flake-compat_2", + "flake-utils": "flake-utils_2", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "hackage": "hackage", + "hpc-coveralls": "hpc-coveralls", + "hydra": "hydra", + "iserv-proxy": "iserv-proxy", + "nixpkgs": [ + "haskellNix", + "nixpkgs-unstable" + ], + "nixpkgs-2003": "nixpkgs-2003", + "nixpkgs-2105": "nixpkgs-2105", + "nixpkgs-2111": "nixpkgs-2111", + "nixpkgs-2205": "nixpkgs-2205", + "nixpkgs-2211": "nixpkgs-2211", + "nixpkgs-unstable": "nixpkgs-unstable", + "old-ghc-nix": "old-ghc-nix", + "stackage": "stackage", + "tullia": "tullia" + }, + "locked": { + "lastModified": 1677977488, + "narHash": "sha256-y7qsroBhVMWGz10oWRflBpigfQjAYG46nt/oPCCKcRE=", + "owner": "input-output-hk", + "repo": "haskell.nix", + "rev": "8d21196826dac2f92ec43d30fd183452621af379", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "haskell.nix", + "type": "github" + } + }, + "hpc-coveralls": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "hydra": { + "inputs": { + "nix": "nix", + "nixpkgs": [ + "haskellNix", + "hydra", + "nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1671755331, + "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", + "owner": "NixOS", + "repo": "hydra", + "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", + "type": "github" + }, + "original": { + "id": "hydra", + "type": "indirect" + } + }, + "incl": { + "inputs": { + "nixlib": [ + "haskellNix", + "tullia", + "std", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1669263024, + "narHash": "sha256-E/+23NKtxAqYG/0ydYgxlgarKnxmDbg6rCMWnOBqn9Q=", + "owner": "divnix", + "repo": "incl", + "rev": "ce7bebaee048e4cd7ebdb4cee7885e00c4e2abca", + "type": "github" + }, + "original": { + "owner": "divnix", + "repo": "incl", + "type": "github" + } + }, + "iserv-proxy": { + "flake": false, + "locked": { + "lastModified": 1670983692, + "narHash": "sha256-avLo34JnI9HNyOuauK5R69usJm+GfW3MlyGlYxZhTgY=", + "ref": "hkm/remote-iserv", + "rev": "50d0abb3317ac439a4e7495b185a64af9b7b9300", + "revCount": 10, + "type": "git", + "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + }, + "original": { + "ref": "hkm/remote-iserv", + "type": "git", + "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" + } + }, + "lowdown-src": { + "flake": false, + "locked": { + "lastModified": 1633514407, + "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", + "owner": "kristapsdz", + "repo": "lowdown", + "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", + "type": "github" + }, + "original": { + "owner": "kristapsdz", + "repo": "lowdown", + "type": "github" + } + }, + "n2c": { + "inputs": { + "flake-utils": [ + "haskellNix", + "tullia", + "std", + "flake-utils" + ], + "nixpkgs": [ + "haskellNix", + "tullia", + "std", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1665039323, + "narHash": "sha256-SAh3ZjFGsaCI8FRzXQyp56qcGdAqgKEfJWPCQ0Sr7tQ=", + "owner": "nlewo", + "repo": "nix2container", + "rev": "b008fe329ffb59b67bf9e7b08ede6ee792f2741a", + "type": "github" + }, + "original": { + "owner": "nlewo", + "repo": "nix2container", + "type": "github" + } + }, + "nix": { + "inputs": { + "lowdown-src": "lowdown-src", + "nixpkgs": "nixpkgs", + "nixpkgs-regression": "nixpkgs-regression" + }, + "locked": { + "lastModified": 1661606874, + "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", + "owner": "NixOS", + "repo": "nix", + "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "2.11.0", + "repo": "nix", + "type": "github" + } + }, + "nix-nomad": { + "inputs": { + "flake-compat": "flake-compat_3", + "flake-utils": [ + "haskellNix", + "tullia", + "nix2container", + "flake-utils" + ], + "gomod2nix": "gomod2nix", + "nixpkgs": [ + "haskellNix", + "tullia", + "nixpkgs" + ], + "nixpkgs-lib": [ + "haskellNix", + "tullia", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1658277770, + "narHash": "sha256-T/PgG3wUn8Z2rnzfxf2VqlR1CBjInPE0l1yVzXxPnt0=", + "owner": "tristanpemble", + "repo": "nix-nomad", + "rev": "054adcbdd0a836ae1c20951b67ed549131fd2d70", + "type": "github" + }, + "original": { + "owner": "tristanpemble", + "repo": "nix-nomad", + "type": "github" + } + }, + "nix2container": { + "inputs": { + "flake-utils": "flake-utils_3", + "nixpkgs": "nixpkgs_3" + }, + "locked": { + "lastModified": 1658567952, + "narHash": "sha256-XZ4ETYAMU7XcpEeAFP3NOl9yDXNuZAen/aIJ84G+VgA=", + "owner": "nlewo", + "repo": "nix2container", + "rev": "60bb43d405991c1378baf15a40b5811a53e32ffa", + "type": "github" + }, + "original": { + "owner": "nlewo", + "repo": "nix2container", + "type": "github" + } + }, + "nixago": { + "inputs": { + "flake-utils": [ + "haskellNix", + "tullia", + "std", + "flake-utils" + ], + "nixago-exts": [ + "haskellNix", + "tullia", + "std", + "blank" + ], + "nixpkgs": [ + "haskellNix", + "tullia", + "std", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1661824785, + "narHash": "sha256-/PnwdWoO/JugJZHtDUioQp3uRiWeXHUdgvoyNbXesz8=", + "owner": "nix-community", + "repo": "nixago", + "rev": "8c1f9e5f1578d4b2ea989f618588d62a335083c3", + "type": "github" + }, + "original": { + "owner": "nix-community", + "repo": "nixago", + "type": "github" + } + }, "nixpkgs": { "locked": { - "lastModified": 1678062977, - "narHash": "sha256-i+wOuZ8arDBldx/5VdhSbv3XoOZsrleaJ/ydP74szIc=", + "lastModified": 1657693803, + "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-22.05-small", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2003": { + "locked": { + "lastModified": 1620055814, + "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-20.03-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2105": { + "locked": { + "lastModified": 1659914493, + "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2111": { + "locked": { + "lastModified": 1659446231, + "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2205": { + "locked": { + "lastModified": 1672580127, + "narHash": "sha256-3lW3xZslREhJogoOkjeZtlBtvFMyxHku7I/9IVehhT8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "0874168639713f547c05947c76124f78441ea46c", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2211": { + "locked": { + "lastModified": 1675730325, + "narHash": "sha256-uNvD7fzO5hNlltNQUAFBPlcEjNG5Gkbhl/ROiX+GZU4=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "b7ce17b1ebf600a72178f6302c77b6382d09323f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-regression": { + "locked": { + "lastModified": 1643052045, + "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "type": "github" + } + }, + "nixpkgs-unstable": { + "locked": { + "lastModified": 1675758091, + "narHash": "sha256-7gFSQbSVAFUHtGCNHPF7mPc5CcqDk9M2+inlVPZSneg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "747927516efcb5e31ba03b7ff32f61f6d47e7d87", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1653581809, + "narHash": "sha256-Uvka0V5MTGbeOfWte25+tfRL3moECDh1VwokWSZUdoY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "83658b28fe638a170a19b8933aa008b30640fbd1", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_3": { + "locked": { + "lastModified": 1654807842, + "narHash": "sha256-ADymZpr6LuTEBXcy6RtFHcUZdjKTBRTMYwu19WOx17E=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "fc909087cc3386955f21b4665731dbdaceefb1d8", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_4": { + "locked": { + "lastModified": 1665087388, + "narHash": "sha256-FZFPuW9NWHJteATOf79rZfwfRn5fE0wi9kRzvGfDHPA=", "owner": "nixos", "repo": "nixpkgs", - "rev": "d154f809e9c3c47fee72186aa3ff6479403435d4", + "rev": "95fda953f6db2e9496d2682c4fc7b82f959878f7", "type": "github" }, "original": { "owner": "nixos", + "ref": "nixpkgs-unstable", "repo": "nixpkgs", "type": "github" } }, + "nosys": { + "locked": { + "lastModified": 1667881534, + "narHash": "sha256-FhwJ15uPLRsvaxtt/bNuqE/ykMpNAPF0upozFKhTtXM=", + "owner": "divnix", + "repo": "nosys", + "rev": "2d0d5207f6a230e9d0f660903f8db9807b54814f", + "type": "github" + }, + "original": { + "owner": "divnix", + "repo": "nosys", + "type": "github" + } + }, + "old-ghc-nix": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, "root": { "inputs": { "flake-compat": "flake-compat", "flake-utils": "flake-utils", - "nixpkgs": "nixpkgs" + "haskellNix": "haskellNix", + "nixpkgs": [ + "haskellNix", + "nixpkgs-unstable" + ] + } + }, + "stackage": { + "flake": false, + "locked": { + "lastModified": 1677975082, + "narHash": "sha256-K0tzntuS5Au+9u99NbU2A+3D1QomI6Wq4jELKfIaga4=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "d6da80d17fed290baf047fa8c74dac70dc996baa", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + }, + "std": { + "inputs": { + "arion": [ + "haskellNix", + "tullia", + "std", + "blank" + ], + "blank": "blank", + "devshell": "devshell", + "dmerge": "dmerge", + "flake-utils": "flake-utils_4", + "incl": "incl", + "makes": [ + "haskellNix", + "tullia", + "std", + "blank" + ], + "microvm": [ + "haskellNix", + "tullia", + "std", + "blank" + ], + "n2c": "n2c", + "nixago": "nixago", + "nixpkgs": "nixpkgs_4", + "nosys": "nosys", + "yants": "yants" + }, + "locked": { + "lastModified": 1674526466, + "narHash": "sha256-tMTaS0bqLx6VJ+K+ZT6xqsXNpzvSXJTmogkraBGzymg=", + "owner": "divnix", + "repo": "std", + "rev": "516387e3d8d059b50e742a2ff1909ed3c8f82826", + "type": "github" + }, + "original": { + "owner": "divnix", + "repo": "std", + "type": "github" + } + }, + "tullia": { + "inputs": { + "nix-nomad": "nix-nomad", + "nix2container": "nix2container", + "nixpkgs": [ + "haskellNix", + "nixpkgs" + ], + "std": "std" + }, + "locked": { + "lastModified": 1675695930, + "narHash": "sha256-B7rEZ/DBUMlK1AcJ9ajnAPPxqXY6zW2SBX+51bZV0Ac=", + "owner": "input-output-hk", + "repo": "tullia", + "rev": "621365f2c725608f381b3ad5b57afef389fd4c31", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "tullia", + "type": "github" + } + }, + "utils": { + "locked": { + "lastModified": 1653893745, + "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "yants": { + "inputs": { + "nixpkgs": [ + "haskellNix", + "tullia", + "std", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1667096281, + "narHash": "sha256-wRRec6ze0gJHmGn6m57/zhz/Kdvp9HS4Nl5fkQ+uIuA=", + "owner": "divnix", + "repo": "yants", + "rev": "d18f356ec25cb94dc9c275870c3a7927a10f8c3c", + "type": "github" + }, + "original": { + "owner": "divnix", + "repo": "yants", + "type": "github" } } }, diff --git a/flake.nix b/flake.nix index b96d950..c2fd5a6 100644 --- a/flake.nix +++ b/flake.nix @@ -1,43 +1,74 @@ { - description = "A simple library for handling data that changes over time"; - + # The flake not intended to be consumed by downstream direcly. Please fetch from Hackage. + # Continue reading if you want to develop this package. + # Useful commands: + # - Build with the default copmiler: nix build .#timeline:lib:timeline + # - Test: nix build .#checks.x86_64-linux.timeline:test:tests + # - Test with other versions of GHC: .#ghc944.checks.x86_64-linux.timeline:test:tests inputs = { + haskellNix.url = "github:input-output-hk/haskell.nix"; + nixpkgs.follows = "haskellNix/nixpkgs-unstable"; + flake-utils.url = "github:numtide/flake-utils"; flake-compat = { url = "github:edolstra/flake-compat"; flake = false; }; - flake-utils.url = "github:numtide/flake-utils"; - nixpkgs.url = "github:nixos/nixpkgs"; }; - outputs = inputs: - inputs.flake-utils.lib.eachDefaultSystem (system: + outputs = { self, nixpkgs, flake-utils, haskellNix, ... }: + flake-utils.lib.eachSystem [ "x86_64-linux" ] (system: let - pkgs = import inputs.nixpkgs { inherit system; }; - makePackage = haskellPackages: haskellPackages.callPackage ./timeline.nix { }; - in - rec - { - packages = { - default = makePackage pkgs.haskellPackages; - ghc884 = makePackage pkgs.haskell.packages.ghc884; - ghc8107 = makePackage pkgs.haskell.packages.ghc8107; - ghc902 = makePackage pkgs.haskell.packages.ghc902; - ghc921 = makePackage pkgs.haskell.packages.ghc921; + lib = nixpkgs.lib; + supportedCompilers = [ "ghc925" "ghc944" "ghc8107" ]; + makeOverlays = compilerNixName: [ + haskellNix.overlay + (final: prev: + { + timeline = final.haskell-nix.project' { + src = ./.; + name = "timeline"; + compiler-nix-name = compilerNixName; + shell = { + additional = pkgs: [ pkgs.tasty-discover ]; + tools = { + cabal = "latest"; + # haskell-language-server = { + # version = "latest"; + # configureArgs = ''--constraint "haskell-language-server -dynamic"''; + # }; + hlint = "latest"; + cabal-fmt = "latest"; + ormolu = "latest"; + }; + buildInputs = with prev; [ + rnix-lsp + nixpkgs-fmt + ]; + withHoogle = true; + }; + }; + }) + ]; + makePkgs = compilerNixName: import nixpkgs { + inherit system; + inherit (haskellNix) config; + overlays = makeOverlays compilerNixName; }; + makeFlake = compilerNixName: (makePkgs compilerNixName).timeline.flake { }; + defaultFlake = makeFlake (builtins.head supportedCompilers); + in + defaultFlake // builtins.listToAttrs + ( + builtins.map + (compilerNixName: { + name = compilerNixName; + value = makeFlake compilerNixName; + }) + supportedCompilers + ) + ); - devShells = builtins.mapAttrs - (_: v: v.env.overrideAttrs (oldAttrs: { - buildInputs = oldAttrs.buildInputs - ++ [ pkgs.nixpkgs-fmt ] - ++ (with pkgs.haskellPackages; [ - cabal-fmt - cabal-install - doctest - haskell-ci - hlint - ]); - })) - packages; - }); -} \ No newline at end of file + nixConfig = { + allow-import-from-derivation = "true"; + }; +} diff --git a/src/Data/Timeline.hs b/src/Data/Timeline.hs deleted file mode 100644 index 1a18f0a..0000000 --- a/src/Data/Timeline.hs +++ /dev/null @@ -1 +0,0 @@ -module Data.Timeline where \ No newline at end of file diff --git a/LICENSE b/timeline-hedgehog/LICENSE similarity index 100% rename from LICENSE rename to timeline-hedgehog/LICENSE diff --git a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs new file mode 100644 index 0000000..1f1c9d0 --- /dev/null +++ b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Timeline.Hedgehog + ( gen, + genRecord, + genUTCTime, + ) +where + +import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime) +import Data.Timeline +import Hedgehog (MonadGen) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +gen :: (MonadGen m) => m a -> m (Timeline a) +gen gen' = do + initialValue <- gen' + values <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> gen' + pure Timeline {initialValue, values} + +genRecord :: (MonadGen m) => m a -> m (Record a) +genRecord valueGen = + Gen.justT $ do + t1 <- genUTCTime + t2 <- Gen.maybe $ Gen.filterT (/= t1) genUTCTime + makeRecord t1 t2 <$> valueGen + +genUTCTime :: (MonadGen m) => m UTCTime +genUTCTime = do + y <- toInteger <$> Gen.int (Range.constant 2000 2030) + m <- Gen.int (Range.constant 1 12) + d <- Gen.int (Range.constant 1 28) + let day = fromGregorian y m d + secs <- toInteger <$> Gen.int (Range.constant 0 86401) + let diff = secondsToDiffTime secs + pure $ UTCTime day diff diff --git a/timeline-hedgehog/timeline-hedgehog.cabal b/timeline-hedgehog/timeline-hedgehog.cabal new file mode 100644 index 0000000..54f8f44 --- /dev/null +++ b/timeline-hedgehog/timeline-hedgehog.cabal @@ -0,0 +1,29 @@ +cabal-version: 2.2 +name: timeline-hedgehog +version: 0.1.0.0 +synopsis: Hedgehog generators for the timeline library +license: BSD-3-Clause +license-file: LICENSE +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +category: Development +build-type: Simple +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 + +source-repository head + type: git + location: https://github.com/bellroy/timeline.git + +common deps + build-depends: + , base >=4.13.0.0 && <4.18 + , hedgehog + , time + , timeline + +library + import: deps + hs-source-dirs: src/ + exposed-modules: Data.Timeline.Hedgehog + default-language: Haskell2010 + ghc-options: -fwarn-unused-imports -Wall -fno-warn-unused-do-bind diff --git a/timeline-tests/LICENSE b/timeline-tests/LICENSE new file mode 100644 index 0000000..e8308e6 --- /dev/null +++ b/timeline-tests/LICENSE @@ -0,0 +1,29 @@ +Copyright (C) 2023 Bellroy Pty Ltd + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/timeline-tests/test/Main.hs b/timeline-tests/test/Main.hs new file mode 100644 index 0000000..d7a0a67 --- /dev/null +++ b/timeline-tests/test/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} \ No newline at end of file diff --git a/timeline-tests/test/Spec/Data/Timeline.hs b/timeline-tests/test/Spec/Data/Timeline.hs new file mode 100644 index 0000000..3c4c316 --- /dev/null +++ b/timeline-tests/test/Spec/Data/Timeline.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.Data.Timeline where + +import Control.Applicative (liftA2) +import Control.Monad.Trans.Writer.CPS (execWriter, tell) +import Data.ByteString.Lazy qualified as LBS +import Data.Functor.WithIndex (imap) +import Data.Hashable +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, isJust, isNothing) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Time + ( UTCTime (UTCTime), + addUTCTime, + fromGregorian, + secondsToNominalDiffTime, + ) +import Data.Timeline + ( Record, + TimeRange (..), + changes, + fromRecords, + fromValues, + makeRecord, + peek, + ) +import Data.Timeline.Hedgehog (gen, genUTCTime) +import Hedgehog (forAll, property, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Test.Tasty (TestName, TestTree) +import Test.Tasty.Golden (goldenVsString) +import Test.Tasty.HUnit (testCase, (@=?), (@?=)) +import Test.Tasty.Hedgehog (testProperty) + +test_makeRecord :: [TestTree] +test_makeRecord = + [ testProperty "it's always valid to have no effective-to" $ property $ do + t <- forAll genUTCTime + isJust (makeRecord @Int t Nothing 1) === True, + testProperty "effectiveFrom must be less than effective-to" $ property $ do + t1 <- forAll genUTCTime + t2 <- forAll genUTCTime + let tMin = min t1 t2 + tMax = max t1 t2 + if t1 == t2 + then isNothing (makeRecord @Int t1 (Just t2) 1) === True + else isJust (makeRecord @Int tMin (Just tMax) 1) === True + ] + +test_fromRecords :: [TestTree] +test_fromRecords = + [ testCase "empty input" $ + fromRecords @Int [] @?= Right (pure Nothing), + testCase' + "one change" + [ makeRecord @Int + (UTCTime (fromGregorian 2023 1 26) 7200) + Nothing + 100 + ], + testCase' + "one change, with effective to" + [ makeRecord @Int + (UTCTime (fromGregorian 2023 1 26) 7200) + (Just $ UTCTime (fromGregorian 2023 2 28) 0) + 100 + ], + testCase' + "all non-overlapping situations together" + [ makeRecord @Int + (UTCTime (fromGregorian 2023 1 26) 7200) + (Just $ UTCTime (fromGregorian 2023 2 28) 0) + 100, + makeRecord @Int + (UTCTime (fromGregorian 2023 3 1) 0) + (Just $ UTCTime (fromGregorian 2023 4 1) 0) + 200, + makeRecord @Int + (UTCTime (fromGregorian 2023 4 1) 0) + Nothing + 300, + makeRecord @Int + (UTCTime (fromGregorian 2023 5 1) 0) + Nothing + 400, + makeRecord @Int + (UTCTime (fromGregorian 2023 6 1) 0) + Nothing + 500 + ], + testCase' + "overlaps" + [ makeRecord @Int + (UTCTime (fromGregorian 2023 1 26) 7200) + (Just $ UTCTime (fromGregorian 2023 2 28) 0) + 100, + makeRecord @Int + (UTCTime (fromGregorian 2023 2 27) 0) + (Just $ UTCTime (fromGregorian 2023 3 5) 0) + 200, + makeRecord @Int + (UTCTime (fromGregorian 2023 3 1) 0) + Nothing + 300 + ], + testCase' + "two groups of overlap" + [ makeRecord @Int + (UTCTime (fromGregorian 2023 1 26) 7200) + (Just $ UTCTime (fromGregorian 2023 2 28) 0) + 100, + makeRecord @Int + (UTCTime (fromGregorian 2023 3 1) 0) + (Just $ UTCTime (fromGregorian 2023 3 5) 0) + 200, + makeRecord @Int + (UTCTime (fromGregorian 2023 3 3) 0) + (Just $ UTCTime (fromGregorian 2023 3 4) 0) + 300, + makeRecord @Int + (UTCTime (fromGregorian 2023 3 6) 0) + (Just $ UTCTime (fromGregorian 2023 3 8) 0) + 400, + makeRecord @Int + (UTCTime (fromGregorian 2023 3 8) 0) + (Just $ UTCTime (fromGregorian 2023 3 15) 0) + 500, + makeRecord @Int + (UTCTime (fromGregorian 2023 3 14) 0) + Nothing + 600 + ] + ] + where + testCase' :: (Show a) => TestName -> [Maybe (Record a)] -> TestTree + testCase' name records = buildGoldenTest name . fromRecords . catMaybes $ records + +test_peek :: [TestTree] +test_peek = + [ testCase "constant" $ 1 @=? peek @Int (pure 1) (UTCTime (fromGregorian 2023 1 26) 0), + testCase "before first change" $ + 1 + @=? peek @Int + (fromValues 1 (Map.singleton (UTCTime (fromGregorian 2023 1 16) 0) 2)) + (UTCTime (fromGregorian 2023 1 15) 0), + testCase "between changes" $ + 2 + @=? peek @Int + ( fromValues + 1 + [ (UTCTime (fromGregorian 2023 1 16) 0, 2), + (UTCTime (fromGregorian 2023 1 19) 0, 3) + ] + ) + (UTCTime (fromGregorian 2023 1 18) 0), + testCase "at the last change" $ + 3 + @=? peek @Int + ( fromValues + 1 + [ (UTCTime (fromGregorian 2023 1 16) 0, 2), + (UTCTime (fromGregorian 2023 1 19) 0, 3) + ] + ) + (UTCTime (fromGregorian 2023 1 19) 0), + testCase "after all changes" $ + 3 + @=? peek @Int + ( fromValues + 1 + [ (UTCTime (fromGregorian 2023 1 16) 0, 2), + (UTCTime (fromGregorian 2023 1 19) 0, 3) + ] + ) + (UTCTime (fromGregorian 2023 1 20) 0) + ] + +-- The purpose of the first testProperty is to verify this rewrite rule +-- suggested by hlint is legal. (We are testing if the Applicative instance is correct) +{-# ANN test_apply ("HLint: ignore Use <$>" :: String) #-} +test_apply :: [TestTree] +test_apply = + [ testProperty "pure f <*> x === f <$> x" $ + property $ do + timeline <- forAll $ gen (Gen.int (Range.linear 0 1000)) + fmap (+ 1) timeline === (pure (+ 1) <*> timeline), + testProperty "combined timeline" $ + property $ do + t1 <- forAll $ gen (Gen.int (Range.linear 0 100)) + t2 <- forAll $ gen (Gen.int (Range.linear (-100) 0)) + let combined = liftA2 (+) t1 t2 + -- check the size + changes t1 `Set.union` changes t2 === changes combined + -- for random time + time <- forAll genUTCTime + peek t1 time + peek t2 time === peek combined time + -- for the times that changes happen + let timepoints = Set.toList $ changes combined + zipWith (+) (fmap (peek t1) timepoints) (fmap (peek t2) timepoints) === fmap (peek combined) timepoints + ] + +test_imap :: [TestTree] +test_imap = + [ testProperty "when ignoring the range, it works the same as fmap" $ property $ do + tl <- forAll $ gen (Gen.int (Range.constant 0 1000)) + imap (const (+ 1)) tl === fmap (+ 1) tl, + testCase "check the time ranges" $ do + let t1 = UTCTime (fromGregorian 2023 1 16) 0 + t2 = UTCTime (fromGregorian 2023 1 19) 0 + timeline = + fromValues @Int + 1 + [ (t1, 2), + (t2, 3) + ] + result = execWriter . sequenceA $ imap (\range _ -> tell @[TimeRange] [range]) timeline + result + @?= [ TimeRange Nothing (Just t1), + TimeRange (Just t1) (Just (addUTCTime (secondsToNominalDiffTime 259200) t1)), + TimeRange (Just t2) Nothing + ], + testProperty "law: imap f . imap g === imap (\\i -> f i . g i)" $ property $ do + tl <- forAll $ gen (Gen.int (Range.constant 0 1000)) + let hashTimeRange :: TimeRange -> Int + hashTimeRange TimeRange {trFrom, trTo} = hash (show trFrom) `hashWithSalt` show trTo + f :: TimeRange -> Int -> Int + f tr x = hashTimeRange tr + x + g :: TimeRange -> Int -> Int + g tr x = hashTimeRange tr - x + (imap f . imap g) tl === imap (\i -> f i . g i) tl, + testProperty "law: imap (\\_ a -> a) === id" $ property $ do + tl <- forAll $ gen (Gen.int (Range.constant 0 1000)) + imap (\_ a -> a) tl === tl + ] + +buildGoldenTest :: (Show a) => TestName -> a -> TestTree +buildGoldenTest name value = + goldenVsString + name + ("test/golden/" <> fmap (\ch -> if ch == ' ' then '_' else ch) name <> ".txt") + $ pure . LBS.fromStrict . T.encodeUtf8 . T.pack . show + $ value diff --git a/timeline-tests/test/golden/all_non-overlapping_situations_together.txt b/timeline-tests/test/golden/all_non-overlapping_situations_together.txt new file mode 100644 index 0000000..cb20b40 --- /dev/null +++ b/timeline-tests/test/golden/all_non-overlapping_situations_together.txt @@ -0,0 +1,10 @@ +Right +----------Timeline--Start------------- +initial value: Nothing +since 2023-01-26 02:00:00 UTC: Just 100 +since 2023-02-28 00:00:00 UTC: Nothing +since 2023-03-01 00:00:00 UTC: Just 200 +since 2023-04-01 00:00:00 UTC: Just 300 +since 2023-05-01 00:00:00 UTC: Just 400 +since 2023-06-01 00:00:00 UTC: Just 500 +----------Timeline--End--------------- diff --git a/timeline-tests/test/golden/one_change,_with_effective_to.txt b/timeline-tests/test/golden/one_change,_with_effective_to.txt new file mode 100644 index 0000000..d184daa --- /dev/null +++ b/timeline-tests/test/golden/one_change,_with_effective_to.txt @@ -0,0 +1,6 @@ +Right +----------Timeline--Start------------- +initial value: Nothing +since 2023-01-26 02:00:00 UTC: Just 100 +since 2023-02-28 00:00:00 UTC: Nothing +----------Timeline--End--------------- diff --git a/timeline-tests/test/golden/one_change.txt b/timeline-tests/test/golden/one_change.txt new file mode 100644 index 0000000..32f961d --- /dev/null +++ b/timeline-tests/test/golden/one_change.txt @@ -0,0 +1,5 @@ +Right +----------Timeline--Start------------- +initial value: Nothing +since 2023-01-26 02:00:00 UTC: Just 100 +----------Timeline--End--------------- diff --git a/timeline-tests/test/golden/overlaps.txt b/timeline-tests/test/golden/overlaps.txt new file mode 100644 index 0000000..c8ba6f0 --- /dev/null +++ b/timeline-tests/test/golden/overlaps.txt @@ -0,0 +1,6 @@ +Left Here are 1 group(s) of overlapping records +-------------------- +2023-01-26 02:00:00 UTC ~ Just 2023-02-28 00:00:00 UTC: 100 +2023-02-27 00:00:00 UTC ~ Just 2023-03-05 00:00:00 UTC: 200 +2023-03-01 00:00:00 UTC ~ Nothing: 300 +-------------------- diff --git a/timeline-tests/test/golden/two_groups_of_overlap.txt b/timeline-tests/test/golden/two_groups_of_overlap.txt new file mode 100644 index 0000000..c01042b --- /dev/null +++ b/timeline-tests/test/golden/two_groups_of_overlap.txt @@ -0,0 +1,8 @@ +Left Here are 2 group(s) of overlapping records +-------------------- +2023-03-01 00:00:00 UTC ~ Just 2023-03-05 00:00:00 UTC: 200 +2023-03-03 00:00:00 UTC ~ Just 2023-03-04 00:00:00 UTC: 300 +-------------------- +2023-03-08 00:00:00 UTC ~ Just 2023-03-15 00:00:00 UTC: 500 +2023-03-14 00:00:00 UTC ~ Nothing: 600 +-------------------- diff --git a/timeline-tests/timeline-tests.cabal b/timeline-tests/timeline-tests.cabal new file mode 100644 index 0000000..336c1af --- /dev/null +++ b/timeline-tests/timeline-tests.cabal @@ -0,0 +1,38 @@ +cabal-version: 2.2 +name: timeline-tests +version: 0.1.0.0 +synopsis: Tests for the timeline library +license: BSD-3-Clause +license-file: LICENSE +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +category: Development +build-type: Simple +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 + +source-repository head + type: git + location: https://github.com/bellroy/timeline.git + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Spec.Data.Timeline + build-tool-depends: tasty-discover:tasty-discover + build-depends: + , base >=4.13.0.0 && <4.18 + , bytestring + , containers + , hashable + , hedgehog + , indexed-traversable + , tasty + , tasty-golden + , tasty-hedgehog + , tasty-hunit + , text + , time + , timeline + , timeline-hedgehog + , transformers diff --git a/timeline.cabal b/timeline.cabal deleted file mode 100644 index 11da7b7..0000000 --- a/timeline.cabal +++ /dev/null @@ -1,36 +0,0 @@ -cabal-version: 2.2 -name: timeline -version: 0.1.0.0 -synopsis: A simple library for handling data that changes over time -license: Apache-2.0 -license-file: LICENSE -author: Bellroy Tech Team -maintainer: Bellroy Tech Team -category: Development -build-type: Simple -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 -extra-source-files: - CHANGELOG.md - README.md - -source-repository head - type: git - location: https://github.com/bellroy/timeline.git - -common deps - build-depends: base >=4.13.0.0 && <4.18 - -library - import: deps - exposed-modules: Data.Timeline - hs-source-dirs: src/ - default-language: Haskell2010 - ghc-options: -fwarn-unused-imports -Wall -fno-warn-unused-do-bind - - if flag(developer) - ghc-options: -Werror - -flag developer - manual: True - default: False - description: compile with -Werror to make warnings fatal diff --git a/timeline.nix b/timeline.nix deleted file mode 100644 index e443632..0000000 --- a/timeline.nix +++ /dev/null @@ -1,9 +0,0 @@ -{ mkDerivation, base, lib }: -mkDerivation { - pname = "timeline"; - version = "0.1.0.0"; - src = ./.; - libraryHaskellDepends = [ base ]; - description = "A simple library for handling data that changes over time"; - license = lib.licenses.asl20; -} diff --git a/timeline/LICENSE b/timeline/LICENSE new file mode 100644 index 0000000..e8308e6 --- /dev/null +++ b/timeline/LICENSE @@ -0,0 +1,29 @@ +Copyright (C) 2023 Bellroy Pty Ltd + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/timeline/src/Data/Timeline.hs b/timeline/src/Data/Timeline.hs new file mode 100644 index 0000000..6c5642c --- /dev/null +++ b/timeline/src/Data/Timeline.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Timeline + ( module Data.Timeline.Internal, + makeRecordTH, + ) +where + +import Data.Time (UTCTime) +import Data.Timeline.Internal +import Language.Haskell.TH (Quote) +import Language.Haskell.TH.Syntax qualified as TH + +makeRecordTH :: + (MonadFail m, Quote m, TH.Lift a) => UTCTime -> Maybe UTCTime -> a -> TH.Code m (Record a) +makeRecordTH effectiveFrom effectiveTo value = TH.bindCode + ( maybe (fail "effective to is no greater than effective from") pure $ + makeRecord effectiveFrom effectiveTo value + ) + $ \record -> [||$$(TH.liftTyped record)||] diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs new file mode 100644 index 0000000..82e2bcc --- /dev/null +++ b/timeline/src/Data/Timeline/Internal.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ViewPatterns #-} + +module Data.Timeline.Internal + ( -- * Common + Timeline (..), + fromValues, + peek, + TimeRange (..), + isTimeAfterRange, + changes, + + -- * effectiveFrom + optional effectiveTo + Record, + makeRecord, + recordEffectiveFrom, + recordEffectiveTo, + recordValue, + fromRecords, + Overlaps (..), + OverlapGroup (..), + unpackOverlapGroup, + ) +where + +import Data.Foldable.WithIndex (FoldableWithIndex (..)) +import Data.Functor.Contravariant (Contravariant, contramap) +import Data.Functor.WithIndex (FunctorWithIndex (..)) +import Data.List (intercalate, sortOn) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe, maybeToList) +import Data.Semigroup.Foldable.Class (fold1) +import Data.Set (Set) +import Data.String.Interpolate (i) +import Data.Time + ( UTCTime (..), + diffTimeToPicoseconds, + picosecondsToDiffTime, + ) +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, pattern YearDay) +import Data.Traversable.WithIndex (TraversableWithIndex (..)) +import GHC.Generics (Generic) +import Language.Haskell.TH (Code, Quote) +import Language.Haskell.TH.Syntax qualified as TH +import Prelude + +-- | An infinite, discrete timeline for data type @a@. +-- It always has a value for any time, but the set of values has a finite size. +data Timeline a = Timeline + {- Internally this is represented by an initial value and a list of updated values. + Each change has an effective time and a new value. + This makes it possible to inspect the individual changes and to serialize the type, + but makes it impossible to represent timelines that change continuously. Continuous data + in computers' world is very rare, unless you are working with some math formulas. + -} + { initialValue :: a, + -- | changes are keyed by their "effective from" time, for easier lookup + values :: Map UTCTime a + } + deriving stock (Eq, Generic, Functor, Foldable, Traversable) + +fromValues :: + -- | initial value + a -> + -- | new values begin to take effect at the specified times + Map UTCTime a -> + Timeline a +fromValues initialValue values = Timeline {initialValue, values} + +instance Applicative Timeline where + pure :: a -> Timeline a + pure a = Timeline {initialValue = a, values = mempty} + + (<*>) :: forall a b. Timeline (a -> b) -> Timeline a -> Timeline b + fs@Timeline {initialValue = initialFunc, values = funcs} <*> xs@Timeline {initialValue, values} = + Timeline + { initialValue = initialFunc initialValue, + values = mergedValues + } + where + mergedValues :: Map UTCTime b + mergedValues = + Map.merge + (Map.mapMissing $ \t f -> f $ peek xs t) + (Map.mapMissing $ \t x -> peek fs t x) + (Map.zipWithMatched (const ($))) + funcs + values + +instance Show a => Show (Timeline a) where + show Timeline {initialValue, values} = + unlines $ + "\n----------Timeline--Start-------------" + : ("initial value: " <> show initialValue) + : fmap showOneChange (Map.toAscList values) + ++ ["----------Timeline--End---------------"] + where + showOneChange :: (UTCTime, a) -> String + showOneChange (t, x) = [i|since #{t}: #{x}|] + +peek :: Timeline a -> UTCTime -> a +peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values + +data TimeRange = TimeRange + { trFrom :: Maybe UTCTime, + trTo :: Maybe UTCTime + } + deriving stock (Show, Eq, Ord, Generic) + +isTimeAfterRange :: UTCTime -> TimeRange -> Bool +isTimeAfterRange t TimeRange {trTo} = maybe False (t >=) trTo + +instance FunctorWithIndex TimeRange Timeline where + imap :: (TimeRange -> a -> b) -> Timeline a -> Timeline b + imap f Timeline {..} = + Timeline + { initialValue = f initialRange initialValue, + values = flip Map.mapWithKey values $ \from value -> + let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from values) + in f timeRange value + } + where + initialRange = TimeRange Nothing $ fst <$> Map.lookupMin values + +instance FoldableWithIndex TimeRange Timeline + +instance TraversableWithIndex TimeRange Timeline where + itraverse :: Applicative f => (TimeRange -> a -> f b) -> Timeline a -> f (Timeline b) + itraverse f = sequenceA . imap f + +changes :: Timeline a -> Set UTCTime +changes Timeline {values} = Map.keysSet values + +data Record a = Record + { effectiveFrom :: UTCTime, + effectiveTo :: Maybe UTCTime, + value :: a + } + deriving stock (Eq, Functor) + +type Getter s a = forall f. Contravariant f => (a -> f a) -> s -> f s + +recordEffectiveFrom :: Getter (Record a) UTCTime +recordEffectiveFrom f r = contramap getEffectiveFrom (f (getEffectiveFrom r)) + where + getEffectiveFrom :: Record a -> UTCTime + getEffectiveFrom Record {effectiveFrom} = effectiveFrom + +recordEffectiveTo :: Getter (Record a) (Maybe UTCTime) +recordEffectiveTo f r = contramap getEffectiveTo (f (getEffectiveTo r)) + where + getEffectiveTo :: Record a -> Maybe UTCTime + getEffectiveTo Record {effectiveTo} = effectiveTo + +recordValue :: Getter (Record a) a +recordValue f r = contramap getValue (f (getValue r)) + where + getValue :: Record a -> a + getValue Record {value} = value + +-- | 'makeRecord' returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ +makeRecord :: + -- | effective from + UTCTime -> + -- | optional effective to + Maybe UTCTime -> + -- | value + a -> + Maybe (Record a) +-- can't write a makeRecordTH because UTCTime has no Lift instance +makeRecord effectiveFrom effectiveTo value = + if maybe False (effectiveFrom >=) effectiveTo + then Nothing + else Just Record {..} + +instance TH.Lift a => TH.Lift (Record a) where + liftTyped :: Quote m => Record a -> Code m (Record a) + liftTyped Record {..} = + [|| + Record + (unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime effectiveFrom)) + (fmap unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime <$> effectiveTo)) + $$(TH.liftTyped value) + ||] + +newtype LiftUTCTime = LiftUTCTime UTCTime + deriving stock (Generic) + +unLiftUTCTime :: LiftUTCTime -> UTCTime +unLiftUTCTime (LiftUTCTime t) = t + +instance TH.Lift LiftUTCTime where + liftTyped :: Quote m => LiftUTCTime -> Code m LiftUTCTime + liftTyped (LiftUTCTime (UTCTime (YearDay year dayOfYear) time)) = + [|| + LiftUTCTime + ( UTCTime + (fromOrdinalDate $$(TH.liftTyped year) $$(TH.liftTyped dayOfYear)) + (picosecondsToDiffTime $$(TH.liftTyped (diffTimeToPicoseconds time))) + ) + ||] + +instance Show a => Show (Record a) where + show Record {..} = [i|#{effectiveFrom} ~ #{effectiveTo}: #{value}|] + +newtype Overlaps a = Overlaps {groups :: NonEmpty (OverlapGroup a)} + deriving newtype (Semigroup) + deriving stock (Eq, Generic) + +instance Show a => Show (Overlaps a) where + show Overlaps {groups} = + [i|Here are #{length groups} group(s) of overlapping records\n|] + ++ sep + ++ intercalate sep (show <$> NonEmpty.toList groups) + ++ sep + where + sep = "--------------------\n" + +data OverlapGroup a = OverlapGroup (Record a) (Record a) [Record a] + deriving stock (Eq, Generic) + +instance Show a => Show (OverlapGroup a) where + show = unlines . fmap show . unpackOverlapGroup + +unpackOverlapGroup :: OverlapGroup a -> [Record a] +unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records + +-- Build a 'Timeline' from a list of 'Record's. +-- +-- For any time, there could be zero, one, or more values, according to the input. No other condition +-- is possible. We have taken account the "zero" case by wrapping the result in 'Maybe', so the only +-- possible error is 'Overlaps'. +fromRecords :: forall a. [Record a] -> Either (Overlaps a) (Timeline (Maybe a)) +fromRecords records = + maybe (Right timeline) Left overlaps + where + sortedRecords = sortOn effectiveFrom records + + -- overlap detection + overlaps = + fmap fold1 + . nonEmpty + . mapMaybe checkForOverlap + . foldr mergeOverlappingNeighbours [] + $ sortedRecords + + mergeOverlappingNeighbours :: + Record a -> + [NonEmpty (Record a)] -> + [NonEmpty (Record a)] + mergeOverlappingNeighbours current ((next :| group) : groups) + -- Be aware that this is called in 'foldr', so it traverse the list from right to left. + -- If the current record overlaps with the top (left-most) record in the next group, we add it + -- to the group. Otherwise, create a new group for it. + | isOverlapping = (current NonEmpty.<| next :| group) : groups + | otherwise = NonEmpty.singleton current : (next :| group) : groups + where + isOverlapping = maybe False (effectiveFrom next <) (effectiveTo current) + mergeOverlappingNeighbours current [] = [NonEmpty.singleton current] + + checkForOverlap :: NonEmpty (Record a) -> Maybe (Overlaps a) + checkForOverlap (_ :| []) = Nothing + checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . NonEmpty.singleton $ OverlapGroup x1 x2 xs + + -- build the timeline assuming all elements of `sortedRecords` cover distinct (non-overlapping) time-periods + timeline :: Timeline (Maybe a) + timeline = + case nonEmpty sortedRecords of + Nothing -> pure Nothing + Just records' -> + Timeline + { initialValue = Nothing, + values = + Map.fromList . concat $ + zipWith + connectAdjacentRecords + (NonEmpty.toList records') + ((Just <$> NonEmpty.tail records') <> [Nothing]) + } + connectAdjacentRecords :: Record a -> Maybe (Record a) -> [(UTCTime, Maybe a)] + connectAdjacentRecords current next = + (effectiveFrom current, Just $ value current) + : maybeToList gap + where + gap = do + effectiveTo' <- effectiveTo current + if maybe True (\next' -> effectiveTo' < effectiveFrom next') next + then pure (effectiveTo', Nothing) + else Nothing diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal new file mode 100644 index 0000000..b52b188 --- /dev/null +++ b/timeline/timeline.cabal @@ -0,0 +1,33 @@ +cabal-version: 2.2 +name: timeline +version: 0.1.0.0 +synopsis: A simple library for handling data that changes over time +license: BSD-3-Clause +license-file: LICENSE +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +category: Development +build-type: Simple +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 + +source-repository head + type: git + location: https://github.com/bellroy/timeline.git + +common deps + build-depends: + , base >=4.13.0.0 && <4.18 + , containers + , indexed-traversable + , semigroupoids + , string-interpolate + , template-haskell + , time + +library + import: deps + hs-source-dirs: src/ + exposed-modules: Data.Timeline + other-modules: Data.Timeline.Internal + default-language: Haskell2010 + ghc-options: -fwarn-unused-imports -Wall -fno-warn-unused-do-bind From 9811528c40e08756bd0dc31f2b47a3e48b3fde4f Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 7 Mar 2023 11:54:28 +0800 Subject: [PATCH 03/24] fix flake --- .gitignore | 3 +- flake.nix | 90 ++++++++++++++++++++++++++++-------------------------- 2 files changed, 48 insertions(+), 45 deletions(-) diff --git a/.gitignore b/.gitignore index ec1d88b..d8d83c3 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ .vscode/ .direnv/ -.envrc \ No newline at end of file +.envrc +result \ No newline at end of file diff --git a/flake.nix b/flake.nix index c2fd5a6..fe89901 100644 --- a/flake.nix +++ b/flake.nix @@ -16,57 +16,59 @@ }; outputs = { self, nixpkgs, flake-utils, haskellNix, ... }: - flake-utils.lib.eachSystem [ "x86_64-linux" ] (system: - let - lib = nixpkgs.lib; - supportedCompilers = [ "ghc925" "ghc944" "ghc8107" ]; - makeOverlays = compilerNixName: [ - haskellNix.overlay - (final: prev: - { - timeline = final.haskell-nix.project' { - src = ./.; - name = "timeline"; - compiler-nix-name = compilerNixName; - shell = { - additional = pkgs: [ pkgs.tasty-discover ]; - tools = { - cabal = "latest"; - # haskell-language-server = { - # version = "latest"; - # configureArgs = ''--constraint "haskell-language-server -dynamic"''; - # }; - hlint = "latest"; - cabal-fmt = "latest"; - ormolu = "latest"; + let + lib = nixpkgs.lib; + supportedCompilers = [ "ghc926" "ghc944" "ghc8107" ]; + makeOverlays = compilerNixName: [ + haskellNix.overlay + (final: prev: + { + timeline = final.haskell-nix.project' { + src = ./.; + name = "timeline"; + compiler-nix-name = compilerNixName; + shell = { + additional = pkgs: [ pkgs.tasty-discover ]; + tools = { + cabal = "latest"; + haskell-language-server = { + version = "latest"; + configureArgs = ''--constraint "haskell-language-server -dynamic"''; }; - buildInputs = with prev; [ - rnix-lsp - nixpkgs-fmt - ]; - withHoogle = true; + hlint = "latest"; + cabal-fmt = "latest"; + ormolu = "latest"; }; + buildInputs = with prev; [ + rnix-lsp + nixpkgs-fmt + ]; + withHoogle = true; }; - }) - ]; - makePkgs = compilerNixName: import nixpkgs { + }; + }) + ]; + in + let + makeFlake = compilerNixName: flake-utils.lib.eachDefaultSystem (system: + let pkgs = import nixpkgs { inherit system; inherit (haskellNix) config; overlays = makeOverlays compilerNixName; }; - makeFlake = compilerNixName: (makePkgs compilerNixName).timeline.flake { }; - defaultFlake = makeFlake (builtins.head supportedCompilers); - in - defaultFlake // builtins.listToAttrs - ( - builtins.map - (compilerNixName: { - name = compilerNixName; - value = makeFlake compilerNixName; - }) - supportedCompilers - ) - ); + in + pkgs.timeline.flake { }); + defaultFlake = makeFlake (builtins.head supportedCompilers); + in + defaultFlake // builtins.listToAttrs + ( + builtins.map + (compilerNixName: { + name = compilerNixName; + value = makeFlake compilerNixName; + }) + supportedCompilers + ); nixConfig = { allow-import-from-derivation = "true"; From 220f53d3c661a2cb2aa13188904befbac8c5cfe1 Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 7 Mar 2023 15:53:58 +0800 Subject: [PATCH 04/24] remove string-interpolate; fix th --- flake.nix | 10 +++--- timeline/src/Data/Timeline.hs | 6 ++-- timeline/src/Data/Timeline/Internal.hs | 47 ++++++++++---------------- timeline/timeline.cabal | 8 ++--- 4 files changed, 30 insertions(+), 41 deletions(-) diff --git a/flake.nix b/flake.nix index fe89901..228f4a6 100644 --- a/flake.nix +++ b/flake.nix @@ -18,7 +18,8 @@ outputs = { self, nixpkgs, flake-utils, haskellNix, ... }: let lib = nixpkgs.lib; - supportedCompilers = [ "ghc926" "ghc944" "ghc8107" ]; + supportedCompilers = [ "ghc944" "ghc926" "ghc8107" ]; + defaultCompiler = "ghc926"; makeOverlays = compilerNixName: [ haskellNix.overlay (final: prev: @@ -31,14 +32,15 @@ additional = pkgs: [ pkgs.tasty-discover ]; tools = { cabal = "latest"; + cabal-fmt = "latest"; + } // (if compilerNixName == "ghc926" then { haskell-language-server = { version = "latest"; configureArgs = ''--constraint "haskell-language-server -dynamic"''; }; hlint = "latest"; - cabal-fmt = "latest"; ormolu = "latest"; - }; + } else { }); buildInputs = with prev; [ rnix-lsp nixpkgs-fmt @@ -58,7 +60,7 @@ }; in pkgs.timeline.flake { }); - defaultFlake = makeFlake (builtins.head supportedCompilers); + defaultFlake = makeFlake defaultCompiler; in defaultFlake // builtins.listToAttrs ( diff --git a/timeline/src/Data/Timeline.hs b/timeline/src/Data/Timeline.hs index 6c5642c..0b8381f 100644 --- a/timeline/src/Data/Timeline.hs +++ b/timeline/src/Data/Timeline.hs @@ -9,12 +9,12 @@ where import Data.Time (UTCTime) import Data.Timeline.Internal -import Language.Haskell.TH (Quote) import Language.Haskell.TH.Syntax qualified as TH +import Language.Haskell.TH.Syntax.Compat qualified as TH makeRecordTH :: - (MonadFail m, Quote m, TH.Lift a) => UTCTime -> Maybe UTCTime -> a -> TH.Code m (Record a) -makeRecordTH effectiveFrom effectiveTo value = TH.bindCode + (TH.Lift a) => UTCTime -> Maybe UTCTime -> a -> TH.SpliceQ (Record a) +makeRecordTH effectiveFrom effectiveTo value = TH.bindSplice ( maybe (fail "effective to is no greater than effective from") pure $ makeRecord effectiveFrom effectiveTo value ) diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs index 82e2bcc..9111a00 100644 --- a/timeline/src/Data/Timeline/Internal.hs +++ b/timeline/src/Data/Timeline/Internal.hs @@ -8,6 +8,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} @@ -17,7 +18,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ViewPatterns #-} module Data.Timeline.Internal @@ -54,17 +54,13 @@ import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe, maybeToList) import Data.Semigroup.Foldable.Class (fold1) import Data.Set (Set) -import Data.String.Interpolate (i) import Data.Time ( UTCTime (..), - diffTimeToPicoseconds, - picosecondsToDiffTime, ) -import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, pattern YearDay) import Data.Traversable.WithIndex (TraversableWithIndex (..)) import GHC.Generics (Generic) -import Language.Haskell.TH (Code, Quote) -import Language.Haskell.TH.Syntax qualified as TH +import Language.Haskell.TH.Syntax qualified as TH (Lift (liftTyped)) +import Language.Haskell.TH.Syntax.Compat qualified as TH import Prelude -- | An infinite, discrete timeline for data type @a@. @@ -110,7 +106,7 @@ instance Applicative Timeline where funcs values -instance Show a => Show (Timeline a) where +instance (Show a) => Show (Timeline a) where show Timeline {initialValue, values} = unlines $ "\n----------Timeline--Start-------------" @@ -119,7 +115,7 @@ instance Show a => Show (Timeline a) where ++ ["----------Timeline--End---------------"] where showOneChange :: (UTCTime, a) -> String - showOneChange (t, x) = [i|since #{t}: #{x}|] + showOneChange (t, x) = "since " <> show t <> ": " <> show x peek :: Timeline a -> UTCTime -> a peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values @@ -148,7 +144,7 @@ instance FunctorWithIndex TimeRange Timeline where instance FoldableWithIndex TimeRange Timeline instance TraversableWithIndex TimeRange Timeline where - itraverse :: Applicative f => (TimeRange -> a -> f b) -> Timeline a -> f (Timeline b) + itraverse :: (Applicative f) => (TimeRange -> a -> f b) -> Timeline a -> f (Timeline b) itraverse f = sequenceA . imap f changes :: Timeline a -> Set UTCTime @@ -161,7 +157,7 @@ data Record a = Record } deriving stock (Eq, Functor) -type Getter s a = forall f. Contravariant f => (a -> f a) -> s -> f s +type Getter s a = forall f. (Contravariant f) => (a -> f a) -> s -> f s recordEffectiveFrom :: Getter (Record a) UTCTime recordEffectiveFrom f r = contramap getEffectiveFrom (f (getEffectiveFrom r)) @@ -196,8 +192,7 @@ makeRecord effectiveFrom effectiveTo value = then Nothing else Just Record {..} -instance TH.Lift a => TH.Lift (Record a) where - liftTyped :: Quote m => Record a -> Code m (Record a) +instance (TH.Lift a) => TH.Lift (Record a) where liftTyped Record {..} = [|| Record @@ -213,26 +208,18 @@ unLiftUTCTime :: LiftUTCTime -> UTCTime unLiftUTCTime (LiftUTCTime t) = t instance TH.Lift LiftUTCTime where - liftTyped :: Quote m => LiftUTCTime -> Code m LiftUTCTime - liftTyped (LiftUTCTime (UTCTime (YearDay year dayOfYear) time)) = - [|| - LiftUTCTime - ( UTCTime - (fromOrdinalDate $$(TH.liftTyped year) $$(TH.liftTyped dayOfYear)) - (picosecondsToDiffTime $$(TH.liftTyped (diffTimeToPicoseconds time))) - ) - ||] + liftTyped (LiftUTCTime t) = [||LiftUTCTime (read $$(TH.liftTyped (show t)))||] -instance Show a => Show (Record a) where - show Record {..} = [i|#{effectiveFrom} ~ #{effectiveTo}: #{value}|] +instance (Show a) => Show (Record a) where + show Record {..} = show effectiveFrom <> " ~ " <> show effectiveTo <> ": " <> show value newtype Overlaps a = Overlaps {groups :: NonEmpty (OverlapGroup a)} deriving newtype (Semigroup) deriving stock (Eq, Generic) -instance Show a => Show (Overlaps a) where +instance (Show a) => Show (Overlaps a) where show Overlaps {groups} = - [i|Here are #{length groups} group(s) of overlapping records\n|] + "Here are " <> show (length groups) <> " group(s) of overlapping records\n" ++ sep ++ intercalate sep (show <$> NonEmpty.toList groups) ++ sep @@ -242,7 +229,7 @@ instance Show a => Show (Overlaps a) where data OverlapGroup a = OverlapGroup (Record a) (Record a) [Record a] deriving stock (Eq, Generic) -instance Show a => Show (OverlapGroup a) where +instance (Show a) => Show (OverlapGroup a) where show = unlines . fmap show . unpackOverlapGroup unpackOverlapGroup :: OverlapGroup a -> [Record a] @@ -276,14 +263,14 @@ fromRecords records = -- If the current record overlaps with the top (left-most) record in the next group, we add it -- to the group. Otherwise, create a new group for it. | isOverlapping = (current NonEmpty.<| next :| group) : groups - | otherwise = NonEmpty.singleton current : (next :| group) : groups + | otherwise = (current :| []) : (next :| group) : groups where isOverlapping = maybe False (effectiveFrom next <) (effectiveTo current) - mergeOverlappingNeighbours current [] = [NonEmpty.singleton current] + mergeOverlappingNeighbours current [] = [current :| []] checkForOverlap :: NonEmpty (Record a) -> Maybe (Overlaps a) checkForOverlap (_ :| []) = Nothing - checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . NonEmpty.singleton $ OverlapGroup x1 x2 xs + checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . (:| []) $ OverlapGroup x1 x2 xs -- build the timeline assuming all elements of `sortedRecords` cover distinct (non-overlapping) time-periods timeline :: Timeline (Maybe a) diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal index b52b188..7f21c0f 100644 --- a/timeline/timeline.cabal +++ b/timeline/timeline.cabal @@ -8,7 +8,7 @@ author: Bellroy Tech Team maintainer: Bellroy Tech Team category: Development build-type: Simple -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 +tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 source-repository head type: git @@ -20,9 +20,9 @@ common deps , containers , indexed-traversable , semigroupoids - , string-interpolate - , template-haskell , time + , th-compat + , template-haskell library import: deps @@ -30,4 +30,4 @@ library exposed-modules: Data.Timeline other-modules: Data.Timeline.Internal default-language: Haskell2010 - ghc-options: -fwarn-unused-imports -Wall -fno-warn-unused-do-bind + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-unused-imports From 69aa06e55e6672570229566f3dab20a03589c484 Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 7 Mar 2023 16:11:10 +0800 Subject: [PATCH 05/24] add version bounds --- timeline-hedgehog/timeline-hedgehog.cabal | 10 +++---- timeline-tests/timeline-tests.cabal | 32 +++++++++++------------ timeline/timeline.cabal | 14 +++++----- 3 files changed, 28 insertions(+), 28 deletions(-) diff --git a/timeline-hedgehog/timeline-hedgehog.cabal b/timeline-hedgehog/timeline-hedgehog.cabal index 54f8f44..3d5e1f1 100644 --- a/timeline-hedgehog/timeline-hedgehog.cabal +++ b/timeline-hedgehog/timeline-hedgehog.cabal @@ -8,7 +8,7 @@ author: Bellroy Tech Team maintainer: Bellroy Tech Team category: Development build-type: Simple -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 +tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 source-repository head type: git @@ -16,10 +16,10 @@ source-repository head common deps build-depends: - , base >=4.13.0.0 && <4.18 - , hedgehog - , time - , timeline + , base >=4.14.3 && <4.17 + , hedgehog ^>=1.2 + , time >=1.9.3 && <1.12 + , timeline ==0.1.0.0 library import: deps diff --git a/timeline-tests/timeline-tests.cabal b/timeline-tests/timeline-tests.cabal index 336c1af..ddb81d6 100644 --- a/timeline-tests/timeline-tests.cabal +++ b/timeline-tests/timeline-tests.cabal @@ -8,7 +8,7 @@ author: Bellroy Tech Team maintainer: Bellroy Tech Team category: Development build-type: Simple -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1 +tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 source-repository head type: git @@ -21,18 +21,18 @@ test-suite tests other-modules: Spec.Data.Timeline build-tool-depends: tasty-discover:tasty-discover build-depends: - , base >=4.13.0.0 && <4.18 - , bytestring - , containers - , hashable - , hedgehog - , indexed-traversable - , tasty - , tasty-golden - , tasty-hedgehog - , tasty-hunit - , text - , time - , timeline - , timeline-hedgehog - , transformers + , base >=4.14.3 && <4.17 + , bytestring >=0.10.12.0.0 && <0.12 + , containers >=0.6.5 && <0.7 + , hashable ^>=1.4.2.0 + , hedgehog ^>=1.2 + , indexed-traversable ^>=0.1.2 + , tasty ^>=1.4.3 + , tasty-golden ^>=2.3.5 + , tasty-hedgehog ^>=1.4.0.0 + , tasty-hunit ^>=0.10.0.3 + , text ^>=1.2.4.1 + , time >=1.9.3 && <1.12 + , timeline ==0.1.0.0 + , timeline-hedgehog ==0.1.0.0 + , transformers ^>=0.5.6.2 diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal index 7f21c0f..7bb5ffd 100644 --- a/timeline/timeline.cabal +++ b/timeline/timeline.cabal @@ -16,13 +16,13 @@ source-repository head common deps build-depends: - , base >=4.13.0.0 && <4.18 - , containers - , indexed-traversable - , semigroupoids - , time - , th-compat - , template-haskell + , base >=4.14.3 && <4.17 + , containers >=0.6.5 && <0.7 + , indexed-traversable >=0.1.2 && <0.2 + , semigroupoids >=5.3.7 && <5.4 + , template-haskell >=2.16.0 && <2.19 + , th-compat >=0.1.4 && <0.2 + , time >=1.9.3 && <1.12 library import: deps From 492716187107d99e4567326df512ffe9a0600a1b Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 8 Mar 2023 13:10:14 +0800 Subject: [PATCH 06/24] use Haskell infrastructure from nixpkgs --- flake.lock | 893 +--------------------- flake.nix | 138 ++-- timeline-hedgehog/default.nix | 9 + timeline-hedgehog/timeline-hedgehog.cabal | 6 +- timeline-tests/default.nix | 20 + timeline-tests/timeline-tests.cabal | 16 +- timeline/default.nix | 14 + timeline/timeline.cabal | 6 +- 8 files changed, 139 insertions(+), 963 deletions(-) create mode 100644 timeline-hedgehog/default.nix create mode 100644 timeline-tests/default.nix create mode 100644 timeline/default.nix diff --git a/flake.lock b/flake.lock index 346467a..025ec34 100644 --- a/flake.lock +++ b/flake.lock @@ -1,161 +1,5 @@ { "nodes": { - "HTTP": { - "flake": false, - "locked": { - "lastModified": 1451647621, - "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", - "owner": "phadej", - "repo": "HTTP", - "rev": "9bc0996d412fef1787449d841277ef663ad9a915", - "type": "github" - }, - "original": { - "owner": "phadej", - "repo": "HTTP", - "type": "github" - } - }, - "blank": { - "locked": { - "lastModified": 1625557891, - "narHash": "sha256-O8/MWsPBGhhyPoPLHZAuoZiiHo9q6FLlEeIDEXuj6T4=", - "owner": "divnix", - "repo": "blank", - "rev": "5a5d2684073d9f563072ed07c871d577a6c614a8", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "blank", - "type": "github" - } - }, - "cabal-32": { - "flake": false, - "locked": { - "lastModified": 1603716527, - "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", - "owner": "haskell", - "repo": "cabal", - "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.2", - "repo": "cabal", - "type": "github" - } - }, - "cabal-34": { - "flake": false, - "locked": { - "lastModified": 1645834128, - "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", - "owner": "haskell", - "repo": "cabal", - "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.4", - "repo": "cabal", - "type": "github" - } - }, - "cabal-36": { - "flake": false, - "locked": { - "lastModified": 1669081697, - "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", - "owner": "haskell", - "repo": "cabal", - "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.6", - "repo": "cabal", - "type": "github" - } - }, - "cardano-shell": { - "flake": false, - "locked": { - "lastModified": 1608537748, - "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", - "owner": "input-output-hk", - "repo": "cardano-shell", - "rev": "9392c75087cb9a3d453998f4230930dea3a95725", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "cardano-shell", - "type": "github" - } - }, - "devshell": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1663445644, - "narHash": "sha256-+xVlcK60x7VY1vRJbNUEAHi17ZuoQxAIH4S4iUFUGBA=", - "owner": "numtide", - "repo": "devshell", - "rev": "e3dc3e21594fe07bdb24bdf1c8657acaa4cb8f66", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "devshell", - "type": "github" - } - }, - "dmerge": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ], - "yants": [ - "haskellNix", - "tullia", - "std", - "yants" - ] - }, - "locked": { - "lastModified": 1659548052, - "narHash": "sha256-fzI2gp1skGA8mQo/FBFrUAtY0GQkAIAaV/V127TJPyY=", - "owner": "divnix", - "repo": "data-merge", - "rev": "d160d18ce7b1a45b88344aa3f13ed1163954b497", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "data-merge", - "type": "github" - } - }, "flake-compat": { "flake": false, "locked": { @@ -172,39 +16,6 @@ "type": "github" } }, - "flake-compat_2": { - "flake": false, - "locked": { - "lastModified": 1672831974, - "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", - "owner": "input-output-hk", - "repo": "flake-compat", - "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "hkm/gitlab-fix", - "repo": "flake-compat", - "type": "github" - } - }, - "flake-compat_3": { - "flake": false, - "locked": { - "lastModified": 1650374568, - "narHash": "sha256-Z+s0J8/r907g149rllvwhb4pKi8Wam5ij0st8PwAh+E=", - "owner": "edolstra", - "repo": "flake-compat", - "rev": "b4a34015c698c7793d592d66adbab377907a2be8", - "type": "github" - }, - "original": { - "owner": "edolstra", - "repo": "flake-compat", - "type": "github" - } - }, "flake-utils": { "locked": { "lastModified": 1676283394, @@ -220,718 +31,26 @@ "type": "github" } }, - "flake-utils_2": { - "locked": { - "lastModified": 1667395993, - "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_3": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_4": { - "locked": { - "lastModified": 1659877975, - "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "ghc-8.6.5-iohk": { - "flake": false, - "locked": { - "lastModified": 1600920045, - "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", - "owner": "input-output-hk", - "repo": "ghc", - "rev": "95713a6ecce4551240da7c96b6176f980af75cae", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "release/8.6.5-iohk", - "repo": "ghc", - "type": "github" - } - }, - "gomod2nix": { - "inputs": { - "nixpkgs": "nixpkgs_2", - "utils": "utils" - }, - "locked": { - "lastModified": 1655245309, - "narHash": "sha256-d/YPoQ/vFn1+GTmSdvbSBSTOai61FONxB4+Lt6w/IVI=", - "owner": "tweag", - "repo": "gomod2nix", - "rev": "40d32f82fc60d66402eb0972e6e368aeab3faf58", - "type": "github" - }, - "original": { - "owner": "tweag", - "repo": "gomod2nix", - "type": "github" - } - }, - "hackage": { - "flake": false, - "locked": { - "lastModified": 1677976124, - "narHash": "sha256-tkvipSaI9asnkgrMT0xQfArOQBIR0T4N1B6dBPKy/OM=", - "owner": "input-output-hk", - "repo": "hackage.nix", - "rev": "7a4c7ed70e382aaa8fd65cc2af57bdf920320ddc", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "hackage.nix", - "type": "github" - } - }, - "haskellNix": { - "inputs": { - "HTTP": "HTTP", - "cabal-32": "cabal-32", - "cabal-34": "cabal-34", - "cabal-36": "cabal-36", - "cardano-shell": "cardano-shell", - "flake-compat": "flake-compat_2", - "flake-utils": "flake-utils_2", - "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "hackage": "hackage", - "hpc-coveralls": "hpc-coveralls", - "hydra": "hydra", - "iserv-proxy": "iserv-proxy", - "nixpkgs": [ - "haskellNix", - "nixpkgs-unstable" - ], - "nixpkgs-2003": "nixpkgs-2003", - "nixpkgs-2105": "nixpkgs-2105", - "nixpkgs-2111": "nixpkgs-2111", - "nixpkgs-2205": "nixpkgs-2205", - "nixpkgs-2211": "nixpkgs-2211", - "nixpkgs-unstable": "nixpkgs-unstable", - "old-ghc-nix": "old-ghc-nix", - "stackage": "stackage", - "tullia": "tullia" - }, - "locked": { - "lastModified": 1677977488, - "narHash": "sha256-y7qsroBhVMWGz10oWRflBpigfQjAYG46nt/oPCCKcRE=", - "owner": "input-output-hk", - "repo": "haskell.nix", - "rev": "8d21196826dac2f92ec43d30fd183452621af379", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "haskell.nix", - "type": "github" - } - }, - "hpc-coveralls": { - "flake": false, - "locked": { - "lastModified": 1607498076, - "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", - "type": "github" - }, - "original": { - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "type": "github" - } - }, - "hydra": { - "inputs": { - "nix": "nix", - "nixpkgs": [ - "haskellNix", - "hydra", - "nix", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1671755331, - "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", - "owner": "NixOS", - "repo": "hydra", - "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", - "type": "github" - }, - "original": { - "id": "hydra", - "type": "indirect" - } - }, - "incl": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1669263024, - "narHash": "sha256-E/+23NKtxAqYG/0ydYgxlgarKnxmDbg6rCMWnOBqn9Q=", - "owner": "divnix", - "repo": "incl", - "rev": "ce7bebaee048e4cd7ebdb4cee7885e00c4e2abca", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "incl", - "type": "github" - } - }, - "iserv-proxy": { - "flake": false, - "locked": { - "lastModified": 1670983692, - "narHash": "sha256-avLo34JnI9HNyOuauK5R69usJm+GfW3MlyGlYxZhTgY=", - "ref": "hkm/remote-iserv", - "rev": "50d0abb3317ac439a4e7495b185a64af9b7b9300", - "revCount": 10, - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" - }, - "original": { - "ref": "hkm/remote-iserv", - "type": "git", - "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" - } - }, - "lowdown-src": { - "flake": false, - "locked": { - "lastModified": 1633514407, - "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", - "owner": "kristapsdz", - "repo": "lowdown", - "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", - "type": "github" - }, - "original": { - "owner": "kristapsdz", - "repo": "lowdown", - "type": "github" - } - }, - "n2c": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1665039323, - "narHash": "sha256-SAh3ZjFGsaCI8FRzXQyp56qcGdAqgKEfJWPCQ0Sr7tQ=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "b008fe329ffb59b67bf9e7b08ede6ee792f2741a", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, - "nix": { - "inputs": { - "lowdown-src": "lowdown-src", - "nixpkgs": "nixpkgs", - "nixpkgs-regression": "nixpkgs-regression" - }, - "locked": { - "lastModified": 1661606874, - "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", - "owner": "NixOS", - "repo": "nix", - "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "2.11.0", - "repo": "nix", - "type": "github" - } - }, - "nix-nomad": { - "inputs": { - "flake-compat": "flake-compat_3", - "flake-utils": [ - "haskellNix", - "tullia", - "nix2container", - "flake-utils" - ], - "gomod2nix": "gomod2nix", - "nixpkgs": [ - "haskellNix", - "tullia", - "nixpkgs" - ], - "nixpkgs-lib": [ - "haskellNix", - "tullia", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1658277770, - "narHash": "sha256-T/PgG3wUn8Z2rnzfxf2VqlR1CBjInPE0l1yVzXxPnt0=", - "owner": "tristanpemble", - "repo": "nix-nomad", - "rev": "054adcbdd0a836ae1c20951b67ed549131fd2d70", - "type": "github" - }, - "original": { - "owner": "tristanpemble", - "repo": "nix-nomad", - "type": "github" - } - }, - "nix2container": { - "inputs": { - "flake-utils": "flake-utils_3", - "nixpkgs": "nixpkgs_3" - }, - "locked": { - "lastModified": 1658567952, - "narHash": "sha256-XZ4ETYAMU7XcpEeAFP3NOl9yDXNuZAen/aIJ84G+VgA=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "60bb43d405991c1378baf15a40b5811a53e32ffa", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, - "nixago": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixago-exts": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1661824785, - "narHash": "sha256-/PnwdWoO/JugJZHtDUioQp3uRiWeXHUdgvoyNbXesz8=", - "owner": "nix-community", - "repo": "nixago", - "rev": "8c1f9e5f1578d4b2ea989f618588d62a335083c3", - "type": "github" - }, - "original": { - "owner": "nix-community", - "repo": "nixago", - "type": "github" - } - }, "nixpkgs": { "locked": { - "lastModified": 1657693803, - "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixos-22.05-small", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2003": { - "locked": { - "lastModified": 1620055814, - "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", + "lastModified": 1678237502, + "narHash": "sha256-J4cAbmC9RK+Jus3U88WaxkTsnNlZSroE2xZ9A0rSxL4=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "rev": "1eeea1f1922fb79a36008ba744310ccbf96130e2", "type": "github" }, "original": { - "owner": "NixOS", - "ref": "nixpkgs-20.03-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2105": { - "locked": { - "lastModified": 1659914493, - "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.05-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2111": { - "locked": { - "lastModified": 1659446231, - "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.11-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2205": { - "locked": { - "lastModified": 1672580127, - "narHash": "sha256-3lW3xZslREhJogoOkjeZtlBtvFMyxHku7I/9IVehhT8=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "0874168639713f547c05947c76124f78441ea46c", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-22.05-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-2211": { - "locked": { - "lastModified": 1675730325, - "narHash": "sha256-uNvD7fzO5hNlltNQUAFBPlcEjNG5Gkbhl/ROiX+GZU4=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "b7ce17b1ebf600a72178f6302c77b6382d09323f", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-22.11-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-regression": { - "locked": { - "lastModified": 1643052045, - "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - }, - "original": { - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - } - }, - "nixpkgs-unstable": { - "locked": { - "lastModified": 1675758091, - "narHash": "sha256-7gFSQbSVAFUHtGCNHPF7mPc5CcqDk9M2+inlVPZSneg=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "747927516efcb5e31ba03b7ff32f61f6d47e7d87", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_2": { - "locked": { - "lastModified": 1653581809, - "narHash": "sha256-Uvka0V5MTGbeOfWte25+tfRL3moECDh1VwokWSZUdoY=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "83658b28fe638a170a19b8933aa008b30640fbd1", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixos-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_3": { - "locked": { - "lastModified": 1654807842, - "narHash": "sha256-ADymZpr6LuTEBXcy6RtFHcUZdjKTBRTMYwu19WOx17E=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "fc909087cc3386955f21b4665731dbdaceefb1d8", - "type": "github" - }, - "original": { - "owner": "NixOS", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_4": { - "locked": { - "lastModified": 1665087388, - "narHash": "sha256-FZFPuW9NWHJteATOf79rZfwfRn5fE0wi9kRzvGfDHPA=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "95fda953f6db2e9496d2682c4fc7b82f959878f7", - "type": "github" - }, - "original": { - "owner": "nixos", + "id": "nixpkgs", "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "nosys": { - "locked": { - "lastModified": 1667881534, - "narHash": "sha256-FhwJ15uPLRsvaxtt/bNuqE/ykMpNAPF0upozFKhTtXM=", - "owner": "divnix", - "repo": "nosys", - "rev": "2d0d5207f6a230e9d0f660903f8db9807b54814f", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "nosys", - "type": "github" - } - }, - "old-ghc-nix": { - "flake": false, - "locked": { - "lastModified": 1631092763, - "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", - "owner": "angerman", - "repo": "old-ghc-nix", - "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", - "type": "github" - }, - "original": { - "owner": "angerman", - "ref": "master", - "repo": "old-ghc-nix", - "type": "github" + "type": "indirect" } }, "root": { "inputs": { "flake-compat": "flake-compat", "flake-utils": "flake-utils", - "haskellNix": "haskellNix", - "nixpkgs": [ - "haskellNix", - "nixpkgs-unstable" - ] - } - }, - "stackage": { - "flake": false, - "locked": { - "lastModified": 1677975082, - "narHash": "sha256-K0tzntuS5Au+9u99NbU2A+3D1QomI6Wq4jELKfIaga4=", - "owner": "input-output-hk", - "repo": "stackage.nix", - "rev": "d6da80d17fed290baf047fa8c74dac70dc996baa", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "stackage.nix", - "type": "github" - } - }, - "std": { - "inputs": { - "arion": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "blank": "blank", - "devshell": "devshell", - "dmerge": "dmerge", - "flake-utils": "flake-utils_4", - "incl": "incl", - "makes": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "microvm": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "n2c": "n2c", - "nixago": "nixago", - "nixpkgs": "nixpkgs_4", - "nosys": "nosys", - "yants": "yants" - }, - "locked": { - "lastModified": 1674526466, - "narHash": "sha256-tMTaS0bqLx6VJ+K+ZT6xqsXNpzvSXJTmogkraBGzymg=", - "owner": "divnix", - "repo": "std", - "rev": "516387e3d8d059b50e742a2ff1909ed3c8f82826", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "std", - "type": "github" - } - }, - "tullia": { - "inputs": { - "nix-nomad": "nix-nomad", - "nix2container": "nix2container", - "nixpkgs": [ - "haskellNix", - "nixpkgs" - ], - "std": "std" - }, - "locked": { - "lastModified": 1675695930, - "narHash": "sha256-B7rEZ/DBUMlK1AcJ9ajnAPPxqXY6zW2SBX+51bZV0Ac=", - "owner": "input-output-hk", - "repo": "tullia", - "rev": "621365f2c725608f381b3ad5b57afef389fd4c31", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "tullia", - "type": "github" - } - }, - "utils": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "yants": { - "inputs": { - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1667096281, - "narHash": "sha256-wRRec6ze0gJHmGn6m57/zhz/Kdvp9HS4Nl5fkQ+uIuA=", - "owner": "divnix", - "repo": "yants", - "rev": "d18f356ec25cb94dc9c275870c3a7927a10f8c3c", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "yants", - "type": "github" + "nixpkgs": "nixpkgs" } } }, diff --git a/flake.nix b/flake.nix index 228f4a6..6c474d6 100644 --- a/flake.nix +++ b/flake.nix @@ -1,13 +1,6 @@ { - # The flake not intended to be consumed by downstream direcly. Please fetch from Hackage. - # Continue reading if you want to develop this package. - # Useful commands: - # - Build with the default copmiler: nix build .#timeline:lib:timeline - # - Test: nix build .#checks.x86_64-linux.timeline:test:tests - # - Test with other versions of GHC: .#ghc944.checks.x86_64-linux.timeline:test:tests inputs = { - haskellNix.url = "github:input-output-hk/haskell.nix"; - nixpkgs.follows = "haskellNix/nixpkgs-unstable"; + nixpkgs.url = "nixpkgs/nixpkgs-unstable"; flake-utils.url = "github:numtide/flake-utils"; flake-compat = { url = "github:edolstra/flake-compat"; @@ -15,64 +8,83 @@ }; }; - outputs = { self, nixpkgs, flake-utils, haskellNix, ... }: + outputs = inputs: let - lib = nixpkgs.lib; - supportedCompilers = [ "ghc944" "ghc926" "ghc8107" ]; + cabalPackages = [ "timeline" "timeline-hedgehog" "timeline-tests" ]; + supportedCompilers = [ "ghc8107" "ghc926" "ghc944" ]; defaultCompiler = "ghc926"; - makeOverlays = compilerNixName: [ - haskellNix.overlay - (final: prev: - { - timeline = final.haskell-nix.project' { - src = ./.; - name = "timeline"; - compiler-nix-name = compilerNixName; - shell = { - additional = pkgs: [ pkgs.tasty-discover ]; - tools = { - cabal = "latest"; - cabal-fmt = "latest"; - } // (if compilerNixName == "ghc926" then { - haskell-language-server = { - version = "latest"; - configureArgs = ''--constraint "haskell-language-server -dynamic"''; - }; - hlint = "latest"; - ormolu = "latest"; - } else { }); - buildInputs = with prev; [ - rnix-lsp - nixpkgs-fmt - ]; - withHoogle = true; - }; - }; - }) - ]; in - let - makeFlake = compilerNixName: flake-utils.lib.eachDefaultSystem (system: - let pkgs = import nixpkgs { - inherit system; - inherit (haskellNix) config; - overlays = makeOverlays compilerNixName; + inputs.flake-utils.lib.eachDefaultSystem (system: + let + nixpkgs = import inputs.nixpkgs { inherit system; }; + + makePackageSet = haskellPackages: haskellPackages.override { + overrides = final: prev: with nixpkgs.haskell.lib; + builtins.listToAttrs + ( + builtins.map + (name: { + inherit name; + value = prev.callPackage (./. + "/${name}") { }; + }) + cabalPackages + ); }; - in - pkgs.timeline.flake { }); - defaultFlake = makeFlake defaultCompiler; - in - defaultFlake // builtins.listToAttrs - ( - builtins.map - (compilerNixName: { - name = compilerNixName; - value = makeFlake compilerNixName; - }) - supportedCompilers - ); - nixConfig = { - allow-import-from-derivation = "true"; - }; + makeShell = haskellPackages: (makePackageSet haskellPackages).shellFor { + packages = p: builtins.map (name: p.${name}) cabalPackages; + withHoogle = true; + buildInputs = with nixpkgs; [ + cabal-install + hlint + ormolu + haskellPackages.haskell-language-server + haskellPackages.cabal-fmt + cabal2nix + ]; + }; + in + { + packages = + let packagesWithoutDefault = + builtins.listToAttrs + ( + builtins.concatMap + (compilerName: + let pkgSet = makePackageSet nixpkgs.haskell.packages.${compilerName}; + in + builtins.map + (name: { + name = "${compilerName}-${name}"; + value = pkgSet.${name}; + }) + cabalPackages + ) + supportedCompilers + ); + in + packagesWithoutDefault // { + default = nixpkgs.runCommand "combine" + { + buildInputs = builtins.map (name: packagesWithoutDefault.${name}) + (builtins.attrNames packagesWithoutDefault); + } "touch $out"; + }; + + devShells = + let devShellsWithoutDefault = + builtins.listToAttrs + ( + builtins.map + (compilerName: { + name = compilerName; + value = makeShell nixpkgs.haskell.packages.${compilerName}; + }) + supportedCompilers + ); in + devShellsWithoutDefault // { + default = devShellsWithoutDefault.${defaultCompiler}; + }; + } + ); } diff --git a/timeline-hedgehog/default.nix b/timeline-hedgehog/default.nix new file mode 100644 index 0000000..347fb5a --- /dev/null +++ b/timeline-hedgehog/default.nix @@ -0,0 +1,9 @@ +{ mkDerivation, base, hedgehog, lib, time, timeline }: +mkDerivation { + pname = "timeline-hedgehog"; + version = "0.1.0.0"; + src = ./.; + libraryHaskellDepends = [ base hedgehog time timeline ]; + description = "Hedgehog generators for the timeline library"; + license = lib.licenses.bsd3; +} diff --git a/timeline-hedgehog/timeline-hedgehog.cabal b/timeline-hedgehog/timeline-hedgehog.cabal index 3d5e1f1..1c91243 100644 --- a/timeline-hedgehog/timeline-hedgehog.cabal +++ b/timeline-hedgehog/timeline-hedgehog.cabal @@ -16,9 +16,9 @@ source-repository head common deps build-depends: - , base >=4.14.3 && <4.17 - , hedgehog ^>=1.2 - , time >=1.9.3 && <1.12 + , base >=4.14.3 && <4.18 + , hedgehog >=1.1 && <1.3 + , time >=1.9.3 && <1.13 , timeline ==0.1.0.0 library diff --git a/timeline-tests/default.nix b/timeline-tests/default.nix new file mode 100644 index 0000000..45cbb91 --- /dev/null +++ b/timeline-tests/default.nix @@ -0,0 +1,20 @@ +{ mkDerivation, base, bytestring, containers, hashable, hedgehog +, indexed-traversable, lib, tasty, tasty-discover, tasty-golden +, tasty-hedgehog, tasty-hunit, text, time, timeline +, timeline-hedgehog, transformers +}: +mkDerivation { + pname = "timeline-tests"; + version = "0.1.0.0"; + src = ./.; + libraryHaskellDepends = [ base ]; + testHaskellDepends = [ + base bytestring containers hashable hedgehog indexed-traversable + tasty tasty-golden tasty-hedgehog tasty-hunit text time timeline + timeline-hedgehog transformers + ]; + testToolDepends = [ tasty-discover ]; + doHaddock = false; + description = "Tests for the timeline library"; + license = lib.licenses.bsd3; +} diff --git a/timeline-tests/timeline-tests.cabal b/timeline-tests/timeline-tests.cabal index ddb81d6..4319654 100644 --- a/timeline-tests/timeline-tests.cabal +++ b/timeline-tests/timeline-tests.cabal @@ -14,6 +14,8 @@ source-repository head type: git location: https://github.com/bellroy/timeline.git +library + test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: test @@ -21,18 +23,18 @@ test-suite tests other-modules: Spec.Data.Timeline build-tool-depends: tasty-discover:tasty-discover build-depends: - , base >=4.14.3 && <4.17 - , bytestring >=0.10.12.0.0 && <0.12 - , containers >=0.6.5 && <0.7 + , base >=4.14.3 && <4.18 + , bytestring >=0.10 && <0.12 + , containers >=0.6.5 && <0.7 , hashable ^>=1.4.2.0 - , hedgehog ^>=1.2 + , hedgehog >=1.1 && <1.3 , indexed-traversable ^>=0.1.2 , tasty ^>=1.4.3 , tasty-golden ^>=2.3.5 - , tasty-hedgehog ^>=1.4.0.0 + , tasty-hedgehog >=1.2.0.0 , tasty-hunit ^>=0.10.0.3 - , text ^>=1.2.4.1 - , time >=1.9.3 && <1.12 + , text >=1.2.4.1 && <2.1 + , time >=1.9.3 && <1.13 , timeline ==0.1.0.0 , timeline-hedgehog ==0.1.0.0 , transformers ^>=0.5.6.2 diff --git a/timeline/default.nix b/timeline/default.nix new file mode 100644 index 0000000..9447399 --- /dev/null +++ b/timeline/default.nix @@ -0,0 +1,14 @@ +{ mkDerivation, base, containers, indexed-traversable, lib +, semigroupoids, template-haskell, th-compat, time +}: +mkDerivation { + pname = "timeline"; + version = "0.1.0.0"; + src = ./.; + libraryHaskellDepends = [ + base containers indexed-traversable semigroupoids template-haskell + th-compat time + ]; + description = "A simple library for handling data that changes over time"; + license = lib.licenses.bsd3; +} diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal index 7bb5ffd..62646ee 100644 --- a/timeline/timeline.cabal +++ b/timeline/timeline.cabal @@ -16,13 +16,13 @@ source-repository head common deps build-depends: - , base >=4.14.3 && <4.17 + , base >=4.14.3 && <4.18 , containers >=0.6.5 && <0.7 , indexed-traversable >=0.1.2 && <0.2 , semigroupoids >=5.3.7 && <5.4 - , template-haskell >=2.16.0 && <2.19 + , template-haskell >=2.16.0 && <2.20 , th-compat >=0.1.4 && <0.2 - , time >=1.9.3 && <1.12 + , time >=1.9.3 && <1.13 library import: deps From 2a5b9598a20ec0f0ee87fb1695fcc8129a210bf1 Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 8 Mar 2023 13:13:10 +0800 Subject: [PATCH 07/24] add comments --- flake.nix | 2 ++ 1 file changed, 2 insertions(+) diff --git a/flake.nix b/flake.nix index 6c474d6..185b62f 100644 --- a/flake.nix +++ b/flake.nix @@ -1,4 +1,6 @@ { + # Use 'nix flake show' to discover the structure of the output. + # Multiple versions of compiler is supported. inputs = { nixpkgs.url = "nixpkgs/nixpkgs-unstable"; flake-utils.url = "github:numtide/flake-utils"; From 227e882d8f51597230fcfb6a94460f48971b49d2 Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 8 Mar 2023 13:14:55 +0800 Subject: [PATCH 08/24] adjust naming --- flake.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/flake.nix b/flake.nix index 185b62f..dd74378 100644 --- a/flake.nix +++ b/flake.nix @@ -66,7 +66,7 @@ ); in packagesWithoutDefault // { - default = nixpkgs.runCommand "combine" + default = nixpkgs.runCommand "aggregate" { buildInputs = builtins.map (name: packagesWithoutDefault.${name}) (builtins.attrNames packagesWithoutDefault); From 3b4ac4254f2587d323f581a76f14c302df6c2492 Mon Sep 17 00:00:00 2001 From: kokobd Date: Thu, 9 Mar 2023 13:28:19 +0800 Subject: [PATCH 09/24] wip: apply some suggestions --- LICENSE | 29 +++++++++++++++++++ timeline-hedgehog/CHANGELOG.md | 0 timeline-hedgehog/README.md | 3 ++ .../src/Data/Timeline/Hedgehog.hs | 6 ++-- timeline-hedgehog/timeline-hedgehog.cabal | 25 +++++++++------- timeline-tests/CHANGELOG.md | 0 timeline-tests/README.md | 3 ++ .../Data/Timeline.hs => Data/TimelineTest.hs} | 2 +- timeline-tests/timeline-tests.cabal | 27 +++++++++-------- timeline/CHANGELOG.md | 1 + timeline/README.md | 1 + timeline/src/Data/Timeline.hs | 11 +++---- timeline/timeline.cabal | 25 +++++++++------- 13 files changed, 90 insertions(+), 43 deletions(-) create mode 100644 LICENSE create mode 100644 timeline-hedgehog/CHANGELOG.md create mode 100644 timeline-hedgehog/README.md create mode 100644 timeline-tests/CHANGELOG.md create mode 100644 timeline-tests/README.md rename timeline-tests/test/{Spec/Data/Timeline.hs => Data/TimelineTest.hs} (99%) create mode 120000 timeline/CHANGELOG.md create mode 120000 timeline/README.md diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e8308e6 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (C) 2023 Bellroy Pty Ltd + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/timeline-hedgehog/CHANGELOG.md b/timeline-hedgehog/CHANGELOG.md new file mode 100644 index 0000000..e69de29 diff --git a/timeline-hedgehog/README.md b/timeline-hedgehog/README.md new file mode 100644 index 0000000..ee33fb3 --- /dev/null +++ b/timeline-hedgehog/README.md @@ -0,0 +1,3 @@ +# timeline + +Provides a container type `Timeline a` for handling data that changes over time. diff --git a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs index 1f1c9d0..b27ac84 100644 --- a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs +++ b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs @@ -15,9 +15,9 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range gen :: (MonadGen m) => m a -> m (Timeline a) -gen gen' = do - initialValue <- gen' - values <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> gen' +gen genA = do + initialValue <- genA + values <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> genA pure Timeline {initialValue, values} genRecord :: (MonadGen m) => m a -> m (Record a) diff --git a/timeline-hedgehog/timeline-hedgehog.cabal b/timeline-hedgehog/timeline-hedgehog.cabal index 1c91243..209bfda 100644 --- a/timeline-hedgehog/timeline-hedgehog.cabal +++ b/timeline-hedgehog/timeline-hedgehog.cabal @@ -1,14 +1,17 @@ -cabal-version: 2.2 -name: timeline-hedgehog -version: 0.1.0.0 -synopsis: Hedgehog generators for the timeline library -license: BSD-3-Clause -license-file: LICENSE -author: Bellroy Tech Team -maintainer: Bellroy Tech Team -category: Development -build-type: Simple -tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 +cabal-version: 2.2 +name: timeline-hedgehog +version: 0.1.0.0 +synopsis: Hedgehog generators for the timeline library +license: BSD-3-Clause +license-file: LICENSE +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +category: Development +build-type: Simple +tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 +extra-source-files: + CHANGELOG.md + README.md source-repository head type: git diff --git a/timeline-tests/CHANGELOG.md b/timeline-tests/CHANGELOG.md new file mode 100644 index 0000000..e69de29 diff --git a/timeline-tests/README.md b/timeline-tests/README.md new file mode 100644 index 0000000..ee33fb3 --- /dev/null +++ b/timeline-tests/README.md @@ -0,0 +1,3 @@ +# timeline + +Provides a container type `Timeline a` for handling data that changes over time. diff --git a/timeline-tests/test/Spec/Data/Timeline.hs b/timeline-tests/test/Data/TimelineTest.hs similarity index 99% rename from timeline-tests/test/Spec/Data/Timeline.hs rename to timeline-tests/test/Data/TimelineTest.hs index 3c4c316..6fdf4c4 100644 --- a/timeline-tests/test/Spec/Data/Timeline.hs +++ b/timeline-tests/test/Data/TimelineTest.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeApplications #-} -module Spec.Data.Timeline where +module Data.TimelineTest where import Control.Applicative (liftA2) import Control.Monad.Trans.Writer.CPS (execWriter, tell) diff --git a/timeline-tests/timeline-tests.cabal b/timeline-tests/timeline-tests.cabal index 4319654..5b6f89e 100644 --- a/timeline-tests/timeline-tests.cabal +++ b/timeline-tests/timeline-tests.cabal @@ -1,14 +1,17 @@ -cabal-version: 2.2 -name: timeline-tests -version: 0.1.0.0 -synopsis: Tests for the timeline library -license: BSD-3-Clause -license-file: LICENSE -author: Bellroy Tech Team -maintainer: Bellroy Tech Team -category: Development -build-type: Simple -tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 +cabal-version: 2.2 +name: timeline-tests +version: 0.1.0.0 +synopsis: Tests for the timeline library +license: BSD-3-Clause +license-file: LICENSE +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +category: Development +build-type: Simple +tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 +extra-source-files: + CHANGELOG.md + README.md source-repository head type: git @@ -20,7 +23,7 @@ test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs - other-modules: Spec.Data.Timeline + other-modules: Data.TimelineTest build-tool-depends: tasty-discover:tasty-discover build-depends: , base >=4.14.3 && <4.18 diff --git a/timeline/CHANGELOG.md b/timeline/CHANGELOG.md new file mode 120000 index 0000000..04c99a5 --- /dev/null +++ b/timeline/CHANGELOG.md @@ -0,0 +1 @@ +../CHANGELOG.md \ No newline at end of file diff --git a/timeline/README.md b/timeline/README.md new file mode 120000 index 0000000..32d46ee --- /dev/null +++ b/timeline/README.md @@ -0,0 +1 @@ +../README.md \ No newline at end of file diff --git a/timeline/src/Data/Timeline.hs b/timeline/src/Data/Timeline.hs index 0b8381f..6c54ea3 100644 --- a/timeline/src/Data/Timeline.hs +++ b/timeline/src/Data/Timeline.hs @@ -14,8 +14,9 @@ import Language.Haskell.TH.Syntax.Compat qualified as TH makeRecordTH :: (TH.Lift a) => UTCTime -> Maybe UTCTime -> a -> TH.SpliceQ (Record a) -makeRecordTH effectiveFrom effectiveTo value = TH.bindSplice - ( maybe (fail "effective to is no greater than effective from") pure $ - makeRecord effectiveFrom effectiveTo value - ) - $ \record -> [||$$(TH.liftTyped record)||] +makeRecordTH effectiveFrom effectiveTo value = + TH.bindSplice + ( maybe (fail "effective to is no greater than effective from") pure $ + makeRecord effectiveFrom effectiveTo value + ) + TH.liftTyped diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal index 62646ee..2551a01 100644 --- a/timeline/timeline.cabal +++ b/timeline/timeline.cabal @@ -1,14 +1,17 @@ -cabal-version: 2.2 -name: timeline -version: 0.1.0.0 -synopsis: A simple library for handling data that changes over time -license: BSD-3-Clause -license-file: LICENSE -author: Bellroy Tech Team -maintainer: Bellroy Tech Team -category: Development -build-type: Simple -tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 +cabal-version: 2.2 +name: timeline +version: 0.1.0.0 +synopsis: A simple library for handling data that changes over time +license: BSD-3-Clause +license-file: LICENSE +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +category: Development +build-type: Simple +tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 +extra-source-files: + CHANGELOG.md + README.md source-repository head type: git From 47434683e905d35f96452e942890ea2e5f4f6433 Mon Sep 17 00:00:00 2001 From: kokobd Date: Fri, 10 Mar 2023 10:20:18 +0800 Subject: [PATCH 10/24] light shell; move complex Show to pretty --- flake.nix | 22 ++++--- timeline-tests/test/Data/TimelineTest.hs | 19 +++--- ...ll_non-overlapping_situations_together.txt | 2 +- .../golden/one_change,_with_effective_to.txt | 2 +- timeline-tests/test/golden/one_change.txt | 2 +- timeline-tests/test/golden/overlaps.txt | 2 +- .../test/golden/two_groups_of_overlap.txt | 2 +- timeline-tests/timeline-tests.cabal | 1 + timeline/default.nix | 4 +- timeline/src/Data/Timeline/Internal.hs | 61 +++++++++++-------- timeline/timeline.cabal | 15 ++--- 11 files changed, 73 insertions(+), 59 deletions(-) diff --git a/flake.nix b/flake.nix index dd74378..441d5bd 100644 --- a/flake.nix +++ b/flake.nix @@ -33,18 +33,25 @@ ); }; + essentialTools = with nixpkgs; [ + cabal-install + hlint + ormolu + haskellPackages.cabal-fmt + cabal2nix + ]; + makeShell = haskellPackages: (makePackageSet haskellPackages).shellFor { packages = p: builtins.map (name: p.${name}) cabalPackages; withHoogle = true; - buildInputs = with nixpkgs; [ - cabal-install - hlint - ormolu - haskellPackages.haskell-language-server - haskellPackages.cabal-fmt - cabal2nix + buildInputs = essentialTools ++ [ + nixpkgs.haskellPackages.haskell-language-server ]; }; + + lightShell = nixpkgs.mkShell { + packages = essentialTools ++ [ nixpkgs.ghc ]; + }; in { packages = @@ -86,6 +93,7 @@ ); in devShellsWithoutDefault // { default = devShellsWithoutDefault.${defaultCompiler}; + light = lightShell; }; } ); diff --git a/timeline-tests/test/Data/TimelineTest.hs b/timeline-tests/test/Data/TimelineTest.hs index 6fdf4c4..61fabc8 100644 --- a/timeline-tests/test/Data/TimelineTest.hs +++ b/timeline-tests/test/Data/TimelineTest.hs @@ -23,14 +23,6 @@ import Data.Time secondsToNominalDiffTime, ) import Data.Timeline - ( Record, - TimeRange (..), - changes, - fromRecords, - fromValues, - makeRecord, - peek, - ) import Data.Timeline.Hedgehog (gen, genUTCTime) import Hedgehog (forAll, property, (===)) import Hedgehog.Gen qualified as Gen @@ -141,7 +133,10 @@ test_fromRecords = ] where testCase' :: (Show a) => TestName -> [Maybe (Record a)] -> TestTree - testCase' name records = buildGoldenTest name . fromRecords . catMaybes $ records + testCase' name = buildGoldenTest pretty name . fromRecords . catMaybes + + pretty (Left overlaps) = prettyOverlaps overlaps + pretty (Right timeline) = prettyTimeline timeline test_peek :: [TestTree] test_peek = @@ -241,10 +236,10 @@ test_imap = imap (\_ a -> a) tl === tl ] -buildGoldenTest :: (Show a) => TestName -> a -> TestTree -buildGoldenTest name value = +buildGoldenTest :: (a -> Text) -> TestName -> a -> TestTree +buildGoldenTest pretty name value = goldenVsString name ("test/golden/" <> fmap (\ch -> if ch == ' ' then '_' else ch) name <> ".txt") - $ pure . LBS.fromStrict . T.encodeUtf8 . T.pack . show + $ pure . LBS.fromStrict . T.encodeUtf8 . pretty $ value diff --git a/timeline-tests/test/golden/all_non-overlapping_situations_together.txt b/timeline-tests/test/golden/all_non-overlapping_situations_together.txt index cb20b40..a7218ef 100644 --- a/timeline-tests/test/golden/all_non-overlapping_situations_together.txt +++ b/timeline-tests/test/golden/all_non-overlapping_situations_together.txt @@ -1,4 +1,4 @@ -Right + ----------Timeline--Start------------- initial value: Nothing since 2023-01-26 02:00:00 UTC: Just 100 diff --git a/timeline-tests/test/golden/one_change,_with_effective_to.txt b/timeline-tests/test/golden/one_change,_with_effective_to.txt index d184daa..f603e18 100644 --- a/timeline-tests/test/golden/one_change,_with_effective_to.txt +++ b/timeline-tests/test/golden/one_change,_with_effective_to.txt @@ -1,4 +1,4 @@ -Right + ----------Timeline--Start------------- initial value: Nothing since 2023-01-26 02:00:00 UTC: Just 100 diff --git a/timeline-tests/test/golden/one_change.txt b/timeline-tests/test/golden/one_change.txt index 32f961d..e8e0e6d 100644 --- a/timeline-tests/test/golden/one_change.txt +++ b/timeline-tests/test/golden/one_change.txt @@ -1,4 +1,4 @@ -Right + ----------Timeline--Start------------- initial value: Nothing since 2023-01-26 02:00:00 UTC: Just 100 diff --git a/timeline-tests/test/golden/overlaps.txt b/timeline-tests/test/golden/overlaps.txt index c8ba6f0..2ba4496 100644 --- a/timeline-tests/test/golden/overlaps.txt +++ b/timeline-tests/test/golden/overlaps.txt @@ -1,4 +1,4 @@ -Left Here are 1 group(s) of overlapping records +Here are 1 group(s) of overlapping records -------------------- 2023-01-26 02:00:00 UTC ~ Just 2023-02-28 00:00:00 UTC: 100 2023-02-27 00:00:00 UTC ~ Just 2023-03-05 00:00:00 UTC: 200 diff --git a/timeline-tests/test/golden/two_groups_of_overlap.txt b/timeline-tests/test/golden/two_groups_of_overlap.txt index c01042b..eb08fab 100644 --- a/timeline-tests/test/golden/two_groups_of_overlap.txt +++ b/timeline-tests/test/golden/two_groups_of_overlap.txt @@ -1,4 +1,4 @@ -Left Here are 2 group(s) of overlapping records +Here are 2 group(s) of overlapping records -------------------- 2023-03-01 00:00:00 UTC ~ Just 2023-03-05 00:00:00 UTC: 200 2023-03-03 00:00:00 UTC ~ Just 2023-03-04 00:00:00 UTC: 300 diff --git a/timeline-tests/timeline-tests.cabal b/timeline-tests/timeline-tests.cabal index 5b6f89e..da075ae 100644 --- a/timeline-tests/timeline-tests.cabal +++ b/timeline-tests/timeline-tests.cabal @@ -12,6 +12,7 @@ tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 extra-source-files: CHANGELOG.md README.md + test/golden/*.txt source-repository head type: git diff --git a/timeline/default.nix b/timeline/default.nix index 9447399..c49f397 100644 --- a/timeline/default.nix +++ b/timeline/default.nix @@ -1,5 +1,5 @@ { mkDerivation, base, containers, indexed-traversable, lib -, semigroupoids, template-haskell, th-compat, time +, semigroupoids, template-haskell, text, th-compat, time }: mkDerivation { pname = "timeline"; @@ -7,7 +7,7 @@ mkDerivation { src = ./.; libraryHaskellDepends = [ base containers indexed-traversable semigroupoids template-haskell - th-compat time + text th-compat time ]; description = "A simple library for handling data that changes over time"; license = lib.licenses.bsd3; diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs index 9111a00..b68240f 100644 --- a/timeline/src/Data/Timeline/Internal.hs +++ b/timeline/src/Data/Timeline/Internal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} @@ -12,6 +11,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} @@ -25,9 +25,10 @@ module Data.Timeline.Internal Timeline (..), fromValues, peek, + prettyTimeline, + changes, TimeRange (..), isTimeAfterRange, - changes, -- * effectiveFrom + optional effectiveTo Record, @@ -37,6 +38,7 @@ module Data.Timeline.Internal recordValue, fromRecords, Overlaps (..), + prettyOverlaps, OverlapGroup (..), unpackOverlapGroup, ) @@ -54,6 +56,8 @@ import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe, maybeToList) import Data.Semigroup.Foldable.Class (fold1) import Data.Set (Set) +import Data.Text (Text) +import Data.Text qualified as T import Data.Time ( UTCTime (..), ) @@ -76,7 +80,7 @@ data Timeline a = Timeline -- | changes are keyed by their "effective from" time, for easier lookup values :: Map UTCTime a } - deriving stock (Eq, Generic, Functor, Foldable, Traversable) + deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) fromValues :: -- | initial value @@ -106,16 +110,19 @@ instance Applicative Timeline where funcs values -instance (Show a) => Show (Timeline a) where - show Timeline {initialValue, values} = - unlines $ - "\n----------Timeline--Start-------------" - : ("initial value: " <> show initialValue) - : fmap showOneChange (Map.toAscList values) - ++ ["----------Timeline--End---------------"] - where - showOneChange :: (UTCTime, a) -> String - showOneChange (t, x) = "since " <> show t <> ": " <> show x +tshow :: Show a => a -> Text +tshow = T.pack . show + +prettyTimeline :: forall a. Show a => Timeline a -> Text +prettyTimeline Timeline {initialValue, values} = + T.unlines $ + "\n----------Timeline--Start-------------" + : ("initial value: " <> tshow initialValue) + : fmap showOneChange (Map.toAscList values) + ++ ["----------Timeline--End---------------"] + where + showOneChange :: (UTCTime, a) -> Text + showOneChange (t, x) = "since " <> tshow t <> ": " <> tshow x peek :: Timeline a -> UTCTime -> a peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values @@ -215,22 +222,24 @@ instance (Show a) => Show (Record a) where newtype Overlaps a = Overlaps {groups :: NonEmpty (OverlapGroup a)} deriving newtype (Semigroup) - deriving stock (Eq, Generic) - -instance (Show a) => Show (Overlaps a) where - show Overlaps {groups} = - "Here are " <> show (length groups) <> " group(s) of overlapping records\n" - ++ sep - ++ intercalate sep (show <$> NonEmpty.toList groups) - ++ sep - where - sep = "--------------------\n" + deriving stock (Show, Eq, Generic) + +prettyOverlaps :: Show a => Overlaps a -> Text +prettyOverlaps Overlaps {groups} = + "Here are " + <> tshow (length groups) + <> " group(s) of overlapping records\n" + <> sep + <> T.intercalate sep (prettyOverlapGroup <$> NonEmpty.toList groups) + <> sep + where + sep = "--------------------\n" data OverlapGroup a = OverlapGroup (Record a) (Record a) [Record a] - deriving stock (Eq, Generic) + deriving stock (Show, Eq, Generic) -instance (Show a) => Show (OverlapGroup a) where - show = unlines . fmap show . unpackOverlapGroup +prettyOverlapGroup :: Show a => OverlapGroup a -> Text +prettyOverlapGroup = T.unlines . fmap tshow . unpackOverlapGroup unpackOverlapGroup :: OverlapGroup a -> [Record a] unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal index 2551a01..d5c5cc3 100644 --- a/timeline/timeline.cabal +++ b/timeline/timeline.cabal @@ -19,13 +19,14 @@ source-repository head common deps build-depends: - , base >=4.14.3 && <4.18 - , containers >=0.6.5 && <0.7 - , indexed-traversable >=0.1.2 && <0.2 - , semigroupoids >=5.3.7 && <5.4 - , template-haskell >=2.16.0 && <2.20 - , th-compat >=0.1.4 && <0.2 - , time >=1.9.3 && <1.13 + , base >=4.14.3 && <4.18 + , containers >=0.6.5 && <0.7 + , indexed-traversable >=0.1.2 && <0.2 + , semigroupoids >=5.3.7 && <5.4 + , template-haskell >=2.16.0 && <2.20 + , text >=1.2.4.1 && <2.1 + , th-compat >=0.1.4 && <0.2 + , time >=1.9.3 && <1.13 library import: deps From 952f5e204d8896e42386a47f6ff80c1e2ac45e58 Mon Sep 17 00:00:00 2001 From: kokobd Date: Fri, 10 Mar 2023 12:10:34 +0800 Subject: [PATCH 11/24] apply all non-doc suggestions --- timeline-tests/test/Data/TimelineTest.hs | 2 +- timeline/src/Data/Timeline.hs | 1 - timeline/src/Data/Timeline/Internal.hs | 59 ++++++++++++------------ 3 files changed, 31 insertions(+), 31 deletions(-) diff --git a/timeline-tests/test/Data/TimelineTest.hs b/timeline-tests/test/Data/TimelineTest.hs index 61fabc8..932bbcd 100644 --- a/timeline-tests/test/Data/TimelineTest.hs +++ b/timeline-tests/test/Data/TimelineTest.hs @@ -225,7 +225,7 @@ test_imap = testProperty "law: imap f . imap g === imap (\\i -> f i . g i)" $ property $ do tl <- forAll $ gen (Gen.int (Range.constant 0 1000)) let hashTimeRange :: TimeRange -> Int - hashTimeRange TimeRange {trFrom, trTo} = hash (show trFrom) `hashWithSalt` show trTo + hashTimeRange TimeRange {from, to} = hash (show from) `hashWithSalt` show to f :: TimeRange -> Int -> Int f tr x = hashTimeRange tr + x g :: TimeRange -> Int -> Int diff --git a/timeline/src/Data/Timeline.hs b/timeline/src/Data/Timeline.hs index 6c54ea3..dbd08c5 100644 --- a/timeline/src/Data/Timeline.hs +++ b/timeline/src/Data/Timeline.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE TemplateHaskell #-} module Data.Timeline ( module Data.Timeline.Internal, diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs index b68240f..225f51a 100644 --- a/timeline/src/Data/Timeline/Internal.hs +++ b/timeline/src/Data/Timeline/Internal.hs @@ -18,6 +18,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Data.Timeline.Internal @@ -33,9 +34,10 @@ module Data.Timeline.Internal -- * effectiveFrom + optional effectiveTo Record, makeRecord, - recordEffectiveFrom, - recordEffectiveTo, - recordValue, + getEffectiveFrom, + getEffectiveTo, + getValue, + prettyRecord, fromRecords, Overlaps (..), prettyOverlaps, @@ -60,9 +62,13 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Time ( UTCTime (..), + diffTimeToPicoseconds, + picosecondsToDiffTime, ) +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, toOrdinalDate) import Data.Traversable.WithIndex (TraversableWithIndex (..)) import GHC.Generics (Generic) +import GHC.Records (HasField (getField)) import Language.Haskell.TH.Syntax qualified as TH (Lift (liftTyped)) import Language.Haskell.TH.Syntax.Compat qualified as TH import Prelude @@ -128,13 +134,13 @@ peek :: Timeline a -> UTCTime -> a peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values data TimeRange = TimeRange - { trFrom :: Maybe UTCTime, - trTo :: Maybe UTCTime + { from :: Maybe UTCTime, + to :: Maybe UTCTime } deriving stock (Show, Eq, Ord, Generic) isTimeAfterRange :: UTCTime -> TimeRange -> Bool -isTimeAfterRange t TimeRange {trTo} = maybe False (t >=) trTo +isTimeAfterRange t TimeRange {to} = maybe False (t >=) to instance FunctorWithIndex TimeRange Timeline where imap :: (TimeRange -> a -> b) -> Timeline a -> Timeline b @@ -162,27 +168,16 @@ data Record a = Record effectiveTo :: Maybe UTCTime, value :: a } - deriving stock (Eq, Functor) + deriving stock (Show, Eq, Functor, Foldable, Traversable) -type Getter s a = forall f. (Contravariant f) => (a -> f a) -> s -> f s +getEffectiveFrom :: Record a -> UTCTime +getEffectiveFrom = effectiveFrom -recordEffectiveFrom :: Getter (Record a) UTCTime -recordEffectiveFrom f r = contramap getEffectiveFrom (f (getEffectiveFrom r)) - where - getEffectiveFrom :: Record a -> UTCTime - getEffectiveFrom Record {effectiveFrom} = effectiveFrom - -recordEffectiveTo :: Getter (Record a) (Maybe UTCTime) -recordEffectiveTo f r = contramap getEffectiveTo (f (getEffectiveTo r)) - where - getEffectiveTo :: Record a -> Maybe UTCTime - getEffectiveTo Record {effectiveTo} = effectiveTo +getEffectiveTo :: Record a -> Maybe UTCTime +getEffectiveTo = effectiveTo -recordValue :: Getter (Record a) a -recordValue f r = contramap getValue (f (getValue r)) - where - getValue :: Record a -> a - getValue Record {value} = value +getValue :: Record a -> a +getValue = value -- | 'makeRecord' returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ makeRecord :: @@ -215,10 +210,16 @@ unLiftUTCTime :: LiftUTCTime -> UTCTime unLiftUTCTime (LiftUTCTime t) = t instance TH.Lift LiftUTCTime where - liftTyped (LiftUTCTime t) = [||LiftUTCTime (read $$(TH.liftTyped (show t)))||] + liftTyped (LiftUTCTime (UTCTime (toOrdinalDate -> (year, day)) diffTime)) = + [|| + LiftUTCTime $ + UTCTime + (fromOrdinalDate $$(TH.liftTyped year) $$(TH.liftTyped day)) + (picosecondsToDiffTime $$(TH.liftTyped (diffTimeToPicoseconds diffTime))) + ||] -instance (Show a) => Show (Record a) where - show Record {..} = show effectiveFrom <> " ~ " <> show effectiveTo <> ": " <> show value +prettyRecord :: Show a => Record a -> Text +prettyRecord Record {..} = tshow effectiveFrom <> " ~ " <> tshow effectiveTo <> ": " <> tshow value newtype Overlaps a = Overlaps {groups :: NonEmpty (OverlapGroup a)} deriving newtype (Semigroup) @@ -239,12 +240,12 @@ data OverlapGroup a = OverlapGroup (Record a) (Record a) [Record a] deriving stock (Show, Eq, Generic) prettyOverlapGroup :: Show a => OverlapGroup a -> Text -prettyOverlapGroup = T.unlines . fmap tshow . unpackOverlapGroup +prettyOverlapGroup = T.unlines . fmap prettyRecord . unpackOverlapGroup unpackOverlapGroup :: OverlapGroup a -> [Record a] unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records --- Build a 'Timeline' from a list of 'Record's. +-- | Build a 'Timeline' from a list of 'Record's. -- -- For any time, there could be zero, one, or more values, according to the input. No other condition -- is possible. We have taken account the "zero" case by wrapping the result in 'Maybe', so the only From ab53abf1a933c58e87cfef7d2093d0b0dc993f5a Mon Sep 17 00:00:00 2001 From: kokobd Date: Fri, 10 Mar 2023 13:45:16 +0800 Subject: [PATCH 12/24] add README and CHANGELOG --- CHANGELOG.md | 4 ++++ README.md | 34 +++++++++++++++++++++++++++++++++- timeline/timeline.cabal | 4 +++- 3 files changed, 40 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e69de29..bc63e58 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# Changelog + +## 0.1.0.0 +- Open source the timeline library used internally at Bellroy diff --git a/README.md b/README.md index ee33fb3..12616d7 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,35 @@ # timeline -Provides a container type `Timeline a` for handling data that changes over time. +## Motivation + +The world is always changing, and often we want to manage the changes of data +using computers. Below are some concrete examples: + +- Employee data such as compensation, city, tax rule, time-off, etc. +- Prices of products. A product could have different prices on Amazon and EBay, + and in different currencies. + +Timeline data is often implemented by attaching a field `effective_from` and +possibly an `effective_to` field to the record. However, only representing and +storing the data is not sufficient, we need to run operations on timeline data, +like extracting a single data point at some specific time, merging multiple +timelines together, etc. + +If you have a similar use case and don't want to reinvent the wheel, this +library is for you. + +## Package Organization + +- `timeline` essential types and functions +- `timeline-tests` unit tests +- `timeline-hedgehog` hedgehog generators for timeline types + +## Getting Started + +The core type is `Timeline a`, refer to +[Haddock](https://hackage.haskell.org/package/timeline-0.0.1.0/docs/Data-Timeline.html) +for its usage. + +## Contribution +We, Bellroy, actively maintains this project. Feel free to submit issues and +pull requests! Our primary timezone is GMT+11. diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal index d5c5cc3..e82a303 100644 --- a/timeline/timeline.cabal +++ b/timeline/timeline.cabal @@ -1,7 +1,9 @@ cabal-version: 2.2 name: timeline version: 0.1.0.0 -synopsis: A simple library for handling data that changes over time +synopsis: + Data type representing a piecewise-constant function over time + license: BSD-3-Clause license-file: LICENSE author: Bellroy Tech Team From 7e6268173d63be735a7d19d8c8a6661d9a96f408 Mon Sep 17 00:00:00 2001 From: kokobd Date: Fri, 10 Mar 2023 14:41:39 +0800 Subject: [PATCH 13/24] 100% haddock coverage --- README.md | 7 ++ flake.nix | 1 + .../src/Data/Timeline/Hedgehog.hs | 28 ++++++-- timeline-tests/test/Data/TimelineTest.hs | 10 +-- timeline/src/Data/Timeline.hs | 9 ++- timeline/src/Data/Timeline/Internal.hs | 68 ++++++++++++------- 6 files changed, 86 insertions(+), 37 deletions(-) diff --git a/README.md b/README.md index 12616d7..e73c67f 100644 --- a/README.md +++ b/README.md @@ -33,3 +33,10 @@ for its usage. ## Contribution We, Bellroy, actively maintains this project. Feel free to submit issues and pull requests! Our primary timezone is GMT+11. + +The code is formatted with [`ormolu`](https://hackage.haskell.org/package/ormolu) + +If you use Nix: +- `nix develop` enter a shell with all necessary tools +- `nix build` build and run tests on all GHC versions we support +- Use `nix flake show` to view a full list of outputs diff --git a/flake.nix b/flake.nix index 441d5bd..96e4f7b 100644 --- a/flake.nix +++ b/flake.nix @@ -39,6 +39,7 @@ ormolu haskellPackages.cabal-fmt cabal2nix + miniserve ]; makeShell = haskellPackages: (makePackageSet haskellPackages).shellFor { diff --git a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs index b27ac84..70d9229 100644 --- a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs +++ b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs @@ -1,9 +1,14 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} +-- | +-- Hedgehog generators for the timeline library. module Data.Timeline.Hedgehog - ( gen, + ( -- * Timeline Generators + gen, genRecord, + + -- * Helpers genUTCTime, ) where @@ -14,19 +19,30 @@ import Hedgehog (MonadGen) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -gen :: (MonadGen m) => m a -> m (Timeline a) -gen genA = do - initialValue <- genA - values <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> genA +-- | Generator for @'Timeline' a@ +gen :: + (MonadGen m) => + -- | Generator for values + m a -> + m (Timeline a) +gen genValue = do + initialValue <- genValue + values <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> genValue pure Timeline {initialValue, values} -genRecord :: (MonadGen m) => m a -> m (Record a) +-- | Generator for @'Record' a@ +genRecord :: + (MonadGen m) => + -- | Generator for the value + m a -> + m (Record a) genRecord valueGen = Gen.justT $ do t1 <- genUTCTime t2 <- Gen.maybe $ Gen.filterT (/= t1) genUTCTime makeRecord t1 t2 <$> valueGen +-- | A 'UTCTime' generator genUTCTime :: (MonadGen m) => m UTCTime genUTCTime = do y <- toInteger <$> Gen.int (Range.constant 2000 2030) diff --git a/timeline-tests/test/Data/TimelineTest.hs b/timeline-tests/test/Data/TimelineTest.hs index 932bbcd..e6d794c 100644 --- a/timeline-tests/test/Data/TimelineTest.hs +++ b/timeline-tests/test/Data/TimelineTest.hs @@ -144,12 +144,12 @@ test_peek = testCase "before first change" $ 1 @=? peek @Int - (fromValues 1 (Map.singleton (UTCTime (fromGregorian 2023 1 16) 0) 2)) + (Timeline 1 (Map.singleton (UTCTime (fromGregorian 2023 1 16) 0) 2)) (UTCTime (fromGregorian 2023 1 15) 0), testCase "between changes" $ 2 @=? peek @Int - ( fromValues + ( Timeline 1 [ (UTCTime (fromGregorian 2023 1 16) 0, 2), (UTCTime (fromGregorian 2023 1 19) 0, 3) @@ -159,7 +159,7 @@ test_peek = testCase "at the last change" $ 3 @=? peek @Int - ( fromValues + ( Timeline 1 [ (UTCTime (fromGregorian 2023 1 16) 0, 2), (UTCTime (fromGregorian 2023 1 19) 0, 3) @@ -169,7 +169,7 @@ test_peek = testCase "after all changes" $ 3 @=? peek @Int - ( fromValues + ( Timeline 1 [ (UTCTime (fromGregorian 2023 1 16) 0, 2), (UTCTime (fromGregorian 2023 1 19) 0, 3) @@ -211,7 +211,7 @@ test_imap = let t1 = UTCTime (fromGregorian 2023 1 16) 0 t2 = UTCTime (fromGregorian 2023 1 19) 0 timeline = - fromValues @Int + Timeline @Int 1 [ (t1, 2), (t2, 3) diff --git a/timeline/src/Data/Timeline.hs b/timeline/src/Data/Timeline.hs index dbd08c5..55ad812 100644 --- a/timeline/src/Data/Timeline.hs +++ b/timeline/src/Data/Timeline.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ImportQualifiedPost #-} +-- | +-- Data type representing a piecewise-constant function over time. module Data.Timeline ( module Data.Timeline.Internal, makeRecordTH, @@ -11,8 +13,13 @@ import Data.Timeline.Internal import Language.Haskell.TH.Syntax qualified as TH import Language.Haskell.TH.Syntax.Compat qualified as TH +-- | Template Haskell counterpart of 'makeRecord'. makeRecordTH :: - (TH.Lift a) => UTCTime -> Maybe UTCTime -> a -> TH.SpliceQ (Record a) + (TH.Lift a) => + UTCTime -> + Maybe UTCTime -> + a -> + TH.SpliceQ (Record a) makeRecordTH effectiveFrom effectiveTo value = TH.bindSplice ( maybe (fail "effective to is no greater than effective from") pure $ diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs index 225f51a..9332a81 100644 --- a/timeline/src/Data/Timeline/Internal.hs +++ b/timeline/src/Data/Timeline/Internal.hs @@ -22,16 +22,15 @@ {-# LANGUAGE ViewPatterns #-} module Data.Timeline.Internal - ( -- * Common + ( -- * Core types and functions Timeline (..), - fromValues, peek, prettyTimeline, changes, TimeRange (..), isTimeAfterRange, - -- * effectiveFrom + optional effectiveTo + -- * Upper bound effectiveness time handling Record, makeRecord, getEffectiveFrom, @@ -73,29 +72,21 @@ import Language.Haskell.TH.Syntax qualified as TH (Lift (liftTyped)) import Language.Haskell.TH.Syntax.Compat qualified as TH import Prelude --- | An infinite, discrete timeline for data type @a@. --- It always has a value for any time, but the set of values has a finite size. +-- | A unbounded discrete timeline for data type @a@. +-- @'Timeline' a@ always has a value for any time, but the value can only change for a finite number of times. +-- +-- * 'Functor', 'Foldable' and 'Traversable' instances are provided to traverse through the timeline; +-- * 'FunctorWithIndex', 'Foldable' and 'TraversableWithIndex' instances are provided in case you need the current time +-- range where each value holds +-- * 'Applicative' instance can be used to merge multiple 'Timeline's together data Timeline a = Timeline - {- Internally this is represented by an initial value and a list of updated values. - Each change has an effective time and a new value. - This makes it possible to inspect the individual changes and to serialize the type, - but makes it impossible to represent timelines that change continuously. Continuous data - in computers' world is very rare, unless you are working with some math formulas. - -} - { initialValue :: a, + { -- | the value from negative infinity time to the first time in 'values' + initialValue :: a, -- | changes are keyed by their "effective from" time, for easier lookup values :: Map UTCTime a } deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) -fromValues :: - -- | initial value - a -> - -- | new values begin to take effect at the specified times - Map UTCTime a -> - Timeline a -fromValues initialValue values = Timeline {initialValue, values} - instance Applicative Timeline where pure :: a -> Timeline a pure a = Timeline {initialValue = a, values = mempty} @@ -119,6 +110,9 @@ instance Applicative Timeline where tshow :: Show a => a -> Text tshow = T.pack . show +-- | Pretty-print @'Timeline' a@. It's provided so that you can investigate the value of 'Timeline' more easily. If you +-- need to show a timeline to the end user, write your own function. We don't gurantee the result to be stable across +-- different versions of this library. prettyTimeline :: forall a. Show a => Timeline a -> Text prettyTimeline Timeline {initialValue, values} = T.unlines $ @@ -130,15 +124,24 @@ prettyTimeline Timeline {initialValue, values} = showOneChange :: (UTCTime, a) -> Text showOneChange (t, x) = "since " <> tshow t <> ": " <> tshow x -peek :: Timeline a -> UTCTime -> a +-- | Extract a single value from the timeline +peek :: + Timeline a -> + -- | The time to peek. Any valid 'UTCTime' value can be passed in. + UTCTime -> + a peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values +-- | A time range. Each bound is optional. 'Nothing' represents infinity. data TimeRange = TimeRange - { from :: Maybe UTCTime, + { -- | inclusive + from :: Maybe UTCTime, + -- | exclusive to :: Maybe UTCTime } deriving stock (Show, Eq, Ord, Generic) +-- | If all time in 'TimeRange' is less than the given 'UTCTime' isTimeAfterRange :: UTCTime -> TimeRange -> Bool isTimeAfterRange t TimeRange {to} = maybe False (t >=) to @@ -160,26 +163,36 @@ instance TraversableWithIndex TimeRange Timeline where itraverse :: (Applicative f) => (TimeRange -> a -> f b) -> Timeline a -> f (Timeline b) itraverse f = sequenceA . imap f +-- | Return a set of 'UTCTime's when the value changes changes :: Timeline a -> Set UTCTime changes Timeline {values} = Map.keysSet values +-- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the type we get from inputs. A list of +-- @'Record' a@ can be converted to @'Timeline' ('Maybe' a)@. See 'fromRecords'. data Record a = Record - { effectiveFrom :: UTCTime, + { -- | inclusive + effectiveFrom :: UTCTime, + -- | exclusive. When 'Nothing', the record never expires, until there is another record with a newer 'effectiveFrom' + -- time. effectiveTo :: Maybe UTCTime, value :: a } deriving stock (Show, Eq, Functor, Foldable, Traversable) +-- | Get the "effective from" time getEffectiveFrom :: Record a -> UTCTime getEffectiveFrom = effectiveFrom +-- | Get the "effective to" time getEffectiveTo :: Record a -> Maybe UTCTime getEffectiveTo = effectiveTo +-- | Get the value wrapped in a @'Record' a@ getValue :: Record a -> a getValue = value --- | 'makeRecord' returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ +-- | A smart constructor for @'Record' a@. +-- Returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ makeRecord :: -- | effective from UTCTime -> @@ -188,7 +201,6 @@ makeRecord :: -- | value a -> Maybe (Record a) --- can't write a makeRecordTH because UTCTime has no Lift instance makeRecord effectiveFrom effectiveTo value = if maybe False (effectiveFrom >=) effectiveTo then Nothing @@ -218,13 +230,17 @@ instance TH.Lift LiftUTCTime where (picosecondsToDiffTime $$(TH.liftTyped (diffTimeToPicoseconds diffTime))) ||] +-- | Pretty-print @'Record' a@, like 'prettyTimeline'. prettyRecord :: Show a => Record a -> Text prettyRecord Record {..} = tshow effectiveFrom <> " ~ " <> tshow effectiveTo <> ": " <> tshow value +-- | An @'Overlaps' a@ consists of several groups. Within each group, all records +-- are connected where two records are "connected" if they are overlapping. newtype Overlaps a = Overlaps {groups :: NonEmpty (OverlapGroup a)} deriving newtype (Semigroup) deriving stock (Show, Eq, Generic) +-- | Pretty-print @'Overlaps' a@, like 'prettyTimeline'. prettyOverlaps :: Show a => Overlaps a -> Text prettyOverlaps Overlaps {groups} = "Here are " @@ -236,12 +252,14 @@ prettyOverlaps Overlaps {groups} = where sep = "--------------------\n" +-- | A group of overlapping records. There must be at least two records within a group. data OverlapGroup a = OverlapGroup (Record a) (Record a) [Record a] deriving stock (Show, Eq, Generic) prettyOverlapGroup :: Show a => OverlapGroup a -> Text prettyOverlapGroup = T.unlines . fmap prettyRecord . unpackOverlapGroup +-- | Unpack @'OverlapGroup' a@ as a list of records. unpackOverlapGroup :: OverlapGroup a -> [Record a] unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records From 8e98e6bc1bd328306194043534ef3031500cf8b9 Mon Sep 17 00:00:00 2001 From: kokobd Date: Mon, 13 Mar 2023 14:49:26 +0800 Subject: [PATCH 14/24] wrap comments at 80 --- CHANGELOG.md | 2 +- timeline/src/Data/Timeline/Internal.hs | 51 +++++++++++++++----------- 2 files changed, 31 insertions(+), 22 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index bc63e58..a5ee1bd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,4 @@ # Changelog ## 0.1.0.0 -- Open source the timeline library used internally at Bellroy +- Open source the timeline library we use internally at Bellroy diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs index 9332a81..5d34976 100644 --- a/timeline/src/Data/Timeline/Internal.hs +++ b/timeline/src/Data/Timeline/Internal.hs @@ -72,12 +72,14 @@ import Language.Haskell.TH.Syntax qualified as TH (Lift (liftTyped)) import Language.Haskell.TH.Syntax.Compat qualified as TH import Prelude --- | A unbounded discrete timeline for data type @a@. --- @'Timeline' a@ always has a value for any time, but the value can only change for a finite number of times. +-- | A unbounded discrete timeline for data type @a@. @'Timeline' a@ always has +-- a value for any time, but the value can only change for a finite number of +-- times. -- --- * 'Functor', 'Foldable' and 'Traversable' instances are provided to traverse through the timeline; --- * 'FunctorWithIndex', 'Foldable' and 'TraversableWithIndex' instances are provided in case you need the current time --- range where each value holds +-- * 'Functor', 'Foldable' and 'Traversable' instances are provided to traverse +-- through the timeline; +-- * 'FunctorWithIndex', 'Foldable' and 'TraversableWithIndex' instances are +-- provided in case you need the current time range where each value holds -- * 'Applicative' instance can be used to merge multiple 'Timeline's together data Timeline a = Timeline { -- | the value from negative infinity time to the first time in 'values' @@ -110,9 +112,10 @@ instance Applicative Timeline where tshow :: Show a => a -> Text tshow = T.pack . show --- | Pretty-print @'Timeline' a@. It's provided so that you can investigate the value of 'Timeline' more easily. If you --- need to show a timeline to the end user, write your own function. We don't gurantee the result to be stable across --- different versions of this library. +-- | Pretty-print @'Timeline' a@. It's provided so that you can investigate the +-- value of 'Timeline' more easily. If you need to show a timeline to the end +-- user, write your own function. We don't gurantee the result to be stable +-- across different versions of this library. prettyTimeline :: forall a. Show a => Timeline a -> Text prettyTimeline Timeline {initialValue, values} = T.unlines $ @@ -167,13 +170,14 @@ instance TraversableWithIndex TimeRange Timeline where changes :: Timeline a -> Set UTCTime changes Timeline {values} = Map.keysSet values --- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the type we get from inputs. A list of --- @'Record' a@ can be converted to @'Timeline' ('Maybe' a)@. See 'fromRecords'. +-- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the +-- type we get from inputs. A list of @'Record' a@ can be converted to +-- @'Timeline' ('Maybe' a)@. See 'fromRecords'. data Record a = Record { -- | inclusive effectiveFrom :: UTCTime, - -- | exclusive. When 'Nothing', the record never expires, until there is another record with a newer 'effectiveFrom' - -- time. + -- | exclusive. When 'Nothing', the record never expires, until there is + -- another record with a newer 'effectiveFrom' time. effectiveTo :: Maybe UTCTime, value :: a } @@ -234,8 +238,9 @@ instance TH.Lift LiftUTCTime where prettyRecord :: Show a => Record a -> Text prettyRecord Record {..} = tshow effectiveFrom <> " ~ " <> tshow effectiveTo <> ": " <> tshow value --- | An @'Overlaps' a@ consists of several groups. Within each group, all records --- are connected where two records are "connected" if they are overlapping. +-- | An @'Overlaps' a@ consists of several groups. Within each group, all +-- records are connected where two records are "connected" if they are +-- overlapping. newtype Overlaps a = Overlaps {groups :: NonEmpty (OverlapGroup a)} deriving newtype (Semigroup) deriving stock (Show, Eq, Generic) @@ -265,9 +270,11 @@ unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records -- | Build a 'Timeline' from a list of 'Record's. -- --- For any time, there could be zero, one, or more values, according to the input. No other condition --- is possible. We have taken account the "zero" case by wrapping the result in 'Maybe', so the only --- possible error is 'Overlaps'. +-- For any time, there could be zero, one, or more values, according to the +-- input. No other condition is possible. We have taken account the "zero" case +-- by wrapping the result in 'Maybe', so the only possible error is 'Overlaps'. +-- The 'Traversable' instance of @'Timeline' a@ can be used to convert +-- @'Timeline' ('Maybe' a)@ to @'Maybe' ('Timeline' a)@ fromRecords :: forall a. [Record a] -> Either (Overlaps a) (Timeline (Maybe a)) fromRecords records = maybe (Right timeline) Left overlaps @@ -287,9 +294,10 @@ fromRecords records = [NonEmpty (Record a)] -> [NonEmpty (Record a)] mergeOverlappingNeighbours current ((next :| group) : groups) - -- Be aware that this is called in 'foldr', so it traverse the list from right to left. - -- If the current record overlaps with the top (left-most) record in the next group, we add it - -- to the group. Otherwise, create a new group for it. + -- Be aware that this is called in 'foldr', so it traverse the list from + -- right to left. If the current record overlaps with the top (left-most) + -- record in the next group, we add it to the group. Otherwise, create a + -- new group for it. | isOverlapping = (current NonEmpty.<| next :| group) : groups | otherwise = (current :| []) : (next :| group) : groups where @@ -300,7 +308,8 @@ fromRecords records = checkForOverlap (_ :| []) = Nothing checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . (:| []) $ OverlapGroup x1 x2 xs - -- build the timeline assuming all elements of `sortedRecords` cover distinct (non-overlapping) time-periods + -- build the timeline assuming all elements of `sortedRecords` cover + -- distinct (non-overlapping) time-periods timeline :: Timeline (Maybe a) timeline = case nonEmpty sortedRecords of From 3fe329eb679aa1fac20ed5ca2ae73b2ebefbdaab Mon Sep 17 00:00:00 2001 From: kokobd Date: Mon, 13 Mar 2023 14:56:38 +0800 Subject: [PATCH 15/24] improve comments --- timeline/src/Data/Timeline/Internal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs index 5d34976..38777dd 100644 --- a/timeline/src/Data/Timeline/Internal.hs +++ b/timeline/src/Data/Timeline/Internal.hs @@ -239,8 +239,8 @@ prettyRecord :: Show a => Record a -> Text prettyRecord Record {..} = tshow effectiveFrom <> " ~ " <> tshow effectiveTo <> ": " <> tshow value -- | An @'Overlaps' a@ consists of several groups. Within each group, all --- records are connected where two records are "connected" if they are --- overlapping. +-- records are connected. Definition of connectivity: two records are +-- "connected" if and only if they overlap. newtype Overlaps a = Overlaps {groups :: NonEmpty (OverlapGroup a)} deriving newtype (Semigroup) deriving stock (Show, Eq, Generic) From d7cfab54105be723c9ad8e59d3071054862fc4ae Mon Sep 17 00:00:00 2001 From: Kobayashi Date: Tue, 14 Mar 2023 09:32:15 +0800 Subject: [PATCH 16/24] Update README.md Co-authored-by: lrworth --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index e73c67f..dba0841 100644 --- a/README.md +++ b/README.md @@ -31,7 +31,7 @@ The core type is `Timeline a`, refer to for its usage. ## Contribution -We, Bellroy, actively maintains this project. Feel free to submit issues and +Bellroy actively maintains this project. Feel free to submit issues and pull requests! Our primary timezone is GMT+11. The code is formatted with [`ormolu`](https://hackage.haskell.org/package/ormolu) From a8725a3d0044711a1fb462496eb2a85c4e9977c8 Mon Sep 17 00:00:00 2001 From: Kobayashi Date: Tue, 14 Mar 2023 09:32:27 +0800 Subject: [PATCH 17/24] Update README.md Co-authored-by: lrworth --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index dba0841..49ae556 100644 --- a/README.md +++ b/README.md @@ -32,7 +32,7 @@ for its usage. ## Contribution Bellroy actively maintains this project. Feel free to submit issues and -pull requests! Our primary timezone is GMT+11. +pull requests! The code is formatted with [`ormolu`](https://hackage.haskell.org/package/ormolu) From a736b7a9e9b4104e5683fab30a81cdfd2dbb5ba1 Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 14 Mar 2023 09:59:00 +0800 Subject: [PATCH 18/24] remove the term 'effective' --- README.md | 10 +-- .../src/Data/Timeline/Hedgehog.hs | 6 +- timeline-tests/test/Data/TimelineTest.hs | 2 +- timeline/src/Data/Timeline/Internal.hs | 86 +++++++++---------- 4 files changed, 52 insertions(+), 52 deletions(-) diff --git a/README.md b/README.md index 49ae556..bdb5178 100644 --- a/README.md +++ b/README.md @@ -9,11 +9,11 @@ using computers. Below are some concrete examples: - Prices of products. A product could have different prices on Amazon and EBay, and in different currencies. -Timeline data is often implemented by attaching a field `effective_from` and -possibly an `effective_to` field to the record. However, only representing and -storing the data is not sufficient, we need to run operations on timeline data, -like extracting a single data point at some specific time, merging multiple -timelines together, etc. +Timeline data is often implemented by attaching extra fields to your business +object, denoting the start and end time of each interval. However, only +representing and storing the data is not sufficient, we need to run operations +on timeline data, like extracting a single data point at some specific time, +merging multiple timelines together, etc. If you have a similar use case and don't want to reinvent the wheel, this library is for you. diff --git a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs index 70d9229..67b37ad 100644 --- a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs +++ b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs @@ -26,9 +26,9 @@ gen :: m a -> m (Timeline a) gen genValue = do - initialValue <- genValue - values <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> genValue - pure Timeline {initialValue, values} + tlInitialValue <- genValue + tlValues <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> genValue + pure Timeline {tlInitialValue, tlValues} -- | Generator for @'Record' a@ genRecord :: diff --git a/timeline-tests/test/Data/TimelineTest.hs b/timeline-tests/test/Data/TimelineTest.hs index e6d794c..0c19d42 100644 --- a/timeline-tests/test/Data/TimelineTest.hs +++ b/timeline-tests/test/Data/TimelineTest.hs @@ -225,7 +225,7 @@ test_imap = testProperty "law: imap f . imap g === imap (\\i -> f i . g i)" $ property $ do tl <- forAll $ gen (Gen.int (Range.constant 0 1000)) let hashTimeRange :: TimeRange -> Int - hashTimeRange TimeRange {from, to} = hash (show from) `hashWithSalt` show to + hashTimeRange TimeRange {trFrom, trTo} = hash (show trFrom) `hashWithSalt` show trTo f :: TimeRange -> Int -> Int f tr x = hashTimeRange tr + x g :: TimeRange -> Int -> Int diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs index 38777dd..67abcf1 100644 --- a/timeline/src/Data/Timeline/Internal.hs +++ b/timeline/src/Data/Timeline/Internal.hs @@ -33,9 +33,9 @@ module Data.Timeline.Internal -- * Upper bound effectiveness time handling Record, makeRecord, - getEffectiveFrom, - getEffectiveTo, - getValue, + recordFrom, + recordTo, + recordValue, prettyRecord, fromRecords, Overlaps (..), @@ -82,22 +82,22 @@ import Prelude -- provided in case you need the current time range where each value holds -- * 'Applicative' instance can be used to merge multiple 'Timeline's together data Timeline a = Timeline - { -- | the value from negative infinity time to the first time in 'values' - initialValue :: a, + { -- | the value from negative infinity time to the first time in 'tlValues' + tlInitialValue :: a, -- | changes are keyed by their "effective from" time, for easier lookup - values :: Map UTCTime a + tlValues :: Map UTCTime a } deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) instance Applicative Timeline where pure :: a -> Timeline a - pure a = Timeline {initialValue = a, values = mempty} + pure a = Timeline {tlInitialValue = a, tlValues = mempty} (<*>) :: forall a b. Timeline (a -> b) -> Timeline a -> Timeline b - fs@Timeline {initialValue = initialFunc, values = funcs} <*> xs@Timeline {initialValue, values} = + fs@Timeline {tlInitialValue = initialFunc, tlValues = funcs} <*> xs@Timeline {tlInitialValue, tlValues} = Timeline - { initialValue = initialFunc initialValue, - values = mergedValues + { tlInitialValue = initialFunc tlInitialValue, + tlValues = mergedValues } where mergedValues :: Map UTCTime b @@ -107,7 +107,7 @@ instance Applicative Timeline where (Map.mapMissing $ \t x -> peek fs t x) (Map.zipWithMatched (const ($))) funcs - values + tlValues tshow :: Show a => a -> Text tshow = T.pack . show @@ -117,11 +117,11 @@ tshow = T.pack . show -- user, write your own function. We don't gurantee the result to be stable -- across different versions of this library. prettyTimeline :: forall a. Show a => Timeline a -> Text -prettyTimeline Timeline {initialValue, values} = +prettyTimeline Timeline {tlInitialValue, tlValues} = T.unlines $ "\n----------Timeline--Start-------------" - : ("initial value: " <> tshow initialValue) - : fmap showOneChange (Map.toAscList values) + : ("initial value: " <> tshow tlInitialValue) + : fmap showOneChange (Map.toAscList tlValues) ++ ["----------Timeline--End---------------"] where showOneChange :: (UTCTime, a) -> Text @@ -133,32 +133,32 @@ peek :: -- | The time to peek. Any valid 'UTCTime' value can be passed in. UTCTime -> a -peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values +peek Timeline {..} time = maybe tlInitialValue snd $ Map.lookupLE time tlValues -- | A time range. Each bound is optional. 'Nothing' represents infinity. data TimeRange = TimeRange { -- | inclusive - from :: Maybe UTCTime, + trFrom :: Maybe UTCTime, -- | exclusive - to :: Maybe UTCTime + trTo :: Maybe UTCTime } deriving stock (Show, Eq, Ord, Generic) -- | If all time in 'TimeRange' is less than the given 'UTCTime' isTimeAfterRange :: UTCTime -> TimeRange -> Bool -isTimeAfterRange t TimeRange {to} = maybe False (t >=) to +isTimeAfterRange t TimeRange {trTo} = maybe False (t >=) trTo instance FunctorWithIndex TimeRange Timeline where imap :: (TimeRange -> a -> b) -> Timeline a -> Timeline b imap f Timeline {..} = Timeline - { initialValue = f initialRange initialValue, - values = flip Map.mapWithKey values $ \from value -> - let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from values) + { tlInitialValue = f initialRange tlInitialValue, + tlValues = flip Map.mapWithKey tlValues $ \from value -> + let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from tlValues) in f timeRange value } where - initialRange = TimeRange Nothing $ fst <$> Map.lookupMin values + initialRange = TimeRange Nothing $ fst <$> Map.lookupMin tlValues instance FoldableWithIndex TimeRange Timeline @@ -168,32 +168,32 @@ instance TraversableWithIndex TimeRange Timeline where -- | Return a set of 'UTCTime's when the value changes changes :: Timeline a -> Set UTCTime -changes Timeline {values} = Map.keysSet values +changes Timeline {tlValues} = Map.keysSet tlValues -- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the -- type we get from inputs. A list of @'Record' a@ can be converted to -- @'Timeline' ('Maybe' a)@. See 'fromRecords'. data Record a = Record { -- | inclusive - effectiveFrom :: UTCTime, + from :: UTCTime, -- | exclusive. When 'Nothing', the record never expires, until there is -- another record with a newer 'effectiveFrom' time. - effectiveTo :: Maybe UTCTime, + to :: Maybe UTCTime, value :: a } deriving stock (Show, Eq, Functor, Foldable, Traversable) -- | Get the "effective from" time -getEffectiveFrom :: Record a -> UTCTime -getEffectiveFrom = effectiveFrom +recordFrom :: Record a -> UTCTime +recordFrom = from -- | Get the "effective to" time -getEffectiveTo :: Record a -> Maybe UTCTime -getEffectiveTo = effectiveTo +recordTo :: Record a -> Maybe UTCTime +recordTo = to -- | Get the value wrapped in a @'Record' a@ -getValue :: Record a -> a -getValue = value +recordValue :: Record a -> a +recordValue = value -- | A smart constructor for @'Record' a@. -- Returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ @@ -205,8 +205,8 @@ makeRecord :: -- | value a -> Maybe (Record a) -makeRecord effectiveFrom effectiveTo value = - if maybe False (effectiveFrom >=) effectiveTo +makeRecord from to value = + if maybe False (from >=) to then Nothing else Just Record {..} @@ -214,8 +214,8 @@ instance (TH.Lift a) => TH.Lift (Record a) where liftTyped Record {..} = [|| Record - (unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime effectiveFrom)) - (fmap unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime <$> effectiveTo)) + (unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime from)) + (fmap unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime <$> to)) $$(TH.liftTyped value) ||] @@ -236,7 +236,7 @@ instance TH.Lift LiftUTCTime where -- | Pretty-print @'Record' a@, like 'prettyTimeline'. prettyRecord :: Show a => Record a -> Text -prettyRecord Record {..} = tshow effectiveFrom <> " ~ " <> tshow effectiveTo <> ": " <> tshow value +prettyRecord Record {..} = tshow from <> " ~ " <> tshow to <> ": " <> tshow value -- | An @'Overlaps' a@ consists of several groups. Within each group, all -- records are connected. Definition of connectivity: two records are @@ -279,7 +279,7 @@ fromRecords :: forall a. [Record a] -> Either (Overlaps a) (Timeline (Maybe a)) fromRecords records = maybe (Right timeline) Left overlaps where - sortedRecords = sortOn effectiveFrom records + sortedRecords = sortOn from records -- overlap detection overlaps = @@ -301,7 +301,7 @@ fromRecords records = | isOverlapping = (current NonEmpty.<| next :| group) : groups | otherwise = (current :| []) : (next :| group) : groups where - isOverlapping = maybe False (effectiveFrom next <) (effectiveTo current) + isOverlapping = maybe False (from next <) (to current) mergeOverlappingNeighbours current [] = [current :| []] checkForOverlap :: NonEmpty (Record a) -> Maybe (Overlaps a) @@ -316,8 +316,8 @@ fromRecords records = Nothing -> pure Nothing Just records' -> Timeline - { initialValue = Nothing, - values = + { tlInitialValue = Nothing, + tlValues = Map.fromList . concat $ zipWith connectAdjacentRecords @@ -326,11 +326,11 @@ fromRecords records = } connectAdjacentRecords :: Record a -> Maybe (Record a) -> [(UTCTime, Maybe a)] connectAdjacentRecords current next = - (effectiveFrom current, Just $ value current) + (from current, Just $ value current) : maybeToList gap where gap = do - effectiveTo' <- effectiveTo current - if maybe True (\next' -> effectiveTo' < effectiveFrom next') next + effectiveTo' <- to current + if maybe True (\next' -> effectiveTo' < from next') next then pure (effectiveTo', Nothing) else Nothing From 85bd65286f59cc285990cc631b03fd360602e9e8 Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 14 Mar 2023 10:03:18 +0800 Subject: [PATCH 19/24] use duplicate record fields --- .../src/Data/Timeline/Hedgehog.hs | 6 +- timeline-tests/test/Data/TimelineTest.hs | 2 +- timeline/src/Data/Timeline/Internal.hs | 58 +++++++++---------- 3 files changed, 33 insertions(+), 33 deletions(-) diff --git a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs index 67b37ad..70d9229 100644 --- a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs +++ b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs @@ -26,9 +26,9 @@ gen :: m a -> m (Timeline a) gen genValue = do - tlInitialValue <- genValue - tlValues <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> genValue - pure Timeline {tlInitialValue, tlValues} + initialValue <- genValue + values <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> genValue + pure Timeline {initialValue, values} -- | Generator for @'Record' a@ genRecord :: diff --git a/timeline-tests/test/Data/TimelineTest.hs b/timeline-tests/test/Data/TimelineTest.hs index 0c19d42..e6d794c 100644 --- a/timeline-tests/test/Data/TimelineTest.hs +++ b/timeline-tests/test/Data/TimelineTest.hs @@ -225,7 +225,7 @@ test_imap = testProperty "law: imap f . imap g === imap (\\i -> f i . g i)" $ property $ do tl <- forAll $ gen (Gen.int (Range.constant 0 1000)) let hashTimeRange :: TimeRange -> Int - hashTimeRange TimeRange {trFrom, trTo} = hash (show trFrom) `hashWithSalt` show trTo + hashTimeRange TimeRange {from, to} = hash (show from) `hashWithSalt` show to f :: TimeRange -> Int -> Int f tr x = hashTimeRange tr + x g :: TimeRange -> Int -> Int diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs index 67abcf1..6bd6965 100644 --- a/timeline/src/Data/Timeline/Internal.hs +++ b/timeline/src/Data/Timeline/Internal.hs @@ -82,22 +82,22 @@ import Prelude -- provided in case you need the current time range where each value holds -- * 'Applicative' instance can be used to merge multiple 'Timeline's together data Timeline a = Timeline - { -- | the value from negative infinity time to the first time in 'tlValues' - tlInitialValue :: a, + { -- | the value from negative infinity time to the first time in 'values' + initialValue :: a, -- | changes are keyed by their "effective from" time, for easier lookup - tlValues :: Map UTCTime a + values :: Map UTCTime a } deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) instance Applicative Timeline where pure :: a -> Timeline a - pure a = Timeline {tlInitialValue = a, tlValues = mempty} + pure a = Timeline {initialValue = a, values = mempty} (<*>) :: forall a b. Timeline (a -> b) -> Timeline a -> Timeline b - fs@Timeline {tlInitialValue = initialFunc, tlValues = funcs} <*> xs@Timeline {tlInitialValue, tlValues} = + fs@Timeline {initialValue = initialFunc, values = funcs} <*> xs@Timeline {initialValue, values} = Timeline - { tlInitialValue = initialFunc tlInitialValue, - tlValues = mergedValues + { initialValue = initialFunc initialValue, + values = mergedValues } where mergedValues :: Map UTCTime b @@ -107,7 +107,7 @@ instance Applicative Timeline where (Map.mapMissing $ \t x -> peek fs t x) (Map.zipWithMatched (const ($))) funcs - tlValues + values tshow :: Show a => a -> Text tshow = T.pack . show @@ -117,11 +117,11 @@ tshow = T.pack . show -- user, write your own function. We don't gurantee the result to be stable -- across different versions of this library. prettyTimeline :: forall a. Show a => Timeline a -> Text -prettyTimeline Timeline {tlInitialValue, tlValues} = +prettyTimeline Timeline {initialValue, values} = T.unlines $ "\n----------Timeline--Start-------------" - : ("initial value: " <> tshow tlInitialValue) - : fmap showOneChange (Map.toAscList tlValues) + : ("initial value: " <> tshow initialValue) + : fmap showOneChange (Map.toAscList values) ++ ["----------Timeline--End---------------"] where showOneChange :: (UTCTime, a) -> Text @@ -133,32 +133,32 @@ peek :: -- | The time to peek. Any valid 'UTCTime' value can be passed in. UTCTime -> a -peek Timeline {..} time = maybe tlInitialValue snd $ Map.lookupLE time tlValues +peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values -- | A time range. Each bound is optional. 'Nothing' represents infinity. data TimeRange = TimeRange { -- | inclusive - trFrom :: Maybe UTCTime, + from :: Maybe UTCTime, -- | exclusive - trTo :: Maybe UTCTime + to :: Maybe UTCTime } deriving stock (Show, Eq, Ord, Generic) -- | If all time in 'TimeRange' is less than the given 'UTCTime' isTimeAfterRange :: UTCTime -> TimeRange -> Bool -isTimeAfterRange t TimeRange {trTo} = maybe False (t >=) trTo +isTimeAfterRange t TimeRange {to} = maybe False (t >=) to instance FunctorWithIndex TimeRange Timeline where imap :: (TimeRange -> a -> b) -> Timeline a -> Timeline b imap f Timeline {..} = Timeline - { tlInitialValue = f initialRange tlInitialValue, - tlValues = flip Map.mapWithKey tlValues $ \from value -> - let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from tlValues) + { initialValue = f initialRange initialValue, + values = flip Map.mapWithKey values $ \from value -> + let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from values) in f timeRange value } where - initialRange = TimeRange Nothing $ fst <$> Map.lookupMin tlValues + initialRange = TimeRange Nothing $ fst <$> Map.lookupMin values instance FoldableWithIndex TimeRange Timeline @@ -168,7 +168,7 @@ instance TraversableWithIndex TimeRange Timeline where -- | Return a set of 'UTCTime's when the value changes changes :: Timeline a -> Set UTCTime -changes Timeline {tlValues} = Map.keysSet tlValues +changes Timeline {values} = Map.keysSet values -- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the -- type we get from inputs. A list of @'Record' a@ can be converted to @@ -185,11 +185,11 @@ data Record a = Record -- | Get the "effective from" time recordFrom :: Record a -> UTCTime -recordFrom = from +recordFrom Record {from} = from -- | Get the "effective to" time recordTo :: Record a -> Maybe UTCTime -recordTo = to +recordTo Record {to} = to -- | Get the value wrapped in a @'Record' a@ recordValue :: Record a -> a @@ -279,7 +279,7 @@ fromRecords :: forall a. [Record a] -> Either (Overlaps a) (Timeline (Maybe a)) fromRecords records = maybe (Right timeline) Left overlaps where - sortedRecords = sortOn from records + sortedRecords = sortOn recordFrom records -- overlap detection overlaps = @@ -301,7 +301,7 @@ fromRecords records = | isOverlapping = (current NonEmpty.<| next :| group) : groups | otherwise = (current :| []) : (next :| group) : groups where - isOverlapping = maybe False (from next <) (to current) + isOverlapping = maybe False (recordFrom next <) (recordTo current) mergeOverlappingNeighbours current [] = [current :| []] checkForOverlap :: NonEmpty (Record a) -> Maybe (Overlaps a) @@ -316,8 +316,8 @@ fromRecords records = Nothing -> pure Nothing Just records' -> Timeline - { tlInitialValue = Nothing, - tlValues = + { initialValue = Nothing, + values = Map.fromList . concat $ zipWith connectAdjacentRecords @@ -326,11 +326,11 @@ fromRecords records = } connectAdjacentRecords :: Record a -> Maybe (Record a) -> [(UTCTime, Maybe a)] connectAdjacentRecords current next = - (from current, Just $ value current) + (recordFrom current, Just $ value current) : maybeToList gap where gap = do - effectiveTo' <- to current - if maybe True (\next' -> effectiveTo' < from next') next + effectiveTo' <- recordTo current + if maybe True (\next' -> effectiveTo' < recordFrom next') next then pure (effectiveTo', Nothing) else Nothing From 0a9627d551af4a1a8921977c6f70a319f8b86885 Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 14 Mar 2023 13:19:16 +0800 Subject: [PATCH 20/24] use type variable t instead of UTCTime --- .../src/Data/Timeline/Hedgehog.hs | 37 +++---- timeline-tests/test/Data/TimelineTest.hs | 90 +++++++++------- timeline/src/Data/Timeline.hs | 9 +- timeline/src/Data/Timeline/Internal.hs | 100 ++++++++++-------- 4 files changed, 121 insertions(+), 115 deletions(-) diff --git a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs index 70d9229..434eef7 100644 --- a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs +++ b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs @@ -7,13 +7,9 @@ module Data.Timeline.Hedgehog ( -- * Timeline Generators gen, genRecord, - - -- * Helpers - genUTCTime, ) where -import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime) import Data.Timeline import Hedgehog (MonadGen) import Hedgehog.Gen qualified as Gen @@ -21,34 +17,25 @@ import Hedgehog.Range qualified as Range -- | Generator for @'Timeline' a@ gen :: - (MonadGen m) => + (MonadGen m, Ord t) => + m t -> -- | Generator for values m a -> - m (Timeline a) -gen genValue = do + m (Timeline t a) +gen genTime genValue = do initialValue <- genValue - values <- Gen.map (Range.linear 0 20) $ (,) <$> genUTCTime <*> genValue + values <- Gen.map (Range.linear 0 20) $ (,) <$> genTime <*> genValue pure Timeline {initialValue, values} -- | Generator for @'Record' a@ genRecord :: - (MonadGen m) => + (MonadGen m, Ord t) => + m t -> -- | Generator for the value m a -> - m (Record a) -genRecord valueGen = + m (Record t a) +genRecord genTime genValue = Gen.justT $ do - t1 <- genUTCTime - t2 <- Gen.maybe $ Gen.filterT (/= t1) genUTCTime - makeRecord t1 t2 <$> valueGen - --- | A 'UTCTime' generator -genUTCTime :: (MonadGen m) => m UTCTime -genUTCTime = do - y <- toInteger <$> Gen.int (Range.constant 2000 2030) - m <- Gen.int (Range.constant 1 12) - d <- Gen.int (Range.constant 1 28) - let day = fromGregorian y m d - secs <- toInteger <$> Gen.int (Range.constant 0 86401) - let diff = secondsToDiffTime secs - pure $ UTCTime day diff + t1 <- genTime + t2 <- Gen.maybe $ Gen.filterT (/= t1) genTime + makeRecord t1 t2 <$> genValue diff --git a/timeline-tests/test/Data/TimelineTest.hs b/timeline-tests/test/Data/TimelineTest.hs index e6d794c..3cab7a7 100644 --- a/timeline-tests/test/Data/TimelineTest.hs +++ b/timeline-tests/test/Data/TimelineTest.hs @@ -20,11 +20,12 @@ import Data.Time ( UTCTime (UTCTime), addUTCTime, fromGregorian, + secondsToDiffTime, secondsToNominalDiffTime, ) import Data.Timeline -import Data.Timeline.Hedgehog (gen, genUTCTime) -import Hedgehog (forAll, property, (===)) +import Data.Timeline.Hedgehog (gen) +import Hedgehog (MonadGen, forAll, property, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Test.Tasty (TestName, TestTree) @@ -36,103 +37,103 @@ test_makeRecord :: [TestTree] test_makeRecord = [ testProperty "it's always valid to have no effective-to" $ property $ do t <- forAll genUTCTime - isJust (makeRecord @Int t Nothing 1) === True, + isJust (makeRecord @UTCTime @Int t Nothing 1) === True, testProperty "effectiveFrom must be less than effective-to" $ property $ do t1 <- forAll genUTCTime t2 <- forAll genUTCTime let tMin = min t1 t2 tMax = max t1 t2 if t1 == t2 - then isNothing (makeRecord @Int t1 (Just t2) 1) === True - else isJust (makeRecord @Int tMin (Just tMax) 1) === True + then isNothing (makeRecord @UTCTime @Int t1 (Just t2) 1) === True + else isJust (makeRecord @UTCTime @Int tMin (Just tMax) 1) === True ] test_fromRecords :: [TestTree] test_fromRecords = [ testCase "empty input" $ - fromRecords @Int [] @?= Right (pure Nothing), + fromRecords @UTCTime @Int [] @?= Right (pure Nothing), testCase' "one change" - [ makeRecord @Int + [ makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 1 26) 7200) Nothing 100 ], testCase' "one change, with effective to" - [ makeRecord @Int + [ makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 1 26) 7200) (Just $ UTCTime (fromGregorian 2023 2 28) 0) 100 ], testCase' "all non-overlapping situations together" - [ makeRecord @Int + [ makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 1 26) 7200) (Just $ UTCTime (fromGregorian 2023 2 28) 0) 100, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 3 1) 0) (Just $ UTCTime (fromGregorian 2023 4 1) 0) 200, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 4 1) 0) Nothing 300, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 5 1) 0) Nothing 400, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 6 1) 0) Nothing 500 ], testCase' "overlaps" - [ makeRecord @Int + [ makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 1 26) 7200) (Just $ UTCTime (fromGregorian 2023 2 28) 0) 100, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 2 27) 0) (Just $ UTCTime (fromGregorian 2023 3 5) 0) 200, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 3 1) 0) Nothing 300 ], testCase' "two groups of overlap" - [ makeRecord @Int + [ makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 1 26) 7200) (Just $ UTCTime (fromGregorian 2023 2 28) 0) 100, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 3 1) 0) (Just $ UTCTime (fromGregorian 2023 3 5) 0) 200, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 3 3) 0) (Just $ UTCTime (fromGregorian 2023 3 4) 0) 300, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 3 6) 0) (Just $ UTCTime (fromGregorian 2023 3 8) 0) 400, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 3 8) 0) (Just $ UTCTime (fromGregorian 2023 3 15) 0) 500, - makeRecord @Int + makeRecord @UTCTime @Int (UTCTime (fromGregorian 2023 3 14) 0) Nothing 600 ] ] where - testCase' :: (Show a) => TestName -> [Maybe (Record a)] -> TestTree + testCase' :: (Show a) => TestName -> [Maybe (Record UTCTime a)] -> TestTree testCase' name = buildGoldenTest pretty name . fromRecords . catMaybes pretty (Left overlaps) = prettyOverlaps overlaps @@ -140,15 +141,15 @@ test_fromRecords = test_peek :: [TestTree] test_peek = - [ testCase "constant" $ 1 @=? peek @Int (pure 1) (UTCTime (fromGregorian 2023 1 26) 0), + [ testCase "constant" $ 1 @=? peek @UTCTime @Int (pure 1) (UTCTime (fromGregorian 2023 1 26) 0), testCase "before first change" $ 1 - @=? peek @Int + @=? peek @UTCTime @Int (Timeline 1 (Map.singleton (UTCTime (fromGregorian 2023 1 16) 0) 2)) (UTCTime (fromGregorian 2023 1 15) 0), testCase "between changes" $ 2 - @=? peek @Int + @=? peek @UTCTime @Int ( Timeline 1 [ (UTCTime (fromGregorian 2023 1 16) 0, 2), @@ -158,7 +159,7 @@ test_peek = (UTCTime (fromGregorian 2023 1 18) 0), testCase "at the last change" $ 3 - @=? peek @Int + @=? peek @UTCTime @Int ( Timeline 1 [ (UTCTime (fromGregorian 2023 1 16) 0, 2), @@ -168,7 +169,7 @@ test_peek = (UTCTime (fromGregorian 2023 1 19) 0), testCase "after all changes" $ 3 - @=? peek @Int + @=? peek @UTCTime @Int ( Timeline 1 [ (UTCTime (fromGregorian 2023 1 16) 0, 2), @@ -185,12 +186,12 @@ test_apply :: [TestTree] test_apply = [ testProperty "pure f <*> x === f <$> x" $ property $ do - timeline <- forAll $ gen (Gen.int (Range.linear 0 1000)) + timeline <- forAll $ gen genUTCTime (Gen.int (Range.linear 0 1000)) fmap (+ 1) timeline === (pure (+ 1) <*> timeline), testProperty "combined timeline" $ property $ do - t1 <- forAll $ gen (Gen.int (Range.linear 0 100)) - t2 <- forAll $ gen (Gen.int (Range.linear (-100) 0)) + t1 <- forAll $ gen genUTCTime (Gen.int (Range.linear 0 100)) + t2 <- forAll $ gen genUTCTime (Gen.int (Range.linear (-100) 0)) let combined = liftA2 (+) t1 t2 -- check the size changes t1 `Set.union` changes t2 === changes combined @@ -205,34 +206,34 @@ test_apply = test_imap :: [TestTree] test_imap = [ testProperty "when ignoring the range, it works the same as fmap" $ property $ do - tl <- forAll $ gen (Gen.int (Range.constant 0 1000)) + tl <- forAll $ gen genUTCTime (Gen.int (Range.constant 0 1000)) imap (const (+ 1)) tl === fmap (+ 1) tl, testCase "check the time ranges" $ do let t1 = UTCTime (fromGregorian 2023 1 16) 0 t2 = UTCTime (fromGregorian 2023 1 19) 0 timeline = - Timeline @Int + Timeline @UTCTime @Int 1 [ (t1, 2), (t2, 3) ] - result = execWriter . sequenceA $ imap (\range _ -> tell @[TimeRange] [range]) timeline + result = execWriter . sequenceA $ imap (\range _ -> tell @[TimeRange UTCTime] [range]) timeline result @?= [ TimeRange Nothing (Just t1), TimeRange (Just t1) (Just (addUTCTime (secondsToNominalDiffTime 259200) t1)), TimeRange (Just t2) Nothing ], testProperty "law: imap f . imap g === imap (\\i -> f i . g i)" $ property $ do - tl <- forAll $ gen (Gen.int (Range.constant 0 1000)) - let hashTimeRange :: TimeRange -> Int + tl <- forAll $ gen genUTCTime (Gen.int (Range.constant 0 1000)) + let hashTimeRange :: TimeRange UTCTime -> Int hashTimeRange TimeRange {from, to} = hash (show from) `hashWithSalt` show to - f :: TimeRange -> Int -> Int + f :: TimeRange UTCTime -> Int -> Int f tr x = hashTimeRange tr + x - g :: TimeRange -> Int -> Int + g :: TimeRange UTCTime -> Int -> Int g tr x = hashTimeRange tr - x (imap f . imap g) tl === imap (\i -> f i . g i) tl, testProperty "law: imap (\\_ a -> a) === id" $ property $ do - tl <- forAll $ gen (Gen.int (Range.constant 0 1000)) + tl <- forAll $ gen genUTCTime (Gen.int (Range.constant 0 1000)) imap (\_ a -> a) tl === tl ] @@ -243,3 +244,14 @@ buildGoldenTest pretty name value = ("test/golden/" <> fmap (\ch -> if ch == ' ' then '_' else ch) name <> ".txt") $ pure . LBS.fromStrict . T.encodeUtf8 . pretty $ value + +-- | A 'UTCTime' generator +genUTCTime :: (MonadGen m) => m UTCTime +genUTCTime = do + y <- toInteger <$> Gen.int (Range.constant 2000 2030) + m <- Gen.int (Range.constant 1 12) + d <- Gen.int (Range.constant 1 28) + let day = fromGregorian y m d + secs <- toInteger <$> Gen.int (Range.constant 0 86401) + let diff = secondsToDiffTime secs + pure $ UTCTime day diff diff --git a/timeline/src/Data/Timeline.hs b/timeline/src/Data/Timeline.hs index 55ad812..0f496b1 100644 --- a/timeline/src/Data/Timeline.hs +++ b/timeline/src/Data/Timeline.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImportQualifiedPost #-} -- | @@ -15,11 +16,11 @@ import Language.Haskell.TH.Syntax.Compat qualified as TH -- | Template Haskell counterpart of 'makeRecord'. makeRecordTH :: - (TH.Lift a) => - UTCTime -> - Maybe UTCTime -> + (Ord t, TH.Lift (Record t a)) => + t -> + Maybe t -> a -> - TH.SpliceQ (Record a) + TH.SpliceQ (Record t a) makeRecordTH effectiveFrom effectiveTo value = TH.bindSplice ( maybe (fail "effective to is no greater than effective from") pure $ diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs index 6bd6965..ef7bc49 100644 --- a/timeline/src/Data/Timeline/Internal.hs +++ b/timeline/src/Data/Timeline/Internal.hs @@ -1,9 +1,11 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} @@ -81,26 +83,26 @@ import Prelude -- * 'FunctorWithIndex', 'Foldable' and 'TraversableWithIndex' instances are -- provided in case you need the current time range where each value holds -- * 'Applicative' instance can be used to merge multiple 'Timeline's together -data Timeline a = Timeline +data Timeline t a = Timeline { -- | the value from negative infinity time to the first time in 'values' initialValue :: a, -- | changes are keyed by their "effective from" time, for easier lookup - values :: Map UTCTime a + values :: Map t a } deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) -instance Applicative Timeline where - pure :: a -> Timeline a +instance Ord t => Applicative (Timeline t) where + pure :: a -> Timeline t a pure a = Timeline {initialValue = a, values = mempty} - (<*>) :: forall a b. Timeline (a -> b) -> Timeline a -> Timeline b + (<*>) :: forall a b. Timeline t (a -> b) -> Timeline t a -> Timeline t b fs@Timeline {initialValue = initialFunc, values = funcs} <*> xs@Timeline {initialValue, values} = Timeline { initialValue = initialFunc initialValue, values = mergedValues } where - mergedValues :: Map UTCTime b + mergedValues :: Map t b mergedValues = Map.merge (Map.mapMissing $ \t f -> f $ peek xs t) @@ -116,7 +118,7 @@ tshow = T.pack . show -- value of 'Timeline' more easily. If you need to show a timeline to the end -- user, write your own function. We don't gurantee the result to be stable -- across different versions of this library. -prettyTimeline :: forall a. Show a => Timeline a -> Text +prettyTimeline :: forall t a. (Ord t, Show t, Show a) => Timeline t a -> Text prettyTimeline Timeline {initialValue, values} = T.unlines $ "\n----------Timeline--Start-------------" @@ -124,32 +126,33 @@ prettyTimeline Timeline {initialValue, values} = : fmap showOneChange (Map.toAscList values) ++ ["----------Timeline--End---------------"] where - showOneChange :: (UTCTime, a) -> Text + showOneChange :: (t, a) -> Text showOneChange (t, x) = "since " <> tshow t <> ": " <> tshow x -- | Extract a single value from the timeline peek :: - Timeline a -> - -- | The time to peek. Any valid 'UTCTime' value can be passed in. - UTCTime -> + Ord t => + Timeline t a -> + -- | the time to peek + t -> a peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values -- | A time range. Each bound is optional. 'Nothing' represents infinity. -data TimeRange = TimeRange +data TimeRange t = TimeRange { -- | inclusive - from :: Maybe UTCTime, + from :: Maybe t, -- | exclusive - to :: Maybe UTCTime + to :: Maybe t } deriving stock (Show, Eq, Ord, Generic) --- | If all time in 'TimeRange' is less than the given 'UTCTime' -isTimeAfterRange :: UTCTime -> TimeRange -> Bool +-- | If all time in 'TimeRange' is less than the given time +isTimeAfterRange :: Ord t => t -> TimeRange t -> Bool isTimeAfterRange t TimeRange {to} = maybe False (t >=) to -instance FunctorWithIndex TimeRange Timeline where - imap :: (TimeRange -> a -> b) -> Timeline a -> Timeline b +instance Ord t => FunctorWithIndex (TimeRange t) (Timeline t) where + imap :: (TimeRange t -> a -> b) -> Timeline t a -> Timeline t b imap f Timeline {..} = Timeline { initialValue = f initialRange initialValue, @@ -160,57 +163,60 @@ instance FunctorWithIndex TimeRange Timeline where where initialRange = TimeRange Nothing $ fst <$> Map.lookupMin values -instance FoldableWithIndex TimeRange Timeline +instance Ord t => FoldableWithIndex (TimeRange t) (Timeline t) -instance TraversableWithIndex TimeRange Timeline where - itraverse :: (Applicative f) => (TimeRange -> a -> f b) -> Timeline a -> f (Timeline b) +instance Ord t => TraversableWithIndex (TimeRange t) (Timeline t) where + itraverse :: (Applicative f) => (TimeRange t -> a -> f b) -> Timeline t a -> f (Timeline t b) itraverse f = sequenceA . imap f --- | Return a set of 'UTCTime's when the value changes -changes :: Timeline a -> Set UTCTime +-- | Return the set of time when the value changes +changes :: Timeline t a -> Set t changes Timeline {values} = Map.keysSet values -- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the -- type we get from inputs. A list of @'Record' a@ can be converted to -- @'Timeline' ('Maybe' a)@. See 'fromRecords'. -data Record a = Record +data Record t a = Record { -- | inclusive - from :: UTCTime, + from :: t, -- | exclusive. When 'Nothing', the record never expires, until there is -- another record with a newer 'effectiveFrom' time. - to :: Maybe UTCTime, + to :: Maybe t, value :: a } - deriving stock (Show, Eq, Functor, Foldable, Traversable) + deriving stock (Show, Eq, Functor, Foldable, Traversable, TH.Lift) -- | Get the "effective from" time -recordFrom :: Record a -> UTCTime +recordFrom :: Record t a -> t recordFrom Record {from} = from -- | Get the "effective to" time -recordTo :: Record a -> Maybe UTCTime +recordTo :: Record t a -> Maybe t recordTo Record {to} = to -- | Get the value wrapped in a @'Record' a@ -recordValue :: Record a -> a +recordValue :: Record t a -> a recordValue = value -- | A smart constructor for @'Record' a@. -- Returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ makeRecord :: + Ord t => -- | effective from - UTCTime -> + t -> -- | optional effective to - Maybe UTCTime -> + Maybe t -> -- | value a -> - Maybe (Record a) + Maybe (Record t a) makeRecord from to value = if maybe False (from >=) to then Nothing else Just Record {..} -instance (TH.Lift a) => TH.Lift (Record a) where +-- | Special support for 'UTCTime'. This will be removed when 'TH.Lift' +-- instances are provided by the @time@ package directly. +instance {-# OVERLAPPING #-} (TH.Lift a) => TH.Lift (Record UTCTime a) where liftTyped Record {..} = [|| Record @@ -235,18 +241,18 @@ instance TH.Lift LiftUTCTime where ||] -- | Pretty-print @'Record' a@, like 'prettyTimeline'. -prettyRecord :: Show a => Record a -> Text +prettyRecord :: (Show t, Show a) => Record t a -> Text prettyRecord Record {..} = tshow from <> " ~ " <> tshow to <> ": " <> tshow value -- | An @'Overlaps' a@ consists of several groups. Within each group, all -- records are connected. Definition of connectivity: two records are -- "connected" if and only if they overlap. -newtype Overlaps a = Overlaps {groups :: NonEmpty (OverlapGroup a)} +newtype Overlaps t a = Overlaps {groups :: NonEmpty (OverlapGroup t a)} deriving newtype (Semigroup) deriving stock (Show, Eq, Generic) -- | Pretty-print @'Overlaps' a@, like 'prettyTimeline'. -prettyOverlaps :: Show a => Overlaps a -> Text +prettyOverlaps :: (Show t, Show a) => Overlaps t a -> Text prettyOverlaps Overlaps {groups} = "Here are " <> tshow (length groups) @@ -258,14 +264,14 @@ prettyOverlaps Overlaps {groups} = sep = "--------------------\n" -- | A group of overlapping records. There must be at least two records within a group. -data OverlapGroup a = OverlapGroup (Record a) (Record a) [Record a] +data OverlapGroup t a = OverlapGroup (Record t a) (Record t a) [Record t a] deriving stock (Show, Eq, Generic) -prettyOverlapGroup :: Show a => OverlapGroup a -> Text +prettyOverlapGroup :: (Show t, Show a) => OverlapGroup t a -> Text prettyOverlapGroup = T.unlines . fmap prettyRecord . unpackOverlapGroup -- | Unpack @'OverlapGroup' a@ as a list of records. -unpackOverlapGroup :: OverlapGroup a -> [Record a] +unpackOverlapGroup :: OverlapGroup t a -> [Record t a] unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records -- | Build a 'Timeline' from a list of 'Record's. @@ -275,7 +281,7 @@ unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records -- by wrapping the result in 'Maybe', so the only possible error is 'Overlaps'. -- The 'Traversable' instance of @'Timeline' a@ can be used to convert -- @'Timeline' ('Maybe' a)@ to @'Maybe' ('Timeline' a)@ -fromRecords :: forall a. [Record a] -> Either (Overlaps a) (Timeline (Maybe a)) +fromRecords :: forall t a. Ord t => [Record t a] -> Either (Overlaps t a) (Timeline t (Maybe a)) fromRecords records = maybe (Right timeline) Left overlaps where @@ -290,9 +296,9 @@ fromRecords records = $ sortedRecords mergeOverlappingNeighbours :: - Record a -> - [NonEmpty (Record a)] -> - [NonEmpty (Record a)] + Record t a -> + [NonEmpty (Record t a)] -> + [NonEmpty (Record t a)] mergeOverlappingNeighbours current ((next :| group) : groups) -- Be aware that this is called in 'foldr', so it traverse the list from -- right to left. If the current record overlaps with the top (left-most) @@ -304,13 +310,13 @@ fromRecords records = isOverlapping = maybe False (recordFrom next <) (recordTo current) mergeOverlappingNeighbours current [] = [current :| []] - checkForOverlap :: NonEmpty (Record a) -> Maybe (Overlaps a) + checkForOverlap :: NonEmpty (Record t a) -> Maybe (Overlaps t a) checkForOverlap (_ :| []) = Nothing checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . (:| []) $ OverlapGroup x1 x2 xs -- build the timeline assuming all elements of `sortedRecords` cover -- distinct (non-overlapping) time-periods - timeline :: Timeline (Maybe a) + timeline :: Timeline t (Maybe a) timeline = case nonEmpty sortedRecords of Nothing -> pure Nothing @@ -324,7 +330,7 @@ fromRecords records = (NonEmpty.toList records') ((Just <$> NonEmpty.tail records') <> [Nothing]) } - connectAdjacentRecords :: Record a -> Maybe (Record a) -> [(UTCTime, Maybe a)] + connectAdjacentRecords :: Record t a -> Maybe (Record t a) -> [(t, Maybe a)] connectAdjacentRecords current next = (recordFrom current, Just $ value current) : maybeToList gap From 39440681551a27e479a1cfb3bf1449c4b09b16ff Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 14 Mar 2023 13:21:43 +0800 Subject: [PATCH 21/24] remove the useless internal module --- timeline/src/Data/Timeline.hs | 341 +++++++++++++++++++++++- timeline/src/Data/Timeline/Internal.hs | 342 ------------------------- timeline/timeline.cabal | 1 - 3 files changed, 335 insertions(+), 349 deletions(-) delete mode 100644 timeline/src/Data/Timeline/Internal.hs diff --git a/timeline/src/Data/Timeline.hs b/timeline/src/Data/Timeline.hs index 0f496b1..445a17c 100644 --- a/timeline/src/Data/Timeline.hs +++ b/timeline/src/Data/Timeline.hs @@ -1,18 +1,220 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} --- | --- Data type representing a piecewise-constant function over time. module Data.Timeline - ( module Data.Timeline.Internal, + ( -- * Core types and functions + Timeline (..), + peek, + prettyTimeline, + changes, + TimeRange (..), + isTimeAfterRange, + + -- * Upper bound effectiveness time handling + Record, + makeRecord, makeRecordTH, + recordFrom, + recordTo, + recordValue, + prettyRecord, + fromRecords, + Overlaps (..), + prettyOverlaps, + OverlapGroup (..), + unpackOverlapGroup, ) where -import Data.Time (UTCTime) -import Data.Timeline.Internal -import Language.Haskell.TH.Syntax qualified as TH +import Data.Foldable.WithIndex (FoldableWithIndex (..)) +import Data.Functor.Contravariant (Contravariant, contramap) +import Data.Functor.WithIndex (FunctorWithIndex (..)) +import Data.List (intercalate, sortOn) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe, maybeToList) +import Data.Semigroup.Foldable.Class (fold1) +import Data.Set (Set) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time + ( UTCTime (..), + diffTimeToPicoseconds, + picosecondsToDiffTime, + ) +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, toOrdinalDate) +import Data.Traversable.WithIndex (TraversableWithIndex (..)) +import GHC.Generics (Generic) +import GHC.Records (HasField (getField)) +import Language.Haskell.TH.Syntax qualified as TH (Lift (liftTyped)) import Language.Haskell.TH.Syntax.Compat qualified as TH +import Prelude + +-- | A unbounded discrete timeline for data type @a@. @'Timeline' a@ always has +-- a value for any time, but the value can only change for a finite number of +-- times. +-- +-- * 'Functor', 'Foldable' and 'Traversable' instances are provided to traverse +-- through the timeline; +-- * 'FunctorWithIndex', 'Foldable' and 'TraversableWithIndex' instances are +-- provided in case you need the current time range where each value holds +-- * 'Applicative' instance can be used to merge multiple 'Timeline's together +data Timeline t a = Timeline + { -- | the value from negative infinity time to the first time in 'values' + initialValue :: a, + -- | changes are keyed by their "effective from" time, for easier lookup + values :: Map t a + } + deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) + +instance Ord t => Applicative (Timeline t) where + pure :: a -> Timeline t a + pure a = Timeline {initialValue = a, values = mempty} + + (<*>) :: forall a b. Timeline t (a -> b) -> Timeline t a -> Timeline t b + fs@Timeline {initialValue = initialFunc, values = funcs} <*> xs@Timeline {initialValue, values} = + Timeline + { initialValue = initialFunc initialValue, + values = mergedValues + } + where + mergedValues :: Map t b + mergedValues = + Map.merge + (Map.mapMissing $ \t f -> f $ peek xs t) + (Map.mapMissing $ \t x -> peek fs t x) + (Map.zipWithMatched (const ($))) + funcs + values + +tshow :: Show a => a -> Text +tshow = T.pack . show + +-- | Pretty-print @'Timeline' a@. It's provided so that you can investigate the +-- value of 'Timeline' more easily. If you need to show a timeline to the end +-- user, write your own function. We don't gurantee the result to be stable +-- across different versions of this library. +prettyTimeline :: forall t a. (Ord t, Show t, Show a) => Timeline t a -> Text +prettyTimeline Timeline {initialValue, values} = + T.unlines $ + "\n----------Timeline--Start-------------" + : ("initial value: " <> tshow initialValue) + : fmap showOneChange (Map.toAscList values) + ++ ["----------Timeline--End---------------"] + where + showOneChange :: (t, a) -> Text + showOneChange (t, x) = "since " <> tshow t <> ": " <> tshow x + +-- | Extract a single value from the timeline +peek :: + Ord t => + Timeline t a -> + -- | the time to peek + t -> + a +peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values + +-- | A time range. Each bound is optional. 'Nothing' represents infinity. +data TimeRange t = TimeRange + { -- | inclusive + from :: Maybe t, + -- | exclusive + to :: Maybe t + } + deriving stock (Show, Eq, Ord, Generic) + +-- | If all time in 'TimeRange' is less than the given time +isTimeAfterRange :: Ord t => t -> TimeRange t -> Bool +isTimeAfterRange t TimeRange {to} = maybe False (t >=) to + +instance Ord t => FunctorWithIndex (TimeRange t) (Timeline t) where + imap :: (TimeRange t -> a -> b) -> Timeline t a -> Timeline t b + imap f Timeline {..} = + Timeline + { initialValue = f initialRange initialValue, + values = flip Map.mapWithKey values $ \from value -> + let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from values) + in f timeRange value + } + where + initialRange = TimeRange Nothing $ fst <$> Map.lookupMin values + +instance Ord t => FoldableWithIndex (TimeRange t) (Timeline t) + +instance Ord t => TraversableWithIndex (TimeRange t) (Timeline t) where + itraverse :: (Applicative f) => (TimeRange t -> a -> f b) -> Timeline t a -> f (Timeline t b) + itraverse f = sequenceA . imap f + +-- | Return the set of time when the value changes +changes :: Timeline t a -> Set t +changes Timeline {values} = Map.keysSet values + +-- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the +-- type we get from inputs. A list of @'Record' a@ can be converted to +-- @'Timeline' ('Maybe' a)@. See 'fromRecords'. +data Record t a = Record + { -- | inclusive + from :: t, + -- | exclusive. When 'Nothing', the record never expires, until there is + -- another record with a newer 'effectiveFrom' time. + to :: Maybe t, + value :: a + } + deriving stock (Show, Eq, Functor, Foldable, Traversable, TH.Lift) + +-- | Get the "effective from" time +recordFrom :: Record t a -> t +recordFrom Record {from} = from + +-- | Get the "effective to" time +recordTo :: Record t a -> Maybe t +recordTo Record {to} = to + +-- | Get the value wrapped in a @'Record' a@ +recordValue :: Record t a -> a +recordValue = value + +-- | A smart constructor for @'Record' a@. +-- Returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ +makeRecord :: + Ord t => + -- | effective from + t -> + -- | optional effective to + Maybe t -> + -- | value + a -> + Maybe (Record t a) +makeRecord from to value = + if maybe False (from >=) to + then Nothing + else Just Record {..} -- | Template Haskell counterpart of 'makeRecord'. makeRecordTH :: @@ -27,3 +229,130 @@ makeRecordTH effectiveFrom effectiveTo value = makeRecord effectiveFrom effectiveTo value ) TH.liftTyped + +-- | Special support for 'UTCTime'. This will be removed when 'TH.Lift' +-- instances are provided by the @time@ package directly. +instance {-# OVERLAPPING #-} (TH.Lift a) => TH.Lift (Record UTCTime a) where + liftTyped Record {..} = + [|| + Record + (unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime from)) + (fmap unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime <$> to)) + $$(TH.liftTyped value) + ||] + +newtype LiftUTCTime = LiftUTCTime UTCTime + deriving stock (Generic) + +unLiftUTCTime :: LiftUTCTime -> UTCTime +unLiftUTCTime (LiftUTCTime t) = t + +instance TH.Lift LiftUTCTime where + liftTyped (LiftUTCTime (UTCTime (toOrdinalDate -> (year, day)) diffTime)) = + [|| + LiftUTCTime $ + UTCTime + (fromOrdinalDate $$(TH.liftTyped year) $$(TH.liftTyped day)) + (picosecondsToDiffTime $$(TH.liftTyped (diffTimeToPicoseconds diffTime))) + ||] + +-- | Pretty-print @'Record' a@, like 'prettyTimeline'. +prettyRecord :: (Show t, Show a) => Record t a -> Text +prettyRecord Record {..} = tshow from <> " ~ " <> tshow to <> ": " <> tshow value + +-- | An @'Overlaps' a@ consists of several groups. Within each group, all +-- records are connected. Definition of connectivity: two records are +-- "connected" if and only if they overlap. +newtype Overlaps t a = Overlaps {groups :: NonEmpty (OverlapGroup t a)} + deriving newtype (Semigroup) + deriving stock (Show, Eq, Generic) + +-- | Pretty-print @'Overlaps' a@, like 'prettyTimeline'. +prettyOverlaps :: (Show t, Show a) => Overlaps t a -> Text +prettyOverlaps Overlaps {groups} = + "Here are " + <> tshow (length groups) + <> " group(s) of overlapping records\n" + <> sep + <> T.intercalate sep (prettyOverlapGroup <$> NonEmpty.toList groups) + <> sep + where + sep = "--------------------\n" + +-- | A group of overlapping records. There must be at least two records within a group. +data OverlapGroup t a = OverlapGroup (Record t a) (Record t a) [Record t a] + deriving stock (Show, Eq, Generic) + +prettyOverlapGroup :: (Show t, Show a) => OverlapGroup t a -> Text +prettyOverlapGroup = T.unlines . fmap prettyRecord . unpackOverlapGroup + +-- | Unpack @'OverlapGroup' a@ as a list of records. +unpackOverlapGroup :: OverlapGroup t a -> [Record t a] +unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records + +-- | Build a 'Timeline' from a list of 'Record's. +-- +-- For any time, there could be zero, one, or more values, according to the +-- input. No other condition is possible. We have taken account the "zero" case +-- by wrapping the result in 'Maybe', so the only possible error is 'Overlaps'. +-- The 'Traversable' instance of @'Timeline' a@ can be used to convert +-- @'Timeline' ('Maybe' a)@ to @'Maybe' ('Timeline' a)@ +fromRecords :: forall t a. Ord t => [Record t a] -> Either (Overlaps t a) (Timeline t (Maybe a)) +fromRecords records = + maybe (Right timeline) Left overlaps + where + sortedRecords = sortOn recordFrom records + + -- overlap detection + overlaps = + fmap fold1 + . nonEmpty + . mapMaybe checkForOverlap + . foldr mergeOverlappingNeighbours [] + $ sortedRecords + + mergeOverlappingNeighbours :: + Record t a -> + [NonEmpty (Record t a)] -> + [NonEmpty (Record t a)] + mergeOverlappingNeighbours current ((next :| group) : groups) + -- Be aware that this is called in 'foldr', so it traverse the list from + -- right to left. If the current record overlaps with the top (left-most) + -- record in the next group, we add it to the group. Otherwise, create a + -- new group for it. + | isOverlapping = (current NonEmpty.<| next :| group) : groups + | otherwise = (current :| []) : (next :| group) : groups + where + isOverlapping = maybe False (recordFrom next <) (recordTo current) + mergeOverlappingNeighbours current [] = [current :| []] + + checkForOverlap :: NonEmpty (Record t a) -> Maybe (Overlaps t a) + checkForOverlap (_ :| []) = Nothing + checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . (:| []) $ OverlapGroup x1 x2 xs + + -- build the timeline assuming all elements of `sortedRecords` cover + -- distinct (non-overlapping) time-periods + timeline :: Timeline t (Maybe a) + timeline = + case nonEmpty sortedRecords of + Nothing -> pure Nothing + Just records' -> + Timeline + { initialValue = Nothing, + values = + Map.fromList . concat $ + zipWith + connectAdjacentRecords + (NonEmpty.toList records') + ((Just <$> NonEmpty.tail records') <> [Nothing]) + } + connectAdjacentRecords :: Record t a -> Maybe (Record t a) -> [(t, Maybe a)] + connectAdjacentRecords current next = + (recordFrom current, Just $ value current) + : maybeToList gap + where + gap = do + effectiveTo' <- recordTo current + if maybe True (\next' -> effectiveTo' < recordFrom next') next + then pure (effectiveTo', Nothing) + else Nothing diff --git a/timeline/src/Data/Timeline/Internal.hs b/timeline/src/Data/Timeline/Internal.hs deleted file mode 100644 index ef7bc49..0000000 --- a/timeline/src/Data/Timeline/Internal.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Data.Timeline.Internal - ( -- * Core types and functions - Timeline (..), - peek, - prettyTimeline, - changes, - TimeRange (..), - isTimeAfterRange, - - -- * Upper bound effectiveness time handling - Record, - makeRecord, - recordFrom, - recordTo, - recordValue, - prettyRecord, - fromRecords, - Overlaps (..), - prettyOverlaps, - OverlapGroup (..), - unpackOverlapGroup, - ) -where - -import Data.Foldable.WithIndex (FoldableWithIndex (..)) -import Data.Functor.Contravariant (Contravariant, contramap) -import Data.Functor.WithIndex (FunctorWithIndex (..)) -import Data.List (intercalate, sortOn) -import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Map.Merge.Strict qualified as Map -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe, maybeToList) -import Data.Semigroup.Foldable.Class (fold1) -import Data.Set (Set) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Time - ( UTCTime (..), - diffTimeToPicoseconds, - picosecondsToDiffTime, - ) -import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, toOrdinalDate) -import Data.Traversable.WithIndex (TraversableWithIndex (..)) -import GHC.Generics (Generic) -import GHC.Records (HasField (getField)) -import Language.Haskell.TH.Syntax qualified as TH (Lift (liftTyped)) -import Language.Haskell.TH.Syntax.Compat qualified as TH -import Prelude - --- | A unbounded discrete timeline for data type @a@. @'Timeline' a@ always has --- a value for any time, but the value can only change for a finite number of --- times. --- --- * 'Functor', 'Foldable' and 'Traversable' instances are provided to traverse --- through the timeline; --- * 'FunctorWithIndex', 'Foldable' and 'TraversableWithIndex' instances are --- provided in case you need the current time range where each value holds --- * 'Applicative' instance can be used to merge multiple 'Timeline's together -data Timeline t a = Timeline - { -- | the value from negative infinity time to the first time in 'values' - initialValue :: a, - -- | changes are keyed by their "effective from" time, for easier lookup - values :: Map t a - } - deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) - -instance Ord t => Applicative (Timeline t) where - pure :: a -> Timeline t a - pure a = Timeline {initialValue = a, values = mempty} - - (<*>) :: forall a b. Timeline t (a -> b) -> Timeline t a -> Timeline t b - fs@Timeline {initialValue = initialFunc, values = funcs} <*> xs@Timeline {initialValue, values} = - Timeline - { initialValue = initialFunc initialValue, - values = mergedValues - } - where - mergedValues :: Map t b - mergedValues = - Map.merge - (Map.mapMissing $ \t f -> f $ peek xs t) - (Map.mapMissing $ \t x -> peek fs t x) - (Map.zipWithMatched (const ($))) - funcs - values - -tshow :: Show a => a -> Text -tshow = T.pack . show - --- | Pretty-print @'Timeline' a@. It's provided so that you can investigate the --- value of 'Timeline' more easily. If you need to show a timeline to the end --- user, write your own function. We don't gurantee the result to be stable --- across different versions of this library. -prettyTimeline :: forall t a. (Ord t, Show t, Show a) => Timeline t a -> Text -prettyTimeline Timeline {initialValue, values} = - T.unlines $ - "\n----------Timeline--Start-------------" - : ("initial value: " <> tshow initialValue) - : fmap showOneChange (Map.toAscList values) - ++ ["----------Timeline--End---------------"] - where - showOneChange :: (t, a) -> Text - showOneChange (t, x) = "since " <> tshow t <> ": " <> tshow x - --- | Extract a single value from the timeline -peek :: - Ord t => - Timeline t a -> - -- | the time to peek - t -> - a -peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values - --- | A time range. Each bound is optional. 'Nothing' represents infinity. -data TimeRange t = TimeRange - { -- | inclusive - from :: Maybe t, - -- | exclusive - to :: Maybe t - } - deriving stock (Show, Eq, Ord, Generic) - --- | If all time in 'TimeRange' is less than the given time -isTimeAfterRange :: Ord t => t -> TimeRange t -> Bool -isTimeAfterRange t TimeRange {to} = maybe False (t >=) to - -instance Ord t => FunctorWithIndex (TimeRange t) (Timeline t) where - imap :: (TimeRange t -> a -> b) -> Timeline t a -> Timeline t b - imap f Timeline {..} = - Timeline - { initialValue = f initialRange initialValue, - values = flip Map.mapWithKey values $ \from value -> - let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from values) - in f timeRange value - } - where - initialRange = TimeRange Nothing $ fst <$> Map.lookupMin values - -instance Ord t => FoldableWithIndex (TimeRange t) (Timeline t) - -instance Ord t => TraversableWithIndex (TimeRange t) (Timeline t) where - itraverse :: (Applicative f) => (TimeRange t -> a -> f b) -> Timeline t a -> f (Timeline t b) - itraverse f = sequenceA . imap f - --- | Return the set of time when the value changes -changes :: Timeline t a -> Set t -changes Timeline {values} = Map.keysSet values - --- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the --- type we get from inputs. A list of @'Record' a@ can be converted to --- @'Timeline' ('Maybe' a)@. See 'fromRecords'. -data Record t a = Record - { -- | inclusive - from :: t, - -- | exclusive. When 'Nothing', the record never expires, until there is - -- another record with a newer 'effectiveFrom' time. - to :: Maybe t, - value :: a - } - deriving stock (Show, Eq, Functor, Foldable, Traversable, TH.Lift) - --- | Get the "effective from" time -recordFrom :: Record t a -> t -recordFrom Record {from} = from - --- | Get the "effective to" time -recordTo :: Record t a -> Maybe t -recordTo Record {to} = to - --- | Get the value wrapped in a @'Record' a@ -recordValue :: Record t a -> a -recordValue = value - --- | A smart constructor for @'Record' a@. --- Returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ -makeRecord :: - Ord t => - -- | effective from - t -> - -- | optional effective to - Maybe t -> - -- | value - a -> - Maybe (Record t a) -makeRecord from to value = - if maybe False (from >=) to - then Nothing - else Just Record {..} - --- | Special support for 'UTCTime'. This will be removed when 'TH.Lift' --- instances are provided by the @time@ package directly. -instance {-# OVERLAPPING #-} (TH.Lift a) => TH.Lift (Record UTCTime a) where - liftTyped Record {..} = - [|| - Record - (unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime from)) - (fmap unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime <$> to)) - $$(TH.liftTyped value) - ||] - -newtype LiftUTCTime = LiftUTCTime UTCTime - deriving stock (Generic) - -unLiftUTCTime :: LiftUTCTime -> UTCTime -unLiftUTCTime (LiftUTCTime t) = t - -instance TH.Lift LiftUTCTime where - liftTyped (LiftUTCTime (UTCTime (toOrdinalDate -> (year, day)) diffTime)) = - [|| - LiftUTCTime $ - UTCTime - (fromOrdinalDate $$(TH.liftTyped year) $$(TH.liftTyped day)) - (picosecondsToDiffTime $$(TH.liftTyped (diffTimeToPicoseconds diffTime))) - ||] - --- | Pretty-print @'Record' a@, like 'prettyTimeline'. -prettyRecord :: (Show t, Show a) => Record t a -> Text -prettyRecord Record {..} = tshow from <> " ~ " <> tshow to <> ": " <> tshow value - --- | An @'Overlaps' a@ consists of several groups. Within each group, all --- records are connected. Definition of connectivity: two records are --- "connected" if and only if they overlap. -newtype Overlaps t a = Overlaps {groups :: NonEmpty (OverlapGroup t a)} - deriving newtype (Semigroup) - deriving stock (Show, Eq, Generic) - --- | Pretty-print @'Overlaps' a@, like 'prettyTimeline'. -prettyOverlaps :: (Show t, Show a) => Overlaps t a -> Text -prettyOverlaps Overlaps {groups} = - "Here are " - <> tshow (length groups) - <> " group(s) of overlapping records\n" - <> sep - <> T.intercalate sep (prettyOverlapGroup <$> NonEmpty.toList groups) - <> sep - where - sep = "--------------------\n" - --- | A group of overlapping records. There must be at least two records within a group. -data OverlapGroup t a = OverlapGroup (Record t a) (Record t a) [Record t a] - deriving stock (Show, Eq, Generic) - -prettyOverlapGroup :: (Show t, Show a) => OverlapGroup t a -> Text -prettyOverlapGroup = T.unlines . fmap prettyRecord . unpackOverlapGroup - --- | Unpack @'OverlapGroup' a@ as a list of records. -unpackOverlapGroup :: OverlapGroup t a -> [Record t a] -unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records - --- | Build a 'Timeline' from a list of 'Record's. --- --- For any time, there could be zero, one, or more values, according to the --- input. No other condition is possible. We have taken account the "zero" case --- by wrapping the result in 'Maybe', so the only possible error is 'Overlaps'. --- The 'Traversable' instance of @'Timeline' a@ can be used to convert --- @'Timeline' ('Maybe' a)@ to @'Maybe' ('Timeline' a)@ -fromRecords :: forall t a. Ord t => [Record t a] -> Either (Overlaps t a) (Timeline t (Maybe a)) -fromRecords records = - maybe (Right timeline) Left overlaps - where - sortedRecords = sortOn recordFrom records - - -- overlap detection - overlaps = - fmap fold1 - . nonEmpty - . mapMaybe checkForOverlap - . foldr mergeOverlappingNeighbours [] - $ sortedRecords - - mergeOverlappingNeighbours :: - Record t a -> - [NonEmpty (Record t a)] -> - [NonEmpty (Record t a)] - mergeOverlappingNeighbours current ((next :| group) : groups) - -- Be aware that this is called in 'foldr', so it traverse the list from - -- right to left. If the current record overlaps with the top (left-most) - -- record in the next group, we add it to the group. Otherwise, create a - -- new group for it. - | isOverlapping = (current NonEmpty.<| next :| group) : groups - | otherwise = (current :| []) : (next :| group) : groups - where - isOverlapping = maybe False (recordFrom next <) (recordTo current) - mergeOverlappingNeighbours current [] = [current :| []] - - checkForOverlap :: NonEmpty (Record t a) -> Maybe (Overlaps t a) - checkForOverlap (_ :| []) = Nothing - checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . (:| []) $ OverlapGroup x1 x2 xs - - -- build the timeline assuming all elements of `sortedRecords` cover - -- distinct (non-overlapping) time-periods - timeline :: Timeline t (Maybe a) - timeline = - case nonEmpty sortedRecords of - Nothing -> pure Nothing - Just records' -> - Timeline - { initialValue = Nothing, - values = - Map.fromList . concat $ - zipWith - connectAdjacentRecords - (NonEmpty.toList records') - ((Just <$> NonEmpty.tail records') <> [Nothing]) - } - connectAdjacentRecords :: Record t a -> Maybe (Record t a) -> [(t, Maybe a)] - connectAdjacentRecords current next = - (recordFrom current, Just $ value current) - : maybeToList gap - where - gap = do - effectiveTo' <- recordTo current - if maybe True (\next' -> effectiveTo' < recordFrom next') next - then pure (effectiveTo', Nothing) - else Nothing diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal index e82a303..00eb4be 100644 --- a/timeline/timeline.cabal +++ b/timeline/timeline.cabal @@ -34,6 +34,5 @@ library import: deps hs-source-dirs: src/ exposed-modules: Data.Timeline - other-modules: Data.Timeline.Internal default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-unused-imports From ab31a35858c906e6e53d9431ba08fed782003fba Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 14 Mar 2023 13:56:14 +0800 Subject: [PATCH 22/24] re-organize packages --- cabal.project | 2 +- flake.nix | 2 +- timeline-core/CHANGELOG.md | 4 + timeline-core/README.md | 42 ++ timeline-core/default.nix | 14 + timeline-core/src/Data/Timeline/Internal.hs | 358 ++++++++++++++++++ timeline-core/timeline-core.cabal | 35 ++ timeline-hedgehog/default.nix | 4 +- .../src/Data/Timeline/Hedgehog.hs | 2 +- timeline-hedgehog/timeline-hedgehog.cabal | 8 +- timeline-tests/CHANGELOG.md | 0 timeline-tests/LICENSE | 29 -- timeline-tests/README.md | 3 - timeline-tests/default.nix | 20 - timeline-tests/timeline-tests.cabal | 44 --- timeline/default.nix | 16 +- timeline/src/Data/Timeline.hs | 356 +---------------- .../test/Data/TimelineTest.hs | 0 {timeline-tests => timeline}/test/Main.hs | 0 ...ll_non-overlapping_situations_together.txt | 0 .../golden/one_change,_with_effective_to.txt | 0 .../test/golden/one_change.txt | 0 .../test/golden/overlaps.txt | 0 .../test/golden/two_groups_of_overlap.txt | 0 timeline/timeline.cabal | 24 ++ 25 files changed, 500 insertions(+), 463 deletions(-) create mode 100644 timeline-core/CHANGELOG.md create mode 100644 timeline-core/README.md create mode 100644 timeline-core/default.nix create mode 100644 timeline-core/src/Data/Timeline/Internal.hs create mode 100644 timeline-core/timeline-core.cabal delete mode 100644 timeline-tests/CHANGELOG.md delete mode 100644 timeline-tests/LICENSE delete mode 100644 timeline-tests/README.md delete mode 100644 timeline-tests/default.nix delete mode 100644 timeline-tests/timeline-tests.cabal rename {timeline-tests => timeline}/test/Data/TimelineTest.hs (100%) rename {timeline-tests => timeline}/test/Main.hs (100%) rename {timeline-tests => timeline}/test/golden/all_non-overlapping_situations_together.txt (100%) rename {timeline-tests => timeline}/test/golden/one_change,_with_effective_to.txt (100%) rename {timeline-tests => timeline}/test/golden/one_change.txt (100%) rename {timeline-tests => timeline}/test/golden/overlaps.txt (100%) rename {timeline-tests => timeline}/test/golden/two_groups_of_overlap.txt (100%) diff --git a/cabal.project b/cabal.project index 6476bb5..89e16f8 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,5 @@ packages: + ./timeline-core ./timeline ./timeline-hedgehog - ./timeline-tests tests: True \ No newline at end of file diff --git a/flake.nix b/flake.nix index 96e4f7b..3001ed6 100644 --- a/flake.nix +++ b/flake.nix @@ -12,7 +12,7 @@ outputs = inputs: let - cabalPackages = [ "timeline" "timeline-hedgehog" "timeline-tests" ]; + cabalPackages = [ "timeline" "timeline-core" "timeline-hedgehog" ]; supportedCompilers = [ "ghc8107" "ghc926" "ghc944" ]; defaultCompiler = "ghc926"; in diff --git a/timeline-core/CHANGELOG.md b/timeline-core/CHANGELOG.md new file mode 100644 index 0000000..a5ee1bd --- /dev/null +++ b/timeline-core/CHANGELOG.md @@ -0,0 +1,4 @@ +# Changelog + +## 0.1.0.0 +- Open source the timeline library we use internally at Bellroy diff --git a/timeline-core/README.md b/timeline-core/README.md new file mode 100644 index 0000000..bdb5178 --- /dev/null +++ b/timeline-core/README.md @@ -0,0 +1,42 @@ +# timeline + +## Motivation + +The world is always changing, and often we want to manage the changes of data +using computers. Below are some concrete examples: + +- Employee data such as compensation, city, tax rule, time-off, etc. +- Prices of products. A product could have different prices on Amazon and EBay, + and in different currencies. + +Timeline data is often implemented by attaching extra fields to your business +object, denoting the start and end time of each interval. However, only +representing and storing the data is not sufficient, we need to run operations +on timeline data, like extracting a single data point at some specific time, +merging multiple timelines together, etc. + +If you have a similar use case and don't want to reinvent the wheel, this +library is for you. + +## Package Organization + +- `timeline` essential types and functions +- `timeline-tests` unit tests +- `timeline-hedgehog` hedgehog generators for timeline types + +## Getting Started + +The core type is `Timeline a`, refer to +[Haddock](https://hackage.haskell.org/package/timeline-0.0.1.0/docs/Data-Timeline.html) +for its usage. + +## Contribution +Bellroy actively maintains this project. Feel free to submit issues and +pull requests! + +The code is formatted with [`ormolu`](https://hackage.haskell.org/package/ormolu) + +If you use Nix: +- `nix develop` enter a shell with all necessary tools +- `nix build` build and run tests on all GHC versions we support +- Use `nix flake show` to view a full list of outputs diff --git a/timeline-core/default.nix b/timeline-core/default.nix new file mode 100644 index 0000000..43165e1 --- /dev/null +++ b/timeline-core/default.nix @@ -0,0 +1,14 @@ +{ mkDerivation, base, containers, indexed-traversable, lib +, semigroupoids, template-haskell, text, th-compat, time +}: +mkDerivation { + pname = "timeline-core"; + version = "0.1.0.0"; + src = ./.; + libraryHaskellDepends = [ + base containers indexed-traversable semigroupoids template-haskell + text th-compat time + ]; + description = "Core types and functions for use within other timeline-* packages"; + license = lib.licenses.bsd3; +} diff --git a/timeline-core/src/Data/Timeline/Internal.hs b/timeline-core/src/Data/Timeline/Internal.hs new file mode 100644 index 0000000..fddc056 --- /dev/null +++ b/timeline-core/src/Data/Timeline/Internal.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Data.Timeline.Internal + ( -- * Core types and functions + Timeline (..), + peek, + prettyTimeline, + changes, + TimeRange (..), + isTimeAfterRange, + + -- * Upper bound effectiveness time handling + Record, + makeRecord, + makeRecordTH, + recordFrom, + recordTo, + recordValue, + prettyRecord, + fromRecords, + Overlaps (..), + prettyOverlaps, + OverlapGroup (..), + unpackOverlapGroup, + ) +where + +import Data.Foldable.WithIndex (FoldableWithIndex (..)) +import Data.Functor.Contravariant (Contravariant, contramap) +import Data.Functor.WithIndex (FunctorWithIndex (..)) +import Data.List (intercalate, sortOn) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe, maybeToList) +import Data.Semigroup.Foldable.Class (fold1) +import Data.Set (Set) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time + ( UTCTime (..), + diffTimeToPicoseconds, + picosecondsToDiffTime, + ) +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, toOrdinalDate) +import Data.Traversable.WithIndex (TraversableWithIndex (..)) +import GHC.Generics (Generic) +import GHC.Records (HasField (getField)) +import Language.Haskell.TH.Syntax qualified as TH (Lift (liftTyped)) +import Language.Haskell.TH.Syntax.Compat qualified as TH +import Prelude + +-- | A unbounded discrete timeline for data type @a@. @'Timeline' a@ always has +-- a value for any time, but the value can only change for a finite number of +-- times. +-- +-- * 'Functor', 'Foldable' and 'Traversable' instances are provided to traverse +-- through the timeline; +-- * 'FunctorWithIndex', 'Foldable' and 'TraversableWithIndex' instances are +-- provided in case you need the current time range where each value holds +-- * 'Applicative' instance can be used to merge multiple 'Timeline's together +data Timeline t a = Timeline + { -- | the value from negative infinity time to the first time in 'values' + initialValue :: a, + -- | changes are keyed by their "effective from" time, for easier lookup + values :: Map t a + } + deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) + +instance Ord t => Applicative (Timeline t) where + pure :: a -> Timeline t a + pure a = Timeline {initialValue = a, values = mempty} + + (<*>) :: forall a b. Timeline t (a -> b) -> Timeline t a -> Timeline t b + fs@Timeline {initialValue = initialFunc, values = funcs} <*> xs@Timeline {initialValue, values} = + Timeline + { initialValue = initialFunc initialValue, + values = mergedValues + } + where + mergedValues :: Map t b + mergedValues = + Map.merge + (Map.mapMissing $ \t f -> f $ peek xs t) + (Map.mapMissing $ \t x -> peek fs t x) + (Map.zipWithMatched (const ($))) + funcs + values + +tshow :: Show a => a -> Text +tshow = T.pack . show + +-- | Pretty-print @'Timeline' a@. It's provided so that you can investigate the +-- value of 'Timeline' more easily. If you need to show a timeline to the end +-- user, write your own function. We don't gurantee the result to be stable +-- across different versions of this library. +prettyTimeline :: forall t a. (Ord t, Show t, Show a) => Timeline t a -> Text +prettyTimeline Timeline {initialValue, values} = + T.unlines $ + "\n----------Timeline--Start-------------" + : ("initial value: " <> tshow initialValue) + : fmap showOneChange (Map.toAscList values) + ++ ["----------Timeline--End---------------"] + where + showOneChange :: (t, a) -> Text + showOneChange (t, x) = "since " <> tshow t <> ": " <> tshow x + +-- | Extract a single value from the timeline +peek :: + Ord t => + Timeline t a -> + -- | the time to peek + t -> + a +peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values + +-- | A time range. Each bound is optional. 'Nothing' represents infinity. +data TimeRange t = TimeRange + { -- | inclusive + from :: Maybe t, + -- | exclusive + to :: Maybe t + } + deriving stock (Show, Eq, Ord, Generic) + +-- | If all time in 'TimeRange' is less than the given time +isTimeAfterRange :: Ord t => t -> TimeRange t -> Bool +isTimeAfterRange t TimeRange {to} = maybe False (t >=) to + +instance Ord t => FunctorWithIndex (TimeRange t) (Timeline t) where + imap :: (TimeRange t -> a -> b) -> Timeline t a -> Timeline t b + imap f Timeline {..} = + Timeline + { initialValue = f initialRange initialValue, + values = flip Map.mapWithKey values $ \from value -> + let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from values) + in f timeRange value + } + where + initialRange = TimeRange Nothing $ fst <$> Map.lookupMin values + +instance Ord t => FoldableWithIndex (TimeRange t) (Timeline t) + +instance Ord t => TraversableWithIndex (TimeRange t) (Timeline t) where + itraverse :: (Applicative f) => (TimeRange t -> a -> f b) -> Timeline t a -> f (Timeline t b) + itraverse f = sequenceA . imap f + +-- | Return the set of time when the value changes +changes :: Timeline t a -> Set t +changes Timeline {values} = Map.keysSet values + +-- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the +-- type we get from inputs. A list of @'Record' a@ can be converted to +-- @'Timeline' ('Maybe' a)@. See 'fromRecords'. +data Record t a = Record + { -- | inclusive + from :: t, + -- | exclusive. When 'Nothing', the record never expires, until there is + -- another record with a newer 'effectiveFrom' time. + to :: Maybe t, + value :: a + } + deriving stock (Show, Eq, Functor, Foldable, Traversable, TH.Lift) + +-- | Get the "effective from" time +recordFrom :: Record t a -> t +recordFrom Record {from} = from + +-- | Get the "effective to" time +recordTo :: Record t a -> Maybe t +recordTo Record {to} = to + +-- | Get the value wrapped in a @'Record' a@ +recordValue :: Record t a -> a +recordValue = value + +-- | A smart constructor for @'Record' a@. +-- Returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ +makeRecord :: + Ord t => + -- | effective from + t -> + -- | optional effective to + Maybe t -> + -- | value + a -> + Maybe (Record t a) +makeRecord from to value = + if maybe False (from >=) to + then Nothing + else Just Record {..} + +-- | Template Haskell counterpart of 'makeRecord'. +makeRecordTH :: + (Ord t, TH.Lift (Record t a)) => + t -> + Maybe t -> + a -> + TH.SpliceQ (Record t a) +makeRecordTH effectiveFrom effectiveTo value = + TH.bindSplice + ( maybe (fail "effective to is no greater than effective from") pure $ + makeRecord effectiveFrom effectiveTo value + ) + TH.liftTyped + +-- | Special support for 'UTCTime'. This will be removed when 'TH.Lift' +-- instances are provided by the @time@ package directly. +instance {-# OVERLAPPING #-} (TH.Lift a) => TH.Lift (Record UTCTime a) where + liftTyped Record {..} = + [|| + Record + (unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime from)) + (fmap unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime <$> to)) + $$(TH.liftTyped value) + ||] + +newtype LiftUTCTime = LiftUTCTime UTCTime + deriving stock (Generic) + +unLiftUTCTime :: LiftUTCTime -> UTCTime +unLiftUTCTime (LiftUTCTime t) = t + +instance TH.Lift LiftUTCTime where + liftTyped (LiftUTCTime (UTCTime (toOrdinalDate -> (year, day)) diffTime)) = + [|| + LiftUTCTime $ + UTCTime + (fromOrdinalDate $$(TH.liftTyped year) $$(TH.liftTyped day)) + (picosecondsToDiffTime $$(TH.liftTyped (diffTimeToPicoseconds diffTime))) + ||] + +-- | Pretty-print @'Record' a@, like 'prettyTimeline'. +prettyRecord :: (Show t, Show a) => Record t a -> Text +prettyRecord Record {..} = tshow from <> " ~ " <> tshow to <> ": " <> tshow value + +-- | An @'Overlaps' a@ consists of several groups. Within each group, all +-- records are connected. Definition of connectivity: two records are +-- "connected" if and only if they overlap. +newtype Overlaps t a = Overlaps {groups :: NonEmpty (OverlapGroup t a)} + deriving newtype (Semigroup) + deriving stock (Show, Eq, Generic) + +-- | Pretty-print @'Overlaps' a@, like 'prettyTimeline'. +prettyOverlaps :: (Show t, Show a) => Overlaps t a -> Text +prettyOverlaps Overlaps {groups} = + "Here are " + <> tshow (length groups) + <> " group(s) of overlapping records\n" + <> sep + <> T.intercalate sep (prettyOverlapGroup <$> NonEmpty.toList groups) + <> sep + where + sep = "--------------------\n" + +-- | A group of overlapping records. There must be at least two records within a group. +data OverlapGroup t a = OverlapGroup (Record t a) (Record t a) [Record t a] + deriving stock (Show, Eq, Generic) + +prettyOverlapGroup :: (Show t, Show a) => OverlapGroup t a -> Text +prettyOverlapGroup = T.unlines . fmap prettyRecord . unpackOverlapGroup + +-- | Unpack @'OverlapGroup' a@ as a list of records. +unpackOverlapGroup :: OverlapGroup t a -> [Record t a] +unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records + +-- | Build a 'Timeline' from a list of 'Record's. +-- +-- For any time, there could be zero, one, or more values, according to the +-- input. No other condition is possible. We have taken account the "zero" case +-- by wrapping the result in 'Maybe', so the only possible error is 'Overlaps'. +-- The 'Traversable' instance of @'Timeline' a@ can be used to convert +-- @'Timeline' ('Maybe' a)@ to @'Maybe' ('Timeline' a)@ +fromRecords :: forall t a. Ord t => [Record t a] -> Either (Overlaps t a) (Timeline t (Maybe a)) +fromRecords records = + maybe (Right timeline) Left overlaps + where + sortedRecords = sortOn recordFrom records + + -- overlap detection + overlaps = + fmap fold1 + . nonEmpty + . mapMaybe checkForOverlap + . foldr mergeOverlappingNeighbours [] + $ sortedRecords + + mergeOverlappingNeighbours :: + Record t a -> + [NonEmpty (Record t a)] -> + [NonEmpty (Record t a)] + mergeOverlappingNeighbours current ((next :| group) : groups) + -- Be aware that this is called in 'foldr', so it traverse the list from + -- right to left. If the current record overlaps with the top (left-most) + -- record in the next group, we add it to the group. Otherwise, create a + -- new group for it. + | isOverlapping = (current NonEmpty.<| next :| group) : groups + | otherwise = (current :| []) : (next :| group) : groups + where + isOverlapping = maybe False (recordFrom next <) (recordTo current) + mergeOverlappingNeighbours current [] = [current :| []] + + checkForOverlap :: NonEmpty (Record t a) -> Maybe (Overlaps t a) + checkForOverlap (_ :| []) = Nothing + checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . (:| []) $ OverlapGroup x1 x2 xs + + -- build the timeline assuming all elements of `sortedRecords` cover + -- distinct (non-overlapping) time-periods + timeline :: Timeline t (Maybe a) + timeline = + case nonEmpty sortedRecords of + Nothing -> pure Nothing + Just records' -> + Timeline + { initialValue = Nothing, + values = + Map.fromList . concat $ + zipWith + connectAdjacentRecords + (NonEmpty.toList records') + ((Just <$> NonEmpty.tail records') <> [Nothing]) + } + connectAdjacentRecords :: Record t a -> Maybe (Record t a) -> [(t, Maybe a)] + connectAdjacentRecords current next = + (recordFrom current, Just $ value current) + : maybeToList gap + where + gap = do + effectiveTo' <- recordTo current + if maybe True (\next' -> effectiveTo' < recordFrom next') next + then pure (effectiveTo', Nothing) + else Nothing diff --git a/timeline-core/timeline-core.cabal b/timeline-core/timeline-core.cabal new file mode 100644 index 0000000..bf9ffd2 --- /dev/null +++ b/timeline-core/timeline-core.cabal @@ -0,0 +1,35 @@ +cabal-version: 2.2 +name: timeline-core +version: 0.1.0.0 +synopsis: + Core types and functions for use within other timeline-* packages + +license: BSD-3-Clause +license-file: LICENSE +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +category: Development +build-type: Simple +tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/bellroy/timeline.git + +library + hs-source-dirs: src/ + exposed-modules: Data.Timeline.Internal + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-unused-imports + build-depends: + , base >=4.14.3 && <4.18 + , containers >=0.6.5 && <0.7 + , indexed-traversable >=0.1.2 && <0.2 + , semigroupoids >=5.3.7 && <5.4 + , template-haskell >=2.16.0 && <2.20 + , text >=1.2.4.1 && <2.1 + , th-compat >=0.1.4 && <0.2 + , time >=1.9.3 && <1.13 diff --git a/timeline-hedgehog/default.nix b/timeline-hedgehog/default.nix index 347fb5a..cc2f799 100644 --- a/timeline-hedgehog/default.nix +++ b/timeline-hedgehog/default.nix @@ -1,9 +1,9 @@ -{ mkDerivation, base, hedgehog, lib, time, timeline }: +{ mkDerivation, base, hedgehog, lib, time, timeline-core }: mkDerivation { pname = "timeline-hedgehog"; version = "0.1.0.0"; src = ./.; - libraryHaskellDepends = [ base hedgehog time timeline ]; + libraryHaskellDepends = [ base hedgehog time timeline-core ]; description = "Hedgehog generators for the timeline library"; license = lib.licenses.bsd3; } diff --git a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs index 434eef7..688ed7c 100644 --- a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs +++ b/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs @@ -10,7 +10,7 @@ module Data.Timeline.Hedgehog ) where -import Data.Timeline +import Data.Timeline.Internal import Hedgehog (MonadGen) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range diff --git a/timeline-hedgehog/timeline-hedgehog.cabal b/timeline-hedgehog/timeline-hedgehog.cabal index 209bfda..94fc9a3 100644 --- a/timeline-hedgehog/timeline-hedgehog.cabal +++ b/timeline-hedgehog/timeline-hedgehog.cabal @@ -19,10 +19,10 @@ source-repository head common deps build-depends: - , base >=4.14.3 && <4.18 - , hedgehog >=1.1 && <1.3 - , time >=1.9.3 && <1.13 - , timeline ==0.1.0.0 + , base >=4.14.3 && <4.18 + , hedgehog >=1.1 && <1.3 + , time >=1.9.3 && <1.13 + , timeline-core ==0.1.0.0 library import: deps diff --git a/timeline-tests/CHANGELOG.md b/timeline-tests/CHANGELOG.md deleted file mode 100644 index e69de29..0000000 diff --git a/timeline-tests/LICENSE b/timeline-tests/LICENSE deleted file mode 100644 index e8308e6..0000000 --- a/timeline-tests/LICENSE +++ /dev/null @@ -1,29 +0,0 @@ -Copyright (C) 2023 Bellroy Pty Ltd - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the - distribution. - -3. Neither the name of the copyright holder nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/timeline-tests/README.md b/timeline-tests/README.md deleted file mode 100644 index ee33fb3..0000000 --- a/timeline-tests/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# timeline - -Provides a container type `Timeline a` for handling data that changes over time. diff --git a/timeline-tests/default.nix b/timeline-tests/default.nix deleted file mode 100644 index 45cbb91..0000000 --- a/timeline-tests/default.nix +++ /dev/null @@ -1,20 +0,0 @@ -{ mkDerivation, base, bytestring, containers, hashable, hedgehog -, indexed-traversable, lib, tasty, tasty-discover, tasty-golden -, tasty-hedgehog, tasty-hunit, text, time, timeline -, timeline-hedgehog, transformers -}: -mkDerivation { - pname = "timeline-tests"; - version = "0.1.0.0"; - src = ./.; - libraryHaskellDepends = [ base ]; - testHaskellDepends = [ - base bytestring containers hashable hedgehog indexed-traversable - tasty tasty-golden tasty-hedgehog tasty-hunit text time timeline - timeline-hedgehog transformers - ]; - testToolDepends = [ tasty-discover ]; - doHaddock = false; - description = "Tests for the timeline library"; - license = lib.licenses.bsd3; -} diff --git a/timeline-tests/timeline-tests.cabal b/timeline-tests/timeline-tests.cabal deleted file mode 100644 index da075ae..0000000 --- a/timeline-tests/timeline-tests.cabal +++ /dev/null @@ -1,44 +0,0 @@ -cabal-version: 2.2 -name: timeline-tests -version: 0.1.0.0 -synopsis: Tests for the timeline library -license: BSD-3-Clause -license-file: LICENSE -author: Bellroy Tech Team -maintainer: Bellroy Tech Team -category: Development -build-type: Simple -tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 -extra-source-files: - CHANGELOG.md - README.md - test/golden/*.txt - -source-repository head - type: git - location: https://github.com/bellroy/timeline.git - -library - -test-suite tests - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - other-modules: Data.TimelineTest - build-tool-depends: tasty-discover:tasty-discover - build-depends: - , base >=4.14.3 && <4.18 - , bytestring >=0.10 && <0.12 - , containers >=0.6.5 && <0.7 - , hashable ^>=1.4.2.0 - , hedgehog >=1.1 && <1.3 - , indexed-traversable ^>=0.1.2 - , tasty ^>=1.4.3 - , tasty-golden ^>=2.3.5 - , tasty-hedgehog >=1.2.0.0 - , tasty-hunit ^>=0.10.0.3 - , text >=1.2.4.1 && <2.1 - , time >=1.9.3 && <1.13 - , timeline ==0.1.0.0 - , timeline-hedgehog ==0.1.0.0 - , transformers ^>=0.5.6.2 diff --git a/timeline/default.nix b/timeline/default.nix index c49f397..c7d5054 100644 --- a/timeline/default.nix +++ b/timeline/default.nix @@ -1,5 +1,7 @@ -{ mkDerivation, base, containers, indexed-traversable, lib -, semigroupoids, template-haskell, text, th-compat, time +{ mkDerivation, base, bytestring, containers, hashable, hedgehog +, indexed-traversable, lib, semigroupoids, tasty, tasty-discover +, tasty-golden, tasty-hedgehog, tasty-hunit, template-haskell, text +, th-compat, time, timeline-core, timeline-hedgehog, transformers }: mkDerivation { pname = "timeline"; @@ -7,8 +9,14 @@ mkDerivation { src = ./.; libraryHaskellDepends = [ base containers indexed-traversable semigroupoids template-haskell - text th-compat time + text th-compat time timeline-core ]; - description = "A simple library for handling data that changes over time"; + testHaskellDepends = [ + base bytestring containers hashable hedgehog indexed-traversable + tasty tasty-golden tasty-hedgehog tasty-hunit text time + timeline-hedgehog transformers + ]; + testToolDepends = [ tasty-discover ]; + description = "Data type representing a piecewise-constant function over time"; license = lib.licenses.bsd3; } diff --git a/timeline/src/Data/Timeline.hs b/timeline/src/Data/Timeline.hs index 445a17c..9ec7ad8 100644 --- a/timeline/src/Data/Timeline.hs +++ b/timeline/src/Data/Timeline.hs @@ -1,358 +1,6 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - module Data.Timeline - ( -- * Core types and functions - Timeline (..), - peek, - prettyTimeline, - changes, - TimeRange (..), - isTimeAfterRange, - - -- * Upper bound effectiveness time handling - Record, - makeRecord, - makeRecordTH, - recordFrom, - recordTo, - recordValue, - prettyRecord, - fromRecords, - Overlaps (..), - prettyOverlaps, - OverlapGroup (..), - unpackOverlapGroup, + ( module Data.Timeline.Internal, ) where -import Data.Foldable.WithIndex (FoldableWithIndex (..)) -import Data.Functor.Contravariant (Contravariant, contramap) -import Data.Functor.WithIndex (FunctorWithIndex (..)) -import Data.List (intercalate, sortOn) -import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Map.Merge.Strict qualified as Map -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe, maybeToList) -import Data.Semigroup.Foldable.Class (fold1) -import Data.Set (Set) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Time - ( UTCTime (..), - diffTimeToPicoseconds, - picosecondsToDiffTime, - ) -import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, toOrdinalDate) -import Data.Traversable.WithIndex (TraversableWithIndex (..)) -import GHC.Generics (Generic) -import GHC.Records (HasField (getField)) -import Language.Haskell.TH.Syntax qualified as TH (Lift (liftTyped)) -import Language.Haskell.TH.Syntax.Compat qualified as TH -import Prelude - --- | A unbounded discrete timeline for data type @a@. @'Timeline' a@ always has --- a value for any time, but the value can only change for a finite number of --- times. --- --- * 'Functor', 'Foldable' and 'Traversable' instances are provided to traverse --- through the timeline; --- * 'FunctorWithIndex', 'Foldable' and 'TraversableWithIndex' instances are --- provided in case you need the current time range where each value holds --- * 'Applicative' instance can be used to merge multiple 'Timeline's together -data Timeline t a = Timeline - { -- | the value from negative infinity time to the first time in 'values' - initialValue :: a, - -- | changes are keyed by their "effective from" time, for easier lookup - values :: Map t a - } - deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) - -instance Ord t => Applicative (Timeline t) where - pure :: a -> Timeline t a - pure a = Timeline {initialValue = a, values = mempty} - - (<*>) :: forall a b. Timeline t (a -> b) -> Timeline t a -> Timeline t b - fs@Timeline {initialValue = initialFunc, values = funcs} <*> xs@Timeline {initialValue, values} = - Timeline - { initialValue = initialFunc initialValue, - values = mergedValues - } - where - mergedValues :: Map t b - mergedValues = - Map.merge - (Map.mapMissing $ \t f -> f $ peek xs t) - (Map.mapMissing $ \t x -> peek fs t x) - (Map.zipWithMatched (const ($))) - funcs - values - -tshow :: Show a => a -> Text -tshow = T.pack . show - --- | Pretty-print @'Timeline' a@. It's provided so that you can investigate the --- value of 'Timeline' more easily. If you need to show a timeline to the end --- user, write your own function. We don't gurantee the result to be stable --- across different versions of this library. -prettyTimeline :: forall t a. (Ord t, Show t, Show a) => Timeline t a -> Text -prettyTimeline Timeline {initialValue, values} = - T.unlines $ - "\n----------Timeline--Start-------------" - : ("initial value: " <> tshow initialValue) - : fmap showOneChange (Map.toAscList values) - ++ ["----------Timeline--End---------------"] - where - showOneChange :: (t, a) -> Text - showOneChange (t, x) = "since " <> tshow t <> ": " <> tshow x - --- | Extract a single value from the timeline -peek :: - Ord t => - Timeline t a -> - -- | the time to peek - t -> - a -peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values - --- | A time range. Each bound is optional. 'Nothing' represents infinity. -data TimeRange t = TimeRange - { -- | inclusive - from :: Maybe t, - -- | exclusive - to :: Maybe t - } - deriving stock (Show, Eq, Ord, Generic) - --- | If all time in 'TimeRange' is less than the given time -isTimeAfterRange :: Ord t => t -> TimeRange t -> Bool -isTimeAfterRange t TimeRange {to} = maybe False (t >=) to - -instance Ord t => FunctorWithIndex (TimeRange t) (Timeline t) where - imap :: (TimeRange t -> a -> b) -> Timeline t a -> Timeline t b - imap f Timeline {..} = - Timeline - { initialValue = f initialRange initialValue, - values = flip Map.mapWithKey values $ \from value -> - let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from values) - in f timeRange value - } - where - initialRange = TimeRange Nothing $ fst <$> Map.lookupMin values - -instance Ord t => FoldableWithIndex (TimeRange t) (Timeline t) - -instance Ord t => TraversableWithIndex (TimeRange t) (Timeline t) where - itraverse :: (Applicative f) => (TimeRange t -> a -> f b) -> Timeline t a -> f (Timeline t b) - itraverse f = sequenceA . imap f - --- | Return the set of time when the value changes -changes :: Timeline t a -> Set t -changes Timeline {values} = Map.keysSet values - --- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the --- type we get from inputs. A list of @'Record' a@ can be converted to --- @'Timeline' ('Maybe' a)@. See 'fromRecords'. -data Record t a = Record - { -- | inclusive - from :: t, - -- | exclusive. When 'Nothing', the record never expires, until there is - -- another record with a newer 'effectiveFrom' time. - to :: Maybe t, - value :: a - } - deriving stock (Show, Eq, Functor, Foldable, Traversable, TH.Lift) - --- | Get the "effective from" time -recordFrom :: Record t a -> t -recordFrom Record {from} = from - --- | Get the "effective to" time -recordTo :: Record t a -> Maybe t -recordTo Record {to} = to - --- | Get the value wrapped in a @'Record' a@ -recordValue :: Record t a -> a -recordValue = value - --- | A smart constructor for @'Record' a@. --- Returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@ -makeRecord :: - Ord t => - -- | effective from - t -> - -- | optional effective to - Maybe t -> - -- | value - a -> - Maybe (Record t a) -makeRecord from to value = - if maybe False (from >=) to - then Nothing - else Just Record {..} - --- | Template Haskell counterpart of 'makeRecord'. -makeRecordTH :: - (Ord t, TH.Lift (Record t a)) => - t -> - Maybe t -> - a -> - TH.SpliceQ (Record t a) -makeRecordTH effectiveFrom effectiveTo value = - TH.bindSplice - ( maybe (fail "effective to is no greater than effective from") pure $ - makeRecord effectiveFrom effectiveTo value - ) - TH.liftTyped - --- | Special support for 'UTCTime'. This will be removed when 'TH.Lift' --- instances are provided by the @time@ package directly. -instance {-# OVERLAPPING #-} (TH.Lift a) => TH.Lift (Record UTCTime a) where - liftTyped Record {..} = - [|| - Record - (unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime from)) - (fmap unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime <$> to)) - $$(TH.liftTyped value) - ||] - -newtype LiftUTCTime = LiftUTCTime UTCTime - deriving stock (Generic) - -unLiftUTCTime :: LiftUTCTime -> UTCTime -unLiftUTCTime (LiftUTCTime t) = t - -instance TH.Lift LiftUTCTime where - liftTyped (LiftUTCTime (UTCTime (toOrdinalDate -> (year, day)) diffTime)) = - [|| - LiftUTCTime $ - UTCTime - (fromOrdinalDate $$(TH.liftTyped year) $$(TH.liftTyped day)) - (picosecondsToDiffTime $$(TH.liftTyped (diffTimeToPicoseconds diffTime))) - ||] - --- | Pretty-print @'Record' a@, like 'prettyTimeline'. -prettyRecord :: (Show t, Show a) => Record t a -> Text -prettyRecord Record {..} = tshow from <> " ~ " <> tshow to <> ": " <> tshow value - --- | An @'Overlaps' a@ consists of several groups. Within each group, all --- records are connected. Definition of connectivity: two records are --- "connected" if and only if they overlap. -newtype Overlaps t a = Overlaps {groups :: NonEmpty (OverlapGroup t a)} - deriving newtype (Semigroup) - deriving stock (Show, Eq, Generic) - --- | Pretty-print @'Overlaps' a@, like 'prettyTimeline'. -prettyOverlaps :: (Show t, Show a) => Overlaps t a -> Text -prettyOverlaps Overlaps {groups} = - "Here are " - <> tshow (length groups) - <> " group(s) of overlapping records\n" - <> sep - <> T.intercalate sep (prettyOverlapGroup <$> NonEmpty.toList groups) - <> sep - where - sep = "--------------------\n" - --- | A group of overlapping records. There must be at least two records within a group. -data OverlapGroup t a = OverlapGroup (Record t a) (Record t a) [Record t a] - deriving stock (Show, Eq, Generic) - -prettyOverlapGroup :: (Show t, Show a) => OverlapGroup t a -> Text -prettyOverlapGroup = T.unlines . fmap prettyRecord . unpackOverlapGroup - --- | Unpack @'OverlapGroup' a@ as a list of records. -unpackOverlapGroup :: OverlapGroup t a -> [Record t a] -unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : records - --- | Build a 'Timeline' from a list of 'Record's. --- --- For any time, there could be zero, one, or more values, according to the --- input. No other condition is possible. We have taken account the "zero" case --- by wrapping the result in 'Maybe', so the only possible error is 'Overlaps'. --- The 'Traversable' instance of @'Timeline' a@ can be used to convert --- @'Timeline' ('Maybe' a)@ to @'Maybe' ('Timeline' a)@ -fromRecords :: forall t a. Ord t => [Record t a] -> Either (Overlaps t a) (Timeline t (Maybe a)) -fromRecords records = - maybe (Right timeline) Left overlaps - where - sortedRecords = sortOn recordFrom records - - -- overlap detection - overlaps = - fmap fold1 - . nonEmpty - . mapMaybe checkForOverlap - . foldr mergeOverlappingNeighbours [] - $ sortedRecords - - mergeOverlappingNeighbours :: - Record t a -> - [NonEmpty (Record t a)] -> - [NonEmpty (Record t a)] - mergeOverlappingNeighbours current ((next :| group) : groups) - -- Be aware that this is called in 'foldr', so it traverse the list from - -- right to left. If the current record overlaps with the top (left-most) - -- record in the next group, we add it to the group. Otherwise, create a - -- new group for it. - | isOverlapping = (current NonEmpty.<| next :| group) : groups - | otherwise = (current :| []) : (next :| group) : groups - where - isOverlapping = maybe False (recordFrom next <) (recordTo current) - mergeOverlappingNeighbours current [] = [current :| []] - - checkForOverlap :: NonEmpty (Record t a) -> Maybe (Overlaps t a) - checkForOverlap (_ :| []) = Nothing - checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . (:| []) $ OverlapGroup x1 x2 xs - - -- build the timeline assuming all elements of `sortedRecords` cover - -- distinct (non-overlapping) time-periods - timeline :: Timeline t (Maybe a) - timeline = - case nonEmpty sortedRecords of - Nothing -> pure Nothing - Just records' -> - Timeline - { initialValue = Nothing, - values = - Map.fromList . concat $ - zipWith - connectAdjacentRecords - (NonEmpty.toList records') - ((Just <$> NonEmpty.tail records') <> [Nothing]) - } - connectAdjacentRecords :: Record t a -> Maybe (Record t a) -> [(t, Maybe a)] - connectAdjacentRecords current next = - (recordFrom current, Just $ value current) - : maybeToList gap - where - gap = do - effectiveTo' <- recordTo current - if maybe True (\next' -> effectiveTo' < recordFrom next') next - then pure (effectiveTo', Nothing) - else Nothing +import Data.Timeline.Internal diff --git a/timeline-tests/test/Data/TimelineTest.hs b/timeline/test/Data/TimelineTest.hs similarity index 100% rename from timeline-tests/test/Data/TimelineTest.hs rename to timeline/test/Data/TimelineTest.hs diff --git a/timeline-tests/test/Main.hs b/timeline/test/Main.hs similarity index 100% rename from timeline-tests/test/Main.hs rename to timeline/test/Main.hs diff --git a/timeline-tests/test/golden/all_non-overlapping_situations_together.txt b/timeline/test/golden/all_non-overlapping_situations_together.txt similarity index 100% rename from timeline-tests/test/golden/all_non-overlapping_situations_together.txt rename to timeline/test/golden/all_non-overlapping_situations_together.txt diff --git a/timeline-tests/test/golden/one_change,_with_effective_to.txt b/timeline/test/golden/one_change,_with_effective_to.txt similarity index 100% rename from timeline-tests/test/golden/one_change,_with_effective_to.txt rename to timeline/test/golden/one_change,_with_effective_to.txt diff --git a/timeline-tests/test/golden/one_change.txt b/timeline/test/golden/one_change.txt similarity index 100% rename from timeline-tests/test/golden/one_change.txt rename to timeline/test/golden/one_change.txt diff --git a/timeline-tests/test/golden/overlaps.txt b/timeline/test/golden/overlaps.txt similarity index 100% rename from timeline-tests/test/golden/overlaps.txt rename to timeline/test/golden/overlaps.txt diff --git a/timeline-tests/test/golden/two_groups_of_overlap.txt b/timeline/test/golden/two_groups_of_overlap.txt similarity index 100% rename from timeline-tests/test/golden/two_groups_of_overlap.txt rename to timeline/test/golden/two_groups_of_overlap.txt diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal index 00eb4be..3a2ba38 100644 --- a/timeline/timeline.cabal +++ b/timeline/timeline.cabal @@ -36,3 +36,27 @@ library exposed-modules: Data.Timeline default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-unused-imports + build-depends: timeline-core ==0.1.0.0 + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Data.TimelineTest + build-tool-depends: tasty-discover:tasty-discover + build-depends: + , base >=4.14.3 && <4.18 + , bytestring >=0.10 && <0.12 + , containers >=0.6.5 && <0.7 + , hashable ^>=1.4.2.0 + , hedgehog >=1.1 && <1.3 + , indexed-traversable ^>=0.1.2 + , tasty ^>=1.4.3 + , tasty-golden ^>=2.3.5 + , tasty-hedgehog >=1.2.0.0 + , tasty-hunit ^>=0.10.0.3 + , text >=1.2.4.1 && <2.1 + , time >=1.9.3 && <1.13 + , timeline + , timeline-hedgehog ==0.1.0.0 + , transformers ^>=0.5.6.2 From fbc4d8100a9b01052345bc965938f5f7b042caa9 Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 14 Mar 2023 13:58:02 +0800 Subject: [PATCH 23/24] add test data to extra-source-files --- timeline/timeline.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/timeline/timeline.cabal b/timeline/timeline.cabal index 3a2ba38..52badb3 100644 --- a/timeline/timeline.cabal +++ b/timeline/timeline.cabal @@ -14,6 +14,7 @@ tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 extra-source-files: CHANGELOG.md README.md + test/golden/*.txt source-repository head type: git @@ -43,6 +44,7 @@ test-suite tests hs-source-dirs: test main-is: Main.hs other-modules: Data.TimelineTest + default-language: Haskell2010 build-tool-depends: tasty-discover:tasty-discover build-depends: , base >=4.14.3 && <4.18 From bbf2fb50967003daadf86187f22b280bceca0953 Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 14 Mar 2023 15:37:47 +0800 Subject: [PATCH 24/24] merge all packages into one --- cabal.project | 5 +-- flake.nix | 21 ++++++---- timeline/default.nix => package.nix | 8 ++-- .../Internal.hs => src/Data/Timeline.hs | 2 +- .../src => src}/Data/Timeline/Hedgehog.hs | 5 +-- {timeline/test => test}/Data/TimelineTest.hs | 0 {timeline/test => test}/Main.hs | 0 ...ll_non-overlapping_situations_together.txt | 0 .../golden/one_change,_with_effective_to.txt | 0 {timeline/test => test}/golden/one_change.txt | 0 {timeline/test => test}/golden/overlaps.txt | 0 .../golden/two_groups_of_overlap.txt | 0 timeline-core/CHANGELOG.md | 4 -- timeline-core/README.md | 42 ------------------- timeline-core/default.nix | 14 ------- timeline-core/timeline-core.cabal | 35 ---------------- timeline-hedgehog/CHANGELOG.md | 0 timeline-hedgehog/LICENSE | 29 ------------- timeline-hedgehog/README.md | 3 -- timeline-hedgehog/default.nix | 9 ---- timeline-hedgehog/timeline-hedgehog.cabal | 32 -------------- timeline/timeline.cabal => timeline.cabal | 8 ++-- timeline/CHANGELOG.md | 1 - timeline/LICENSE | 29 ------------- timeline/README.md | 1 - timeline/src/Data/Timeline.hs | 6 --- 26 files changed, 26 insertions(+), 228 deletions(-) rename timeline/default.nix => package.nix (74%) rename timeline-core/src/Data/Timeline/Internal.hs => src/Data/Timeline.hs (99%) rename {timeline-hedgehog/src => src}/Data/Timeline/Hedgehog.hs (90%) rename {timeline/test => test}/Data/TimelineTest.hs (100%) rename {timeline/test => test}/Main.hs (100%) rename {timeline/test => test}/golden/all_non-overlapping_situations_together.txt (100%) rename {timeline/test => test}/golden/one_change,_with_effective_to.txt (100%) rename {timeline/test => test}/golden/one_change.txt (100%) rename {timeline/test => test}/golden/overlaps.txt (100%) rename {timeline/test => test}/golden/two_groups_of_overlap.txt (100%) delete mode 100644 timeline-core/CHANGELOG.md delete mode 100644 timeline-core/README.md delete mode 100644 timeline-core/default.nix delete mode 100644 timeline-core/timeline-core.cabal delete mode 100644 timeline-hedgehog/CHANGELOG.md delete mode 100644 timeline-hedgehog/LICENSE delete mode 100644 timeline-hedgehog/README.md delete mode 100644 timeline-hedgehog/default.nix delete mode 100644 timeline-hedgehog/timeline-hedgehog.cabal rename timeline/timeline.cabal => timeline.cabal (94%) delete mode 120000 timeline/CHANGELOG.md delete mode 100644 timeline/LICENSE delete mode 120000 timeline/README.md delete mode 100644 timeline/src/Data/Timeline.hs diff --git a/cabal.project b/cabal.project index 89e16f8..2b34c35 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,2 @@ -packages: - ./timeline-core - ./timeline - ./timeline-hedgehog +packages: ./ tests: True \ No newline at end of file diff --git a/flake.nix b/flake.nix index 3001ed6..9323054 100644 --- a/flake.nix +++ b/flake.nix @@ -12,7 +12,12 @@ outputs = inputs: let - cabalPackages = [ "timeline" "timeline-core" "timeline-hedgehog" ]; + cabalPackages = [ + { + name = "timeline"; + path = ./package.nix; + } + ]; supportedCompilers = [ "ghc8107" "ghc926" "ghc944" ]; defaultCompiler = "ghc926"; in @@ -25,9 +30,9 @@ builtins.listToAttrs ( builtins.map - (name: { - inherit name; - value = prev.callPackage (./. + "/${name}") { }; + (cabalPackage: { + name = cabalPackage.name; + value = prev.callPackage cabalPackage.path { }; }) cabalPackages ); @@ -43,7 +48,7 @@ ]; makeShell = haskellPackages: (makePackageSet haskellPackages).shellFor { - packages = p: builtins.map (name: p.${name}) cabalPackages; + packages = p: builtins.map (cabalPackage: p.${cabalPackage.name}) cabalPackages; withHoogle = true; buildInputs = essentialTools ++ [ nixpkgs.haskellPackages.haskell-language-server @@ -64,9 +69,9 @@ let pkgSet = makePackageSet nixpkgs.haskell.packages.${compilerName}; in builtins.map - (name: { - name = "${compilerName}-${name}"; - value = pkgSet.${name}; + (cabalPackage: { + name = "${compilerName}-${cabalPackage.name}"; + value = pkgSet.${cabalPackage.name}; }) cabalPackages ) diff --git a/timeline/default.nix b/package.nix similarity index 74% rename from timeline/default.nix rename to package.nix index c7d5054..58f5c4b 100644 --- a/timeline/default.nix +++ b/package.nix @@ -1,20 +1,20 @@ { mkDerivation, base, bytestring, containers, hashable, hedgehog , indexed-traversable, lib, semigroupoids, tasty, tasty-discover , tasty-golden, tasty-hedgehog, tasty-hunit, template-haskell, text -, th-compat, time, timeline-core, timeline-hedgehog, transformers +, th-compat, time, transformers }: mkDerivation { pname = "timeline"; version = "0.1.0.0"; src = ./.; libraryHaskellDepends = [ - base containers indexed-traversable semigroupoids template-haskell - text th-compat time timeline-core + base containers hedgehog indexed-traversable semigroupoids + template-haskell text th-compat time ]; testHaskellDepends = [ base bytestring containers hashable hedgehog indexed-traversable tasty tasty-golden tasty-hedgehog tasty-hunit text time - timeline-hedgehog transformers + transformers ]; testToolDepends = [ tasty-discover ]; description = "Data type representing a piecewise-constant function over time"; diff --git a/timeline-core/src/Data/Timeline/Internal.hs b/src/Data/Timeline.hs similarity index 99% rename from timeline-core/src/Data/Timeline/Internal.hs rename to src/Data/Timeline.hs index fddc056..445a17c 100644 --- a/timeline-core/src/Data/Timeline/Internal.hs +++ b/src/Data/Timeline.hs @@ -24,7 +24,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -module Data.Timeline.Internal +module Data.Timeline ( -- * Core types and functions Timeline (..), peek, diff --git a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs b/src/Data/Timeline/Hedgehog.hs similarity index 90% rename from timeline-hedgehog/src/Data/Timeline/Hedgehog.hs rename to src/Data/Timeline/Hedgehog.hs index 688ed7c..4c24e94 100644 --- a/timeline-hedgehog/src/Data/Timeline/Hedgehog.hs +++ b/src/Data/Timeline/Hedgehog.hs @@ -1,8 +1,7 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} --- | --- Hedgehog generators for the timeline library. +-- | Hedgehog generators for the timeline library. module Data.Timeline.Hedgehog ( -- * Timeline Generators gen, @@ -10,7 +9,7 @@ module Data.Timeline.Hedgehog ) where -import Data.Timeline.Internal +import Data.Timeline import Hedgehog (MonadGen) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range diff --git a/timeline/test/Data/TimelineTest.hs b/test/Data/TimelineTest.hs similarity index 100% rename from timeline/test/Data/TimelineTest.hs rename to test/Data/TimelineTest.hs diff --git a/timeline/test/Main.hs b/test/Main.hs similarity index 100% rename from timeline/test/Main.hs rename to test/Main.hs diff --git a/timeline/test/golden/all_non-overlapping_situations_together.txt b/test/golden/all_non-overlapping_situations_together.txt similarity index 100% rename from timeline/test/golden/all_non-overlapping_situations_together.txt rename to test/golden/all_non-overlapping_situations_together.txt diff --git a/timeline/test/golden/one_change,_with_effective_to.txt b/test/golden/one_change,_with_effective_to.txt similarity index 100% rename from timeline/test/golden/one_change,_with_effective_to.txt rename to test/golden/one_change,_with_effective_to.txt diff --git a/timeline/test/golden/one_change.txt b/test/golden/one_change.txt similarity index 100% rename from timeline/test/golden/one_change.txt rename to test/golden/one_change.txt diff --git a/timeline/test/golden/overlaps.txt b/test/golden/overlaps.txt similarity index 100% rename from timeline/test/golden/overlaps.txt rename to test/golden/overlaps.txt diff --git a/timeline/test/golden/two_groups_of_overlap.txt b/test/golden/two_groups_of_overlap.txt similarity index 100% rename from timeline/test/golden/two_groups_of_overlap.txt rename to test/golden/two_groups_of_overlap.txt diff --git a/timeline-core/CHANGELOG.md b/timeline-core/CHANGELOG.md deleted file mode 100644 index a5ee1bd..0000000 --- a/timeline-core/CHANGELOG.md +++ /dev/null @@ -1,4 +0,0 @@ -# Changelog - -## 0.1.0.0 -- Open source the timeline library we use internally at Bellroy diff --git a/timeline-core/README.md b/timeline-core/README.md deleted file mode 100644 index bdb5178..0000000 --- a/timeline-core/README.md +++ /dev/null @@ -1,42 +0,0 @@ -# timeline - -## Motivation - -The world is always changing, and often we want to manage the changes of data -using computers. Below are some concrete examples: - -- Employee data such as compensation, city, tax rule, time-off, etc. -- Prices of products. A product could have different prices on Amazon and EBay, - and in different currencies. - -Timeline data is often implemented by attaching extra fields to your business -object, denoting the start and end time of each interval. However, only -representing and storing the data is not sufficient, we need to run operations -on timeline data, like extracting a single data point at some specific time, -merging multiple timelines together, etc. - -If you have a similar use case and don't want to reinvent the wheel, this -library is for you. - -## Package Organization - -- `timeline` essential types and functions -- `timeline-tests` unit tests -- `timeline-hedgehog` hedgehog generators for timeline types - -## Getting Started - -The core type is `Timeline a`, refer to -[Haddock](https://hackage.haskell.org/package/timeline-0.0.1.0/docs/Data-Timeline.html) -for its usage. - -## Contribution -Bellroy actively maintains this project. Feel free to submit issues and -pull requests! - -The code is formatted with [`ormolu`](https://hackage.haskell.org/package/ormolu) - -If you use Nix: -- `nix develop` enter a shell with all necessary tools -- `nix build` build and run tests on all GHC versions we support -- Use `nix flake show` to view a full list of outputs diff --git a/timeline-core/default.nix b/timeline-core/default.nix deleted file mode 100644 index 43165e1..0000000 --- a/timeline-core/default.nix +++ /dev/null @@ -1,14 +0,0 @@ -{ mkDerivation, base, containers, indexed-traversable, lib -, semigroupoids, template-haskell, text, th-compat, time -}: -mkDerivation { - pname = "timeline-core"; - version = "0.1.0.0"; - src = ./.; - libraryHaskellDepends = [ - base containers indexed-traversable semigroupoids template-haskell - text th-compat time - ]; - description = "Core types and functions for use within other timeline-* packages"; - license = lib.licenses.bsd3; -} diff --git a/timeline-core/timeline-core.cabal b/timeline-core/timeline-core.cabal deleted file mode 100644 index bf9ffd2..0000000 --- a/timeline-core/timeline-core.cabal +++ /dev/null @@ -1,35 +0,0 @@ -cabal-version: 2.2 -name: timeline-core -version: 0.1.0.0 -synopsis: - Core types and functions for use within other timeline-* packages - -license: BSD-3-Clause -license-file: LICENSE -author: Bellroy Tech Team -maintainer: Bellroy Tech Team -category: Development -build-type: Simple -tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 -extra-source-files: - CHANGELOG.md - README.md - -source-repository head - type: git - location: https://github.com/bellroy/timeline.git - -library - hs-source-dirs: src/ - exposed-modules: Data.Timeline.Internal - default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-unused-imports - build-depends: - , base >=4.14.3 && <4.18 - , containers >=0.6.5 && <0.7 - , indexed-traversable >=0.1.2 && <0.2 - , semigroupoids >=5.3.7 && <5.4 - , template-haskell >=2.16.0 && <2.20 - , text >=1.2.4.1 && <2.1 - , th-compat >=0.1.4 && <0.2 - , time >=1.9.3 && <1.13 diff --git a/timeline-hedgehog/CHANGELOG.md b/timeline-hedgehog/CHANGELOG.md deleted file mode 100644 index e69de29..0000000 diff --git a/timeline-hedgehog/LICENSE b/timeline-hedgehog/LICENSE deleted file mode 100644 index e8308e6..0000000 --- a/timeline-hedgehog/LICENSE +++ /dev/null @@ -1,29 +0,0 @@ -Copyright (C) 2023 Bellroy Pty Ltd - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the - distribution. - -3. Neither the name of the copyright holder nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/timeline-hedgehog/README.md b/timeline-hedgehog/README.md deleted file mode 100644 index ee33fb3..0000000 --- a/timeline-hedgehog/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# timeline - -Provides a container type `Timeline a` for handling data that changes over time. diff --git a/timeline-hedgehog/default.nix b/timeline-hedgehog/default.nix deleted file mode 100644 index cc2f799..0000000 --- a/timeline-hedgehog/default.nix +++ /dev/null @@ -1,9 +0,0 @@ -{ mkDerivation, base, hedgehog, lib, time, timeline-core }: -mkDerivation { - pname = "timeline-hedgehog"; - version = "0.1.0.0"; - src = ./.; - libraryHaskellDepends = [ base hedgehog time timeline-core ]; - description = "Hedgehog generators for the timeline library"; - license = lib.licenses.bsd3; -} diff --git a/timeline-hedgehog/timeline-hedgehog.cabal b/timeline-hedgehog/timeline-hedgehog.cabal deleted file mode 100644 index 94fc9a3..0000000 --- a/timeline-hedgehog/timeline-hedgehog.cabal +++ /dev/null @@ -1,32 +0,0 @@ -cabal-version: 2.2 -name: timeline-hedgehog -version: 0.1.0.0 -synopsis: Hedgehog generators for the timeline library -license: BSD-3-Clause -license-file: LICENSE -author: Bellroy Tech Team -maintainer: Bellroy Tech Team -category: Development -build-type: Simple -tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4 -extra-source-files: - CHANGELOG.md - README.md - -source-repository head - type: git - location: https://github.com/bellroy/timeline.git - -common deps - build-depends: - , base >=4.14.3 && <4.18 - , hedgehog >=1.1 && <1.3 - , time >=1.9.3 && <1.13 - , timeline-core ==0.1.0.0 - -library - import: deps - hs-source-dirs: src/ - exposed-modules: Data.Timeline.Hedgehog - default-language: Haskell2010 - ghc-options: -fwarn-unused-imports -Wall -fno-warn-unused-do-bind diff --git a/timeline/timeline.cabal b/timeline.cabal similarity index 94% rename from timeline/timeline.cabal rename to timeline.cabal index 52badb3..e5e2c50 100644 --- a/timeline/timeline.cabal +++ b/timeline.cabal @@ -24,6 +24,7 @@ common deps build-depends: , base >=4.14.3 && <4.18 , containers >=0.6.5 && <0.7 + , hedgehog >=1.1 && <1.3 , indexed-traversable >=0.1.2 && <0.2 , semigroupoids >=5.3.7 && <5.4 , template-haskell >=2.16.0 && <2.20 @@ -34,10 +35,12 @@ common deps library import: deps hs-source-dirs: src/ - exposed-modules: Data.Timeline + exposed-modules: + Data.Timeline + Data.Timeline.Hedgehog + default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-unused-imports - build-depends: timeline-core ==0.1.0.0 test-suite tests type: exitcode-stdio-1.0 @@ -60,5 +63,4 @@ test-suite tests , text >=1.2.4.1 && <2.1 , time >=1.9.3 && <1.13 , timeline - , timeline-hedgehog ==0.1.0.0 , transformers ^>=0.5.6.2 diff --git a/timeline/CHANGELOG.md b/timeline/CHANGELOG.md deleted file mode 120000 index 04c99a5..0000000 --- a/timeline/CHANGELOG.md +++ /dev/null @@ -1 +0,0 @@ -../CHANGELOG.md \ No newline at end of file diff --git a/timeline/LICENSE b/timeline/LICENSE deleted file mode 100644 index e8308e6..0000000 --- a/timeline/LICENSE +++ /dev/null @@ -1,29 +0,0 @@ -Copyright (C) 2023 Bellroy Pty Ltd - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the - distribution. - -3. Neither the name of the copyright holder nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/timeline/README.md b/timeline/README.md deleted file mode 120000 index 32d46ee..0000000 --- a/timeline/README.md +++ /dev/null @@ -1 +0,0 @@ -../README.md \ No newline at end of file diff --git a/timeline/src/Data/Timeline.hs b/timeline/src/Data/Timeline.hs deleted file mode 100644 index 9ec7ad8..0000000 --- a/timeline/src/Data/Timeline.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Data.Timeline - ( module Data.Timeline.Internal, - ) -where - -import Data.Timeline.Internal