diff --git a/exe-weeder/Main.hs b/exe-weeder/Main.hs index 110361a..a4df7a0 100644 --- a/exe-weeder/Main.hs +++ b/exe-weeder/Main.hs @@ -1,4 +1,4 @@ -module Main ( main ) where +module Main (main) where -- weeder import qualified Weeder.Main diff --git a/flake.lock b/flake.lock index 27746d8..d0fa43d 100644 --- a/flake.lock +++ b/flake.lock @@ -16,6 +16,22 @@ "type": "github" } }, + "HTTP_2": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, "cabal-32": { "flake": false, "locked": { @@ -33,6 +49,23 @@ "type": "github" } }, + "cabal-32_2": { + "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": { @@ -50,6 +83,23 @@ "type": "github" } }, + "cabal-34_2": { + "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": { @@ -67,6 +117,23 @@ "type": "github" } }, + "cabal-36_2": { + "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": { @@ -83,6 +150,46 @@ "type": "github" } }, + "cardano-shell_2": { + "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" + } + }, + "ch-hs-imports": { + "inputs": { + "flake-utils": "flake-utils", + "haskellNix": "haskellNix", + "nixpkgs": [ + "ch-hs-imports", + "haskellNix", + "nixpkgs-unstable" + ] + }, + "locked": { + "lastModified": 1718016097, + "narHash": "sha256-LTZeScv+y8oZsa5TjBcIhyWUfJLbqSR2i6i3JzuSU2U=", + "owner": "circuithub", + "repo": "ch-hs-imports", + "rev": "d94cc91211808493bca5b84d50e33907c9ddf63d", + "type": "github" + }, + "original": { + "owner": "circuithub", + "repo": "ch-hs-imports", + "type": "github" + } + }, "flake-compat": { "flake": false, "locked": { @@ -100,10 +207,45 @@ "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-utils": { "inputs": { "systems": "systems" }, + "locked": { + "lastModified": 1710146030, + "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_2": { + "inputs": { + "systems": "systems_2" + }, "locked": { "lastModified": 1705309234, "narHash": "sha256-uNRRNRKmJyCRC/8y1RqBkqWBLM034y4qN7EprSdmgyA=", @@ -135,6 +277,60 @@ "type": "github" } }, + "ghc-8.6.5-iohk_2": { + "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" + } + }, + "ghc910X": { + "flake": false, + "locked": { + "lastModified": 1714520650, + "narHash": "sha256-4uz6RA1hRr0RheGNDM49a/B3jszqNNU8iHIow4mSyso=", + "ref": "ghc-9.10", + "rev": "2c6375b9a804ac7fca1e82eb6fcfc8594c67c5f5", + "revCount": 62663, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "ref": "ghc-9.10", + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, + "ghc911": { + "flake": false, + "locked": { + "lastModified": 1714817013, + "narHash": "sha256-m2je4UvWfkgepMeUIiXHMwE6W+iVfUY38VDGkMzjCcc=", + "ref": "refs/heads/master", + "rev": "fc24c5cf6c62ca9e3c8d236656e139676df65034", + "revCount": 62816, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + }, + "original": { + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, "ghc98X": { "flake": false, "locked": { @@ -173,6 +369,22 @@ } }, "hackage": { + "flake": false, + "locked": { + "lastModified": 1717979894, + "narHash": "sha256-SVMvRpYC6qtlwkiMZ58hySX5qw8y5TsuM5Z8J/Utetc=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "db1008e5d48d61ce70c7117fa92c0a2ea7d63821", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "hackage_2": { "flake": false, "locked": { "lastModified": 1706660549, @@ -197,8 +409,8 @@ "cardano-shell": "cardano-shell", "flake-compat": "flake-compat", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "ghc98X": "ghc98X", - "ghc99": "ghc99", + "ghc910X": "ghc910X", + "ghc911": "ghc911", "hackage": "hackage", "hls-1.10": "hls-1.10", "hls-2.0": "hls-2.0", @@ -207,11 +419,13 @@ "hls-2.4": "hls-2.4", "hls-2.5": "hls-2.5", "hls-2.6": "hls-2.6", + "hls-2.7": "hls-2.7", + "hls-2.8": "hls-2.8", "hpc-coveralls": "hpc-coveralls", "hydra": "hydra", "iserv-proxy": "iserv-proxy", - "nix-tools-static": "nix-tools-static", "nixpkgs": [ + "ch-hs-imports", "haskellNix", "nixpkgs-unstable" ], @@ -226,6 +440,58 @@ "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, + "locked": { + "lastModified": 1717980631, + "narHash": "sha256-ONiKbTxzx7YAME2ZXR8VgD8oxA7xHOV2uG4UR/RKFGc=", + "owner": "input-output-hk", + "repo": "haskell.nix", + "rev": "3af53828dfcf7117e1ee385a583a916fe4d72253", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "haskell.nix", + "type": "github" + } + }, + "haskellNix_2": { + "inputs": { + "HTTP": "HTTP_2", + "cabal-32": "cabal-32_2", + "cabal-34": "cabal-34_2", + "cabal-36": "cabal-36_2", + "cardano-shell": "cardano-shell_2", + "flake-compat": "flake-compat_2", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk_2", + "ghc98X": "ghc98X", + "ghc99": "ghc99", + "hackage": "hackage_2", + "hls-1.10": "hls-1.10_2", + "hls-2.0": "hls-2.0_2", + "hls-2.2": "hls-2.2_2", + "hls-2.3": "hls-2.3_2", + "hls-2.4": "hls-2.4_2", + "hls-2.5": "hls-2.5_2", + "hls-2.6": "hls-2.6_2", + "hpc-coveralls": "hpc-coveralls_2", + "hydra": "hydra_2", + "iserv-proxy": "iserv-proxy_2", + "nix-tools-static": "nix-tools-static", + "nixpkgs": [ + "haskellNix", + "nixpkgs-unstable" + ], + "nixpkgs-2003": "nixpkgs-2003_2", + "nixpkgs-2105": "nixpkgs-2105_2", + "nixpkgs-2111": "nixpkgs-2111_2", + "nixpkgs-2205": "nixpkgs-2205_2", + "nixpkgs-2211": "nixpkgs-2211_2", + "nixpkgs-2305": "nixpkgs-2305_2", + "nixpkgs-2311": "nixpkgs-2311_2", + "nixpkgs-unstable": "nixpkgs-unstable_2", + "old-ghc-nix": "old-ghc-nix_2", + "stackage": "stackage_2" + }, "locked": { "lastModified": 1706662202, "narHash": "sha256-gTGsgdlXXwcsSgQxQkxcv1iOS90m8Xr8ze5i5BnCbo0=", @@ -257,6 +523,23 @@ "type": "github" } }, + "hls-1.10_2": { + "flake": false, + "locked": { + "lastModified": 1680000865, + "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "1.10.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.0": { "flake": false, "locked": { @@ -274,6 +557,23 @@ "type": "github" } }, + "hls-2.0_2": { + "flake": false, + "locked": { + "lastModified": 1687698105, + "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "783905f211ac63edf982dd1889c671653327e441", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.0.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.2": { "flake": false, "locked": { @@ -291,6 +591,23 @@ "type": "github" } }, + "hls-2.2_2": { + "flake": false, + "locked": { + "lastModified": 1693064058, + "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.2.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.3": { "flake": false, "locked": { @@ -308,6 +625,23 @@ "type": "github" } }, + "hls-2.3_2": { + "flake": false, + "locked": { + "lastModified": 1695910642, + "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.3.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.4": { "flake": false, "locked": { @@ -325,6 +659,23 @@ "type": "github" } }, + "hls-2.4_2": { + "flake": false, + "locked": { + "lastModified": 1699862708, + "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.4.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.5": { "flake": false, "locked": { @@ -342,6 +693,23 @@ "type": "github" } }, + "hls-2.5_2": { + "flake": false, + "locked": { + "lastModified": 1701080174, + "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.5.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.6": { "flake": false, "locked": { @@ -359,7 +727,74 @@ "type": "github" } }, - "hpc-coveralls": { + "hls-2.6_2": { + "flake": false, + "locked": { + "lastModified": 1705325287, + "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.6.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.7": { + "flake": false, + "locked": { + "lastModified": 1708965829, + "narHash": "sha256-LfJ+TBcBFq/XKoiNI7pc4VoHg4WmuzsFxYJ3Fu+Jf+M=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "50322b0a4aefb27adc5ec42f5055aaa8f8e38001", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.7.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.8": { + "flake": false, + "locked": { + "lastModified": 1715153580, + "narHash": "sha256-Vi/iUt2pWyUJlo9VrYgTcbRviWE0cFO6rmGi9rmALw0=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "dd1be1beb16700de59e0d6801957290bcf956a0a", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.8.0.0", + "repo": "haskell-language-server", + "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" + } + }, + "hpc-coveralls_2": { "flake": false, "locked": { "lastModified": 1607498076, @@ -378,6 +813,30 @@ "hydra": { "inputs": { "nix": "nix", + "nixpkgs": [ + "ch-hs-imports", + "haskellNix", + "hydra", + "nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1671755331, + "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", + "owner": "NixOS", + "repo": "hydra", + "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", + "type": "github" + }, + "original": { + "id": "hydra", + "type": "indirect" + } + }, + "hydra_2": { + "inputs": { + "nix": "nix_2", "nixpkgs": [ "haskellNix", "hydra", @@ -399,6 +858,23 @@ } }, "iserv-proxy": { + "flake": false, + "locked": { + "lastModified": 1717479972, + "narHash": "sha256-7vE3RQycHI1YT9LHJ1/fUaeln2vIpYm6Mmn8FTpYeVo=", + "owner": "stable-haskell", + "repo": "iserv-proxy", + "rev": "2ed34002247213fc435d0062350b91bab920626e", + "type": "github" + }, + "original": { + "owner": "stable-haskell", + "ref": "iserv-syms", + "repo": "iserv-proxy", + "type": "github" + } + }, + "iserv-proxy_2": { "flake": false, "locked": { "lastModified": 1691634696, @@ -431,6 +907,22 @@ "type": "github" } }, + "lowdown-src_2": { + "flake": false, + "locked": { + "lastModified": 1633514407, + "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", + "owner": "kristapsdz", + "repo": "lowdown", + "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", + "type": "github" + }, + "original": { + "owner": "kristapsdz", + "repo": "lowdown", + "type": "github" + } + }, "nix": { "inputs": { "lowdown-src": "lowdown-src", @@ -469,6 +961,27 @@ "type": "github" } }, + "nix_2": { + "inputs": { + "lowdown-src": "lowdown-src_2", + "nixpkgs": "nixpkgs_2", + "nixpkgs-regression": "nixpkgs-regression_2" + }, + "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" + } + }, "nixpkgs": { "locked": { "lastModified": 1657693803, @@ -501,6 +1014,22 @@ "type": "github" } }, + "nixpkgs-2003_2": { + "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, @@ -517,6 +1046,22 @@ "type": "github" } }, + "nixpkgs-2105_2": { + "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, @@ -533,6 +1078,22 @@ "type": "github" } }, + "nixpkgs-2111_2": { + "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": 1685573264, @@ -549,6 +1110,22 @@ "type": "github" } }, + "nixpkgs-2205_2": { + "locked": { + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-2211": { "locked": { "lastModified": 1688392541, @@ -565,6 +1142,22 @@ "type": "github" } }, + "nixpkgs-2211_2": { + "locked": { + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-2305": { "locked": { "lastModified": 1701362232, @@ -581,6 +1174,22 @@ "type": "github" } }, + "nixpkgs-2305_2": { + "locked": { + "lastModified": 1701362232, + "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-2311": { "locked": { "lastModified": 1701386440, @@ -597,6 +1206,22 @@ "type": "github" } }, + "nixpkgs-2311_2": { + "locked": { + "lastModified": 1701386440, + "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-regression": { "locked": { "lastModified": 1643052045, @@ -613,6 +1238,22 @@ "type": "github" } }, + "nixpkgs-regression_2": { + "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": 1694822471, @@ -629,6 +1270,38 @@ "type": "github" } }, + "nixpkgs-unstable_2": { + "locked": { + "lastModified": 1694822471, + "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", + "type": "github" + } + }, + "nixpkgs_2": { + "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" + } + }, "old-ghc-nix": { "flake": false, "locked": { @@ -646,10 +1319,28 @@ "type": "github" } }, + "old-ghc-nix_2": { + "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-utils": "flake-utils", - "haskellNix": "haskellNix", + "ch-hs-imports": "ch-hs-imports", + "flake-utils": "flake-utils_2", + "haskellNix": "haskellNix_2", "nixpkgs": [ "haskellNix", "nixpkgs-unstable" @@ -657,6 +1348,22 @@ } }, "stackage": { + "flake": false, + "locked": { + "lastModified": 1717978996, + "narHash": "sha256-T8LcK1WhFGHX+tOXwwXGqEImm+VC0s5jVO/DOcKSsqc=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "af64a3588c966f102bb5843f9fd5cf7fae9bf034", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + }, + "stackage_2": { "flake": false, "locked": { "lastModified": 1706659779, @@ -686,6 +1393,21 @@ "repo": "default", "type": "github" } + }, + "systems_2": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } } }, "root": "root", diff --git a/flake.nix b/flake.nix index 17f02d0..03cec75 100644 --- a/flake.nix +++ b/flake.nix @@ -16,9 +16,10 @@ flake-utils.url = github:numtide/flake-utils; haskellNix.url = github:input-output-hk/haskell.nix; nixpkgs.follows = "haskellNix/nixpkgs-unstable"; + ch-hs-imports.url = "github:circuithub/ch-hs-imports"; }; - outputs = { self, nixpkgs, flake-utils, haskellNix }: + outputs = { self, nixpkgs, flake-utils, haskellNix, ch-hs-imports }: flake-utils.lib.eachSystem ["x86_64-linux"] (system: let pkgs = import nixpkgs { @@ -59,7 +60,7 @@ withHoogle = false; tools = { cabal = "latest"; }; exactDeps = false; - buildInputs = [ pkgs.changie ]; + buildInputs = [ pkgs.changie ch-hs-imports.packages.x86_64-linux.default pkgs.treefmt pkgs.haskellPackages.fourmolu ]; }; } ); diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..aeb9f5e --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,10 @@ +indentation: 2 +comma-style: leading +import-export-style: diff-friendly +indent-wheres: true +record-brace-space: false +respectful: true +haddock-style: multi-line +newlines-between-decls: 2 +fixities: [] +single-constraint-parens: auto diff --git a/src/Weeder.hs b/src/Weeder.hs index 8de39aa..b936868 100644 --- a/src/Weeder.hs +++ b/src/Weeder.hs @@ -1,53 +1,53 @@ -{-# language ApplicativeDo #-} -{-# language BlockArguments #-} -{-# language DeriveGeneric #-} -{-# language DeriveAnyClass #-} -{-# language FlexibleContexts #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language NoImplicitPrelude #-} -{-# language OverloadedLabels #-} -{-# language OverloadedStrings #-} -{-# language TupleSections #-} - -module Weeder - ( -- * Analysis - Analysis(..) - , analyseEvidenceUses - , analyseHieFile - , emptyAnalysis - , outputableDeclarations - - -- ** Reachability - , Root(..) - , reachable - - -- * Declarations - , Declaration(..) - ) - where +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Weeder ( + -- * Analysis + Analysis (..), + analyseEvidenceUses, + analyseHieFile, + emptyAnalysis, + outputableDeclarations, + + -- ** Reachability + Root (..), + reachable, + + -- * Declarations + Declaration (..), +) +where -- algebraic-graphs -import Algebra.Graph ( Graph, edge, empty, overlay, vertex, stars, star, overlays ) -import Algebra.Graph.ToGraph ( dfs ) +import Algebra.Graph (Graph, edge, empty, overlay, overlays, star, stars, vertex) +import Algebra.Graph.ToGraph (dfs) -- base -import Control.Applicative ( Alternative ) -import Control.Monad ( guard, msum, when, unless, mzero ) -import Data.Traversable ( for ) -import Data.Maybe ( mapMaybe ) -import Data.Foldable ( for_, traverse_, toList ) -import Data.Function ( (&) ) -import Data.List ( intercalate ) -import Data.Monoid ( First( First ), getFirst ) -import GHC.Generics ( Generic ) -import Prelude hiding ( span ) +import Control.Applicative (Alternative) +import Control.Monad (guard, msum, mzero, unless, when) +import Data.Foldable (for_, toList, traverse_) +import Data.Function ((&)) +import Data.List (intercalate) +import Data.Maybe (mapMaybe) +import Data.Monoid (First (First), getFirst) +import Data.Traversable (for) +import GHC.Generics (Generic) +import Prelude hiding (span) -- containers -import Data.Map.Strict ( Map ) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Sequence ( Seq ) -import Data.Set ( Set ) +import Data.Sequence (Seq) +import Data.Set (Set) import qualified Data.Set as Set import Data.Tree (Tree) import qualified Data.Tree as Tree @@ -56,80 +56,81 @@ import qualified Data.Tree as Tree import Data.Generics.Labels () -- ghc -import GHC.Data.FastString ( unpackFS ) -import GHC.Iface.Ext.Types - ( BindType( RegularBind ) - , ContextInfo( Decl, ValBind, PatternBind, Use, TyDecl, ClassTyDecl, EvidenceVarBind, RecField ) - , DeclType( DataDec, ClassDec, ConDec, SynDec, FamDec ) - , EvVarSource ( EvInstBind, cls ) - , HieAST( Node, nodeChildren, nodeSpan, sourcedNodeInfo ) - , HieASTs( HieASTs ) - , HieFile( HieFile, hie_asts, hie_module, hie_hs_file, hie_types ) - , HieType( HTyVarTy, HAppTy, HTyConApp, HForAllTy, HFunTy, HQualTy, HLitTy, HCastTy, HCoercionTy ) - , HieArgs( HieArgs ) - , HieTypeFix( Roll ) - , IdentifierDetails( IdentifierDetails, identInfo, identType ) - , NodeAnnotation( NodeAnnotation, nodeAnnotType ) - , NodeInfo( nodeIdentifiers, nodeAnnotations ) - , Scope( ModuleScope ) - , RecFieldContext ( RecFieldOcc ) - , TypeIndex - , getSourcedNodeInfo - ) -import GHC.Iface.Ext.Utils - ( EvidenceInfo( EvidenceInfo, evidenceVar ) - , RefMap - , findEvidenceUse - , getEvidenceTree - , hieTypeToIface - , recoverFullType - ) -import GHC.Unit.Module ( Module, moduleStableString ) -import GHC.Utils.Outputable ( defaultSDocContext, showSDocOneLine ) -import GHC.Iface.Type - ( ShowForAllFlag (ShowForAllWhen) - , pprIfaceSigmaType - , IfaceTyCon (IfaceTyCon, ifaceTyConName) - ) -import GHC.Types.Name - ( Name, nameModule_maybe, nameOccName - , OccName - , isDataOcc - , isDataSymOcc - , isTcOcc - , isTvOcc - , isVarOcc - , occNameString - ) -import GHC.Types.SrcLoc ( RealSrcSpan, realSrcSpanEnd, realSrcSpanStart, srcLocLine, srcLocCol ) +import GHC.Data.FastString (unpackFS) +import GHC.Iface.Ext.Types ( + BindType (RegularBind), + ContextInfo (ClassTyDecl, Decl, EvidenceVarBind, PatternBind, RecField, TyDecl, Use, ValBind), + DeclType (ClassDec, ConDec, DataDec, FamDec, SynDec), + EvVarSource (EvInstBind, cls), + HieAST (Node, nodeChildren, nodeSpan, sourcedNodeInfo), + HieASTs (HieASTs), + HieArgs (HieArgs), + HieFile (HieFile, hie_asts, hie_hs_file, hie_module, hie_types), + HieType (HAppTy, HCastTy, HCoercionTy, HForAllTy, HFunTy, HLitTy, HQualTy, HTyConApp, HTyVarTy), + HieTypeFix (Roll), + IdentifierDetails (IdentifierDetails, identInfo, identType), + NodeAnnotation (NodeAnnotation, nodeAnnotType), + NodeInfo (nodeAnnotations, nodeIdentifiers), + RecFieldContext (RecFieldOcc), + Scope (ModuleScope), + TypeIndex, + getSourcedNodeInfo, + ) +import GHC.Iface.Ext.Utils ( + EvidenceInfo (EvidenceInfo, evidenceVar), + RefMap, + findEvidenceUse, + getEvidenceTree, + hieTypeToIface, + recoverFullType, + ) +import GHC.Iface.Type ( + IfaceTyCon (IfaceTyCon, ifaceTyConName), + ShowForAllFlag (ShowForAllWhen), + pprIfaceSigmaType, + ) +import GHC.Types.Name ( + Name, + OccName, + isDataOcc, + isDataSymOcc, + isTcOcc, + isTvOcc, + isVarOcc, + nameModule_maybe, + nameOccName, + occNameString, + ) +import GHC.Types.SrcLoc (RealSrcSpan, realSrcSpanEnd, realSrcSpanStart, srcLocCol, srcLocLine) +import GHC.Unit.Module (Module, moduleStableString) +import GHC.Utils.Outputable (defaultSDocContext, showSDocOneLine) -- lens -import Control.Lens ( (%=) ) +import Control.Lens ((%=)) -- mtl -import Control.Monad.State.Class ( MonadState ) -import Control.Monad.Reader.Class ( MonadReader, asks ) +import Control.Monad.Reader.Class (MonadReader, asks) +import Control.Monad.State.Class (MonadState) -- parallel -import Control.Parallel.Strategies ( NFData ) +import Control.Parallel.Strategies (NFData) -- transformers -import Control.Monad.Trans.Maybe ( runMaybeT ) -import Control.Monad.Trans.Reader ( runReaderT ) +import Control.Monad.Trans.Maybe (runMaybeT) +import Control.Monad.Trans.Reader (runReaderT) -- weeder -import Weeder.Config ( Config, ConfigType( Config, typeClassRoots, unusedTypes ) ) +import Weeder.Config (Config, ConfigType (Config, typeClassRoots, unusedTypes)) -data Declaration = - Declaration - { declModule :: Module - -- ^ The module this declaration occurs in. - , declOccName :: OccName - -- ^ The symbol name of a declaration. - } +data Declaration = Declaration + { declModule :: Module + -- ^ The module this declaration occurs in. + , declOccName :: OccName + -- ^ The symbol name of a declaration. + } deriving - ( Eq, Ord, Generic, NFData ) + (Eq, Ord, Generic, NFData) instance Show Declaration where @@ -138,57 +139,55 @@ instance Show Declaration where declarationStableName :: Declaration -> String -declarationStableName Declaration { declModule, declOccName } = +declarationStableName Declaration{declModule, declOccName} = let namespace - | isVarOcc declOccName = "var" - | isTvOcc declOccName = "tv" - | isTcOcc declOccName = "tc" - | isDataOcc declOccName = "data" + | isVarOcc declOccName = "var" + | isTvOcc declOccName = "tv" + | isTcOcc declOccName = "tc" + | isDataOcc declOccName = "data" | isDataSymOcc declOccName = "dataSym" - | otherwise = "unknown" - - in - intercalate "$" [ namespace, moduleStableString declModule, "$", occNameString declOccName ] + | otherwise = "unknown" + in + intercalate "$" [namespace, moduleStableString declModule, "$", occNameString declOccName] -- | All information maintained by 'analyseHieFile'. -data Analysis = - Analysis - { dependencyGraph :: Graph Declaration - -- ^ A graph between declarations, capturing dependencies. - , declarationSites :: Map Declaration (Set (Int, Int)) - -- ^ A partial mapping between declarations and their line numbers. - -- This Map is partial as we don't always know where a Declaration was - -- defined (e.g., it may come from a package without source code). - -- We capture a set of sites, because a declaration may be defined in - -- multiple locations, e.g., a type signature for a function separate - -- from its definition. - , implicitRoots :: Set Root - -- ^ Stores information on Declarations that may be automatically marked - -- as always reachable. This is used, for example, to capture knowledge - -- not yet modelled in weeder, or to mark all instances of a class as - -- roots. - , exports :: Map Module ( Set Declaration ) - -- ^ All exports for a given module. - , modulePaths :: Map Module FilePath - -- ^ A map from modules to the file path to the .hs file defining them. - , prettyPrintedType :: Map Declaration String - -- ^ Used to match against the types of instances and to replace the - -- appearance of declarations in the output - , requestedEvidence :: Map Declaration (Set Name) - -- ^ Map from declarations to the names containing evidence uses that - -- should be followed and treated as dependencies of the declaration. - -- We use this to be able to delay analysing evidence uses until later, - -- allowing us to begin the rest of the analysis before we have read all - -- hie files. - } +data Analysis = Analysis + { dependencyGraph :: Graph Declaration + -- ^ A graph between declarations, capturing dependencies. + , declarationSites :: Map Declaration (Set (Int, Int)) + -- ^ A partial mapping between declarations and their line numbers. + -- This Map is partial as we don't always know where a Declaration was + -- defined (e.g., it may come from a package without source code). + -- We capture a set of sites, because a declaration may be defined in + -- multiple locations, e.g., a type signature for a function separate + -- from its definition. + , implicitRoots :: Set Root + -- ^ Stores information on Declarations that may be automatically marked + -- as always reachable. This is used, for example, to capture knowledge + -- not yet modelled in weeder, or to mark all instances of a class as + -- roots. + , exports :: Map Module (Set Declaration) + -- ^ All exports for a given module. + , modulePaths :: Map Module FilePath + -- ^ A map from modules to the file path to the .hs file defining them. + , prettyPrintedType :: Map Declaration String + -- ^ Used to match against the types of instances and to replace the + -- appearance of declarations in the output + , requestedEvidence :: Map Declaration (Set Name) + -- ^ Map from declarations to the names containing evidence uses that + -- should be followed and treated as dependencies of the declaration. + -- We use this to be able to delay analysing evidence uses until later, + -- allowing us to begin the rest of the analysis before we have read all + -- hie files. + } deriving - ( Generic, NFData ) + (Generic, NFData) instance Semigroup Analysis where - (<>) (Analysis a1 b1 c1 d1 e1 f1 g1) (Analysis a2 b2 c2 d2 e2 f2 g2)= + (<>) (Analysis a1 b1 c1 d1 e1 f1 g1) (Analysis a2 b2 c2 d2 e2 f2 g2) = Analysis (a1 `overlay` a2) (Map.unionWith (<>) b1 b2) (c1 <> c2) (Map.unionWith (<>) d1 d2) (e1 <> e2) (f1 <> f2) (Map.unionWith (<>) g1 g2) @@ -196,11 +195,10 @@ instance Monoid Analysis where mempty = emptyAnalysis -data AnalysisInfo = - AnalysisInfo - { currentHieFile :: HieFile - , weederConfig :: Config - } +data AnalysisInfo = AnalysisInfo + { currentHieFile :: HieFile + , weederConfig :: Config + } -- | The empty analysis - the result of analysing zero @.hie@ files. @@ -214,51 +212,52 @@ data Root DeclarationRoot Declaration | -- | We store extra information for instances in order to be able -- to specify e.g. all instances of a class as roots. - InstanceRoot - Declaration -- ^ Declaration of the instance - Declaration -- ^ Declaration of the parent class + InstanceRoot + Declaration + -- ^ Declaration of the instance + Declaration + -- ^ Declaration of the parent class | -- | All exported declarations in a module are roots. ModuleRoot Module deriving - ( Eq, Ord, Generic, NFData ) + (Eq, Ord, Generic, NFData) -- | Determine the set of all declaration reachable from a set of roots. reachable :: Analysis -> Set Root -> Set Declaration -reachable Analysis{ dependencyGraph, exports } roots = - Set.fromList ( dfs dependencyGraph ( foldMap rootDeclarations roots ) ) - +reachable Analysis{dependencyGraph, exports} roots = + Set.fromList (dfs dependencyGraph (foldMap rootDeclarations roots)) where - rootDeclarations = \case - DeclarationRoot d -> [ d ] - InstanceRoot d _ -> [ d ] -- filter InstanceRoots in `Main.hs` - ModuleRoot m -> foldMap Set.toList ( Map.lookup m exports ) + DeclarationRoot d -> [d] + InstanceRoot d _ -> [d] -- filter InstanceRoots in `Main.hs` + ModuleRoot m -> foldMap Set.toList (Map.lookup m exports) --- | The set of all declarations that could possibly --- appear in the output. +{- | The set of all declarations that could possibly +appear in the output. +-} outputableDeclarations :: Analysis -> Set Declaration -outputableDeclarations Analysis{ declarationSites } = +outputableDeclarations Analysis{declarationSites} = Map.keysSet declarationSites -- Generate an initial graph of the current HieFile. initialGraph :: AnalysisInfo -> Graph Declaration initialGraph info = - let hf@HieFile{ hie_asts = HieASTs hieAsts } = currentHieFile info - Config{ unusedTypes } = weederConfig info + let hf@HieFile{hie_asts = HieASTs hieAsts} = currentHieFile info + Config{unusedTypes} = weederConfig info asts = Map.elems hieAsts decls = concatMap (toList . findIdentifiers' (const True)) asts - in if unusedTypes - then stars do - (d, IdentifierDetails{identType}, _) <- decls - t <- maybe mzero pure identType - let ns = Set.toList $ typeToNames (lookupType hf t) - ds = mapMaybe nameToDeclaration ns - guard $ not (null ds) - pure (d, ds) - else mempty + in if unusedTypes + then stars do + (d, IdentifierDetails{identType}, _) <- decls + t <- maybe mzero pure identType + let ns = Set.toList $ typeToNames (lookupType hf t) + ds = mapMaybe nameToDeclaration ns + guard $ not (null ds) + pure (d, ds) + else mempty -- | Incrementally update 'Analysis' with information in a 'HieFile'. @@ -268,11 +267,11 @@ analyseHieFile weederConfig hieFile = in runReaderT analyseHieFile' info -analyseHieFile' :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => m () +analyseHieFile' :: (MonadState Analysis m, MonadReader AnalysisInfo m) => m () analyseHieFile' = do - HieFile{ hie_asts = HieASTs hieASTs, hie_module, hie_hs_file } <- asks currentHieFile + HieFile{hie_asts = HieASTs hieASTs, hie_module, hie_hs_file} <- asks currentHieFile #modulePaths %= Map.insert hie_module hie_hs_file - + g <- asks initialGraph #dependencyGraph %= overlay g @@ -283,13 +282,11 @@ lookupType :: HieFile -> TypeIndex -> HieTypeFix lookupType hf t = recoverFullType t $ hie_types hf -lookupPprType :: MonadReader AnalysisInfo m => TypeIndex -> m String +lookupPprType :: (MonadReader AnalysisInfo m) => TypeIndex -> m String lookupPprType t = do hf <- asks currentHieFile pure . renderType $ lookupType hf t - where - renderType = showSDocOneLine defaultSDocContext . pprIfaceSigmaType ShowForAllWhen . hieTypeToIface @@ -297,85 +294,77 @@ lookupPprType t = do typeToNames :: HieTypeFix -> Set Name typeToNames (Roll t) = case t of HTyVarTy n -> Set.singleton n - HAppTy a (HieArgs args) -> typeToNames a <> hieArgsTypes args - HTyConApp (IfaceTyCon{ifaceTyConName}) (HieArgs args) -> Set.singleton ifaceTyConName <> hieArgsTypes args - HForAllTy _ a -> typeToNames a - HFunTy _mult b c -> typeToNames b <> typeToNames c - HQualTy a b -> typeToNames a <> typeToNames b - HLitTy _ -> mempty - HCastTy a -> typeToNames a - HCoercionTy -> mempty - where - hieArgsTypes :: [(Bool, HieTypeFix)] -> Set Name hieArgsTypes = foldMap (typeToNames . snd) . filter fst -- | @addDependency x y@ adds the information that @x@ depends on @y@. -addDependency :: MonadState Analysis m => Declaration -> Declaration -> m () +addDependency :: (MonadState Analysis m) => Declaration -> Declaration -> m () addDependency x y = - #dependencyGraph %= overlay ( edge x y ) + #dependencyGraph %= overlay (edge x y) -addImplicitRoot :: MonadState Analysis m => Declaration -> m () +addImplicitRoot :: (MonadState Analysis m) => Declaration -> m () addImplicitRoot x = #implicitRoots %= Set.insert (DeclarationRoot x) -addInstanceRoot :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => Declaration -> TypeIndex -> Name -> m () +addInstanceRoot :: (MonadState Analysis m, MonadReader AnalysisInfo m) => Declaration -> TypeIndex -> Name -> m () addInstanceRoot x t cls = do for_ (nameToDeclaration cls) \cls' -> #implicitRoots %= Set.insert (InstanceRoot x cls') -- since instances will not appear in the output if typeClassRoots is True - Config{ typeClassRoots } <- asks weederConfig + Config{typeClassRoots} <- asks weederConfig unless typeClassRoots $ do str <- lookupPprType t #prettyPrintedType %= Map.insert x str -define :: MonadState Analysis m => Declaration -> RealSrcSpan -> m () +define :: (MonadState Analysis m) => Declaration -> RealSrcSpan -> m () define decl span = - when ( realSrcSpanStart span /= realSrcSpanEnd span ) do + when (realSrcSpanStart span /= realSrcSpanEnd span) do let start = realSrcSpanStart span let loc = (srcLocLine start, srcLocCol start) - #declarationSites %= Map.insertWith Set.union decl ( Set.singleton loc) - #dependencyGraph %= overlay ( vertex decl ) + #declarationSites %= Map.insertWith Set.union decl (Set.singleton loc) + #dependencyGraph %= overlay (vertex decl) -topLevelAnalysis :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m () -topLevelAnalysis n@Node{ nodeChildren } = do - Config{ unusedTypes } <- asks weederConfig +topLevelAnalysis :: (MonadState Analysis m, MonadReader AnalysisInfo m) => HieAST TypeIndex -> m () +topLevelAnalysis n@Node{nodeChildren} = do + Config{unusedTypes} <- asks weederConfig analysed <- runMaybeT ( msum $ - [ - analyseStandaloneDeriving n + [ analyseStandaloneDeriving n , analyseInstanceDeclaration n , analyseBinding n , analyseRewriteRule n , analyseClassDeclaration n , analyseDataDeclaration n , analysePatternSynonyms n - ] ++ if unusedTypes then - [ analyseTypeSynonym n - , analyseFamilyDeclaration n - , analyseFamilyInstance n - , analyseTypeSignature n - ] else [] + ] + ++ if unusedTypes + then + [ analyseTypeSynonym n + , analyseFamilyDeclaration n + , analyseFamilyInstance n + , analyseTypeSignature n + ] + else [] ) case analysed of @@ -383,127 +372,121 @@ topLevelAnalysis n@Node{ nodeChildren } = do -- We didn't find a top level declaration here, check all this nodes -- children. traverse_ topLevelAnalysis nodeChildren - Just () -> -- Top level analysis succeeded, there's nothing more to do for this node. return () annsContain :: HieAST a -> (String, String) -> Bool -annsContain Node{ sourcedNodeInfo } ann = +annsContain Node{sourcedNodeInfo} ann = any (Set.member ann . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo -analyseBinding :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST a -> m () -analyseBinding n@Node{ nodeSpan } = do +analyseBinding :: (Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m) => HieAST a -> m () +analyseBinding n@Node{nodeSpan} = do let bindAnns = Set.fromList [("FunBind", "HsBindLR"), ("PatBind", "HsBindLR")] guard $ any (annsContain n) bindAnns - for_ ( findDeclarations n ) \d -> do + for_ (findDeclarations n) \d -> do define d nodeSpan requestEvidence n d - for_ ( uses n ) $ addDependency d + for_ (uses n) $ addDependency d -analyseRewriteRule :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () +analyseRewriteRule :: (Alternative m, MonadState Analysis m) => HieAST a -> m () analyseRewriteRule n = do guard $ annsContain n ("HsRule", "RuleDecl") - for_ ( uses n ) addImplicitRoot + for_ (uses n) addImplicitRoot -analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m () -analyseInstanceDeclaration n@Node{ nodeSpan } = do +analyseInstanceDeclaration :: (Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m) => HieAST TypeIndex -> m () +analyseInstanceDeclaration n@Node{nodeSpan} = do guard $ annsContain n ("ClsInstD", "InstDecl") - for_ ( findEvInstBinds n ) \(d, cs, ids, _) -> do - -- This makes instance declarations show up in + for_ (findEvInstBinds n) \(d, cs, ids, _) -> do + -- This makes instance declarations show up in -- the output if type-class-roots is set to False. define d nodeSpan requestEvidence n d - for_ ( uses n ) $ addDependency d + for_ (uses n) $ addDependency d case identType ids of Just t -> for_ cs (addInstanceRoot d t) Nothing -> pure () -analyseClassDeclaration :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST a -> m () -analyseClassDeclaration n@Node{ nodeSpan } = do +analyseClassDeclaration :: (Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m) => HieAST a -> m () +analyseClassDeclaration n@Node{nodeSpan} = do guard $ annsContain n ("ClassDecl", "TyClDecl") - for_ ( findIdentifiers isClassDeclaration n ) $ \d -> do + for_ (findIdentifiers isClassDeclaration n) $ \d -> do define d nodeSpan requestEvidence n d - (for_ ( findIdentifiers ( const True ) n ) . addDependency) d - + (for_ (findIdentifiers (const True) n) . addDependency) d where - isClassDeclaration = not . Set.null . Set.filter \case Decl ClassDec _ -> True - _ -> False -analyseDataDeclaration :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m () +analyseDataDeclaration :: (Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m) => HieAST TypeIndex -> m () analyseDataDeclaration n = do guard $ annsContain n ("DataDecl", "TyClDecl") - Config{ unusedTypes } <- asks weederConfig + Config{unusedTypes} <- asks weederConfig for_ ( foldMap - ( First . Just ) - ( findIdentifiers ( any isDataDec ) n ) + (First . Just) + (findIdentifiers (any isDataDec) n) ) \dataTypeName -> do when unusedTypes $ define dataTypeName (nodeSpan n) - -- Without connecting constructors to the data declaration TypeAliasGADT.hs + -- Without connecting constructors to the data declaration TypeAliasGADT.hs -- fails with a false positive for A - conDecs <- for ( constructors n ) \constructor -> - for ( foldMap ( First . Just ) ( findIdentifiers ( any isConDec ) constructor ) ) \conDec -> do + conDecs <- for (constructors n) \constructor -> + for (foldMap (First . Just) (findIdentifiers (any isConDec) constructor)) \conDec -> do addDependency conDec dataTypeName pure conDec -- To keep acyclicity in record declarations let isDependent d = Just d `elem` fmap getFirst conDecs - for_ ( uses n ) (\d -> unless (isDependent d) $ addDependency dataTypeName d) + for_ (uses n) (\d -> unless (isDependent d) $ addDependency dataTypeName d) - for_ ( derivedInstances n ) \(d, cs, ids, ast) -> do + for_ (derivedInstances n) \(d, cs, ids, ast) -> do define d (nodeSpan ast) requestEvidence ast d - for_ ( uses ast ) $ addDependency d + for_ (uses ast) $ addDependency d case identType ids of Just t -> for_ cs (addInstanceRoot d t) Nothing -> pure () - where - isDataDec = \case Decl DataDec _ -> True - _ -> False + _ -> False isConDec = \case Decl ConDec _ -> True - _ -> False + _ -> False -constructors :: HieAST a -> Seq ( HieAST a ) +constructors :: HieAST a -> Seq (HieAST a) constructors = findNodeTypes "ConDecl" @@ -511,17 +494,15 @@ derivedInstances :: HieAST a -> Seq (Declaration, Set Name, IdentifierDetails a, derivedInstances n = findNodeTypes "HsDerivingClause" n >>= findEvInstBinds -findNodeTypes :: String -> HieAST a -> Seq ( HieAST a ) -findNodeTypes t n@Node{ nodeChildren, sourcedNodeInfo } = - if any (any ( (t ==) . unpackFS . nodeAnnotType) . nodeAnnotations) (getSourcedNodeInfo sourcedNodeInfo) then - pure n - - else - foldMap (findNodeTypes t) nodeChildren +findNodeTypes :: String -> HieAST a -> Seq (HieAST a) +findNodeTypes t n@Node{nodeChildren, sourcedNodeInfo} = + if any (any ((t ==) . unpackFS . nodeAnnotType) . nodeAnnotations) (getSourcedNodeInfo sourcedNodeInfo) + then pure n + else foldMap (findNodeTypes t) nodeChildren -analyseStandaloneDeriving :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m () -analyseStandaloneDeriving n@Node{ nodeSpan } = do +analyseStandaloneDeriving :: (Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m) => HieAST TypeIndex -> m () +analyseStandaloneDeriving n@Node{nodeSpan} = do guard $ annsContain n ("DerivDecl", "DerivDecl") for_ (findEvInstBinds n) \(d, cs, ids, _) -> do @@ -536,145 +517,138 @@ analyseStandaloneDeriving n@Node{ nodeSpan } = do Nothing -> pure () -analyseTypeSynonym :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () -analyseTypeSynonym n@Node{ nodeSpan } = do +analyseTypeSynonym :: (Alternative m, MonadState Analysis m) => HieAST a -> m () +analyseTypeSynonym n@Node{nodeSpan} = do guard $ annsContain n ("SynDecl", "TyClDecl") - for_ ( findIdentifiers isTypeSynonym n ) $ \d -> do + for_ (findIdentifiers isTypeSynonym n) $ \d -> do define d nodeSpan for_ (uses n) (addDependency d) - where - isTypeSynonym = any \case Decl SynDec _ -> True - _ -> False + _ -> False -analyseFamilyDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () -analyseFamilyDeclaration n@Node{ nodeSpan } = do +analyseFamilyDeclaration :: (Alternative m, MonadState Analysis m) => HieAST a -> m () +analyseFamilyDeclaration n@Node{nodeSpan} = do guard $ annsContain n ("FamDecl", "TyClDecl") - for_ ( findIdentifiers isFamDec n ) $ \d -> do + for_ (findIdentifiers isFamDec n) $ \d -> do define d nodeSpan for_ (uses n) (addDependency d) - where - isFamDec = any \case Decl FamDec _ -> True - _ -> False + _ -> False -analyseFamilyInstance :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () +analyseFamilyInstance :: (Alternative m, MonadState Analysis m) => HieAST a -> m () analyseFamilyInstance n = do guard $ annsContain n ("TyFamInstD", "InstDecl") - for_ ( uses n ) addImplicitRoot + for_ (uses n) addImplicitRoot -analyseTypeSignature :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () +analyseTypeSignature :: (Alternative m, MonadState Analysis m) => HieAST a -> m () analyseTypeSignature n = do guard $ annsContain n ("TypeSig", "Sig") for_ (findIdentifiers isTypeSigDecl n) $ - for_ ( uses n ) . addDependency - + for_ (uses n) . addDependency where - isTypeSigDecl = any \case TyDecl -> True - _ -> False + _ -> False -analysePatternSynonyms :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m () +analysePatternSynonyms :: (Alternative m, MonadState Analysis m) => HieAST a -> m () analysePatternSynonyms n = do guard $ annsContain n ("PatSynBind", "HsBindLR") - for_ ( findDeclarations n ) $ for_ ( uses n ) . addDependency + for_ (findDeclarations n) $ for_ (uses n) . addDependency findEvInstBinds :: HieAST a -> Seq (Declaration, Set Name, IdentifierDetails a, HieAST a) -findEvInstBinds n = (\(d, ids, ast) -> (d, getClassNames ids, ids, ast)) <$> - findIdentifiers' - ( not - . Set.null - . getEvVarSources - ) n - +findEvInstBinds n = + (\(d, ids, ast) -> (d, getClassNames ids, ids, ast)) + <$> findIdentifiers' + ( not + . Set.null + . getEvVarSources + ) + n where - getEvVarSources :: Set ContextInfo -> Set EvVarSource - getEvVarSources = foldMap (maybe mempty Set.singleton) . - Set.map \case - EvidenceVarBind a@EvInstBind{} ModuleScope _ -> Just a - _ -> Nothing + getEvVarSources = + foldMap (maybe mempty Set.singleton) + . Set.map \case + EvidenceVarBind a@EvInstBind{} ModuleScope _ -> Just a + _ -> Nothing getClassNames :: IdentifierDetails a -> Set Name getClassNames = Set.map cls - . getEvVarSources - . identInfo + . getEvVarSources + . identInfo findDeclarations :: HieAST a -> Seq Declaration findDeclarations = findIdentifiers - ( not - . Set.null - . Set.filter \case + ( not + . Set.null + . Set.filter \case -- Things that count as declarations ValBind RegularBind ModuleScope _ -> True - PatternBind ModuleScope _ _ -> True - Decl _ _ -> True - TyDecl -> True - ClassTyDecl{} -> True - + PatternBind ModuleScope _ _ -> True + Decl _ _ -> True + TyDecl -> True + ClassTyDecl{} -> True -- Anything else is not a declaration _ -> False ) -findIdentifiers - :: ( Set ContextInfo -> Bool ) - -> HieAST a - -> Seq Declaration +findIdentifiers :: + (Set ContextInfo -> Bool) -> + HieAST a -> + Seq Declaration findIdentifiers f = fmap (\(d, _, _) -> d) . findIdentifiers' f --- | Version of findIdentifiers containing more information, --- namely the IdentifierDetails of the declaration and the --- node it was found in. -findIdentifiers' - :: ( Set ContextInfo -> Bool ) - -> HieAST a - -> Seq (Declaration, IdentifierDetails a, HieAST a) -findIdentifiers' f n@Node{ sourcedNodeInfo, nodeChildren } = - foldMap - (\case - ( Left _, _ ) -> - mempty - - ( Right name, ids@IdentifierDetails{ identInfo } ) -> - if f identInfo then - (, ids, n) <$> foldMap pure (nameToDeclaration name) - - else - mempty - ) - (foldMap (Map.toList . nodeIdentifiers) (getSourcedNodeInfo sourcedNodeInfo)) - <> foldMap ( findIdentifiers' f ) nodeChildren +{- | Version of findIdentifiers containing more information, +namely the IdentifierDetails of the declaration and the +node it was found in. +-} +findIdentifiers' :: + (Set ContextInfo -> Bool) -> + HieAST a -> + Seq (Declaration, IdentifierDetails a, HieAST a) +findIdentifiers' f n@Node{sourcedNodeInfo, nodeChildren} = + foldMap + ( \case + (Left _, _) -> + mempty + (Right name, ids@IdentifierDetails{identInfo}) -> + if f identInfo + then (,ids,n) <$> foldMap pure (nameToDeclaration name) + else mempty + ) + (foldMap (Map.toList . nodeIdentifiers) (getSourcedNodeInfo sourcedNodeInfo)) + <> foldMap (findIdentifiers' f) nodeChildren uses :: HieAST a -> Set Declaration uses = - foldMap Set.singleton - . findIdentifiers (any isUse) + foldMap Set.singleton + . findIdentifiers (any isUse) + isUse :: ContextInfo -> Bool isUse = \case @@ -690,7 +664,7 @@ isUse = \case nameToDeclaration :: Name -> Maybe Declaration nameToDeclaration name = do m <- nameModule_maybe name - return Declaration { declModule = m, declOccName = nameOccName name } + return Declaration{declModule = m, declOccName = nameOccName name} unNodeAnnotation :: NodeAnnotation -> (String, String) @@ -698,42 +672,44 @@ unNodeAnnotation (NodeAnnotation x y) = (unpackFS x, unpackFS y) -- | Add evidence uses found under the given node to 'requestedEvidence'. -requestEvidence :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST a -> Declaration -> m () +requestEvidence :: (MonadState Analysis m, MonadReader AnalysisInfo m) => HieAST a -> Declaration -> m () requestEvidence n d = do - Config{ typeClassRoots } <- asks weederConfig + Config{typeClassRoots} <- asks weederConfig -- If type-class-roots flag is set then we don't need to follow -- evidence uses as the binding sites will be roots anyway unless typeClassRoots $ #requestedEvidence %= Map.insertWith (<>) d (Set.fromList names) - where - names = concat . Tree.flatten $ evidenceUseTree n evidenceUseTree :: HieAST a -> Tree [Name] - evidenceUseTree Node{ sourcedNodeInfo, nodeChildren } = Tree.Node - { Tree.rootLabel = concatMap (findEvidenceUse . nodeIdentifiers) (getSourcedNodeInfo sourcedNodeInfo) - , Tree.subForest = map evidenceUseTree nodeChildren - } + evidenceUseTree Node{sourcedNodeInfo, nodeChildren} = + Tree.Node + { Tree.rootLabel = concatMap (findEvidenceUse . nodeIdentifiers) (getSourcedNodeInfo sourcedNodeInfo) + , Tree.subForest = map evidenceUseTree nodeChildren + } --- | Follow the given evidence uses back to their instance bindings, --- and connect the declaration to those bindings. +{- | Follow the given evidence uses back to their instance bindings, +and connect the declaration to those bindings. +-} followEvidenceUses :: RefMap TypeIndex -> Declaration -> Set Name -> Graph Declaration followEvidenceUses refMap d names = let getEvidenceTrees = mapMaybe (getEvidenceTree refMap) . Set.toList evidenceInfos = concatMap Tree.flatten (getEvidenceTrees names) - instanceEvidenceInfos = evidenceInfos & filter \case - EvidenceInfo _ _ _ (Just (EvInstBind _ _, ModuleScope, _)) -> True - _ -> False + instanceEvidenceInfos = + evidenceInfos & filter \case + EvidenceInfo _ _ _ (Just (EvInstBind _ _, ModuleScope, _)) -> True + _ -> False evBindSiteDecls = mapMaybe (nameToDeclaration . evidenceVar) instanceEvidenceInfos in star d evBindSiteDecls --- | Follow evidence uses listed under 'requestedEvidence' back to their --- instance bindings, and connect their corresponding declaration to those bindings. +{- | Follow evidence uses listed under 'requestedEvidence' back to their +instance bindings, and connect their corresponding declaration to those bindings. +-} analyseEvidenceUses :: RefMap TypeIndex -> Analysis -> Analysis -analyseEvidenceUses rf a@Analysis{ requestedEvidence, dependencyGraph } = +analyseEvidenceUses rf a@Analysis{requestedEvidence, dependencyGraph} = let graphs = map (uncurry (followEvidenceUses rf)) $ Map.toList requestedEvidence - in a { dependencyGraph = overlays (dependencyGraph : graphs) } + in a{dependencyGraph = overlays (dependencyGraph : graphs)} diff --git a/src/Weeder/Config.hs b/src/Weeder/Config.hs index 22a8b68..ad160ad 100644 --- a/src/Weeder/Config.hs +++ b/src/Weeder/Config.hs @@ -1,46 +1,47 @@ -{-# language ApplicativeDo #-} -{-# language BlockArguments #-} -{-# language OverloadedStrings #-} -{-# language RecordWildCards #-} -{-# language LambdaCase #-} -{-# language PatternSynonyms #-} -{-# language FlexibleInstances #-} -{-# language DeriveTraversable #-} -{-# language NamedFieldPuns #-} - -module Weeder.Config - ( -- * Config - Config - , ConfigParsed - , ConfigType(..) - , compileConfig - , configToToml - , decodeNoDefaults - , defaultConfig - -- * Marking instances as roots - , InstancePattern - , modulePattern - , instancePattern - , classPattern - , pattern InstanceOnly - , pattern ClassOnly - , pattern ModuleOnly - ) - where +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +module Weeder.Config ( + -- * Config + Config, + ConfigParsed, + ConfigType (..), + compileConfig, + configToToml, + decodeNoDefaults, + defaultConfig, + + -- * Marking instances as roots + InstancePattern, + modulePattern, + instancePattern, + classPattern, + pattern InstanceOnly, + pattern ClassOnly, + pattern ModuleOnly, +) +where -- base -import Control.Applicative ((<|>), empty) +import Control.Applicative (empty, (<|>)) import Data.Bifunctor (bimap) import Data.Char (toLower) -import Data.List (intersperse, intercalate) +import Data.List (intercalate, intersperse) -- containers import Data.Containers.ListUtils (nubOrd) -- regex-tdfa -import Text.Regex.TDFA ( Regex, RegexOptions ( defaultExecOpt, defaultCompOpt ) ) -import Text.Regex.TDFA.TDFA ( patternToRegex ) -import Text.Regex.TDFA.ReadRegex ( parseRegex ) +import Text.Regex.TDFA (Regex, RegexOptions (defaultCompOpt, defaultExecOpt)) +import Text.Regex.TDFA.ReadRegex (parseRegex) +import Text.Regex.TDFA.TDFA (patternToRegex) -- toml-reader import qualified TOML @@ -50,37 +51,41 @@ import qualified TOML type Config = ConfigType Regex --- | Configuration that has been parsed from TOML (and can still be --- converted back), but not yet compiled to a 'Config'. +{- | Configuration that has been parsed from TOML (and can still be +converted back), but not yet compiled to a 'Config'. +-} type ConfigParsed = ConfigType String -- | Underlying type for 'Config' and 'ConfigParsed'. data ConfigType a = Config { rootPatterns :: [a] - -- ^ Any declarations matching these regular expressions will be added to - -- the root set. + -- ^ Any declarations matching these regular expressions will be added to + -- the root set. , typeClassRoots :: Bool - -- ^ If True, consider all declarations in a type class as part of the root - -- set. Overrides root-instances. + -- ^ If True, consider all declarations in a type class as part of the root + -- set. Overrides root-instances. , rootInstances :: [InstancePattern a] - -- ^ All matching instances will be added to the root set. An absent field - -- will always match. + -- ^ All matching instances will be added to the root set. An absent field + -- will always match. , unusedTypes :: Bool - -- ^ Toggle to look for and output unused types. Type family instances will - -- be marked as implicit roots. - } deriving (Eq, Show) + -- ^ Toggle to look for and output unused types. Type family instances will + -- be marked as implicit roots. + } + deriving (Eq, Show) --- | Construct via InstanceOnly, ClassOnly or ModuleOnly, --- and combine with the Semigroup instance. The Semigroup --- instance ignores duplicate fields, prioritising the --- left argument. +{- | Construct via InstanceOnly, ClassOnly or ModuleOnly, +and combine with the Semigroup instance. The Semigroup +instance ignores duplicate fields, prioritising the +left argument. +-} data InstancePattern a = InstancePattern { instancePattern :: Maybe a , classPattern :: Maybe a , modulePattern :: Maybe a - } deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + } + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) instance Semigroup (InstancePattern a) where @@ -95,12 +100,13 @@ pattern ModuleOnly m = InstancePattern Nothing Nothing (Just m) defaultConfig :: ConfigParsed -defaultConfig = Config - { rootPatterns = [ "Main.main", "^Paths_.*"] - , typeClassRoots = False - , rootInstances = [ ClassOnly "\\.IsString$", ClassOnly "\\.IsList$" ] - , unusedTypes = False - } +defaultConfig = + Config + { rootPatterns = ["Main.main", "^Paths_.*"] + , typeClassRoots = False + , rootInstances = [ClassOnly "\\.IsString$", ClassOnly "\\.IsList$"] + , unusedTypes = False + } instance TOML.DecodeTOML Config where @@ -113,7 +119,7 @@ instance TOML.DecodeTOML ConfigParsed where tomlDecoder = do rootPatterns <- TOML.getFieldOr (rootPatterns defaultConfig) "roots" typeClassRoots <- TOML.getFieldOr (typeClassRoots defaultConfig) "type-class-roots" - rootInstances <- TOML.getFieldOr (rootInstances defaultConfig) "root-instances" + rootInstances <- TOML.getFieldOr (rootInstances defaultConfig) "root-instances" unusedTypes <- TOML.getFieldOr (unusedTypes defaultConfig) "unused-types" pure Config{..} @@ -133,22 +139,21 @@ instance TOML.DecodeTOML (InstancePattern String) where tomlDecoder = decodeInstancePattern --- | Decoder for a value of any of the forms: --- --- @{instance = t, class = c, module = m} -> InstanceClassAndModule t c m@ --- --- @a -> InstanceOnly a@ --- --- @{instance = t} -> InstanceOnly t@ --- --- @{class = m} -> ClassOnly c@ --- --- etc. +{- | Decoder for a value of any of the forms: + +@{instance = t, class = c, module = m} -> InstanceClassAndModule t c m@ + +@a -> InstanceOnly a@ + +@{instance = t} -> InstanceOnly t@ + +@{class = m} -> ClassOnly c@ + +etc. +-} decodeInstancePattern :: TOML.Decoder (InstancePattern String) decodeInstancePattern = decodeTable <|> decodeStringLiteral <|> decodeInstanceError - where - decodeStringLiteral = InstanceOnly <$> TOML.tomlDecoder decodeTable = do @@ -157,16 +162,18 @@ decodeInstancePattern = decodeTable <|> decodeStringLiteral <|> decodeInstanceEr m <- fmap ModuleOnly <$> TOML.getFieldOpt "module" maybe empty pure (t <> c <> m) - decodeInstanceError = TOML.makeDecoder $ - TOML.invalidValue "Need to specify at least one of 'instance', 'class', or 'module'" + decodeInstanceError = + TOML.makeDecoder $ + TOML.invalidValue "Need to specify at least one of 'instance', 'class', or 'module'" -showInstancePattern :: Show a => InstancePattern a -> String +showInstancePattern :: (Show a) => InstancePattern a -> String showInstancePattern = \case InstanceOnly a -> show a p -> "{ " ++ table ++ " }" where - table = intercalate ", " . filter (not . null) $ + table = + intercalate ", " . filter (not . null) $ [ maybe mempty typeField (instancePattern p) , maybe mempty classField (classPattern p) , maybe mempty moduleField (modulePattern p) @@ -181,19 +188,19 @@ compileRegex = bimap show (\p -> patternToRegex p defaultCompOpt defaultExecOpt) compileConfig :: ConfigParsed -> Either String Config -compileConfig conf@Config{ rootInstances, rootPatterns } = do +compileConfig conf@Config{rootInstances, rootPatterns} = do rootInstances' <- traverse (traverse compileRegex) . nubOrd $ rootInstances rootPatterns' <- traverse compileRegex $ nubOrd rootPatterns - pure conf{ rootInstances = rootInstances', rootPatterns = rootPatterns' } + pure conf{rootInstances = rootInstances', rootPatterns = rootPatterns'} configToToml :: ConfigParsed -> String -configToToml Config{..} - = unlines . intersperse mempty $ - [ "roots = " ++ show rootPatterns - , "type-class-roots = " ++ map toLower (show typeClassRoots) - , "root-instances = " ++ "[" ++ intercalate "," (map showInstancePattern rootInstances') ++ "]" - , "unused-types = " ++ map toLower (show unusedTypes) - ] +configToToml Config{..} = + unlines . intersperse mempty $ + [ "roots = " ++ show rootPatterns + , "type-class-roots = " ++ map toLower (show typeClassRoots) + , "root-instances = " ++ "[" ++ intercalate "," (map showInstancePattern rootInstances') ++ "]" + , "unused-types = " ++ map toLower (show unusedTypes) + ] where rootInstances' = rootInstances diff --git a/src/Weeder/Main.hs b/src/Weeder/Main.hs index 5521cd6..34c86d8 100644 --- a/src/Weeder/Main.hs +++ b/src/Weeder/Main.hs @@ -1,42 +1,38 @@ -{-# language ApplicativeDo #-} -{-# language BlockArguments #-} -{-# language FlexibleContexts #-} -{-# language NamedFieldPuns #-} -{-# language OverloadedStrings #-} -{-# language LambdaCase #-} -{-# language RecordWildCards #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | This module provides an entry point to the Weeder executable. - -module Weeder.Main ( main, mainWithConfig, getHieFiles ) where +module Weeder.Main (main, mainWithConfig, getHieFiles) where -- async -import Control.Concurrent.Async ( async, link, ExceptionInLinkedThread ( ExceptionInLinkedThread ) ) +import Control.Concurrent.Async (ExceptionInLinkedThread (ExceptionInLinkedThread), async, link) -- base -import Control.Exception ( Exception, throwIO, displayException, catches, Handler ( Handler ), SomeException ( SomeException ) ) -import Control.Concurrent ( getChanContents, newChan, writeChan, setNumCapabilities ) -import Control.Monad ( unless, when ) +import Control.Concurrent (getChanContents, newChan, setNumCapabilities, writeChan) +import Control.Exception (Exception, Handler (Handler), SomeException (SomeException), catches, displayException, throwIO) +import Control.Monad (unless, when) import Data.Foldable -import Data.List ( isSuffixOf ) -import Data.Maybe ( isJust, catMaybes ) -import Data.Version ( showVersion ) -import System.Exit ( ExitCode(..), exitWith ) -import System.IO ( stderr, hPutStrLn ) - --- toml-reader -import qualified TOML +import Data.List (isSuffixOf) +import Data.Maybe (catMaybes, isJust) +import Data.Version (showVersion) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hPutStrLn, stderr) -- directory -import System.Directory ( canonicalizePath, doesDirectoryExist, doesFileExist, doesPathExist, listDirectory, withCurrentDirectory ) +import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, doesPathExist, listDirectory, withCurrentDirectory) -- filepath -import System.FilePath ( isExtensionOf ) +import System.FilePath (isExtensionOf) -- ghc -import GHC.Iface.Ext.Binary ( HieFileResult( HieFileResult, hie_file_result ), readHieFileWithVersion ) -import GHC.Iface.Ext.Types ( HieFile( hie_hs_file ), hieVersion ) -import GHC.Types.Name.Cache ( initNameCache, NameCache ) +import GHC.Iface.Ext.Binary (HieFileResult (HieFileResult, hie_file_result), readHieFileWithVersion) +import GHC.Iface.Ext.Types (HieFile (hie_hs_file), hieVersion) +import GHC.Types.Name.Cache (NameCache, initNameCache) -- optparse-applicative import Options.Applicative @@ -44,22 +40,28 @@ import Options.Applicative -- text import qualified Data.Text.IO as T +-- toml-reader +import qualified TOML + -- weeder -import Weeder.Run -import Weeder.Config import Paths_weeder (version) +import Weeder.Config +import Weeder.Run -- | Each exception corresponds to an exit code. -data WeederException +data WeederException = ExitNoHieFilesFailure - | ExitHieVersionFailure - FilePath -- ^ Path to HIE file - Integer -- ^ HIE file's header version - | ExitConfigFailure - String -- ^ Error message + | ExitHieVersionFailure + FilePath + -- ^ Path to HIE file + Integer + -- ^ HIE file's header version + | -- | Error message + ExitConfigFailure + String | ExitWeedsFound - deriving Show + deriving (Show) weederExitCode :: WeederException -> ExitCode @@ -77,33 +79,35 @@ instance Exception WeederException where ExitConfigFailure s -> s ExitWeedsFound -> mempty where - - noHieFilesFoundMessage = + noHieFilesFoundMessage = "No HIE files found: check that the directory is correct " - <> "and that the -fwrite-ide-info compilation flag is set." - - hieVersionMismatchMessage path v = unlines - [ "incompatible hie file: " <> path - , " this version of weeder was compiled with GHC version " - <> show hieVersion - , " the hie files in this project were generated with GHC version " - <> show v - , " weeder must be built with the same GHC version" - <> " as the project it is used on" - ] - - --- | Convert 'WeederException' to the corresponding 'ExitCode' and emit an error --- message to stderr. --- --- Additionally, unwrap 'ExceptionInLinkedThread' exceptions: this is for --- 'getHieFiles'. + <> "and that the -fwrite-ide-info compilation flag is set." + + hieVersionMismatchMessage path v = + unlines + [ "incompatible hie file: " <> path + , " this version of weeder was compiled with GHC version " + <> show hieVersion + , " the hie files in this project were generated with GHC version " + <> show v + , " weeder must be built with the same GHC version" + <> " as the project it is used on" + ] + + +{- | Convert 'WeederException' to the corresponding 'ExitCode' and emit an error +message to stderr. + +Additionally, unwrap 'ExceptionInLinkedThread' exceptions: this is for +'getHieFiles'. +-} handleWeederException :: IO a -> IO a -handleWeederException a = catches a handlers +handleWeederException a = catches a handlers where - handlers = [ Handler rethrowExits - , Handler unwrapLinks - ] + handlers = + [ Handler rethrowExits + , Handler unwrapLinks + ] rethrowExits w = do hPutStrLn stderr (displayException w) exitWith (weederExitCode w) @@ -124,53 +128,66 @@ data CLIArguments = CLIArguments parseCLIArguments :: Parser CLIArguments parseCLIArguments = do - configPath <- strOption - ( long "config" - <> help "A file path for Weeder's configuration." - <> value "./weeder.toml" - <> metavar "" - ) - hieExt <- strOption - ( long "hie-extension" - <> value ".hie" - <> help "Extension of HIE files" - <> showDefault - ) - hieDirectories <- many ( - strOption - ( long "hie-directory" - <> help "A directory to look for .hie files in. Maybe specified multiple times. Default ./." - ) - ) - requireHsFiles <- switch - ( long "require-hs-files" - <> help "Skip stale .hie files with no matching .hs modules" - ) - writeDefaultConfig <- switch - ( long "write-default-config" - <> help "Write a default configuration file if the one specified by --config does not exist" + configPath <- + strOption + ( long "config" + <> help "A file path for Weeder's configuration." + <> value "./weeder.toml" + <> metavar "" + ) + hieExt <- + strOption + ( long "hie-extension" + <> value ".hie" + <> help "Extension of HIE files" + <> showDefault + ) + hieDirectories <- + many + ( strOption + ( long "hie-directory" + <> help "A directory to look for .hie files in. Maybe specified multiple times. Default ./." ) - noDefaultFields <- switch - ( long "no-default-fields" - <> help "Do not use default field values for missing fields in the configuration." - ) - capabilities <- nParser <|> jParser - pure CLIArguments{..} - where - jParser = Just <$> option auto + ) + requireHsFiles <- + switch + ( long "require-hs-files" + <> help "Skip stale .hie files with no matching .hs modules" + ) + writeDefaultConfig <- + switch + ( long "write-default-config" + <> help "Write a default configuration file if the one specified by --config does not exist" + ) + noDefaultFields <- + switch + ( long "no-default-fields" + <> help "Do not use default field values for missing fields in the configuration." + ) + capabilities <- nParser <|> jParser + pure CLIArguments{..} + where + jParser = + Just + <$> option + auto ( short 'j' <> value 1 <> help "Number of cores to use." - <> showDefault) - nParser = flag' Nothing - ( short 'N' - <> help "Use all available cores." + <> showDefault ) + nParser = + flag' + Nothing + ( short 'N' + <> help "Use all available cores." + ) --- | Parse command line arguments and into a 'Config' and run 'mainWithConfig'. --- --- Exits with one of the listed Weeder exit codes on failure. +{- | Parse command line arguments and into a 'Config' and run 'mainWithConfig'. + +Exits with one of the listed Weeder exit codes on failure. +-} main :: IO () main = handleWeederException do CLIArguments{..} <- @@ -198,19 +215,23 @@ main = handleWeederException do then fmap (TOML.decodeWith decodeNoDefaults) . T.readFile else TOML.decodeFile - versionP = infoOption ( "weeder version " - <> showVersion version - <> "\nhie version " - <> show hieVersion ) - ( long "version" <> help "Show version" ) + versionP = + infoOption + ( "weeder version " + <> showVersion version + <> "\nhie version " + <> show hieVersion + ) + (long "version" <> help "Show version") + + +{- | Run Weeder in the current working directory with a given 'Config'. +This will recursively find all files with the given extension in the given directories, perform +analysis, and report all unused definitions according to the 'Config'. --- | Run Weeder in the current working directory with a given 'Config'. --- --- This will recursively find all files with the given extension in the given directories, perform --- analysis, and report all unused definitions according to the 'Config'. --- --- Exits with one of the listed Weeder exit codes on failure. +Exits with one of the listed Weeder exit codes on failure. +-} mainWithConfig :: String -> [FilePath] -> Bool -> Config -> IO () mainWithConfig hieExt hieDirectories requireHsFiles weederConfig = handleWeederException do hieFiles <- @@ -227,19 +248,21 @@ mainWithConfig hieExt hieDirectories requireHsFiles weederConfig = handleWeederE unless (null weeds) $ throwIO ExitWeedsFound --- | Find and read all .hie files in the given directories according to the given parameters, --- exiting if any are incompatible with the current version of GHC. --- The .hie files are returned as a lazy stream in the form of a list. --- --- Will rethrow exceptions as 'ExceptionInLinkedThread' to the calling thread. +{- | Find and read all .hie files in the given directories according to the given parameters, +exiting if any are incompatible with the current version of GHC. +The .hie files are returned as a lazy stream in the form of a list. + +Will rethrow exceptions as 'ExceptionInLinkedThread' to the calling thread. +-} getHieFiles :: String -> [FilePath] -> Bool -> IO [HieFile] getHieFiles hieExt hieDirectories requireHsFiles = do hieFilePaths <- - concat <$> - traverse ( getFilesIn hieExt ) + concat + <$> traverse + (getFilesIn hieExt) ( if null hieDirectories - then ["./."] - else hieDirectories + then ["./."] + else hieDirectories ) hsFilePaths <- @@ -255,29 +278,27 @@ getHieFiles hieExt hieDirectories requireHsFiles = do a <- async $ handleWeederException do readHieFiles nameCache hieFilePaths hieFileResultsChan hsFilePaths writeChan hieFileResultsChan Nothing - + link a catMaybes . takeWhile isJust <$> getChanContents hieFileResultsChan - where - readHieFiles nameCache hieFilePaths hieFileResultsChan hsFilePaths = for_ hieFilePaths \hieFilePath -> do hieFileResult <- readCompatibleHieFileOrExit nameCache hieFilePath - let hsFileExists = any ( hie_hs_file hieFileResult `isSuffixOf` ) hsFilePaths + let hsFileExists = any (hie_hs_file hieFileResult `isSuffixOf`) hsFilePaths when (requireHsFiles ==> hsFileExists) $ writeChan hieFileResultsChan (Just hieFileResult) -- | Recursively search for files with the given extension in given directory -getFilesIn - :: String - -- ^ Only files with this extension are considered - -> FilePath - -- ^ Directory to look in - -> IO [FilePath] +getFilesIn :: + -- | Only files with this extension are considered + String -> + -- | Directory to look in + FilePath -> + IO [FilePath] getFilesIn ext path = do exists <- doesPathExist path @@ -292,8 +313,7 @@ getFilesIn ext path = do path' <- canonicalizePath path - return [ path' ] - + return [path'] else do isDir <- doesDirectoryExist path @@ -303,13 +323,9 @@ getFilesIn ext path = do cnts <- listDirectory path - withCurrentDirectory path ( foldMap ( getFilesIn ext ) cnts ) - - else - return [] - - else - return [] + withCurrentDirectory path (foldMap (getFilesIn ext) cnts) + else return [] + else return [] -- | Read a .hie file, exiting if it's an incompatible version. @@ -317,9 +333,9 @@ readCompatibleHieFileOrExit :: NameCache -> FilePath -> IO HieFile readCompatibleHieFileOrExit nameCache path = do res <- readHieFileWithVersion (\(v, _) -> v == hieVersion) nameCache path case res of - Right HieFileResult{ hie_file_result } -> + Right HieFileResult{hie_file_result} -> return hie_file_result - Left ( v, _ghcVersion ) -> + Left (v, _ghcVersion) -> throwIO $ ExitHieVersionFailure path v @@ -328,5 +344,5 @@ infixr 5 ==> -- | An infix operator for logical implication (==>) :: Bool -> Bool -> Bool -True ==> x = x +True ==> x = x False ==> _ = True diff --git a/src/Weeder/Run.hs b/src/Weeder/Run.hs index c4bf594..8620727 100644 --- a/src/Weeder/Run.hs +++ b/src/Weeder/Run.hs @@ -1,43 +1,43 @@ -{-# language RecordWildCards #-} -{-# language BlockArguments #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} -module Weeder.Run ( runWeeder, Weed(..), formatWeed ) where +module Weeder.Run (runWeeder, Weed (..), formatWeed) where -- base -import Control.Applicative ( liftA2 ) -import Control.Monad ( guard ) -import Data.List ( sortOn ) -import Data.Foldable ( fold, foldl' ) -import Data.Function ( (&) ) +import Control.Applicative (liftA2) +import Control.Monad (guard) +import Data.Foldable (fold, foldl') +import Data.Function ((&)) +import Data.List (sortOn) -- containers -import Data.Set ( Set ) -import qualified Data.Set as Set import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set -- ghc -import GHC.Plugins - ( occNameString - , unitString - , moduleUnit - , moduleName - , moduleNameString - ) -import GHC.Iface.Ext.Types ( HieFile( hie_asts ), getAsts ) +import GHC.Iface.Ext.Types (HieFile (hie_asts), getAsts) import GHC.Iface.Ext.Utils (generateReferencesMap) +import GHC.Plugins ( + moduleName, + moduleNameString, + moduleUnit, + occNameString, + unitString, + ) + +-- mtl +import Control.Monad.State.Strict (execState) -- parallel import Control.Parallel (pseq) import Control.Parallel.Strategies (parMap, rdeepseq) -- regex-tdfa -import Text.Regex.TDFA ( matchTest ) - --- transformers -import Control.Monad.State.Strict ( execState ) +import Text.Regex.TDFA (matchTest) -- weeder import Weeder @@ -56,18 +56,27 @@ data Weed = Weed formatWeed :: Weed -> String formatWeed Weed{..} = - weedPackage <> ": " <> weedPath <> ":" <> show weedLine <> ":" <> show weedCol <> ": " + weedPackage + <> ": " + <> weedPath + <> ":" + <> show weedLine + <> ":" + <> show weedCol + <> ": " <> case weedPrettyPrintedType of - Nothing -> occNameString ( declOccName weedDeclaration ) + Nothing -> occNameString (declOccName weedDeclaration) Just t -> "(Instance) :: " <> t --- | Run Weeder on the given .hie files with the given 'Config'. --- --- Returns a list of 'Weed's that can be displayed using --- 'formatWeed', and the final 'Analysis'. + +{- | Run Weeder on the given .hie files with the given 'Config'. + +Returns a list of 'Weed's that can be displayed using +'formatWeed', and the final 'Analysis'. +-} runWeeder :: Config -> [HieFile] -> ([Weed], Analysis) -runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances } hieFiles = - let +runWeeder weederConfig@Config{rootPatterns, typeClassRoots, rootInstances} hieFiles = + let asts = concatMap (Map.elems . getAsts . hie_asts) hieFiles rf = generateReferencesMap asts @@ -75,18 +84,19 @@ runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances } hie analyses = parMap rdeepseq (\hf -> execState (analyseHieFile weederConfig hf) emptyAnalysis) hieFiles - analyseEvidenceUses' = + analyseEvidenceUses' = if typeClassRoots then id else analyseEvidenceUses rf - analysis1 = + analysis1 = foldl' mappend mempty analyses - -- Evaluating 'analysis1' first allows us to begin analysis + -- Evaluating 'analysis1' first allows us to begin analysis -- while hieFiles is still being read (since rf depends on all hie files) - analysis = analysis1 `pseq` - analyseEvidenceUses' analysis1 + analysis = + analysis1 `pseq` + analyseEvidenceUses' analysis1 -- We limit ourselves to outputable declarations only rather than all -- declarations in the graph. This has a slight performance benefit, @@ -99,12 +109,12 @@ runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances } hie (`matchTest` displayDeclaration d) rootPatterns ) - ( outputableDeclarations analysis ) + (outputableDeclarations analysis) reachableSet = reachable analysis - ( Set.map DeclarationRoot roots <> filterImplicitRoots analysis ( implicitRoots analysis ) ) + (Set.map DeclarationRoot roots <> filterImplicitRoots analysis (implicitRoots analysis)) -- We only care about dead declarations if they have a span assigned, -- since they don't show up in the output otherwise @@ -113,55 +123,52 @@ runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances } hie warnings = Map.unionsWith (++) $ - foldMap - ( \d -> - fold $ do - moduleFilePath <- Map.lookup ( declModule d ) ( modulePaths analysis ) - let packageName = unitString . moduleUnit . declModule $ d - starts <- Map.lookup d ( declarationSites analysis ) - let locs = (,) packageName <$> Set.toList starts - guard $ not $ null starts - return [ Map.singleton moduleFilePath ( liftA2 (,) locs (pure d) ) ] - ) - dead + foldMap + ( \d -> + fold $ do + moduleFilePath <- Map.lookup (declModule d) (modulePaths analysis) + let packageName = unitString . moduleUnit . declModule $ d + starts <- Map.lookup d (declarationSites analysis) + let locs = (,) packageName <$> Set.toList starts + guard $ not $ null starts + return [Map.singleton moduleFilePath (liftA2 (,) locs (pure d))] + ) + dead weeds = - Map.toList warnings & concatMap \( weedPath, declarations ) -> - sortOn fst declarations & map \( (weedPackage, (weedLine, weedCol)) , weedDeclaration ) -> - Weed { weedPrettyPrintedType = Map.lookup weedDeclaration (prettyPrintedType analysis) - , weedPackage - , weedPath - , weedLine - , weedCol - , weedDeclaration - } - - in (weeds, analysis) - + Map.toList warnings & concatMap \(weedPath, declarations) -> + sortOn fst declarations & map \((weedPackage, (weedLine, weedCol)), weedDeclaration) -> + Weed + { weedPrettyPrintedType = Map.lookup weedDeclaration (prettyPrintedType analysis) + , weedPackage + , weedPath + , weedLine + , weedCol + , weedDeclaration + } + in + (weeds, analysis) where - filterImplicitRoots :: Analysis -> Set Root -> Set Root - filterImplicitRoots Analysis{ prettyPrintedType, modulePaths } = Set.filter $ \case + filterImplicitRoots Analysis{prettyPrintedType, modulePaths} = Set.filter $ \case DeclarationRoot _ -> True -- keep implicit roots for rewrite rules etc - ModuleRoot _ -> True - InstanceRoot d c -> typeClassRoots || matchingType where - matchingType = + matchingType = let mt = Map.lookup d prettyPrintedType matches = maybe (const False) (flip matchTest) mt - in any (maybe True matches) filteredInstances + in any (maybe True matches) filteredInstances - filteredInstances = - map instancePattern - . filter (maybe True (`matchTest` displayDeclaration c) . classPattern) - . filter (maybe True modulePathMatches . modulePattern) - $ rootInstances + filteredInstances = + map instancePattern + . filter (maybe True (`matchTest` displayDeclaration c) . classPattern) + . filter (maybe True modulePathMatches . modulePattern) + $ rootInstances - modulePathMatches p = maybe False (p `matchTest`) (Map.lookup ( declModule d ) modulePaths) + modulePathMatches p = maybe False (p `matchTest`) (Map.lookup (declModule d) modulePaths) displayDeclaration :: Declaration -> String -displayDeclaration d = - moduleNameString ( moduleName ( declModule d ) ) <> "." <> occNameString ( declOccName d ) +displayDeclaration d = + moduleNameString (moduleName (declModule d)) <> "." <> occNameString (declOccName d) diff --git a/test/Main.hs b/test/Main.hs index 17dca70..a10cc61 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,78 +1,109 @@ module Main (main) where -import qualified Weeder.Main -import qualified Weeder.Run -import qualified Weeder -import qualified TOML -import qualified UnitTests.Weeder.ConfigSpec +-- algebraic-graphs +import Algebra.Graph.Export.Dot +-- base +import Control.Exception (IOException, handle, throwIO) +import Control.Monad (when, zipWithM_) +import Data.List (find, sortOn) import Data.Maybe -import Algebra.Graph.Export.Dot -import GHC.Types.Name.Occurrence (occNameString) -import System.Directory +import Data.Maybe (isJust) import System.Environment (getArgs, withArgs) +import System.IO (hPrint, stderr) + +-- bytestring +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS + +-- directory +import System.Directory + +-- filepath import System.FilePath + +-- ghc +import GHC.Types.Name.Occurrence (occNameString) + +-- process import System.Process -import System.IO (stderr, hPrint) + +-- tasty import Test.Tasty (TestTree, defaultMain, testGroup) -import Control.Monad (zipWithM_, when) -import Control.Exception ( throwIO, IOException, handle ) -import Data.Maybe (isJust) -import Data.List (find, sortOn) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS + +-- tasty-golden +import Test.Tasty.Golden + +-- text import Data.Text (Text, pack) import Data.Text.Encoding (encodeUtf8) -import Test.Tasty.Golden + +-- toml-reader +import qualified TOML + +-- weeder +import qualified UnitTests.Weeder.ConfigSpec +import qualified Weeder +import qualified Weeder.Main +import qualified Weeder.Run + main :: IO () main = do testOutputFiles <- fmap sortTests discoverIntegrationTests let hieDirectories = map (dropExtension . snd) testOutputFiles - defaultMain $ - testGroup "Weeder" + defaultMain $ + testGroup + "Weeder" [ testGroup "Weeder.Run" $ [ testGroup "runWeeder" $ - zipWith (uncurry integrationTest) - testOutputFiles + zipWith + (uncurry integrationTest) + testOutputFiles hieDirectories ] - , UnitTests.Weeder.ConfigSpec.tests + , UnitTests.Weeder.ConfigSpec.tests ] where -- Sort the output files such that the failing ones go last sortTests = sortOn (isJust . fst) --- | Run weeder on @hieDirectory@, comparing the output to @stdoutFile@. --- --- The directory containing @hieDirectory@ must also have a @.toml@ file --- with the same name as @hieDirectory@. --- --- If @failingFile@ is @Just@, it is used as the expected output instead of --- @stdoutFile@, and a different failure message is printed if the output --- matches @stdoutFile@. + +{- | Run weeder on @hieDirectory@, comparing the output to @stdoutFile@. + +The directory containing @hieDirectory@ must also have a @.toml@ file +with the same name as @hieDirectory@. + +If @failingFile@ is @Just@, it is used as the expected output instead of +@stdoutFile@, and a different failure message is printed if the output +matches @stdoutFile@. +-} integrationTest :: Maybe FilePath -> FilePath -> FilePath -> TestTree integrationTest failingFile stdoutFile hieDirectory = do - goldenVsString (integrationTestText ++ hieDirectory) (fromMaybe stdoutFile failingFile) $ + goldenVsString (integrationTestText ++ hieDirectory) (fromMaybe stdoutFile failingFile) $ integrationTestOutput hieDirectory where integrationTestText = case failingFile of Nothing -> "produces the expected output for " Just _ -> "produces the expected (wrong) output for " + -- | Returns detected .failing and .stdout files in ./test/Spec discoverIntegrationTests :: IO [(Maybe FilePath, FilePath)] discoverIntegrationTests = do contents <- listDirectory testPath - let stdoutFiles = map (testPath ) $ - filter (".stdout" `isExtensionOf`) contents + let stdoutFiles = + map (testPath ) $ + filter (".stdout" `isExtensionOf`) contents pure . map (\s -> (findFailing s contents, s)) $ stdoutFiles - where - findFailing s = fmap (testPath ) . find (takeBaseName s <.> ".failing" ==) - testPath = "./test/Spec" + where + findFailing s = fmap (testPath ) . find (takeBaseName s <.> ".failing" ==) + testPath = "./test/Spec" + --- | Run weeder on the given directory for .hie files, returning stdout --- Also creates a dotfile containing the dependency graph as seen by Weeder +{- | Run weeder on the given directory for .hie files, returning stdout +Also creates a dotfile containing the dependency graph as seen by Weeder +-} integrationTestOutput :: FilePath -> IO LBS.ByteString integrationTestOutput hieDirectory = do hieFiles <- Weeder.Main.getHieFiles ".hie" [hieDirectory] True diff --git a/test/Spec/ApplicativeDo/ApplicativeDo.hs b/test/Spec/ApplicativeDo/ApplicativeDo.hs index dff9c63..6517a7b 100644 --- a/test/Spec/ApplicativeDo/ApplicativeDo.hs +++ b/test/Spec/ApplicativeDo/ApplicativeDo.hs @@ -1,15 +1,20 @@ {-# LANGUAGE ApplicativeDo #-} + module Spec.ApplicativeDo.ApplicativeDo where + newtype Foo a = Foo a + instance Functor Foo where fmap f (Foo a) = Foo (f a) + instance Applicative Foo where pure = Foo Foo f <*> Foo a = Foo (f a) + root :: Foo Int root = do a <- Foo 1 diff --git a/test/Spec/BasicExample/BasicExample.hs b/test/Spec/BasicExample/BasicExample.hs index f9461d8..0fa618a 100644 --- a/test/Spec/BasicExample/BasicExample.hs +++ b/test/Spec/BasicExample/BasicExample.hs @@ -1,10 +1,13 @@ module Spec.BasicExample.BasicExample where + unrelated :: Int unrelated = 3 + dependency :: Int dependency = 1 + root :: Int root = dependency + 1 diff --git a/test/Spec/ConfigInstanceModules/Module1.hs b/test/Spec/ConfigInstanceModules/Module1.hs index ff5a860..8aaf399 100644 --- a/test/Spec/ConfigInstanceModules/Module1.hs +++ b/test/Spec/ConfigInstanceModules/Module1.hs @@ -1,3 +1,4 @@ module Spec.ConfigInstanceModules.Module1 where + data T = MkT deriving (Show, Bounded, Enum, Read) diff --git a/test/Spec/ConfigInstanceModules/Module2.hs b/test/Spec/ConfigInstanceModules/Module2.hs index 6690e22..c1ca279 100644 --- a/test/Spec/ConfigInstanceModules/Module2.hs +++ b/test/Spec/ConfigInstanceModules/Module2.hs @@ -1,3 +1,4 @@ module Spec.ConfigInstanceModules.Module2 where + data T = MkT deriving (Show, Bounded, Enum, Read) diff --git a/test/Spec/ConfigInstanceModules/Module3.hs b/test/Spec/ConfigInstanceModules/Module3.hs index 05a9a99..8bd7b3a 100644 --- a/test/Spec/ConfigInstanceModules/Module3.hs +++ b/test/Spec/ConfigInstanceModules/Module3.hs @@ -1,3 +1,4 @@ module Spec.ConfigInstanceModules.Module3 where -data A = MkA deriving Bounded + +data A = MkA deriving (Bounded) diff --git a/test/Spec/DeriveGeneric/DeriveGeneric.hs b/test/Spec/DeriveGeneric/DeriveGeneric.hs index f27e228..58dc92a 100644 --- a/test/Spec/DeriveGeneric/DeriveGeneric.hs +++ b/test/Spec/DeriveGeneric/DeriveGeneric.hs @@ -1,15 +1,24 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} + module Spec.DeriveGeneric.DeriveGeneric where -import GHC.Generics +-- aeson import Data.Aeson +-- base +import GHC.Generics + + newtype T = MkT Bool -- Generic and ToJSON must not be detected as unused -- but FromJSON should be detected as unused - deriving ( Generic, ToJSON - , FromJSON ) + deriving + ( Generic + , ToJSON + , FromJSON + ) + t :: Value t = toJSON $ MkT True diff --git a/test/Spec/InstanceRootConstraint/InstanceRootConstraint.hs b/test/Spec/InstanceRootConstraint/InstanceRootConstraint.hs index 318263c..a205c64 100644 --- a/test/Spec/InstanceRootConstraint/InstanceRootConstraint.hs +++ b/test/Spec/InstanceRootConstraint/InstanceRootConstraint.hs @@ -1,13 +1,17 @@ module Spec.InstanceRootConstraint.InstanceRootConstraint where + class Foo a where foo :: a -> Char + instance Foo Char where foo = id -instance Foo a => Foo [a] where + +instance (Foo a) => Foo [a] where foo = const a + a :: Char a = foo 'a' diff --git a/test/Spec/InstanceTypeclass/InstanceTypeclass.hs b/test/Spec/InstanceTypeclass/InstanceTypeclass.hs index ce85c48..5a5731b 100644 --- a/test/Spec/InstanceTypeclass/InstanceTypeclass.hs +++ b/test/Spec/InstanceTypeclass/InstanceTypeclass.hs @@ -1,18 +1,22 @@ -- | Test for correct output of unreachable classes and instances module Spec.InstanceTypeclass.InstanceTypeclass where + class Foo a where foo :: a -> Char + -- this instance is not marked as root, -- therefore class Foo will show up in the output -- as well instance Foo Char where foo = id + class RootClass a where rootClass :: a -> Char + -- this instance is explicitly marked as root, -- hence RootClass will not show up in the output -- (note the way it is written in InstanceTypeclass.toml) diff --git a/test/Spec/Monads/Monads.hs b/test/Spec/Monads/Monads.hs index 9b08ea0..17ce875 100644 --- a/test/Spec/Monads/Monads.hs +++ b/test/Spec/Monads/Monads.hs @@ -1,37 +1,48 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-type-defaults #-} + module Spec.Monads.Monads where -newtype Identity a = Identity { runIdentity :: a } + +newtype Identity a = Identity {runIdentity :: a} + instance Functor Identity where fmap f (Identity x) = Identity (f x) + instance Applicative Identity where pure = Identity Identity f <*> Identity x = Identity (f x) + instance Monad Identity where return = pure Identity x >>= f = f x -newtype Identity' a = Identity' { runIdentity' :: a} + +newtype Identity' a = Identity' {runIdentity' :: a} + instance Functor Identity' where fmap f (Identity' x) = Identity' (f x) + instance Applicative Identity' where pure = Identity' Identity' f <*> Identity' x = Identity' (f x) + instance Monad Identity' where return = pure Identity' x >>= f = f x + foo = do _x <- Identity 3 Identity 4 + bar :: Identity' Integer -- oh no (the type signature breaks the evidence variables) bar = do _x <- Identity' 3 diff --git a/test/Spec/NumInstance/NumInstance.hs b/test/Spec/NumInstance/NumInstance.hs index c75cea4..24fc954 100644 --- a/test/Spec/NumInstance/NumInstance.hs +++ b/test/Spec/NumInstance/NumInstance.hs @@ -1,11 +1,16 @@ {-# OPTIONS_GHC -Wno-missing-methods #-} + module Spec.NumInstance.NumInstance where + data Modulo2 = Zero | One + instance Num Modulo2 where (+) = add - -- leave the rest undefined + + +-- leave the rest undefined -- add should not be detected as unused add :: Modulo2 -> Modulo2 -> Modulo2 @@ -13,5 +18,6 @@ add One One = Zero add Zero n = n add n Zero = n + two :: Modulo2 two = One + One diff --git a/test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs b/test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs index bacec18..71b0cda 100644 --- a/test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs +++ b/test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs @@ -1,12 +1,17 @@ {-# OPTIONS_GHC -Wno-missing-methods #-} + module Spec.NumInstanceLiteral.NumInstanceLiteral where + data Modulo1 = Zero + -- $fNumModulo1 should not be detected as unused instance Num Modulo1 where fromInteger _ = Zero - -- leave the rest undefined + + +-- leave the rest undefined zero :: Modulo1 zero = 0 -- no evidence usage here at all in the HieAST (9.4.4 and 9.6.1) diff --git a/test/Spec/OverloadedLabels/OverloadedLabels.hs b/test/Spec/OverloadedLabels/OverloadedLabels.hs index 04b5d3c..94d539f 100644 --- a/test/Spec/OverloadedLabels/OverloadedLabels.hs +++ b/test/Spec/OverloadedLabels/OverloadedLabels.hs @@ -1,24 +1,37 @@ -{-# LANGUAGE DataKinds, KindSignatures, - FunctionalDependencies, FlexibleInstances, - OverloadedLabels, ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Spec.OverloadedLabels.OverloadedLabels where -import GHC.OverloadedLabels (IsLabel(..)) + +-- base +import GHC.OverloadedLabels (IsLabel (..)) import GHC.TypeLits (Symbol) + data Label (l :: Symbol) = Get + class Has a l b | a l -> b where from :: a -> Label l -> b + data Point = Point Int Int -- odd behaviour with dependencies between Point and Int + instance Has Point "x" Int where from (Point x _) _ = x instance Has Point "y" Int where from (Point _ y) _ = y -instance Has a l b => IsLabel l (a -> b) where + +instance (Has a l b) => IsLabel l (a -> b) where fromLabel x = from x (Get :: Label l) + root :: Int -root = #x (Point 1 2) - -- surprisingly OverloadedLabels works perfectly out of the box +root = #x (Point 1 2) + +-- surprisingly OverloadedLabels works perfectly out of the box diff --git a/test/Spec/OverloadedLists/OverloadedLists.hs b/test/Spec/OverloadedLists/OverloadedLists.hs index 96509d2..a0094b3 100644 --- a/test/Spec/OverloadedLists/OverloadedLists.hs +++ b/test/Spec/OverloadedLists/OverloadedLists.hs @@ -1,16 +1,21 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeFamilies #-} + module Spec.OverloadedLists.OverloadedLists where -import GHC.IsList ( IsList(..) ) +-- base +import GHC.IsList (IsList (..)) + data BetterList x = Nil | Cons x (BetterList x) + instance IsList (BetterList x) where type Item (BetterList x) = x fromList = foldr Cons Nil toList Nil = [] toList (Cons x xs) = x : toList xs + root :: BetterList Int root = [1, 2, 3] diff --git a/test/Spec/OverloadedStrings/OverloadedStrings.hs b/test/Spec/OverloadedStrings/OverloadedStrings.hs index c99dba4..96d4e8f 100644 --- a/test/Spec/OverloadedStrings/OverloadedStrings.hs +++ b/test/Spec/OverloadedStrings/OverloadedStrings.hs @@ -1,22 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} + module Spec.OverloadedStrings.OverloadedStrings where -import Data.String ( IsString(fromString) ) +-- base +import Data.String (IsString (fromString)) + newtype BetterString = BetterString String + -- $fIsStringBetterString should not be detected as unused instance IsString BetterString where fromString = BetterString + newtype BetterString' = BetterString' String + instance IsString BetterString' where fromString = BetterString' + -- Thought: this problem might be similar to RebindableSyntax, QualifiedDo, etc root :: BetterString root = "Hello World" -- no evidence variable usage here + root' = "Hello World" :: BetterString' -- evidence usage present diff --git a/test/Spec/RangeEnum/RangeEnum.hs b/test/Spec/RangeEnum/RangeEnum.hs index 837706b..91e55bc 100644 --- a/test/Spec/RangeEnum/RangeEnum.hs +++ b/test/Spec/RangeEnum/RangeEnum.hs @@ -1,26 +1,35 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} + module Spec.RangeEnum.RangeEnum where + data Planet = Mercury | Venus | Earth deriving (Enum, Bounded) + data Letter = A | B | C deriving (Enum, Bounded, Show) + data Shape = Circle | Square | Triangle deriving (Enum, Bounded) + data Colour = Red | Green | Blue deriving (Enum, Bounded) + planets = [minBound .. (maxBound :: Planet)] + letters = map f [minBound .. maxBound] where f :: Letter -> String f = show + shapes = [minBound .. maxBound] :: [Shape] + colours :: [Colour] colours = [minBound .. maxBound] :: [Colour] -- breaks diff --git a/test/Spec/RootClasses/RootClasses.hs b/test/Spec/RootClasses/RootClasses.hs index 18259e4..7818c00 100644 --- a/test/Spec/RootClasses/RootClasses.hs +++ b/test/Spec/RootClasses/RootClasses.hs @@ -1,15 +1,21 @@ --- | Test for marking classes as roots {-# LANGUAGE StandaloneDeriving #-} + +-- | Test for marking classes as roots module Spec.RootClasses.RootClasses where + data T = MkT deriving (Eq, Show, Enum) + deriving instance Ord T + data V = MkV + class Bar a where bar :: a -> Char + instance Bar V where bar = const 'b' diff --git a/test/Spec/StandaloneDeriving/StandaloneDeriving.hs b/test/Spec/StandaloneDeriving/StandaloneDeriving.hs index dce1b18..91f5980 100644 --- a/test/Spec/StandaloneDeriving/StandaloneDeriving.hs +++ b/test/Spec/StandaloneDeriving/StandaloneDeriving.hs @@ -1,13 +1,19 @@ {-# LANGUAGE StandaloneDeriving #-} + module Spec.StandaloneDeriving.StandaloneDeriving where + data A = A + deriving instance Show A + data T = T + deriving instance Show T + root :: String root = show T diff --git a/test/Spec/TypeAliasGADT/TypeAliasGADT.hs b/test/Spec/TypeAliasGADT/TypeAliasGADT.hs index f33a19a..79d8fce 100644 --- a/test/Spec/TypeAliasGADT/TypeAliasGADT.hs +++ b/test/Spec/TypeAliasGADT/TypeAliasGADT.hs @@ -2,12 +2,15 @@ module Spec.TypeAliasGADT.TypeAliasGADT where --- This is a false positive when the GADT language extension + +-- This is a false positive when the GADT language extension -- is enabled and we do not consider type signatures type Secret = String + data A = MkA String Int + root :: Secret -> Int -> Secret root secret a = let _params = MkA mempty a diff --git a/test/Spec/TypeDataDecl/TypeDataDecl.hs b/test/Spec/TypeDataDecl/TypeDataDecl.hs index bb1f6ad..3571a36 100644 --- a/test/Spec/TypeDataDecl/TypeDataDecl.hs +++ b/test/Spec/TypeDataDecl/TypeDataDecl.hs @@ -3,10 +3,13 @@ module Spec.TypeDataDecl.TypeDataDecl where + data Kind = MkKind + type Number = Int + data Root (l :: Kind) = MkRecord { recordField :: Number } diff --git a/test/Spec/TypeFamilies/TypeFamilies.hs b/test/Spec/TypeFamilies/TypeFamilies.hs index 00ea137..adcbd34 100644 --- a/test/Spec/TypeFamilies/TypeFamilies.hs +++ b/test/Spec/TypeFamilies/TypeFamilies.hs @@ -1,9 +1,13 @@ {-# LANGUAGE TypeFamilies #-} + -- | NOTE: the .stdout file for this test is a placeholder module Spec.TypeFamilies.TypeFamilies where + type family Family a + type instance Family Int = Bool + type instance Family Bool = Int diff --git a/test/Spec/TypeFamilies/TypeFamilyUsage.hs b/test/Spec/TypeFamilies/TypeFamilyUsage.hs index 596cbd8..fad9f42 100644 --- a/test/Spec/TypeFamilies/TypeFamilyUsage.hs +++ b/test/Spec/TypeFamilies/TypeFamilyUsage.hs @@ -1,6 +1,8 @@ module Spec.TypeFamilies.TypeFamilyUsage where +-- weeder import Spec.TypeFamilies.TypeFamilies + root :: Family Int root = True diff --git a/test/Spec/Types/Types.hs b/test/Spec/Types/Types.hs index fa28273..0453d3e 100644 --- a/test/Spec/Types/Types.hs +++ b/test/Spec/Types/Types.hs @@ -1,18 +1,23 @@ -{-# OPTIONS_GHC -Wno-missing-methods #-} {-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -Wno-missing-methods #-} module Spec.Types.Types where + -- this Bounded will not depend on Modulo1 as intended -data Modulo1 = Zero deriving Bounded +data Modulo1 = Zero deriving (Bounded) + -- should be reachable via Number data Modulo2 = Zero' | One' + type Number = Modulo2 + newtype Vector a = MkVector (a, a, a) deriving (Functor) + data Record = MkRecord { recordField1 :: Int , recordField2 :: Double diff --git a/test/Spec/Types/Usages.hs b/test/Spec/Types/Usages.hs index bee9f0a..471026e 100644 --- a/test/Spec/Types/Usages.hs +++ b/test/Spec/Types/Usages.hs @@ -1,22 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-unused-foralls #-} -{-# LANGUAGE ScopedTypeVariables #-} + module Spec.Types.Usages where +-- weeder import Spec.Types.Types + numberUsage :: forall a. Number -> Number numberUsage = id + -- should depend on Modulo1 modulo1Usage = minBound + -- exists to force type inference of modulo1Root to Modulo1 notRoot :: Modulo1 notRoot = modulo1Usage + recordUsage = recordField1 + vectorUsage = mapVector (const (0 :: Integer)) where mapVector :: (b -> c) -> Vector b -> Vector c diff --git a/test/Spec/TypesUnused/TypesUnused.hs b/test/Spec/TypesUnused/TypesUnused.hs index 7688b3f..3ecaa79 100644 --- a/test/Spec/TypesUnused/TypesUnused.hs +++ b/test/Spec/TypesUnused/TypesUnused.hs @@ -1,12 +1,18 @@ {-# LANGUAGE TypeFamilies #-} --- | Control version of Types that is not imported --- All these declarations should show up in the output + +{- | Control version of Types that is not imported +All these declarations should show up in the output +-} module Spec.TypesUnused.TypesUnused where + data Modulo1 = Zero + type Number = Double + newtype Vector = MkVector (Double, Double, Double) + type family Family a diff --git a/test/UnitTests/Weeder/ConfigSpec.hs b/test/UnitTests/Weeder/ConfigSpec.hs index adfdb43..e2d0f9f 100644 --- a/test/UnitTests/Weeder/ConfigSpec.hs +++ b/test/UnitTests/Weeder/ConfigSpec.hs @@ -1,24 +1,39 @@ module UnitTests.Weeder.ConfigSpec (tests) where -import Weeder.Config -import qualified TOML -import qualified Data.Text as T -import Test.Tasty.HUnit +-- hspec-expectations import Test.Hspec.Expectations (shouldBe) + +-- tasty import Test.Tasty (TestTree, testGroup) +-- tasty-hunit +import Test.Tasty.HUnit + +-- text +import qualified Data.Text as T + +-- toml-reader +import qualified TOML + +-- weeder +import Weeder.Config + + tests :: TestTree -tests = - testGroup "Weeder.Config" - [ testCase "configToToml" configToTomlTests ] +tests = + testGroup + "Weeder.Config" + [testCase "configToToml" configToTomlTests] + configToTomlTests :: Assertion configToTomlTests = - let cf = Config - { rootPatterns = mempty - , typeClassRoots = True - , rootInstances = [InstanceOnly "Quux\\\\[\\]", ClassOnly "[\\[\\\\[baz" <> ModuleOnly "[Quuux]", InstanceOnly "[\\[\\\\[baz" <> ClassOnly "[Quuux]" <> ModuleOnly "[Quuuux]"] - , unusedTypes = True - } + let cf = + Config + { rootPatterns = mempty + , typeClassRoots = True + , rootInstances = [InstanceOnly "Quux\\\\[\\]", ClassOnly "[\\[\\\\[baz" <> ModuleOnly "[Quuux]", InstanceOnly "[\\[\\\\[baz" <> ClassOnly "[Quuux]" <> ModuleOnly "[Quuuux]"] + , unusedTypes = True + } cf' = T.pack $ configToToml cf in TOML.decode cf' `shouldBe` Right cf diff --git a/treefmt.toml b/treefmt.toml new file mode 100644 index 0000000..16df37d --- /dev/null +++ b/treefmt.toml @@ -0,0 +1,14 @@ +# A bit of a hack, but until https://github.com/numtide/treefmt/issues/77 is +# resolved we need to manually sequence our Haskell formatters. +[formatter.haskell] +command = "/bin/sh" +options = [ + "-euc", + """ +fourmolu -i "$@" +ch-hs-imports --overwrite --local-modules-from-current-dir --report-progress "$@" + """, + "format-haskell" +] +includes = [ "*.hs" ] +