diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +# 0.0.0.1 + +* conception + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/app/cabal-fix.hs b/app/cabal-fix.hs new file mode 100644 --- /dev/null +++ b/app/cabal-fix.hs @@ -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" diff --git a/cabal-fix.cabal b/cabal-fix.cabal new file mode 100644 --- /dev/null +++ b/cabal-fix.cabal @@ -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 diff --git a/other/textdeps.svg b/other/textdeps.svg new file mode 100644 --- /dev/null +++ b/other/textdeps.svg @@ -0,0 +1,132 @@ + + + + + + + + + +text + +text + + + +template-haskell + +template-haskell + + + +template-haskell->text + + + + + +bytestring + +bytestring + + + +template-haskell->bytestring + + + + + +ghc-prim + +ghc-prim + + + +ghc-prim->text + + + + + +ghc-prim->template-haskell + + + + + +ghc-prim->bytestring + + + + + +deepseq + +deepseq + + + +deepseq->text + + + + + +deepseq->bytestring + + + + + +bytestring->text + + + + + +binary + +binary + + + +bytestring->binary + + + + + +binary->text + + + + + +array + +array + + + +array->text + + + + + +array->deepseq + + + + + +array->binary + + + + + diff --git a/readme.org b/readme.org new file mode 100644 --- /dev/null +++ b/readme.org @@ -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]] diff --git a/src/CabalFix.hs b/src/CabalFix.hs new file mode 100644 --- /dev/null +++ b/src/CabalFix.hs @@ -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 + } diff --git a/src/CabalFix/Archive.hs b/src/CabalFix/Archive.hs new file mode 100644 --- /dev/null +++ b/src/CabalFix/Archive.hs @@ -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 +-- +-- ![text example](other/textdeps.svg) +dotUpstreamSvg :: Graph ByteString -> FilePath -> IO ByteString +dotUpstreamSvg g svg = Dot.processDotWith Dot.Directed ["-Tsvg", "-o" <> svg] (dotUpstream g) diff --git a/src/CabalFix/FlatParse.hs b/src/CabalFix/FlatParse.hs new file mode 100644 --- /dev/null +++ b/src/CabalFix/FlatParse.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Various 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 diff --git a/src/CabalFix/Patch.hs b/src/CabalFix/Patch.hs new file mode 100644 --- /dev/null +++ b/src/CabalFix/Patch.hs @@ -0,0 +1,87 @@ +-- | A patch function for . +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)