cabal-fix (empty) → 0.0.0.1
raw patch · 10 files changed
+2833/−0 lines, 10 filesdep +Cabal-syntaxdep +algebraic-graphsdep +base
Dependencies added: Cabal-syntax, algebraic-graphs, base, bytestring, cabal-fix, containers, directory, dotparse, filepath, flatparse, optics-extra, optparse-applicative, pretty, pretty-simple, string-interpolate, tar, text, these, tree-diff, vector
Files
- ChangeLog.md +4/−0
- LICENSE +30/−0
- app/cabal-fix.hs +93/−0
- cabal-fix.cabal +144/−0
- other/textdeps.svg +132/−0
- readme.org +838/−0
- src/CabalFix.hs +1143/−0
- src/CabalFix/Archive.hs +143/−0
- src/CabalFix/FlatParse.hs +219/−0
- src/CabalFix/Patch.hs +87/−0
+ ChangeLog.md view
@@ -0,0 +1,4 @@+# 0.0.0.1++* conception+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tony Day (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tony Day nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ app/cabal-fix.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}++-- | cabal-fix app+module Main where++import CabalFix+ ( Config,+ defaultConfig,+ fixCabalFields,+ fixCabalFile,+ parseCabalFields,+ printCabalFields,+ )+import CabalFix.Patch+import Control.Monad+import Data.Bool+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as C+import Data.Text.Lazy.IO qualified as Text+import Data.TreeDiff+import GHC.Generics+import Options.Applicative+import System.Directory+import System.FilePath+import Text.Pretty.Simple+import Prelude++data CommandType = FixInplace | FixCheck | GenerateConfig deriving (Generic, Eq, Show)++data Options = Options+ { commandType :: CommandType,+ projectDir :: FilePath,+ configFile :: FilePath+ }+ deriving (Eq, Show)++defaultOptions :: Options+defaultOptions = Options FixCheck "." "cabal-fix.config"++parseCommand :: Parser CommandType+parseCommand =+ subparser $+ command "inplace" (info (pure FixInplace) (progDesc "fix cabal file inplace"))+ <> command "check" (info (pure FixCheck) (progDesc "check cabal file"))+ <> command "genConfig" (info (pure GenerateConfig) (progDesc "generate config file"))++parseOptions :: Parser Options+parseOptions =+ Options+ <$> parseCommand+ <*> option str (Options.Applicative.value (projectDir defaultOptions) <> long "directory" <> short 'd' <> help "project directory")+ <*> option str (Options.Applicative.value (configFile defaultOptions) <> long "config" <> short 'c' <> help "config file")++infoOptions :: ParserInfo Options+infoOptions =+ info+ (parseOptions <**> helper)+ (fullDesc <> progDesc "cabal fixer" <> header "fixes your cabal file")++main :: IO ()+main = do+ o <- execParser infoOptions+ runCabalFix o++runCabalFix :: Options -> IO ()+runCabalFix o = do+ case commandType o of+ GenerateConfig ->+ Text.writeFile (configFile o) (pShowNoColor defaultConfig)+ FixInplace -> do+ cfg <- getConfig o+ fp <- getCabalFile o+ b <- fixCabalFile fp cfg+ unless b (putStrLn "parsing failure")+ FixCheck -> do+ cfg <- getConfig o+ fp <- getCabalFile o+ bs <- BS.readFile fp+ let bs' = printCabalFields cfg . fixCabalFields cfg <$> parseCabalFields cfg bs+ print $ fmap ansiWlBgEditExpr . patch (C.lines bs) . C.lines <$> bs'++getConfig :: Options -> IO Config+getConfig o = do+ configExists <- doesFileExist (configFile o)+ bool (pure defaultConfig) (read <$> readFile (configFile o)) configExists++getCabalFile :: Options -> IO FilePath+getCabalFile o = do+ fs <- getDirectoryContents (projectDir o)+ case filter ((== ".cabal") . takeExtension) fs of+ [] -> error "No .cabal file found"+ [c] -> pure (projectDir o </> c)+ _ -> error "multiple .cabal files found"
+ cabal-fix.cabal view
@@ -0,0 +1,144 @@+cabal-version: 3.0+name: cabal-fix+version: 0.0.0.1+license: BSD-3-Clause+license-file: LICENSE+category: distribution+author: Tony Day+maintainer: tonyday567@gmail.com+homepage: https://github.com/tonyday567/cabal-fixes#readme+bug-reports: https://github.com/tonyday567/cabal-fixes/issues+synopsis: Fix for cabal files.+description:+ An executable and library to help fix cabal files and explore cabal.+build-type: Simple+tested-with:+ GHC == 8.10.7+ GHC == 9.2.8+ GHC == 9.4.8+ GHC == 9.6.4+ GHC == 9.8.1+extra-doc-files:+ ChangeLog.md+ other/textdeps.svg+ readme.org++source-repository head+ type: git+ location: https://github.com/tonyday567/cabal-fixes++common ghc-options-exe-stanza+ ghc-options:+ -fforce-recomp+ -funbox-strict-fields+ -rtsopts+ -threaded+ -with-rtsopts=-N++common ghc-options-stanza+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints++common ghc2021-stanza+ if impl ( ghc >= 9.2 )+ default-language: GHC2021++ if impl ( ghc < 9.2 )+ default-language: Haskell2010+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances++ if impl ( ghc < 9.2 ) && impl ( ghc >= 8.10 )+ default-extensions:+ ImportQualifiedPost+ StandaloneKindSignatures++library+ import: ghc-options-stanza+ import: ghc2021-stanza+ hs-source-dirs: src+ build-depends:+ , Cabal-syntax >=3.10 && <3.11+ , algebraic-graphs >=0.7 && <0.8+ , base >=4.17 && <5+ , bytestring >=0.11 && <0.13+ , containers >=0.6 && <0.8+ , directory >=1.3 && <1.4+ , dotparse >=0.1 && <0.2+ , flatparse >=0.3 && <0.6+ , optics-extra >=0.4 && <0.5+ , pretty >=1.1 && <1.2+ , pretty-simple >=4.1 && <4.2+ , string-interpolate >=0.3 && <0.4+ , tar >=0.5 && <0.7+ , these >=1.2 && <1.3+ , tree-diff >=0.3 && <0.4+ , vector >=0.13 && <0.14+ exposed-modules:+ CabalFix+ CabalFix.Archive+ CabalFix.FlatParse+ CabalFix.Patch++executable cabal-fix+ import: ghc-options-exe-stanza+ import: ghc-options-stanza+ import: ghc2021-stanza+ main-is: cabal-fix.hs+ hs-source-dirs: app+ build-depends:+ , base >=4.17 && <5+ , bytestring >=0.11 && <0.13+ , cabal-fix+ , directory >=1.3 && <1.4+ , filepath >=1.4 && <1.6+ , optparse-applicative >=0.17 && <0.19+ , pretty-simple >=4.1 && <4.2+ , text >=2.0 && <2.2+ , tree-diff >=0.3 && <0.4
+ other/textdeps.svg view
@@ -0,0 +1,132 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<!-- Generated by graphviz version 9.0.0 (20230911.1827)+ -->+<!-- Pages: 1 -->+<svg width="324pt" height="360pt"+ viewBox="0.00 0.00 323.65 360.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+<g id="graph0" class="graph" transform="scale(1.08434 1.08434) rotate(0) translate(4 328)">+<polygon fill="white" stroke="none" points="-4,4 -4,-328 294.48,-328 294.48,4 -4,4"/>+<!-- text -->+<g id="node1" class="node">+<title>text</title>+<polygon fill="none" stroke="black" points="158.48,-36 104.48,-36 104.48,0 158.48,0 158.48,-36"/>+<text text-anchor="middle" x="131.48" y="-12.95" font-family="Times,serif" font-size="14.00">text</text>+</g>+<!-- template-haskell -->+<g id="node2" class="node">+<title>template-haskell</title>+<polygon fill="none" stroke="black" points="119.48,-252 13.48,-252 13.48,-216 119.48,-216 119.48,-252"/>+<text text-anchor="middle" x="66.48" y="-228.95" font-family="Times,serif" font-size="14.00">template-haskell</text>+</g>+<!-- template-haskell->text -->+<g id="edge1" class="edge">+<title>template-haskell->text</title>+<path fill="none" stroke="black" d="M71.69,-215.85C83.29,-177.66 111.26,-85.57 124.41,-42.26"/>+<polygon fill="black" stroke="black" points="126.02,-42.97 125.8,-37.68 122.68,-41.96 126.02,-42.97"/>+</g>+<!-- bytestring -->+<g id="node5" class="node">+<title>bytestring</title>+<polygon fill="none" stroke="black" points="182.48,-180 112.48,-180 112.48,-144 182.48,-144 182.48,-180"/>+<text text-anchor="middle" x="147.48" y="-156.95" font-family="Times,serif" font-size="14.00">bytestring</text>+</g>+<!-- template-haskell->bytestring -->+<g id="edge2" class="edge">+<title>template-haskell->bytestring</title>+<path fill="none" stroke="black" d="M86.5,-215.7C97.4,-206.27 111,-194.53 122.58,-184.52"/>+<polygon fill="black" stroke="black" points="123.62,-185.93 126.26,-181.34 121.33,-183.28 123.62,-185.93"/>+</g>+<!-- ghc-prim -->+<g id="node3" class="node">+<title>ghc-prim</title>+<polygon fill="none" stroke="black" points="99.6,-324 33.35,-324 33.35,-288 99.6,-288 99.6,-324"/>+<text text-anchor="middle" x="66.48" y="-300.95" font-family="Times,serif" font-size="14.00">ghc-prim</text>+</g>+<!-- ghc-prim->text -->+<g id="edge3" class="edge">+<title>ghc-prim->text</title>+<path fill="none" stroke="black" d="M36.65,-287.7C24.27,-278.78 11.23,-266.66 4.48,-252 -2.22,-237.47 -0.04,-231.35 4.48,-216 25.34,-145.12 80.5,-75.69 110.81,-41.3"/>+<polygon fill="black" stroke="black" points="112.07,-42.51 114.08,-37.62 109.45,-40.19 112.07,-42.51"/>+</g>+<!-- ghc-prim->template-haskell -->+<g id="edge4" class="edge">+<title>ghc-prim->template-haskell</title>+<path fill="none" stroke="black" d="M66.48,-287.7C66.48,-278.88 66.48,-268.03 66.48,-258.47"/>+<polygon fill="black" stroke="black" points="68.23,-258.62 66.48,-253.62 64.73,-258.62 68.23,-258.62"/>+</g>+<!-- ghc-prim->bytestring -->+<g id="edge5" class="edge">+<title>ghc-prim->bytestring</title>+<path fill="none" stroke="black" d="M93.97,-287.68C106.32,-278.53 120,-266.24 128.48,-252 140.46,-231.87 144.93,-205.21 146.58,-186.33"/>+<polygon fill="black" stroke="black" points="148.29,-186.88 146.92,-181.76 144.8,-186.62 148.29,-186.88"/>+</g>+<!-- deepseq -->+<g id="node4" class="node">+<title>deepseq</title>+<polygon fill="none" stroke="black" points="235.23,-252 175.73,-252 175.73,-216 235.23,-216 235.23,-252"/>+<text text-anchor="middle" x="205.48" y="-228.95" font-family="Times,serif" font-size="14.00">deepseq</text>+</g>+<!-- deepseq->text -->+<g id="edge6" class="edge">+<title>deepseq->text</title>+<path fill="none" stroke="black" d="M208.64,-215.87C213.43,-185.14 219.6,-119.43 195.48,-72 188.44,-58.16 176.01,-46.59 163.96,-37.83"/>+<polygon fill="black" stroke="black" points="165.18,-36.54 160.08,-35.11 163.17,-39.41 165.18,-36.54"/>+</g>+<!-- deepseq->bytestring -->+<g id="edge7" class="edge">+<title>deepseq->bytestring</title>+<path fill="none" stroke="black" d="M191.14,-215.7C183.48,-206.46 173.98,-194.98 165.79,-185.11"/>+<polygon fill="black" stroke="black" points="167.15,-184 162.62,-181.27 164.46,-186.24 167.15,-184"/>+</g>+<!-- bytestring->text -->+<g id="edge8" class="edge">+<title>bytestring->text</title>+<path fill="none" stroke="black" d="M137.27,-143.5C132.02,-133.47 126.16,-120.44 123.48,-108 118.75,-86.12 121.9,-60.63 125.54,-42.55"/>+<polygon fill="black" stroke="black" points="127.24,-42.99 126.57,-37.73 123.81,-42.25 127.24,-42.99"/>+</g>+<!-- binary -->+<g id="node6" class="node">+<title>binary</title>+<polygon fill="none" stroke="black" points="186.48,-108 132.48,-108 132.48,-72 186.48,-72 186.48,-108"/>+<text text-anchor="middle" x="159.48" y="-84.95" font-family="Times,serif" font-size="14.00">binary</text>+</g>+<!-- bytestring->binary -->+<g id="edge9" class="edge">+<title>bytestring->binary</title>+<path fill="none" stroke="black" d="M150.44,-143.7C151.95,-134.88 153.81,-124.03 155.45,-114.47"/>+<polygon fill="black" stroke="black" points="157.17,-114.82 156.29,-109.6 153.72,-114.23 157.17,-114.82"/>+</g>+<!-- binary->text -->+<g id="edge10" class="edge">+<title>binary->text</title>+<path fill="none" stroke="black" d="M152.56,-71.7C148.96,-62.71 144.52,-51.61 140.65,-41.92"/>+<polygon fill="black" stroke="black" points="142.36,-41.5 138.88,-37.51 139.11,-42.8 142.36,-41.5"/>+</g>+<!-- array -->+<g id="node7" class="node">+<title>array</title>+<polygon fill="none" stroke="black" points="290.48,-324 236.48,-324 236.48,-288 290.48,-288 290.48,-324"/>+<text text-anchor="middle" x="263.48" y="-300.95" font-family="Times,serif" font-size="14.00">array</text>+</g>+<!-- array->text -->+<g id="edge11" class="edge">+<title>array->text</title>+<path fill="none" stroke="black" d="M264.81,-287.66C267.08,-245.83 267.2,-137.98 215.48,-72 202.19,-55.05 181.88,-42.03 164.56,-33.13"/>+<polygon fill="black" stroke="black" points="165.42,-31.61 160.17,-30.95 163.86,-34.74 165.42,-31.61"/>+</g>+<!-- array->deepseq -->+<g id="edge12" class="edge">+<title>array->deepseq</title>+<path fill="none" stroke="black" d="M249.14,-287.7C241.48,-278.46 231.98,-266.98 223.79,-257.11"/>+<polygon fill="black" stroke="black" points="225.15,-256 220.62,-253.27 222.46,-258.24 225.15,-256"/>+</g>+<!-- array->binary -->+<g id="edge13" class="edge">+<title>array->binary</title>+<path fill="none" stroke="black" d="M261.78,-287.67C259.53,-269.29 254.6,-239.68 244.48,-216 227.73,-176.8 198.01,-137.01 178.53,-113.17"/>+<polygon fill="black" stroke="black" points="180.03,-112.24 175.49,-109.5 177.33,-114.47 180.03,-112.24"/>+</g>+</g>+</svg>
+ readme.org view
@@ -0,0 +1,838 @@+* cabal-fix++[[https://hackage.haskell.org/package/cabal-fixes][https://img.shields.io/hackage/v/cabal-fix.svg]]+[[https://github.com/tonyday567/cabal-fixes/actions?query=workflow%3Ahaskell-ci][https://github.com/tonyday567/cabal-fix/workflows/haskell-ci/badge.svg]]++~cabal-fix~ helps fix your cabal files. This package:++- Contains an app which parses your existing cabal file, re-renders it according to some config, then either displays a diff or alters your cabal file, in-place.+- Is an idempotent parser of a cabal file or ByteString, into the ~Field~ type used in Cabal.+- Is an inexact printer.+- Contains code to explore the cabal index archive at the base of your cabal installation.++* App Usage++#+begin_src sh :results output :exports both++#+end_export+cabal-fix --help+#+end_src++#+RESULTS:+#+begin_example+fixes your cabal file++Usage: cabal-fix COMMAND [-d|--directory ARG] [-c|--config ARG]++ cabal fixer++Available options:+ -d,--directory ARG project directory+ -c,--config ARG config file+ -h,--help Show this help text++Available commands:+ inplace fix cabal file inplace+ check check cabal file+ genConfig generate config file+#+end_example++* App Configuration++The configuration of cabal-fix is encapsulated in the Config type. The configuration file generated by the app (via =cabal-fix genConfig=) just (pretty) prints defaultConfig.++#+begin_src haskell-ng :results output :exports both+import Text.Pretty.Simple+pPrint defaultConfig+#+end_src++#+RESULTS:+#+begin_example+Config+ { freeTexts = [ "description" ]+ , fieldRemovals = []+ , preferredDeps =+ [+ ( "base"+ , ">=4.7 && <5"+ )+ ]+ , addFields = []+ , fixCommas =+ [+ ( "extra-doc-files"+ , NoCommas+ )+ ,+ ( "build-depends"+ , PrefixCommas+ )+ ]+ , sortFieldLines =+ [ "build-depends"+ , "exposed-modules"+ , "default-extensions"+ , "ghc-options"+ , "extra-doc-files"+ , "tested-with"+ ]+ , sortFields = True+ , fieldOrdering =+ [+ ( "cabal-version"+ , 0.0+ )+ ,+ ( "import"+ , 1.0+ )+ ,+ ( "main-is"+ , 2.0+ )+ ,+ ( "default-language"+ , 3.0+ )+ ,+ ( "name"+ , 4.0+ )+ ,+ ( "hs-source-dirs"+ , 5.0+ )+ ,+ ( "version"+ , 6.0+ )+ ,+ ( "build-depends"+ , 7.0+ )+ ,+ ( "exposed-modules"+ , 8.0+ )+ ,+ ( "license"+ , 9.0+ )+ ,+ ( "license-file"+ , 10.0+ )+ ,+ ( "other-modules"+ , 11.0+ )+ ,+ ( "copyright"+ , 12.0+ )+ ,+ ( "category"+ , 13.0+ )+ ,+ ( "author"+ , 14.0+ )+ ,+ ( "default-extensions"+ , 15.0+ )+ ,+ ( "ghc-options"+ , 16.0+ )+ ,+ ( "maintainer"+ , 17.0+ )+ ,+ ( "homepage"+ , 18.0+ )+ ,+ ( "bug-reports"+ , 19.0+ )+ ,+ ( "synopsis"+ , 20.0+ )+ ,+ ( "description"+ , 21.0+ )+ ,+ ( "build-type"+ , 22.0+ )+ ,+ ( "tested-with"+ , 23.0+ )+ ,+ ( "extra-doc-files"+ , 24.0+ )+ ,+ ( "source-repository"+ , 25.0+ )+ ,+ ( "type"+ , 26.0+ )+ ,+ ( "common"+ , 27.0+ )+ ,+ ( "location"+ , 28.0+ )+ ,+ ( "library"+ , 29.0+ )+ ,+ ( "executable"+ , 30.0+ )+ ,+ ( "test-suite"+ , 31.0+ )+ ]+ , fixBuildDeps = True+ , depAlignment = DepAligned+ , removeBlankFields = True+ , valueAligned = ValueUnaligned+ , sectionMargin = Margin+ , commentMargin = NoMargin+ , narrowN = 60+ , indentN = 4+ }+#+end_example++* Library Usage++#+begin_src haskell-ng :results output :exports both+:set -XOverloadedStrings+:set -XOverloadedLabels+:set -Wno-incomplete-uni-patterns+:set -Wno-name-shadowing+import CabalFix+import Optics.Extra+import Data.ByteString.Char8 qualified as C+bs = minimalExampleBS+cfg = defaultConfig+(Just cf) = preview (cabalFields' cfg) bs+fs = cf & view (#fields % fieldList')+#+end_src++#+RESULTS:+#+begin_example+Build profile: -w ghc-9.4.8 -O1+In order, the following will be built (use -v for more details):+ - cabal-fix-0.0.0.1 (lib) (ephemeral targets)+Preprocessing library for cabal-fix-0.0.0.1..+GHCi, version 9.4.8: https://www.haskell.org/ghc/ :? for help+[1 of 4] Compiling CabalFix.FlatParse ( src/CabalFix/FlatParse.hs, interpreted )+[2 of 4] Compiling CabalFix ( src/CabalFix.hs, interpreted )+[3 of 4] Compiling CabalFix.Archive ( src/CabalFix/Archive.hs, interpreted )+[4 of 4] Compiling CabalFix.Patch ( src/CabalFix/Patch.hs, interpreted )+Ok, four modules loaded.+#+end_example++#+begin_src haskell-ng :results output :exports both+cf & review (cabalFields' cfg) & C.putStr+#+end_src++#+RESULTS:+#+begin_example+cabal-version: 3.0+name: minimal+version: 0.1.0.0+license: BSD-2-Clause+license-file: LICENSE+build-type: Simple+extra-doc-files: CHANGELOG.md++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: MyLib+ build-depends: base ^>=4.17.2.1+ hs-source-dirs: src+ default-language: GHC2021++test-suite minimal-test+ import: warnings+ default-language: GHC2021+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends:+ base ^>=4.17.2.1,+ minimal+#+end_example++* cabal init++** minimal++A minimal =cabal init=++#+begin_src sh :results output :exports both+mkdir minimal && cd minimal && cabal init --minimal --simple --overwrite --lib --tests --language=GHC2021 --license=BSD-2-Clause -p minimal+#+end_src++#+RESULTS:+#+begin_example+[Log] Using cabal specification: 3.0+[Log] Creating fresh file LICENSE...+[Log] Creating fresh file CHANGELOG.md...+[Log] Creating fresh directory ./src...+[Log] Creating fresh file src/MyLib.hs...+[Log] Creating fresh directory ./test...+[Log] Creating fresh file test/Main.hs...+[Log] Creating fresh file minimal.cabal...+[Warning] No synopsis given. You should edit the .cabal file and add one.+[Info] You may want to edit the .cabal file and add a Description field.++#+end_example++Compared with the original =cabal init= contents, =cabal-fix=:++- widens the =base= range, in line with standard practice.+- reorders the =test-suite= section fields, in line with the ordering of the =library= section ones.++#+begin_src sh :results output :exports both+cabal-fix check -d "minimal" -c "other/minimal.config"+#+end_src++#+RESULTS:+#+begin_example+Right (Just [+ -" build-depends: base ^>=4.17.2.1",+ +" build-depends: base >=4.17 && <5",+ -" default-language: GHC2021",+ +" main-is: Main.hs",+ -" type: exitcode-stdio-1.0",+ +" build-depends:",+ -" hs-source-dirs: test",+ +" base >=4.17 && <5,",+ -" main-is: Main.hs",+ +" minimal",+ -" build-depends:",+ +" hs-source-dirs: test",+ -" base ^>=4.17.2.1,",+ +" default-language: GHC2021",+ -" minimal",+ +" type: exitcode-stdio-1.0"])+#+end_example++** code example++For reference, the code below should produce the same results as the app run above:++#+begin_src haskell-ng :results output :exports both+:set -XOverloadedStrings+:set -XOverloadedLabels+:set -Wno-incomplete-uni-patterns+:set -Wno-name-shadowing+:set -Wno-type-defaults+import CabalFix+import Text.Pretty.Simple+import CabalFix.Patch+import Data.TreeDiff+bs = minimalExampleBS+cfg = minimalConfig+(Just cf) = preview (cabalFields' cfg) bs+bs' = review (cabalFields' cfg) cf+(Just cf') = preview (cabalFields' cfg) bs'+cfFixed = fixCabalFields cfg cf+bsFixed = review (cabalFields' cfg) cfFixed+fmap ansiWlBgEditExpr $ patch (C.lines bs) (C.lines bsFixed)+#+end_src++#+RESULTS:+#+begin_example+Just [+ -" build-depends: base ^>=4.17.2.1",+ +" build-depends: base >=4.17 && <5",+ -" default-language: GHC2021",+ +" main-is: Main.hs",+ -" type: exitcode-stdio-1.0",+ +" build-depends:",+ -" hs-source-dirs: test",+ +" base >=4.17 && <5,",+ -" main-is: Main.hs",+ +" minimal",+ -" build-depends:",+ +" hs-source-dirs: test",+ -" base ^>=4.17.2.1,",+ +" default-language: GHC2021",+ -" minimal",+ +" type: exitcode-stdio-1.0"]+#+end_example++** simple++#+begin_src sh :results output :exports both+mkdir simple && cd simple && cabal init --simple --overwrite --lib --tests --language=GHC2021 --license=BSD-2-Clause -p simple+#+end_src++#+RESULTS:+#+begin_example+[Log] Using cabal specification: 3.0+[Log] Creating fresh file LICENSE...+[Log] Creating fresh file CHANGELOG.md...+[Log] Creating fresh directory ./src...+[Log] Creating fresh file src/MyLib.hs...+[Log] Creating fresh directory ./test...+[Log] Creating fresh file test/Main.hs...+[Log] Creating fresh file simple.cabal...+[Warning] No synopsis given. You should edit the .cabal file and add one.+[Info] You may want to edit the .cabal file and add a Description field.++#+end_example++#+begin_src sh :results output :exports both+cabal-fix check -d "simple" -c "other/minimal.config"+#+end_src++#+RESULTS:+#+begin_example+Right (Just [+ +"cabal-version: 3.0",+ -"cabal-version: 3.0",+ +"",+ -"name: simple",+ +"name: simple",+ -"version: 0.1.0.0",+ +"version: 0.1.0.0",+ -"license: BSD-2-Clause",+ +"license: BSD-2-Clause",+ -"license-file: LICENSE",+ +"license-file: LICENSE",+ -"build-type: Simple",+ +"build-type: Simple",+ -"extra-doc-files: CHANGELOG.md",+ +"extra-doc-files: CHANGELOG.md",+ -" build-depends: base ^>=4.17.2.1",+ +" build-depends: base >=4.17 && <5",+ -" -- Base language which the package is written in.",+ +" -- The entrypoint to the test suite.",+ -" default-language: GHC2021",+ +" main-is: Main.hs",+ -" -- Modules included in this executable, other than Main.",+ -" -- other-modules:",+ +" -- Test dependencies.",+ -"",+ +" build-depends:",+ -" -- LANGUAGE extensions used by modules in this package.",+ +" base >=4.17 && <5,",+ -" -- other-extensions:",+ +" simple",+ -" -- The interface type and version of the test suite.",+ +" -- Directories containing source files.",+ -" type: exitcode-stdio-1.0",+ +" hs-source-dirs: test",+ -" -- Directories containing source files.",+ +" -- Base language which the package is written in.",+ -" hs-source-dirs: test",+ +" default-language: GHC2021",+ -" -- The entrypoint to the test suite.",+ +" -- Modules included in this executable, other than Main.",+ -" main-is: Main.hs",+ +" -- other-modules:",+ +" -- LANGUAGE extensions used by modules in this package.",+ -" -- Test dependencies.",+ +" -- other-extensions:",+ -" build-depends:",+ +"",+ -" base ^>=4.17.2.1,",+ +" -- The interface type and version of the test suite.",+ -" simple",+ +" type: exitcode-stdio-1.0"])+#+end_example++* Archive Exploration++CabalFix.Archive contains functions to extract and explore cabal files listed in your cabal index file.++The sections below are some exploration notes.++** imports+#+begin_src haskell-ng :results output :exports both+:r+:set -Wno-type-defaults+:set -Wno-name-shadowing+:set -XOverloadedLabels+:set -XOverloadedStrings+:set -Wno-incomplete-uni-patterns+import Algebra.Graph+import Algebra.Graph.ToGraph qualified as ToGraph+import CabalFix+import CabalFix.Archive+import CabalFix.FlatParse+import Codec.Archive.Tar qualified as Tar+import Control.Monad+import Data.Bifunctor+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as C+import Data.ByteString.Lazy qualified as BSL+import Data.Char+import Data.Either+import Data.Function+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Ord+import Data.Set qualified as Set+import DotParse+import FlatParse.Basic qualified as FP+import System.Directory+import Text.Pretty.Simple+#+end_src++#+RESULTS:+: Ok, four modules loaded.++** tar file to list of cabal files+*** entries++#+begin_src haskell-ng :results output :exports both+es <- cabalEntries+length es+#+end_src++#+RESULTS:+: 317368++#+begin_src haskell-ng :results output :exports both+Tar.entryPath <$> take 5 es+#+end_src++#+RESULTS:+: ["iconv/0.2/iconv.cabal","Crypto/3.0.3/Crypto.cabal","HDBC/1.0.1/HDBC.cabal","HDBC-odbc/1.0.1.0/HDBC-odbc.cabal","HDBC-postgresql/1.0.1.0/HDBC-postgresql.cabal"]++They are all normal files++#+begin_src haskell-ng :results output :exports both+(length [x | (Tar.NormalFile x _) <- Tar.entryContent <$> es])+#+end_src++#+RESULTS:+: 317368++*** Maximum file size:++#+begin_src haskell-ng :results output :exports both+(\xs -> filter ((maximum (snd <$> xs) ==) . snd) xs) $ [(fp,x) | (fp, Tar.NormalFile _ x) <- (\e -> (Tar.entryPath e, Tar.entryContent e)) <$> es]+#+end_src++#+RESULTS:+: [("acme-everything/2018.11.18/acme-everything.cabal",261865)]++*** zero size++#+begin_src haskell-ng :results output :exports both+take 4 $ (\xs -> filter ((0 ==) . snd) xs) $ [(fp,x) | (fp, Tar.NormalFile _ x) <- (\e -> (Tar.entryPath e, Tar.entryContent e)) <$> es]+#+end_src++#+RESULTS:+: [("lzma/preferred-versions",0),("signal/preferred-versions",0),("peyotls-codec/preferred-versions",0),("th-orphans/preferred-versions",0)]++*** preferred-versions++[[https://hackage.haskell.org/package/Cabal/preferred][Cabal: preferred and deprecated versions | Hackage]]++#+begin_src haskell-ng :results output :exports both+take 3 $ (\xs -> filter ((List.isSuffixOf "preferred-versions") . fst) xs) $ [(fp,bs) | (fp, Tar.NormalFile bs _) <- (\e -> (Tar.entryPath e, Tar.entryContent e)) <$> es]+#+end_src++#+RESULTS:+: [("ADPfusion/preferred-versions","ADPfusion <0.4.0.0 || >0.4.0.0"),("AesonBson/preferred-versions","AesonBson <0.2.0 || >0.2.0 && <0.2.1 || >0.2.1"),("BiobaseXNA/preferred-versions","BiobaseXNA <0.9.1.0 || >0.9.1.0")]++#+begin_src haskell-ng :results output :exports both+length $ (\xs -> filter ((List.isSuffixOf "preferred-versions") . fst) xs) $ [(fp,bs) | (fp, Tar.NormalFile bs _) <- (\e -> (Tar.entryPath e, Tar.entryContent e)) <$> es]+#+end_src++#+RESULTS:+: 3376++*** package.json++=package-json= content is a security/signing feature you can read about in [[https://github.com/haskell-ng/hackage-security/blob/master/README.md][hackage-security]].++#+begin_src haskell-ng :results output :exports both+length $ filter ((== "package.json") . filenameFN . runParser_ filenameP . FP.strToUtf8 . fst) $ filter (not . (List.isSuffixOf "preferred-versions") . fst) $ [(fp,bs) | (fp, Tar.NormalFile bs _) <- (\e -> (Tar.entryPath e, Tar.entryContent e)) <$> es]+#+end_src++#+RESULTS:+: 137524++*** cabal files++Unique package/version combinations.++There are multiple versions of package/versions because of revisions. See [[https://github.com/haskell-infra/hackage-trustees/blob/master/revisions-information.md][revisions-information.md]]++Unique =*/*.cabal/version= entries++#+begin_src haskell-ng :results output :exports both+cs <- cabals+length cs+#+end_src++#+RESULTS:+: 137524++Unique cabal packages++#+begin_src haskell-ng :results output :exports both+lcs <- latestCabals+Map.size lcs+#+end_src++#+RESULTS:+: 17631++Average number of versions per package++#+begin_src haskell-ng :results output :exports both+(fromIntegral (length cs)) / fromIntegral (Map.size lcs)+#+end_src++#+RESULTS:+: 7.800124780216664++** latestCabals to CabalFields map++#+begin_src haskell-ng :results output :exports both+lcs <- latestCabals defaultConfig+Map.size lcs+cfg = defaultConfig+lcs' = fmap (second (parseCabalFields cfg)) lcs+Map.size $ Map.filter (snd >>> isLeft) lcs'+:t lcs'+badParse = Map.filter (isLeft . parseCabalFields cfg . snd) lcs+Map.size badParse+#+end_src++#+RESULTS:+: 17631+: 6+: lcs' :: Map.Map ByteString (Version, Either ByteString CabalFields)+: 6+** CabalFields map to dependency graph++#+begin_src haskell-ng :results output :exports both+lcfs <- latestCabalFields+vlds = validLibDeps $ fmap snd lcfs+Map.size vlds+depG = allDepGraph $ fmap snd lcfs+vertexCount depG+edgeCount depG+#+end_src++#+RESULTS:+: 15547+: 15621+: 107566++** algebraic-graphs++An (algebraic) graph of dependencies:++=text= package dependency example++#+begin_src haskell-ng+supers = upstreams "text" depG <> Set.singleton "text"+superG = induce (`elem` (Data.Foldable.toList supers)) depG+#+end_src++#+RESULTS:++#+begin_src haskell-ng :results output :exports both+supers+#+end_src++#+RESULTS:+: fromList ["array","binary","bytestring","deepseq","ghc-prim","template-haskell","text"]+++#+begin_src haskell-ng :file other/textdeps.svg :results output graphics file :exports results+ baseGraph = defaultGraph & attL GraphType (ID "size") .~ Just (IDQuoted "5!") & attL NodeType (ID "shape") .~ Just (ID "box") & attL NodeType (ID "height") .~ Just (ID 2) & gattL (ID "rankdir") .~ Just (IDQuoted "TB")+ g = toDotGraphWith Directed baseGraph superG+ processDotWith Directed ["-Tsvg", "-oother/textdeps.svg"] (dotPrint defaultDotConfig g)+ BS.writeFile "other/textdeps.dot" (dotPrint defaultDotConfig g)+ #+end_src++#+RESULTS:+[[file:other/textdeps.svg]]++** sections+*** section count++#+begin_src haskell-ng :results output :exports both+cfs = lcfs & Map.toList & fmap (snd . snd)+cfs & toListOf (each % #fields % fieldList') & fmap (filter isSection >>> length) & count_+#+end_src++#+RESULTS:+: fromList [(0,359),(1,2559),(2,5508),(3,4730),(4,2224),(5,956),(6,479),(7,236),(8,138),(9,98),(10,63),(11,57),(12,31),(13,32),(14,22),(15,16),(16,12),(17,7),(18,11),(19,8),(20,8),(21,8),(22,4),(23,3),(24,7),(25,4),(26,6),(27,1),(28,1),(29,4),(30,2),(32,4),(33,2),(34,4),(36,1),(37,4),(38,1),(39,2),(40,1),(41,1),(43,2),(47,2),(48,2),(50,1),(65,1),(93,1),(97,1),(295,1)]++*** section types++#+begin_src haskell-ng+cfs & toListOf (each % #fields % fieldList') & fmap (filter isSection) & fmap (fmap (view fieldName')) & mconcat & count_ & Map.toList & List.sortOn (Down . snd)++#+end_src++#+RESULTS:+: [("library",16028),("source-repository",13889),("test-suite",8718),("executable",7292),("flag",4134),("common",2302),("benchmark",1246),("custom-setup",321),("foreign-library",4)]++combinations:++#+begin_src haskell-ng :results output :exports both+cfs & toListOf (each % #fields % fieldList') & fmap (filter isSection) & fmap (fmap (view fieldName')) & fmap (filter (not . (flip List.elem) ["source-repository", "custom-setup", "foreign-library", "flag", "common"])) & fmap (count_ >>> Map.toList >>> List.sortOn fst) & count_ & Map.toList & List.sortOn (Down . snd) & take 10+#+end_src++#+RESULTS:+: [([("library",1)],7291),([("library",1),("test-suite",1)],4195),([("executable",1),("library",1)],1148),([("executable",1)],1105),([("executable",1),("library",1),("test-suite",1)],901),([("benchmark",1),("library",1),("test-suite",1)],520),([("library",1),("test-suite",2)],416),([],359),([("executable",2),("library",1)],163),([("executable",2),("library",1),("test-suite",1)],133)]++at least 1 combinations:++#+begin_src haskell-ng :results output :exports both+cfs & toListOf (each % #fields % fieldList') & fmap (filter isSection) & fmap (fmap (view fieldName')) & fmap (filter (not . (flip List.elem) ["source-repository", "custom-setup", "foreign-library", "flag", "common"])) & fmap (count_ >>> Map.toList >>> fmap fst >>> List.sortOn id) & count_ & Map.toList & List.sortOn (Down . snd) & take 10+#+end_src++#+RESULTS:+: [(["library"],7297),(["library","test-suite"],4778),(["executable","library"],1490),(["executable","library","test-suite"],1309),(["executable"],1263),(["benchmark","library","test-suite"],739),([],359),(["benchmark","executable","library","test-suite"],182),(["executable","test-suite"],119),(["benchmark","library"],59)]++*** section in section++#+begin_src haskell-ng :results output :exports both+sections' = to (filter isSection)+-- cfs & fmap (foldOf (#fields % fieldList' % sections' % each % secFields' % sections')) & filter (not . null) & fmap (second (fmap (view fieldName'))) & fmap snd & mconcat & count_+cfs & fmap (foldOf (#fields % fieldList' % sections' % each % secFields' % sections')) & filter (not . null) & fmap ((fmap (view fieldName'))) & mconcat & count_+#+end_src++#+RESULTS:+: fromList [("elif",52),("else",3203),("if",11459),("library",3)]++Embedded libraries are all deprecated.++*** zero-section cfs++Looks like library fields used to be allowed at the top level...++#+begin_src haskell-ng :results output :exports both+cfs0 = cfs & toListOf (each % #fields % fieldList') & filter ((==0) . length . (filter isSection))+length cfs0+count_ $ cfs0 & fmap (foldOf (field' "build-depends") >>> length)+cfs00 = cfs0 & filter (foldOf (field' "build-depends") >>> length >>> (==0))+length cfs00+#+end_src++#+RESULTS:+: 359+: fromList [(0,2),(1,349),(2,7),(4,1)]+: 2++** Dependency counts++package dependency count:++#+begin_src haskell-ng :results output :exports both+lcfs & fmap (snd >>> libDeps >>> fmap dep >>> List.nub >>> length) & Map.toList & List.sortOn (Down . snd) & take 20+#+end_src++#+RESULTS:+: [("acme-everything",7533),("yesod-platform",132),("planet-mitchell",109),("freckle-app",78),("cachix",76),("btc-lsp",71),("too-many-cells",70),("swarm",68),("ghcide",67),("pandoc",67),("sprinkles",65),("pantry-tmp",64),("taffybar",63),("NGLess",60),("project-m36",59),("stack",59),("espial",58),("hermes",58),("purescript",56),("futhark",55)]++dependency count:++#+begin_src haskell-ng :results output :exports both+lcfs & fmap (snd >>> libDeps >>> fmap dep >>> List.nub) & Map.toList & fmap snd & mconcat & count_ & Map.toList & List.sortOn (snd >>> Down) & take 40+#+end_src++#+RESULTS:+: [("base",14883),("bytestring",5384),("text",4972),("containers",4753),("mtl",3468),("transformers",3070),("aeson",2013),("time",1961),("vector",1793),("directory",1597),("filepath",1510),("template-haskell",1472),("unordered-containers",1392),("deepseq",1240),("lens",1173),("hashable",930),("binary",929),("array",892),("exceptions",855),("process",844),("stm",819),("random",811),("http-types",784),("attoparsec",781),("network",756),("parsec",744),("data-default",609),("QuickCheck",597),("conduit",503),("http-client",497),("split",472),("primitive",470),("ghc-prim",456),("async",449),("semigroups",427),("monad-control",424),("scientific",420),("resourcet",401),("unix",398),("utf8-string",392)]++** version ranges++#+begin_src haskell-ng :results output :exports both+cs <- cabals+length cs+#+end_src++#+RESULTS:+: 137323++#+begin_src haskell-ng :results output :exports both+:t cs++mVersions = Map.fromListWith (<>) $ ((\x -> (nameFN x, (:[]) $ (versionInts $ versionFN x))) . fst) <$> cs+Map.size mVersions+#+end_src++#+RESULTS:+: cs :: [(FileName, ByteString)]+: 17631++#+begin_src haskell-ng :results output :exports both+(Just x1) = Map.lookup "chart-svg" mVersions+x1+minimum x1+maximum x1+#+end_src++#+RESULTS:+: [[0,6,0,0],[0,5,2,0],[0,5,1,1],[0,5,1,0],[0,5,0,0],[0,4,1,1],[0,4,1,0],[0,4,0],[0,3,3],[0,3,2],[0,3,1],[0,3,0],[0,2,3],[0,2,2],[0,2,1],[0,2,0],[0,1,3],[0,1,2],[0,1,1],[0,1,0],[0,0,3],[0,0,2],[0,0,1]]+: [0,0,1]+: [0,6,0,0]++*** all versions are unique?++#+begin_src haskell-ng :results output :exports both+take 10 $ Map.toList $ Map.filter (\a -> length a /= length (List.nub a)) mVersions+#+end_src++#+RESULTS:+: []++*** Version counts++#+begin_src haskell-ng :results output :exports both+take 10 $ List.sortOn (Down . snd) $ Map.toList $ Map.map length mVersions+#+end_src++#+RESULTS:+: [("haskoin-store",298),("git-annex",282),("hlint",221),("yesod-core",216),("purescript",204),("warp",204),("pandoc",193),("hakyll",192),("egison",190),("persistent",186)]++* Field re-ordering++#+begin_src haskell-ng :results output :exports both+zipWith (\o l -> (fst l, o)) [0..] (List.sortOn snd $ fieldOrdering defaultConfig)+#+end_src++#+RESULTS:+: [("cabal-version",0),("import",1),("main-is",2),("default-language",3),("name",4),("hs-source-dirs",5),("version",6),("build-depends",7),("exposed-modules",8),("license",9),("license-file",10),("other-modules",11),("copyright",12),("category",13),("author",14),("default-extensions",15),("ghc-options",16),("maintainer",17),("homepage",18),("bug-reports",19),("synopsis",20),("description",21),("build-type",22),("tested-with",23),("extra-doc-files",24),("source-repository",25),("type",26),("common",27),("location",28),("library",29),("executable",30),("test-suite",31)]++* references++[[https://hackage.haskell.org/package/Cabal-syntax-3.10.2.0/docs/Distribution-Fields-Field.html][Distribution.Fields.Field]]++[[https://hackage.haskell.org/package/optics-core-0.4.1.1][optics-core: Optics as an abstract interface: core definitions]]++[[https://cabal.readthedocs.io/en/stable/cabal-package.html#package-descriptions][6. Package Description — Cabal 3.10.1.0 User's Guide]]
+ src/CabalFix.hs view
@@ -0,0 +1,1143 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}++-- | Tools to print, parse and fix cabal files, 'ByteString' and 'Field' lists.+module CabalFix+ ( -- * Usage+ -- $usage++ -- * Configuration+ Config (..),+ defaultConfig,+ AddPolicy (..),+ CommaStyle (..),+ CommaTrail (..),+ DepAlignment (..),+ ValueAlignment (..),+ Margin (..),++ -- * CabalFields+ Comment,+ CabalFields (..),+ cabalFields',+ fieldList',++ -- * Lenses+ -- $lenses+ topfield',+ field',+ subfield',+ section',+ secFields',+ fieldOrSection',+ overField,+ overFields,+ pname,+ fieldLines',+ fieldName',+ secArgs',+ secArgBS',+ fieldLine',+ fieldValues',++ -- * Parsing+ parseCabalFields,++ -- * Printing+ printCabalFields,++ -- * Fixes+ fixCabalFields,+ fixCabalFile,+ fixesCommas,+ addsFields,+ addField,+ fixBuildDeps,++ -- * Dependency+ Dep (..),++ -- * Examples+ minimalExampleBS,+ minimalConfig,+ )+where++import CabalFix.FlatParse (depP, runParserEither)+import Control.Category ((>>>))+import Control.Monad+import Data.Bifunctor+import Data.Bool+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as C+import Data.Foldable+import Data.Function+import Data.Functor.Identity+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.String.Interpolate+import Data.TreeDiff hiding (FieldName)+import Data.TreeDiff.OMap qualified as OMap+import Data.Vector qualified as V+import Distribution.Fields+import Distribution.Fields.Field+import Distribution.Parsec+import Distribution.Pretty+import Distribution.Utils.Generic+import Distribution.Version+import GHC.Generics hiding (to)+import Optics.Extra+import Text.PrettyPrint qualified as PP+import Prelude++-- $setup+--+-- >>> :set -XOverloadedStrings+-- >>> :set -XOverloadedLabels+-- >>> import CabalFix+-- >>> import Optics.Extra+-- >>> import Data.ByteString.Char8 qualified as C+-- >>> import CabalFix.Patch+-- >>> bs = minimalExampleBS+-- >>> cfg = defaultConfig+-- >>> (Just cf) = preview (cabalFields' cfg) bs+-- >>> fs = cf & view (#fields % fieldList')+-- >>> printCabalFields cfg (cf & over (#fields % fieldList') (take 4)) & C.putStr+-- cabal-version: 3.0+-- name: minimal+-- version: 0.1.0.0+-- license: BSD-2-Clause++-- $usage+--+-- >>> :set -XOverloadedStrings+-- >>> :set -XOverloadedLabels+-- >>> import CabalFix+-- >>> import Optics.Extra+-- >>> import Data.ByteString.Char8 qualified as C+-- >>> import CabalFix.Patch+-- >>> bs = minimalExampleBS+-- >>> cfg = defaultConfig+-- >>> (Just cf) = preview (cabalFields' cfg) bs+-- >>> fs = cf & view (#fields % fieldList')+-- >>> printCabalFields cfg (cf & over (#fields % fieldList') (take 4)) & C.putStr+-- cabal-version: 3.0+-- name: minimal+-- version: 0.1.0.0+-- license: BSD-2-Clause++-- | Configuration values for various aspects of (re)rendering a cabal file.+data Config = Config+ { -- | fields that should be converted to free text+ freeTexts :: [ByteString],+ -- | fields that should be removed+ fieldRemovals :: [ByteString],+ -- | Preferred dependency ranges+ preferredDeps :: [(ByteString, ByteString)],+ -- | Add fields (Overwriting depends on an 'AddPolicy')+ addFields :: [(ByteString, ByteString, AddPolicy)],+ -- | Fields where CommaStyle should be checked and fixed.+ fixCommas :: [(ByteString, CommaStyle, CommaTrail)],+ -- | Fields where elements should be sorted alphabetically+ sortFieldLines :: [ByteString],+ -- | Whether to sort Fields.+ doSortFields :: Bool,+ -- | The preferred ordering of Fields if they are sorted (lower numbers are placed first).+ fieldOrdering :: [(ByteString, Double)],+ -- | Whether to fix the build dependency Field+ doFixBuildDeps :: Bool,+ -- | How to align build dependencies+ depAlignment :: DepAlignment,+ -- | Whether to remove Fields with no information+ removeBlankFields :: Bool,+ -- | Whether to column-align values+ valueAligned :: ValueAlignment,+ -- | The number of spaces between the field nameand the value, if aligned.+ valueAlignGap :: Int,+ -- | Margin between sections+ sectionMargin :: Margin,+ -- | Margin around comments+ commentMargin :: Margin,+ -- | Shift from narrow style to multi-line beyond this column size.+ narrowN :: Int,+ -- | Indentation value+ indentN :: Int+ }+ deriving (Eq, Show, Read, Generic)++-- | An opinionated configuration for formatting cabal files.+--+-- Some opinions (that can be configured):+--+-- >>> fixCommas defaultConfig+-- [("extra-doc-files",NoCommas,NoTrailer),("build-depends",PrefixCommas,Trailer)]+--+-- 'PrefixCommas' are better for the dependency list as dependency ranges are already noisy enough without a comma thrown in. 'Trailer' (which means leading comma for prefixed commas) is neater and easier to prepend to, append to & sort.+--+-- If a field list doesn't need commas, then they should be removed.+--+-- >>> preferredDeps defaultConfig+-- [("base",">=4.17 && <5")]+--+-- Standard practice compared with the much tighter eg @base ^>=4.17.2.1@+--+-- >>> sortFieldLines defaultConfig+-- ["build-depends","exposed-modules","default-extensions","ghc-options","extra-doc-files","tested-with"]+--+-- Sort all the things, but especially the module list.+--+-- >>> valueAligned defaultConfig+-- ValueUnaligned+--+-- Adding an extra, long-named field to the cabal file means we have to re-align all the value parts in all the other fields.+--+-- >>> depAlignment defaultConfig+-- DepAligned+--+-- build-depends is so busy, however, the extra alignment becomes more important.+--+-- >>> doSortFields defaultConfig+-- True+--+-- Whatever the order, fields should have the same order within each section.+defaultConfig :: Config+defaultConfig =+ Config+ ["description"]+ []+ defaultPreferredDeps+ []+ defaultFixCommas+ defaultFieldLineSorts+ True+ defaultFieldOrdering+ True+ DepAligned+ True+ ValueUnaligned+ 1+ Margin+ NoMargin+ 60+ 4++-- | The style for comma-separated values+data CommaStyle+ = -- | commas before values+ PrefixCommas+ | -- | commas after values+ PostfixCommas+ | -- | comma freedom+ FreeformCommas+ | -- | remove commas (allowed for some fields)+ NoCommas+ deriving (Eq, Show, Read, Generic)++-- | Include a trailing (or leading) comma, after the last value (or before the first value.)+data CommaTrail+ = Trailer+ | NoTrailer+ deriving (Eq, Show, Read, Generic)++-- | Policy for Fields listed in 'addFields'+data AddPolicy+ = -- | Replace existing values+ AddReplace+ | -- | Append after existing values+ AddAppend+ | -- | Add only of the Field doesn't exist+ AddIfNotExisting+ deriving (Eq, Show, Read, Generic)++defaultFixCommas :: [(ByteString, CommaStyle, CommaTrail)]+defaultFixCommas =+ [ ("extra-doc-files", NoCommas, NoTrailer),+ ("build-depends", PrefixCommas, Trailer)+ ]++-- | An opionated ordering of fields.+defaultFieldOrdering :: [(ByteString, Double)]+defaultFieldOrdering = [("cabal-version", 0), ("import", 1), ("main-is", 2), ("default-language", 3), ("name", 4), ("hs-source-dirs", 5), ("version", 6), ("build-depends", 7), ("exposed-modules", 8), ("license", 9), ("license-file", 10), ("other-modules", 11), ("copyright", 12), ("category", 13), ("author", 14), ("default-extensions", 15), ("ghc-options", 16), ("maintainer", 17), ("homepage", 18), ("bug-reports", 19), ("synopsis", 20), ("description", 21), ("build-type", 22), ("tested-with", 23), ("extra-doc-files", 24), ("source-repository", 25), ("type", 26), ("common", 27), ("location", 28), ("library", 29), ("executable", 30), ("test-suite", 31)]++-- An opinionated list of fields whose elements should be sorted.+defaultFieldLineSorts :: [ByteString]+defaultFieldLineSorts =+ [ "build-depends",+ "exposed-modules",+ "default-extensions",+ "ghc-options",+ "extra-doc-files",+ "tested-with"+ ]++-- An opinionated list of preferred builddeps:+--+defaultPreferredDeps :: [(ByteString, ByteString)]+defaultPreferredDeps = [("base", ">=4.17 && <5")]++-- | Whether the value part of each field should be vertically aligned on a column.+data ValueAlignment = ValueAligned | ValueUnaligned deriving (Eq, Show, Read, Generic)++-- | Whether the range part of the dependency list should be vertically aligned on a column.+data DepAlignment = DepAligned | DepUnaligned deriving (Eq, Show, Read)++-- | A margin tracker for combining sections.+data Margin = Margin | NoMargin+ deriving (Eq, Show, Read, Generic)++-- | Collapse margins, any margin = margin+instance Semigroup Margin where+ NoMargin <> NoMargin = NoMargin+ _ <> _ = Margin++-- | Note that cabal does not have multi-line comments+type Comment = [ByteString]++-- | 'Field' list annotated with a 'Comment'+--+-- Note that this type does not contain any position information.+--+-- The construction assumes that comments relate to fields below, so there is potential for an end comment unrelated to any particular field.+data CabalFields = CabalFields {fields :: V.Vector (Field Comment), endComment :: Comment} deriving (Generic, Eq, Show)++instance Semigroup CabalFields where+ (CabalFields fs ec) <> (CabalFields fs' ec') = CabalFields (fs <> fs') (ec <> ec')++instance Monoid CabalFields where+ mempty = CabalFields V.empty []++-- | iso to flip between vectors and lists easily.+--+-- >>> cf & view (#fields % fieldList') & take 2+-- [Field (Name [] "cabal-version") [FieldLine [] "3.0"],Field (Name [] "name") [FieldLine [] "minimal"]]+fieldList' :: Iso' (V.Vector (Field Comment)) [Field Comment]+fieldList' = iso V.toList V.fromList++instance ToExpr (FieldLine Comment) where+ toExpr fl = Rec "FieldLine" (OMap.fromList [("comment", toExpr (fieldLineAnn fl)), ("fieldline", toExpr (fieldLineBS fl))])++instance ToExpr (Name Comment) where+ toExpr n = Rec "Name" (OMap.fromList [("comment", toExpr (nameAnn n)), ("name", toExpr (getName n))])++instance ToExpr (SectionArg Comment) where+ toExpr (SecArgName c bs) = Rec "SecArgName" (OMap.fromList [("comment", toExpr c), ("arg", toExpr bs)])+ toExpr (SecArgStr c bs) = Rec "SecArgStr" (OMap.fromList [("comment", toExpr c), ("arg", toExpr bs)])+ toExpr (SecArgOther c bs) = Rec "SecArgOther" (OMap.fromList [("comment", toExpr c), ("arg", toExpr bs)])++instance ToExpr (Field Comment) where+ toExpr (Field n fls) = Rec "Field" (OMap.fromList [("name", toExpr n), ("field lines", toExpr fls)])+ toExpr (Section n ss fs) = Rec "Section" (OMap.fromList [("name", toExpr n), ("section args", toExpr ss), ("fields", toExpr fs)])++instance ToExpr CabalFields where+ toExpr cf = Rec "CabalFields" (OMap.fromList [("fields", toExpr $ fields cf), ("extras", toExpr $ endComment cf)])++-- | A Prism betwixt a 'ByteString' and a 'CabalFields'.+--+-- >>> cf & over (#fields % fieldList') (take 2) & review (cabalFields' cfg) & C.putStr+-- cabal-version: 3.0+-- name: minimal+cabalFields' :: Config -> Prism' ByteString CabalFields+cabalFields' cfg = prism (printCabalFields cfg) (parseCabalFields cfg)++-- $lenses+--+-- Lensing into 'Field' is tricky.+--+-- A 'Field' is a sum type of a field constructor or a section constructor, and a section contains fields.+--+-- Sometimes you only want to modify a field (and not a section). Other times you want to access a section but not a field. Sometimes you want to modify either a field or a section, and the fields within sections. It can be difficult to remember which lens is which.+--+-- The use of a list is also problematic; it is hard to safely delete a field, and invalid cabals are easily represented. A list can easily contain two name fields say, which is an invalid state. It can contain no name which is also invalid. It is difficult, however, to switch to a map because sections contain lists of fields (and not maps of fields).+--+-- Most useful are lenses that lens into named fields.++-- | A lens that doesn't descend into sections. It will lens the first-encountered named field, if any.+--+-- >>> view (topfield' "name") cf+-- Just (Field (Name [] "name") [FieldLine [] "minimal"])+--+-- >>> view (topfield' "build-depends") cf+-- Nothing+topfield' :: FieldName -> Lens' CabalFields (Maybe (Field Comment))+topfield' name = lens (view (#fields % fieldList' % field' name) >>> listToMaybe) (fieldSet name)++fieldSet :: FieldName -> CabalFields -> Maybe (Field Comment) -> CabalFields+fieldSet name cf f =+ case V.findIndex ((== name) . getName . fieldName) (view #fields cf) of+ Just i -> case f of+ Nothing -> cf & over #fields (\v -> V.take i v <> V.drop (i + 1) v)+ Just f' -> cf & over #fields (\v -> V.take i v <> V.singleton f' <> V.drop (i + 1) v)+ Nothing -> cf & maybe id (over #fields . (\f -> (<> V.singleton f))) f++-- | A lens by name into a field (but not a section).+--+-- >>> fs & view (field' "version")+-- [Field (Name [] "version") [FieldLine [] "0.1.0.0"]]+field' :: FieldName -> Getter [Field Comment] [Field Comment]+field' name = to (filter (not . isSection) . filter (isName name))++-- | A getter by name into a field (including within sections)+--+-- >>> fs & toListOf (each % subfield' "default-language")+-- [[],[],[],[],[],[],[],[],[Field (Name [] "default-language") [FieldLine [] "GHC2021"]],[Field (Name [] "default-language") [FieldLine [] "GHC2021"]]]+subfield' :: FieldName -> Getter (Field Comment) [Field Comment]+subfield' name = to (subfield_ name)++subfield_ :: FieldName -> Field ann -> [Field ann]+subfield_ name f = filter (isName name) $ fieldUniverse f++-- | A getter of a section (not a field)+--+-- >>> fs & foldOf (section' "library" % each % secFields' % field' "exposed-modules")+-- [Field (Name [] "exposed-modules") [FieldLine [] "MyLib"]]+section' :: FieldName -> Getter [Field ann] [Field ann]+section' name = to (filter (\f -> isName name f && isSection f))++-- | A getter of section fields+secFields' :: Lens' (Field ann) [Field ann]+secFields' = lens secFieldsView secFieldsSet++secFieldsSet :: Field ann -> [Field ann] -> Field ann+secFieldsSet f@(Field {}) _ = f+secFieldsSet (Section n sa _) fs = Section n sa fs++secFieldsView :: Field ann -> [Field ann]+secFieldsView (Field {}) = []+secFieldsView (Section _ _ fs) = fs++-- | A getter by name of a field or section.+fieldOrSection' :: FieldName -> Getter [Field ann] [Field ann]+fieldOrSection' name = to (filter (isName name))++isName :: FieldName -> Field ann -> Bool+isName name = (== name) . view fieldName'++isSection :: Field ann -> Bool+isSection (Section {}) = True+isSection (Field {}) = False++-- | A mapping into the field structure, operating on field lists in sections as well as the field itself.+overField :: (Field ann -> Field ann) -> Field ann -> Field ann+overField f' f@(Field {}) = f' f+overField f' (Section n sa fs) = Section n sa (fmap (overField f') fs)++-- | A mapping into the field structure, operating on field lists in sections as well as field lists themselves.+overFields :: ([Field ann] -> [Field ann]) -> [Field ann] -> [Field ann]+overFields f fs = f $ fmap inner fs+ where+ inner f'@(Field {}) = f'+ inner (Section n sa fs') = Section n sa (overFields f fs')++-- | Project name. Errors if the field is missing.+--+-- >>> pname cf+-- "minimal"+pname :: CabalFields -> ByteString+pname cf = cf & preview (topfield' "name" % _Just % fieldLines' % ix 0 % to fieldLineBS) & fromMaybe (error "no name field")++-- | Name of (field or section).+--+-- >>> head fs & view fieldName'+-- "cabal-version"+fieldName' :: Lens' (Field ann) ByteString+fieldName' = lens (fieldName >>> getName) fieldNameSet+ where+ fieldNameSet (Field (Name ann _) fls) name = Field (Name ann name) fls+ fieldNameSet (Section (Name ann _) sa fs) name = Section (Name ann name) sa fs++inNameList :: [ByteString] -> Field ann -> Bool+inNameList ns f = view fieldName' f `elem` ns++-- | Lens into field lines+--+-- >>> fs & foldOf (section' "test-suite" % each % secFields' % field' "build-depends" % each % fieldLines')+-- [FieldLine [] "base ^>=4.17.2.1,",FieldLine [] "minimal"]+fieldLines' :: Lens' (Field ann) [FieldLine ann]+fieldLines' = lens fieldFieldLinesView fieldFieldLinesSet++fieldFieldLinesView :: Field ann -> [FieldLine ann]+fieldFieldLinesView (Field _ fls) = fls+fieldFieldLinesView _ = []++fieldFieldLinesSet :: Field ann -> [FieldLine ann] -> Field ann+fieldFieldLinesSet (Field n _) fls = Field n fls+fieldFieldLinesSet _ _ = error "setting a section field line"++-- * SectionArg++-- | lens into SectionArg part of a section.+--+-- Errors if you actually have a field.+--+-- >>> fs & foldOf (section' "test-suite" % each % secArgs')+-- [SecArgName [] "minimal-test"]+secArgs' :: Lens' (Field ann) [SectionArg ann]+secArgs' = lens secArgView secArgSet++secArgView :: Field ann -> [SectionArg ann]+secArgView (Field {}) = error "not a section"+secArgView (Section _ a _) = a++secArgSet :: Field ann -> [SectionArg ann] -> Field ann+secArgSet (Field {}) _ = error "not a section"+secArgSet (Section n _ fs) a = Section n a fs++-- | secArg lens into a ByteString representation+--+-- >>> fs & foldOf (section' "test-suite" % each % secArgs' % each % secArgBS')+-- ("name","minimal-test")+secArgBS' :: Lens' (SectionArg ann) (ByteString, ByteString)+secArgBS' = lens secArgBSView secArgBSSet++secArgBSView :: SectionArg a -> (ByteString, ByteString)+secArgBSView (SecArgName _ n) = ("name", n)+secArgBSView (SecArgStr _ n) = ("str", n)+secArgBSView (SecArgOther _ n) = ("other", n)++secArgBSSet :: SectionArg ann -> (ByteString, ByteString) -> SectionArg ann+secArgBSSet sa (t, a) = case t of+ "name" -> SecArgName (sectionArgAnn sa) a+ "str" -> SecArgStr (sectionArgAnn sa) a+ _ -> SecArgOther (sectionArgAnn sa) a++-- | lens into field line contents.+--+-- >>> fs & toListOf (section' "test-suite" % each % secFields' % field' "build-depends" % each % fieldLines' % each % fieldLine')+-- ["base ^>=4.17.2.1,","minimal"]+fieldLine' :: Lens' (FieldLine ann) ByteString+fieldLine' = lens fieldLineBS setValueFL+ where+ setValueFL (FieldLine ann _) = FieldLine ann++-- | A fold of a field list into a ByteString.+fieldValues' :: FieldName -> Optic A_Fold '[Int, Int] [Field Comment] [Field Comment] ByteString ByteString+fieldValues' name = field' name % each % fieldLines' % each % fieldLine'++-- * fixes++-- | fix order:+--+-- - removes fields+--+-- - removes blank fields+--+-- - fixes commas+--+-- - adds Fields+--+-- - fix build dependencies+--+-- - sort field lines+--+-- - sort fields+fixCabalFields :: Config -> CabalFields -> CabalFields+fixCabalFields cfg cf =+ cf+ & over+ (#fields % fieldList')+ ( overFields (filter (not . inNameList (fieldRemovals cfg)))+ >>> overFields (bool id (filter (not . isBlankField)) (removeBlankFields cfg))+ >>> fmap (overField (fixesCommas cfg))+ >>> addsFields cfg+ >>> bool id (fmap (overField (fixBuildDeps cfg (pname cf)))) (doFixBuildDeps cfg)+ >>> fmap (overField (sortFieldLinesFor (sortFieldLines cfg)))+ >>> bool id (overFields (sortFields cfg)) (doSortFields cfg)+ )++-- | Fix a cabal file in-place+fixCabalFile :: FilePath -> Config -> IO Bool+fixCabalFile fp cfg = do+ bs <- BS.readFile fp+ maybe+ (pure False)+ (\cf -> BS.writeFile fp (printCabalFields cfg (fixCabalFields cfg cf)) >> pure True)+ (preview (cabalFields' cfg) bs)++-- * blank field removal++-- | Is the field blank (including has no section arguments if a section)+isBlankField :: Field ann -> Bool+isBlankField (Field _ fs) = null fs+isBlankField (Section _ sas fss) = null fss && null sas++-- * commas++-- | Fix the comma usage in a field list+--+-- >>> fs & toListOf (section' "test-suite" % each % secFields' % field' "build-depends" % each) & fmap (fixesCommas cfg)+-- [Field (Name [] "build-depends") [FieldLine [] ", base ^>=4.17.2.1",FieldLine [] ", minimal"]]+fixesCommas :: Config -> Field ann -> Field ann+fixesCommas cfg x = foldl' (&) x $ fixCommas cfg & fmap (\(n, s, t) -> bool id (fixCommasF s t) ((== n) $ view fieldName' x))++addCommaBS :: CommaStyle -> CommaTrail -> [ByteString] -> [ByteString]+addCommaBS commaStyle trailStyle xs = case trailStyle of+ NoTrailer -> case commaStyle of+ PostfixCommas -> ((<> ",") <$> init xs) <> [last xs]+ PrefixCommas -> head xs : ((", " <>) <$> tail xs)+ -- since we don't know the prior comma strategy, we just guess here.+ FreeformCommas -> ((<> ",") <$> init xs) <> [last xs]+ NoCommas -> xs+ Trailer -> case commaStyle of+ PostfixCommas -> (<> ",") <$> xs+ PrefixCommas -> (", " <>) <$> xs+ -- since we don't know the prior comma strategy, we just guess here.+ FreeformCommas -> (<> ",") <$> xs+ NoCommas -> xs++stripCommaBS :: ByteString -> ByteString+stripCommaBS bs =+ C.stripPrefix ", " bs+ & fromMaybe+ ( C.stripPrefix "," bs+ & fromMaybe+ ( C.stripSuffix "," bs+ & fromMaybe bs+ )+ )++fixCommasF :: CommaStyle -> CommaTrail -> Field ann -> Field ann+fixCommasF s t f = fls'+ where+ fls = toListOf (fieldLines' % each % fieldLine') f+ fls' = set fieldLines' (zipWith (set fieldLine') (addCommaBS s t $ fmap stripCommaBS fls) (view fieldLines' f)) f++-- | add fields+--+-- >>> addsFields (cfg & set #addFields [("description", "added by addsFields", AddReplace)]) []+-- [Field (Name [] "description") [FieldLine [] "added by addsFields"]]+addsFields :: Config -> [Field Comment] -> [Field Comment]+addsFields cfg x = foldl' (&) x $ addFields cfg & fmap (\(n, v, p) -> addField p (Field (Name [] n) [FieldLine [] v]))++-- | Add a field according to an AddPolicy.+addField :: AddPolicy -> Field ann -> [Field ann] -> [Field ann]+addField p f fs = case p of+ AddReplace -> notsames <> [f]+ AddAppend -> fs <> [f]+ AddIfNotExisting -> bool fs (fs <> [f]) (null sames)+ where+ sames = filter ((view fieldName' f ==) . view fieldName') fs+ notsames = filter ((view fieldName' f /=) . view fieldName') fs++-- | Align dependencies (if depAlignment is DepAligned), remove ranges for any self-dependency, and substitute preferred dependency ranges.+--+-- >>> fs & toListOf (section' "test-suite" % each % secFields' % field' "build-depends" % each) & fmap (fixBuildDeps cfg "minimal")+-- [Field (Name [] "build-depends") [FieldLine [] ", base >=4.17 && <5",FieldLine [] ", minimal"]]+fixBuildDeps :: Config -> FieldName -> Field ann -> Field ann+fixBuildDeps cfg pname f = overField (bool id (over fieldLines' (fixBDLines cfg pname)) (isName "build-depends" f)) f++fixBDLines :: Config -> ByteString -> [FieldLine ann] -> [FieldLine ann]+fixBDLines cfg libdep fls = fls'+ where+ align = depAlignment cfg+ deps = [x | (Right x) <- parseDepFL <$> fls]+ pds = addCommaBS commaStyle trailStyle $ printDepsPreferred cfg libdep align deps+ fls' = zipWith (set fieldLine') pds fls++ (commaStyle, trailStyle) =+ maybe+ (PostfixCommas, NoTrailer)+ (\(_, x, y) -> (x, y))+ (find ((== "build-depends") . (\(x, _, _) -> x)) (fixCommas cfg))++-- | Split of a dependency 'FieldLine' into the dependency name and the range.+data Dep = Dep {dep :: ByteString, depRange :: ByteString} deriving (Show, Ord, Eq, Generic)++normDepRange :: ByteString -> ByteString+normDepRange dr = (maybe dr (C.pack . show . pretty) . (simpleParsecBS :: ByteString -> Maybe VersionRange)) dr++printDepPreferred :: Config -> ByteString -> Int -> Dep -> ByteString+printDepPreferred cfg libd n (Dep d r) = C.intercalate (C.pack $ replicate n ' ') ([d] <> rs)+ where+ r' = bool (fromMaybe (normDepRange r) (Map.lookup d (Map.fromList (preferredDeps cfg)))) (normDepRange r) (libd == d)+ rs = bool [r'] [] (r' == "")++printDepsPreferred :: Config -> ByteString -> DepAlignment -> [Dep] -> [ByteString]+printDepsPreferred cfg libd DepUnaligned ds = printDepPreferred cfg libd 1 <$> ds+printDepsPreferred cfg libd DepAligned ds = zipWith (printDepPreferred cfg libd) ns ds+ where+ ls = BS.length . dep <$> ds+ ns = (\x -> maximum ls - x + 1) <$> ls++parseDepFL :: FieldLine ann -> Either ByteString Dep+parseDepFL fl = uncurry Dep <$> runParserEither depP (view fieldLine' fl)++-- | sort field lines for listed fields+sortFieldLinesFor :: [ByteString] -> Field ann -> Field ann+sortFieldLinesFor ns f@(Field n fl) =+ Field n (bool fl (List.sortOn fieldLineBS fl) (view fieldName' f `elem` ns))+sortFieldLinesFor ns (Section n a fss) = Section n a (sortFieldLinesFor ns <$> fss)++-- | sorting fields, based on fieldOrdering configuration.+--+-- A secondary ordering is based on the first fieldline (for fields) or section args (for sections).+sortFields :: Config -> [Field ann] -> [Field ann]+sortFields cfg fs = overFields (List.sortOn (\f -> (fromMaybe 100 (Map.lookup (view fieldName' f) (Map.fromList $ fieldOrdering cfg)), name2 f))) fs++name2 :: Field ann -> Maybe ByteString+name2 (Field _ fl) = listToMaybe (fieldLineBS <$> fl)+name2 (Section _ a _) = listToMaybe $ snd . view secArgBS' <$> a++-- | Printing+--+-- Convert a 'CabalFields' to a 'ByteString'+--+-- >>> printCabalFields cfg (cf & over (#fields % fieldList') (take 4)) & C.putStr+-- cabal-version: 3.0+-- name: minimal+-- version: 0.1.0.0+-- license: BSD-2-Clause+printCabalFields :: Config -> CabalFields -> ByteString+printCabalFields cfg cf =+ ( C.pack+ . showFieldsIndent cfg fComment (const id) (indentN cfg)+ . fmap (fmap (fmap C.unpack))+ . printFieldsComments+ $ view (#fields % fieldList') cf+ )+ <> C.unlines (view #endComment cf)+ where+ fComment [] = NoComment+ fComment xs = CommentBefore xs++printFieldsComments :: [Field [ByteString]] -> [PrettyField [ByteString]]+printFieldsComments =+ runIdentity+ . genericFromParsecFields+ (Identity .: prettyFieldLines)+ (Identity .: prettySectionArgs)+ where+ (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b)+ (f .: g) x y = f (g x y)++-- | Used in 'fromParsecFields'.+prettyFieldLines :: FieldName -> [FieldLine [ByteString]] -> PP.Doc+prettyFieldLines _ fls =+ PP.vcat $+ mconcat $+ [ PP.text . fromUTF8BS <$> cs <> [bs]+ | FieldLine cs bs <- fls+ ]++-- | Used in 'fromParsecFields'.+prettySectionArgs :: FieldName -> [SectionArg [ByteString]] -> [PP.Doc]+prettySectionArgs _ =+ fmap $+ mconcat . \case+ SecArgName cs bs -> showToken . fromUTF8BS <$> cs <> [bs]+ SecArgStr cs bs -> showToken . fromUTF8BS <$> cs <> [bs]+ SecArgOther cs bs -> PP.text . fromUTF8BS <$> cs <> [bs]++-- | 'showFields' with user specified indentation.+showFieldsIndent ::+ Config ->+ -- | Convert an annotation to lined to preceed the field or section.+ (ann -> CommentPosition) ->+ -- | Post-process non-annotation produced lines.+ (ann -> [String] -> [String]) ->+ -- | Indentation level.+ Int ->+ -- | Fields/sections to show.+ [PrettyField ann] ->+ String+showFieldsIndent cfg rann post n = unlines . renderFields cfg (Opts rann indent post)+ where+ -- few hardcoded, "unrolled" variants.+ indent+ | n == 4 = indent4+ | n == 2 = indent2+ | otherwise = (replicate (max n 1) ' ' ++)++ indent4 :: String -> String+ indent4 [] = []+ indent4 xs = ' ' : ' ' : ' ' : ' ' : xs++ indent2 :: String -> String+ indent2 [] = []+ indent2 xs = ' ' : ' ' : xs++data Opts ann = Opts+ { _optAnnotation :: ann -> CommentPosition,+ _optIndent :: String -> String,+ _optPostprocess :: ann -> [String] -> [String]+ }++renderFields :: Config -> Opts ann -> [PrettyField ann] -> [String]+renderFields cfg opts fields = flattenBlocks blocks+ where+ len = maxNameLength 0 fields+ blocks =+ filter (not . null . _contentsBlock) $ -- empty blocks cause extra newlines #8236+ map (renderField cfg opts len) fields++ maxNameLength !acc [] = acc+ maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest+ maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest+ maxNameLength !acc (PrettyEmpty : rest) = maxNameLength acc rest++-- | Block of lines with flags for optional blank lines before and after+data Block = Block+ { _beforeBlock :: Margin,+ _afterBlock :: Margin,+ _contentsBlock :: [String]+ }+ deriving (Show, Eq, Read, Generic)++flattenBlocks :: [Block] -> [String]+flattenBlocks = go0+ where+ go0 [] = []+ go0 (Block _before after strs : blocks) = strs ++ go after blocks++ go _surr' [] = []+ go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks+ where+ ins+ | surr' <> before == Margin = ("" :)+ | otherwise = id++lines_ :: String -> [String]+lines_ [] = []+lines_ s = lines s <> bool [] [""] ((== '\n') . last $ s)++renderField :: Config -> Opts ann -> Int -> PrettyField ann -> Block+renderField cfg (Opts rann indent post) fw (PrettyField ann name doc) =+ Block before after content+ where+ content = case comments of+ CommentBefore cs -> cs ++ post ann lines'+ CommentAfter cs -> post ann lines' ++ cs+ NoComment -> post ann lines'+ comments = rann ann+ before = case comments of+ CommentBefore [] -> NoMargin+ CommentAfter [] -> NoMargin+ NoComment -> NoMargin+ _ -> commentMargin cfg++ (lines', after) = case lines_ narrow of+ [] -> ([name' ++ ":"], NoMargin)+ [singleLine]+ | length singleLine < narrowN cfg ->+ ([name' ++ ": " ++ replicate (bool 0 (fw - length name' + (valueAlignGap cfg - 1)) (valueAligned cfg == ValueAligned)) ' ' ++ narrow], NoMargin)+ _ -> ((name' ++ ":") : map indent (lines_ (PP.render doc)), NoMargin)++ name' = fromUTF8BS name+ narrow = PP.renderStyle narrowStyle doc++ narrowStyle :: PP.Style+ narrowStyle = PP.style {PP.lineLength = PP.lineLength PP.style - fw}+renderField cfg opts@(Opts rann indent post) _ (PrettySection ann name args fields) =+ Block (sectionMargin cfg) (sectionMargin cfg) $+ attachComments+ (post ann [PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args])+ ++ map indent (renderFields cfg opts fields)+ where+ attachComments content = case rann ann of+ CommentBefore cs -> cs ++ content+ CommentAfter cs -> content ++ cs+ NoComment -> content+renderField _ _ _ PrettyEmpty = Block NoMargin NoMargin mempty++-- | Parse a 'ByteString' into a 'CabalFields'. Failure is possible.+--+-- >>> bs & C.lines & take 4 & C.unlines & parseCabalFields cfg+-- Right (CabalFields {fields = [Field (Name [] "cabal-version") [FieldLine [] "3.0"],Field (Name [] "name") [FieldLine [] "minimal"],Field (Name [] "version") [FieldLine [] "0.1.0.0"],Field (Name [] "license") [FieldLine [] "BSD-2-Clause"]], endComment = []})+parseCabalFields :: Config -> ByteString -> Either ByteString CabalFields+parseCabalFields cfg bs = case readFields bs of+ Left err -> Left $ C.pack (show err)+ Right fps ->+ (\(fs, ec) -> Right (CabalFields (V.fromList fs) ec)) $+ foldl' (&) (fmap (fmap (const [])) fs, []) (uncurry addComment <$> cfs)+ where+ fs = convertFreeTexts (view #freeTexts cfg) fps+ cs = extractComments bs+ pt = Map.toList $ makePositionTree fs+ cfs = fmap (first (fmap snd)) (first (fmap (pt List.!!) . (\x -> List.findIndex (\e -> fst e > x) pt)) <$> cs)++convertFreeText :: [ByteString] -> Field Position -> Field Position+convertFreeText freeTexts f@(Field n fls) = bool f (Field n (convertToFreeText fls)) (inNameList freeTexts f)+convertFreeText freeTexts (Section n a fss) = Section n a (convertFreeTexts freeTexts fss)++convertFreeTexts :: [ByteString] -> [Field Position] -> [Field Position]+convertFreeTexts freeTexts fs = snd $ foldl' step (Nothing, []) fs+ where+ step :: (Maybe (Field Position), [Field Position]) -> Field Position -> (Maybe (Field Position), [Field Position])+ step (Nothing, res) nextFP = case inNameList freeTexts nextFP of+ True -> (Just (convertFreeText freeTexts nextFP), res)+ False -> (Nothing, res <> [nextFP])+ step (Just freeFP, res) nextFP = case inNameList freeTexts nextFP of+ True -> (Just (convertFreeText freeTexts nextFP), res <> [freeFP'])+ False -> (Nothing, res <> [freeFP', nextFP])+ where+ (Field n fls) = freeFP+ c1 = firstCol nextFP+ c0 = fromMaybe c1 $ firstColFls freeFP+ (FieldLine ann fls') = fromMaybe (FieldLine (Position 0 0) "") (listToMaybe fls)+ freeFP' = Field n [FieldLine ann (fls' <> C.pack (replicate (c1 - c0 - length (C.lines fls')) '\n'))]++firstCol :: Field Position -> Int+firstCol (Field (Name (Position c _) _) _) = c+firstCol (Section (Name (Position c _) _) _ _) = c++firstColFls :: Field Position -> Maybe Int+firstColFls (Field _ []) = Nothing+firstColFls (Field _ ((FieldLine (Position c _) _) : _)) = Just c+firstColFls (Section {}) = error "no field lines in a section"++convertToFreeText :: [FieldLine Position] -> [FieldLine Position]+convertToFreeText [] = []+convertToFreeText ((FieldLine (Position r0 c0) bs0) : xs) = [FieldLine (Position r0 c0) x]+ where+ x = mconcat $ snd $ foldl' (\(r', xs') (FieldLine (Position r _) bs) -> (r, xs' <> replicate (r - r') "\n" <> [bs])) (r0, [bs0]) xs++extractComments :: BS.ByteString -> [(Int, Comment)]+extractComments = go . zip [1 ..] . map (BS.dropWhile isSpace8) . C.lines+ where+ go :: [(Int, BS.ByteString)] -> [(Int, Comment)]+ go [] = []+ go ((n, bs) : rest)+ | isComment bs = case span ((isComment .|| BS.null) . snd) rest of+ (h, t) -> (n, bs : map snd h) : go t+ | otherwise = go rest++ (f .|| g) x = f x || g x++ isSpace8 w = w == 9 || w == 32++ isComment :: BS.ByteString -> Bool+ isComment = BS.isPrefixOf "--"++data FieldPath+ = End+ | Nth Int FieldPath -- nth field+ deriving (Eq, Ord, Show)++makePositionTree :: [Field Position] -> Map.Map Int ([Int], String)+makePositionTree fs = foldFss Map.empty [] fs+ where+ foldFss m cursor fs = fst $ foldl' stepFss (m, cursor <> [0]) fs+ stepFss (m, cursor) (Field (Name (Position c _) _) fls) =+ (foldFls (Map.insertWith (\_ o -> o) c (cursor, "fieldname") m) cursor fls, inc cursor)+ stepFss (m, cursor) (Section (Name (Position c _) _) sas fss) =+ (foldFss (foldSas (Map.insertWith (\_ o -> o) c (cursor, "sectionname") m) cursor sas) cursor fss, inc cursor)+ foldFls m c fls = fst $ foldl' stepFls (m, c <> [0]) fls+ stepFls (m, cursor) (FieldLine (Position c _) _) = (Map.insertWith (\_ o -> o) c (cursor, "fieldline") m, inc cursor)+ foldSas m c sas = fst $ foldl' stepSas (m, c <> [0]) (sectionArgAnn <$> sas)+ stepSas (m, cursor) (Position c _) = (Map.insertWith (\_ o -> o) c (cursor, "sectionarg") m, inc cursor)++ inc :: [Int] -> [Int]+ inc [] = []+ inc xs = reverse (1 + last xs : drop 1 (reverse xs))++addComment :: Maybe ([Int], String) -> [ByteString] -> ([Field [ByteString]], [ByteString]) -> ([Field [ByteString]], [ByteString])+addComment Nothing cs (fs, extras) = (fs, extras <> cs)+addComment (Just (cursor, tag)) cs (fs, extras) = (addc cs cursor tag fs, extras)++addc :: [ByteString] -> [Int] -> String -> [Field [ByteString]] -> [Field [ByteString]]+addc comments [] _ fs = fs+addc comments [x] "fieldname" fs = take x fs <> [f'] <> drop (x + 1) fs+ where+ (Field (Name cs n) fls) = (List.!!) fs x+ f' = Field (Name (cs <> comments) n) fls+addc comments [x] "sectionname" fs = take x fs <> [f'] <> drop (x + 1) fs+ where+ (Section (Name cs n) a fss) = (List.!!) fs x+ f' = Section (Name (cs <> comments) n) a fss+addc comments [x, y] "fieldline" fs = take x fs <> [f'] <> drop (x + 1) fs+ where+ (Field n fls) = (List.!!) fs x+ (FieldLine cs bs) = (List.!!) fls y+ fl' = FieldLine (cs <> comments) bs+ f' = Field n (take y fls <> [fl'] <> drop (y + 1) fls)+addc comments [x, y] "sectionarg" fs = take x fs <> [f'] <> drop (x + 1) fs+ where+ (Section n sas fss) = (List.!!) fs x+ sa' = (<> comments) <$> (List.!!) sas y+ f' = Section n (take y sas <> [sa'] <> drop (y + 1) sas) fss+addc comments (x : xs) tag fs = take x fs <> [f'] <> drop (x + 1) fs+ where+ (Section n a fss) = (List.!!) fs x+ f' = Section n a (addc comments xs tag fss)++-- | Minimal cabal file contents for testing purposes. Originally created via:+--+-- > mkdir minimal && cd minimal && cabal init --minimal --simple --overwrite --lib --tests --language=GHC2021 --license=BSD-2-Clause -p minimal+minimalExampleBS :: ByteString+minimalExampleBS =+ [i|cabal-version: 3.0+name: minimal+version: 0.1.0.0+license: BSD-2-Clause+license-file: LICENSE+build-type: Simple+extra-doc-files: CHANGELOG.md++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: MyLib+ build-depends: base ^>=4.17.2.1+ hs-source-dirs: src+ default-language: GHC2021++test-suite minimal-test+ import: warnings+ default-language: GHC2021+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends:+ base ^>=4.17.2.1,+ minimal|]++-- | A config close to the @cabal init@ styles.+minimalConfig :: Config+minimalConfig =+ Config+ { freeTexts = ["description"],+ fieldRemovals = [],+ preferredDeps =+ [ ( "base",+ ">=4.17 && <5"+ )+ ],+ addFields = [],+ fixCommas =+ [ ( "extra-doc-files",+ NoCommas,+ NoTrailer+ ),+ ( "build-depends",+ PostfixCommas,+ NoTrailer+ )+ ],+ sortFieldLines =+ [ "build-depends",+ "exposed-modules",+ "default-extensions",+ "ghc-options",+ "extra-doc-files",+ "tested-with"+ ],+ doSortFields = True,+ fieldOrdering =+ [ ( "cabal-version",+ 0.0+ ),+ ( "import",+ 1.0+ ),+ ( "main-is",+ 2.0+ ),+ ( "default-language",+ 8.6+ ),+ ( "name",+ 4.0+ ),+ ( "hs-source-dirs",+ 8.4+ ),+ ( "version",+ 6.0+ ),+ ( "build-depends",+ 8.2+ ),+ ( "exposed-modules",+ 8.0+ ),+ ( "license",+ 9.0+ ),+ ( "license-file",+ 10.0+ ),+ ( "other-modules",+ 11.0+ ),+ ( "copyright",+ 12.0+ ),+ ( "category",+ 13.0+ ),+ ( "author",+ 14.0+ ),+ ( "default-extensions",+ 15.0+ ),+ ( "ghc-options",+ 16.0+ ),+ ( "maintainer",+ 17.0+ ),+ ( "homepage",+ 18.0+ ),+ ( "bug-reports",+ 19.0+ ),+ ( "synopsis",+ 20.0+ ),+ ( "description",+ 21.0+ ),+ ( "build-type",+ 22.0+ ),+ ( "tested-with",+ 23.0+ ),+ ( "extra-doc-files",+ 24.0+ ),+ ( "source-repository",+ 25.0+ ),+ ( "type",+ 26.0+ ),+ ( "common",+ 27.0+ ),+ ( "location",+ 28.0+ ),+ ( "library",+ 29.0+ ),+ ( "executable",+ 30.0+ ),+ ( "test-suite",+ 31.0+ )+ ],+ doFixBuildDeps = True,+ depAlignment = DepAligned,+ removeBlankFields = True,+ valueAligned = ValueAligned,+ valueAlignGap = 1,+ sectionMargin = Margin,+ commentMargin = Margin,+ narrowN = 60,+ indentN = 4+ }
+ src/CabalFix/Archive.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++-- | Archive investigation+module CabalFix.Archive where++import Algebra.Graph+import Algebra.Graph.ToGraph qualified as ToGraph+import CabalFix+import CabalFix.FlatParse (depP, runParser_, untilP)+import Codec.Archive.Tar qualified as Tar+import Control.Category ((>>>))+import Data.Bifunctor+import Data.Bool+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.Either+import Data.Foldable+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Set qualified as Set+import Distribution.Parsec+import Distribution.Version+import DotParse qualified as Dot+import FlatParse.Basic qualified as FP+import GHC.Generics+import Optics.Extra+import System.Directory++-- | the cabal index+cabalIndex :: IO FilePath+cabalIndex = do+ h <- getHomeDirectory+ pure $ h <> "/.cabal/packages/hackage.haskell.org/01-index.tar"++-- | all the tar entries that represent packages of some kind.+cabalEntries :: IO [Tar.Entry]+cabalEntries = entryList . Tar.read <$> (BSL.readFile =<< cabalIndex)+ where+ entryList es = Tar.foldEntries (:) [] (error . show) es++-- | The naming convention in 01-index.tar+data FileName = FileName {nameFN :: ByteString, versionFN :: ByteString, filenameFN :: ByteString} deriving (Generic, Eq, Ord, Show)++-- | Convert a ByteString to a FileName. Errors on failure.+filename :: ByteString -> FileName+filename = runParser_ filenameP++-- | FileName parser+filenameP :: FP.Parser e FileName+filenameP = FileName <$> untilP '/' <*> untilP '/' <*> FP.takeRest++-- | cabal files+--+-- Discards stale versions with later revisions+cabals :: IO [(FileName, ByteString)]+cabals = do+ es <- cabalEntries+ let cs = first (runParser_ filenameP . FP.strToUtf8) <$> filter ((/= "package.json") . filenameFN . runParser_ filenameP . FP.strToUtf8 . fst) (filter (not . List.isSuffixOf "preferred-versions" . fst) $ [(fp, BSL.toStrict bs) | (fp, Tar.NormalFile bs _) <- (\e -> (Tar.entryPath e, Tar.entryContent e)) <$> es])+ pure $ Map.toList $ Map.fromList cs++-- | Assumes cabal entries are in chronological order and that the last version encountered is the+-- latest valid one.+latestCabals :: IO (Map.Map ByteString (Version, ByteString))+latestCabals = do+ cs <- CabalFix.Archive.cabals+ pure $ Map.fromListWith (\new old -> bool old new (fst new >= fst old)) $ (\(fn, bs) -> (nameFN fn, (getVersion fn, bs))) <$> cs+ where+ getVersion = fromMaybe undefined . simpleParsecBS . versionFN++-- | Latest successfully parsing 'CabalFields'+latestCabalFields :: Config -> IO (Map.Map ByteString (Version, CabalFields))+latestCabalFields cfg = do+ lcs <- latestCabals+ let lcs' = second (parseCabalFields cfg) <$> lcs+ pure (second (fromRight undefined) <$> Map.filter (snd >>> isRight) lcs')++-- | extract library build-deps from a Field list, also looking in common stanzas+libDeps :: CabalFields -> [Dep]+libDeps cf = deps+ where+ libFields = cf & foldOf (#fields % fieldList' % section' "library" % each % secFields')+ libBds = libFields & foldOf (fieldValues' "build-depends")+ libDeps = runParser_ (FP.many depP) libBds+ libImports = libFields & toListOf (fieldValues' "import")+ cs = cf & foldOf (#fields % fieldList' % section' "common")+ libCommons = cs & filter (all (`elem` libImports) . toListOf (secArgs' % each % secArgBS' % _2))+ commonsBds = libCommons & foldOf (fieldValues' "build-depends")+ commonsDeps = runParser_ (FP.many depP) commonsBds+ deps = fmap (uncurry Dep) (libDeps <> commonsDeps)++-- | Map of valid dependencies+validLibDeps :: Map.Map ByteString CabalFields -> Map.Map ByteString [ByteString]+validLibDeps cs = ldeps+ where+ vlls = cs & Map.filter (view (#fields % fieldList' % section' "library") >>> length >>> (> 0))+ ldeps' = vlls & fmap (libDeps >>> fmap dep >>> List.nub)+ bdnames = List.nub $ mconcat (snd <$> Map.toList ldeps')+ -- dependencies that do not exist in the main library list+ bdnames0 = filter (not . (`elem` Map.keys ldeps')) bdnames+ -- Exclude any library that has dependencies outside the universe.+ ldeps = ldeps' & Map.filter (any (`List.elem` bdnames0) >>> not)++-- | Graph of all valid dependencies+allDepGraph :: Map.Map ByteString CabalFields -> Graph ByteString+allDepGraph cs = transpose $ stars (Map.toList (validLibDeps cs))++-- | count distinct elements of a list.+count_ :: (Ord a) => [a] -> Map.Map a Int+count_ = foldl' (\x a -> Map.insertWith (+) a 1 x) Map.empty++-- | collect distinct monoidal values+collect_ :: (Ord k) => [(k, v)] -> Map.Map k [v]+collect_ = foldl' (\x (k, v) -> Map.insertWith (<>) k [v] x) Map.empty++-- | Get the set of upstream projects+upstreams :: ByteString -> Graph ByteString -> Set.Set ByteString+upstreams x g = Set.delete "base" $ ToGraph.preSet x g++-- | Get the set of downstream projects.+downstreams :: ByteString -> Graph ByteString -> Set.Set ByteString+downstreams x g = ToGraph.postSet x g++-- | Get the upstream graph of a library. text, for example:+upstreamG :: ByteString -> Graph ByteString -> Graph ByteString+upstreamG lib g = induce (`elem` toList supers) g+ where+ supers = upstreams lib g <> Set.singleton "text"++-- | Create a dot graph from an algebraic graph of dependencies+dotUpstream :: Graph ByteString -> ByteString+dotUpstream g = Dot.dotPrint Dot.defaultDotConfig g'+ where+ baseGraph = Dot.defaultGraph & Dot.attL Dot.GraphType (Dot.ID "size") .~ Just (Dot.IDQuoted "5!") & Dot.attL Dot.NodeType (Dot.ID "shape") .~ Just (Dot.ID "box") & Dot.attL Dot.NodeType (Dot.ID "height") .~ Just (Dot.ID "2") & Dot.gattL (Dot.ID "rankdir") .~ Just (Dot.IDQuoted "TB")+ g' = Dot.toDotGraphWith Dot.Directed baseGraph g++-- | make an svg file of a dependency graph+--+-- +dotUpstreamSvg :: Graph ByteString -> FilePath -> IO ByteString+dotUpstreamSvg g svg = Dot.processDotWith Dot.Directed ["-Tsvg", "-o" <> svg] (dotUpstream g)
+ src/CabalFix/FlatParse.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Various <https://hackage.haskell.org/package/flatparse flatparse> helpers and combinators.+module CabalFix.FlatParse+ ( -- * Parsing+ ParserWarning (..),+ runParserMaybe,+ runParserEither,+ runParserWarn,+ runParser_,+ runParser__,++ -- * Flatparse re-exports+ runParser,+ Parser,+ Result (..),++ -- * Parsers+ depP,+ versionP,+ versionInts,+ untilP,+ nota,+ ws_,+ ws,+ )+where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as C+import Data.Char hiding (isDigit)+import Data.These+import FlatParse.Basic hiding (cut, take)+import GHC.Exts+import GHC.Generics (Generic)+import Prelude hiding (replicate)++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -XOverloadedStrings+-- >>> import CabalFix.FlatParse+-- >>> import FlatParse.Basic++-- | Run a Parser, throwing away leftovers. Nothing on 'Fail' or 'Err'.+runParserMaybe :: Parser e a -> ByteString -> Maybe a+runParserMaybe p b = case runParser p b of+ OK r _ -> Just r+ Fail -> Nothing+ Err _ -> Nothing++-- | Run a Parser, throwing away leftovers. Returns Left on 'Fail' or 'Err'.+runParserEither :: (IsString e) => Parser e a -> ByteString -> Either e a+runParserEither p bs = case runParser p bs of+ Err e -> Left e+ OK a _ -> Right a+ Fail -> Left "uncaught parse error"++-- | Warnings covering leftovers, 'Err's and 'Fail'+data ParserWarning = ParserLeftover ByteString | ParserError ByteString | ParserUncaught deriving (Eq, Show, Ord, Generic)++-- | Run parser, returning leftovers and errors as 'ParserWarning's.+runParserWarn :: Parser ByteString a -> ByteString -> These ParserWarning a+runParserWarn p bs = case runParser p bs of+ Err e -> This (ParserError e)+ OK a "" -> That a+ OK a x -> These (ParserLeftover $ C.take 200 x) a+ Fail -> This ParserUncaught++-- | Run parser, discards leftovers & throws an error on failure.+--+-- >>> runParser_ ws " "+-- ' '+--+-- >>> runParser_ ws "x"+-- *** Exception: uncaught parse error+-- ...+runParser_ :: Parser String a -> ByteString -> a+runParser_ p bs = case runParser p bs of+ Err e -> error e+ OK a _ -> a+ Fail -> error "uncaught parse error"++-- | Run parser, errors on leftovers & failure.+--+-- >>> runParser_ ws " "+-- ' '+--+-- >>> runParser_ ws "x"+-- *** Exception: uncaught parse error+-- ...+runParser__ :: Parser String a -> ByteString -> a+runParser__ p bs = case runParser p bs of+ Err e -> error e+ OK a "" -> a+ OK _ x -> error $ "leftovers: " <> C.unpack (C.take 20 x)+ Fail -> error "uncaught parse error"++-- | Consume whitespace.+--+-- >>> runParser ws_ " \nx"+-- OK () "x"+--+-- >>> runParser ws_ "x"+-- OK () "x"+ws_ :: Parser e ()+ws_ =+ $( switch+ [|+ case _ of+ " " -> ws_+ "\n" -> ws_+ "\t" -> ws_+ "\r" -> ws_+ "\f" -> ws_+ _ -> pure ()+ |]+ )+{-# INLINE ws_ #-}++-- | \\n \\t \\f \\r and space+isWhitespace :: Char -> Bool+isWhitespace ' ' = True -- \x20 space+isWhitespace '\x0a' = True -- \n linefeed+isWhitespace '\x09' = True -- \t tab+isWhitespace '\x0c' = True -- \f formfeed+isWhitespace '\x0d' = True -- \r carriage return+isWhitespace _ = False+{-# INLINE isWhitespace #-}++-- | single whitespace+--+-- >>> runParser ws " \nx"+-- OK ' ' "\nx"+ws :: Parser e Char+ws = satisfy isWhitespace++-- | Parse whilst not a specific character+--+-- >>> runParser (nota 'x') "abcxyz"+-- OK "abc" "xyz"+nota :: Char -> Parser e ByteString+nota c = withSpan (skipMany (satisfy (/= c))) (\() s -> unsafeSpanToByteString s)+{-# INLINE nota #-}++-- | parse whilst not a specific character, then consume the character.+--+-- >>> runParser (untilP 'x') "abcxyz"+-- OK "abc" "yz"+untilP :: Char -> Parser e ByteString+untilP c = nota c <* satisfy (== c)++prefixComma :: Parser e ()+prefixComma = $(char ',') >> ws_++postfixComma :: Parser e ()+postfixComma = ws_ >> $(char ',')++initialPackageChar :: Parser e Char+initialPackageChar =+ satisfyAscii+ ( `C.elem`+ ( C.pack $+ ['a' .. 'z']+ <> ['A' .. 'Z']+ <> ['0' .. '9']+ )+ )++packageChar :: Parser e Char+packageChar =+ satisfyAscii+ ( `C.elem`+ ( C.pack $+ ['a' .. 'z']+ <> ['A' .. 'Z']+ <> ['-']+ <> ['0' .. '9']+ )+ )++validName :: Parser e String+validName = (:) <$> initialPackageChar <*> many packageChar++-- | Parse a dependency line into a name, range tuple. Consumes any commas it finds.+depP :: Parser e (ByteString, ByteString)+depP =+ (,)+ <$> ( optional prefixComma+ *> ws_+ *> byteStringOf validName+ <* ws_+ )+ <*> nota ','+ <* optional postfixComma++-- | Parse a version bytestring ti an int list.+versionP :: Parser e [Int]+versionP = (:) <$> int <*> many ($(char '.') >> int)++-- | A single digit+digit :: Parser e Int+digit = (\c -> ord c - ord '0') <$> satisfyAscii isDigit++-- | An (unsigned) 'Int' parser+int :: Parser e Int+int = do+ (place, n) <- chainr (\n (!place, !acc) -> (place * 10, acc + place * n)) digit (pure (1, 0))+ case place of+ 1 -> empty+ _ -> pure n++-- | partial running of versionP+--+-- >>> versionInts "0.6.10.0"+-- [0,6,10,0]+versionInts :: ByteString -> [Int]+versionInts x = runParser__ versionP x
+ src/CabalFix/Patch.hs view
@@ -0,0 +1,87 @@+-- | A patch function for <https://hackage.haskell.org/package/tree-diff tree-diff>.+module CabalFix.Patch+ ( patch,+ showPatch,+ )+where++import Control.Category ((>>>))+import Data.Foldable+import Data.Function+import Data.Maybe+import Data.TreeDiff+import Data.TreeDiff.OMap qualified as O+import GHC.Exts+import Prelude++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import CabalFix.Patch++isUnchangedList :: [Edit EditExpr] -> Bool+isUnchangedList xs = all isCpy xs && all isUnchangedExpr (mapMaybe cpy xs)++isCpy :: Edit a -> Bool+isCpy (Cpy _) = True+isCpy _ = False++cpy :: Edit a -> Maybe a+cpy (Cpy a) = Just a+cpy _ = Nothing++isUnchangedEdit :: Edit EditExpr -> Bool+isUnchangedEdit (Cpy e) = isUnchangedExpr e+isUnchangedEdit _ = False++isUnchangedExpr :: EditExpr -> Bool+isUnchangedExpr e = isUnchangedList $ getList e++getList :: EditExpr -> [Edit EditExpr]+getList (EditApp _ xs) = xs+getList (EditRec _ m) = snd <$> O.toList m+getList (EditLst xs) = xs+getList (EditExp _) = []++filterChangedExprs :: EditExpr -> Maybe EditExpr+filterChangedExprs (EditApp n xs) =+ case filter (not . isUnchangedEdit) (filterChangedEdits xs) of+ [] -> Nothing+ xs' -> Just $ EditApp n xs'+filterChangedExprs (EditRec n m) =+ case filterChangedEditMap (O.fromList $ filter (not . isUnchangedEdit . snd) (O.toList m)) of+ Nothing -> Nothing+ Just m' -> Just (EditRec n m')+filterChangedExprs (EditLst xs) =+ case filter (not . isUnchangedEdit) (filterChangedEdits xs) of+ [] -> Nothing+ xs' -> Just (EditLst xs')+filterChangedExprs (EditExp _) = Nothing++filterChangedEdit :: Edit EditExpr -> Maybe (Edit EditExpr)+filterChangedEdit (Cpy a) = Cpy <$> filterChangedExprs a+filterChangedEdit x = Just x++filterChangedEdit' :: (f, Edit EditExpr) -> Maybe (f, Edit EditExpr)+filterChangedEdit' (f, e) = (f,) <$> filterChangedEdit e++filterChangedEdits :: [Edit EditExpr] -> [Edit EditExpr]+filterChangedEdits xs = mapMaybe filterChangedEdit xs++filterChangedEditMap :: O.OMap FieldName (Edit EditExpr) -> Maybe (O.OMap FieldName (Edit EditExpr))+filterChangedEditMap m = case xs' of+ [] -> Nothing+ xs'' -> Just $ O.fromList xs''+ where+ xs = O.toList m+ xs' = mapMaybe filterChangedEdit' xs++-- | 'ediff' with unchanged sections filtered out+--+-- >>> showPatch $ patch [1, 2, 3, 5] [0, 1, 2, 4, 6]+-- "[+0, -3, +4, -5, +6]"+patch :: (ToExpr a) => a -> a -> Maybe (Edit EditExpr)+patch m m' = filterChangedEdit $ ediff m m'++-- | Create a String representation of a patch.+showPatch :: Maybe (Edit EditExpr) -> String+showPatch p = p & maybe mempty (ansiWlEditExpr >>> show)