stylish-cabal (empty) → 0.1.0.0
raw patch · 20 files changed
+1687/−0 lines, 20 filesdep +Cabaldep +StrictCheckdep +aesonsetup-changed
Dependencies added: Cabal, StrictCheck, aeson, ansi-wl-pprint, base, bytestring, containers, deepseq, generics-sop, hlint, hspec, hspec-core, hspec-expectations-pretty-diff, lens, mwc-random, optparse-applicative, split, stylish-cabal, utf8-string, vector, wreq
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Main.hs +72/−0
- Setup.hs +2/−0
- src/Parse.hs +48/−0
- src/Render.hs +174/−0
- src/Render/Lib.hs +154/−0
- src/StylishCabal.hs +16/−0
- src/Transform.hs +257/−0
- src/Types/Block.hs +28/−0
- src/Types/Field.hs +129/−0
- stylish-cabal.cabal +124/−0
- tests/hlint.hs +6/−0
- tests/roundtrip/Hackage.hs +63/−0
- tests/roundtrip/Main.hs +12/−0
- tests/roundtrip/SortedDesc.hs +268/−0
- tests/roundtrip/Utils.hs +59/−0
- tests/strictness/Instances.hs +126/−0
- tests/strictness/Main.hs +48/−0
- tests/strictness/Pretty.hs +66/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for stylish-cabal++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Jude Taylor++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 Jude Taylor 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.
+ Main.hs view
@@ -0,0 +1,72 @@+{-# Language NoMonomorphismRestriction #-}+{-# Language OverloadedStrings #-}++module Main where++import Data.Char+import Data.Monoid+import Options.Applicative hiding (ParserResult(..))+import StylishCabal+import System.Exit+import System.IO+import Text.PrettyPrint.ANSI.Leijen (Doc, displayIO, displayS, plain, renderSmart)++data Opts = Opts+ { file :: Maybe FilePath+ , inPlace :: Bool+ , color :: Bool+ , width :: Int+ , indent :: Int+ } deriving (Show)++opts :: Parser Opts+opts =+ Opts <$> optional (strArgument (metavar "FILE" <> help "Input file")) <*>+ switch (long "in-place" <> short 'i' <> help "Format file in place" <> showDefault) <*>+ flag+ True+ False+ (long "disable-color" <> short 'c' <>+ help+ "Disable colorized output (already disabled if using --in-place or if output is a file)") <*>+ option+ auto+ (long "width" <> short 'w' <> help "Character width limit for cabal file" <>+ showDefault <>+ value 90 <>+ metavar "INT") <*>+ option+ auto+ (long "indent" <> short 'n' <> help "Indent size in spaces" <> showDefault <>+ value 2 <>+ metavar "INT")++render :: Opts -> Doc -> Handle -> IO ()+render o doc h = do+ isTerminal <- hIsTerminalDevice stdout+ if color o && isTerminal+ then displayIO h (f doc)+ else do+ let docStr = unlines . map stripBlank . lines $ displayS (f $ plain doc) ""+ hPutStr h docStr+ where+ f = renderSmart 1.0 (width o)+ stripBlank x+ | all isSpace x = []+ | otherwise = x++main :: IO ()+main = do+ o <- execParser $ info (opts <**> helper) (fullDesc <> progDesc "Format a Cabal file")+ f <- maybe getContents readFile (file o)+ case pretty (indent o) <$> parse f of+ Error m s -> displayError (file o) m s+ Warn warnings -> printWarnings warnings+ Success doc ->+ if inPlace o+ then case file o of+ Just fname -> withFile fname WriteMode (render o doc)+ Nothing -> hPutStrLn stderr inPlaceErr >> exitFailure+ else render o doc stdout+ where+ inPlaceErr = "stylish-cabal: --in-place specified, but I'm reading from stdin"
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Parse.hs view
@@ -0,0 +1,48 @@+module Parse+ ( parse+ , displayError+ , printWarnings+ , Result(..)+ ) where++import Data.Maybe+import Distribution.PackageDescription.Parse+import Distribution.ParseUtils+import Distribution.Simple.Utils+import Distribution.Verbosity+import System.Environment+import System.Exit+import System.IO++data Result a+ = Error (Maybe LineNo)+ String+ | Warn [PWarning]+ | Success a+ deriving (Show)++instance Functor Result where+ fmap f (Success a) = Success (f a)+ fmap _ (Warn ps) = Warn ps+ fmap _ (Error m s) = Error m s++parse input =+ case parseGenericPackageDescription input of+ ParseFailed e -> uncurry Error $ locatedErrorMsg e+ ParseOk warnings x+ | null warnings -> Success x+ | otherwise -> Warn $ reverse warnings++displayError fpath line' message = do+ prog <- getProgName+ hPutStrLn stderr $+ prog +++ ": " +++ fromMaybe "<input>" fpath +++ (case line' of+ Just lineno -> ":" ++ show lineno+ Nothing -> "") +++ ": " ++ message+ exitFailure++printWarnings ps = mapM_ (warn normal . showPWarning "<input>") ps >> exitFailure
+ src/Render.hs view
@@ -0,0 +1,174 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-dodgy-imports #-}+{-# Language RecordWildCards #-}+{-# Language StandaloneDeriving #-}+{-# Language FlexibleContexts #-}++module Render+ ( blockBodyToDoc+ ) where++import Data.List hiding (group)+import Data.List.Split+import Data.Maybe+import Data.Ord+import Distribution.Types.Dependency+import Distribution.Types.IncludeRenaming+import Distribution.Types.LegacyExeDependency+import Distribution.Types.Mixin+import Distribution.Types.ModuleReexport+import Distribution.Types.ModuleRenaming+import Distribution.Types.PackageName+import Distribution.Types.PkgconfigDependency+import Distribution.Types.PkgconfigName+import Distribution.Version+import Prelude hiding ((<$>))+import Text.PrettyPrint.ANSI.Leijen++import Render.Lib+import Types.Block+import Types.Field++deriving instance Ord ModuleReexport++fieldValueToDoc _ k (Field _ f) =+ case f of+ Dependencies ds ->+ buildDepsToDoc k $ map (\(Dependency pn v) -> (P $ unPackageName pn, v)) ds+ ToolDepends ts -> buildDepsToDoc k $ map exeDependencyAsDependency ts+ OldToolDepends ds ->+ buildDepsToDoc k $ map (\(LegacyExeDependency pn v) -> (P pn, v)) ds+ PcDepends ds ->+ buildDepsToDoc k $+ map (\(PkgconfigDependency pn v) -> (P $ unPkgconfigName pn, v)) ds+ Mixins ms -> mixinsToDoc k $ map (\(Mixin pn r) -> (P $ unPackageName pn, r)) ms+ RexpModules rms ->+ buildDepsToDoc k $+ map (\rexp -> (P $ show $ rexpModuleDoc rexp, anyVersion)) rms+ n -> colon <> indent (k + 1) (align $ val' n)+ where+ val' (Str x) = string x+ val' (File x) = filepath x+ val' (Version v) = string $ showVersion v+ val' (CabalVersion v)+ -- section syntax was introduced in Cabal 1.2. if no cabal-version+ -- is specified in the source, we require >=1.2 to be present in+ -- the output+ | v == mkVersion [0] = renderVersion $ orLaterVersion (mkVersion [1, 2])+ -- up until Cabal 1.10, we have to specify '>=' with cabal-version+ | withinRange v (orEarlierVersion (mkVersion [1, 10])) =+ renderVersion $ orLaterVersion v+ | otherwise = string $ showVersion v+ val' (License l) = string $ showLicense l+ val' (TestedWith ts) = renderTestedWith ts+ val' (LongList fs) = vcat $ map filepath fs+ val' (Commas fs) = fillSep $ punctuate comma $ map filepath fs+ val' (Spaces ls) = fillSep $ map filepath ls+ val' (Modules ms) = vcat $ map moduleDoc $ sort ms+ val' (Module m) = moduleDoc m+ val' (Extensions es) = val' (LongList $ map showExtension es)+ val' (FlibType ty) = string $ showFlibType ty+ val' (FlibOptions fs) = val' $ Spaces $ map showFlibOpt fs+ val' x = error $ show x+fieldValueToDoc n k (Description s) = descriptionToDoc n k s++descriptionToDoc n k s =+ (<>) colon $+ nest n $+ case paragraphs of+ [p]+ -- i still don't know what this does+ ->+ group $+ flatAlt+ (linebreak <> fillSep (map text $ words p))+ (indent (k + 1) (string p))+ xs -> line <> vcat (intersperse (green dot) (map paragraph xs))+ where+ paragraphs = map (unwords . lines) $ splitOn "\n\n" s+ paragraph t = fillSep (map text $ words t)++mixinsToDoc k bs+ | k == 0 = deps ": "+ | otherwise = colon <> indent (k - 1) (deps " ")+ where+ deps lsep =+ encloseSep (string lsep) empty (string ", ") $+ map showField $ sortBy (comparing fst) bs+ longest = maximum $ map (length . unP . fst) bs+ hasRequires = any (\(_, c) -> not (isDefaultRenaming $ includeRequiresRn c)) bs+ showField (P fName, i@IncludeRenaming {..})+ | isDefaultIncludeRenaming i = string fName+ | otherwise =+ width (string fName) $ \fn ->+ let delt n =+ indent+ (n + 1)+ (if isDefaultRenaming includeRequiresRn+ then providesDoc includeProvidesRn+ else group $+ align'+ 9+ (providesDoc includeProvidesRn <$>+ string "requires" <+>+ providesDoc includeRequiresRn))+ pad doc =+ if hasRequires+ then string (replicate (8 - longest) ' ') <> doc+ else doc+ in flatAlt (pad $ delt (longest - fn)) (delt 0)+ parenthesize =+ group .+ encloseSep+ (flatAlt (string " (") lparen) -- `mixin-name ( Module` doesn't parse+ (flatAlt (line <> rparen) rparen)+ (string ", ")+ providesDoc (ModuleRenaming ms) = parenthesize $ map renaming ms+ providesDoc (HidingRenaming hs) = string "hiding" <+> parenthesize (map moduleDoc hs)+ providesDoc DefaultRenaming = empty+ renaming (m1, m2) = moduleDoc m1 <+> string "as" <+> moduleDoc m2+ align' n doc = column (\ko -> nesting (\i -> nest (ko - i - n) doc))++buildDepsToDoc k bs+ | k == 0 = deps ": "+ | otherwise = colon <> indent (k - 1) (deps " ")+ where+ deps lsep =+ encloseSep+ (string lsep)+ empty+ (string ", ")+ (map showField $ sortBy (comparing fst) bs)+ longest = maximum $ map (length . unP . fst) bs+ showField (P fName, fieldVal)+ | fieldVal == anyVersion = string fName+ | otherwise =+ width (string fName) $ \fn ->+ let delt n = indent (n + 1) (renderVersion fieldVal)+ in flatAlt (delt (longest - fn)) (delt 0)++fieldsToDoc n fs =+ vcat $+ map (\field ->+ width (dullblue $ string (fieldName field)) $ \fn ->+ fieldValueToDoc n (longestField - fn) field)+ fs+ where+ longestField = maximum $ map (length . fieldName) fs++renderBlock n (Block t fs blocks) =+ (if isElse t+ then id+ else (<>) line)+ (renderBlockHead t) <$$>+ indent n (align $ blockBodyToDoc n fs blocks)++blockBodyToDoc n fs blocks =+ fieldsToDoc+ n+ (if null fs'+ then buildable'+ else fs') <>+ vcat (empty : map (renderBlock n) blocks)+ where+ fs' = catMaybes fs+ buildable' = [fromJust $ stringField "buildable" "True"]
+ src/Render/Lib.hs view
@@ -0,0 +1,154 @@+{-# Language FlexibleContexts #-}+{-# Language OverloadedStrings #-}++module Render.Lib+ ( P(..)+ , renderBlockHead+ , renderVersion+ , showExtension+ , moduleDoc+ , rexpModuleDoc+ , showFlibType+ , showFlibOpt+ , filepath+ , renderTestedWith+ , showLicense+ , exeDependencyAsDependency+ ) where++import Data.Char+import Data.List+import Distribution.Compiler+import Distribution.License+import Distribution.ModuleName+import Distribution.PackageDescription+import Distribution.Types.ExeDependency+import Distribution.Types.ForeignLibOption+import Distribution.Types.ForeignLibType+import Distribution.Types.PackageName+import Distribution.Types.UnqualComponentName+import Distribution.Version+import Language.Haskell.Extension+import Text.PrettyPrint.ANSI.Leijen+import Types.Block++newtype P = P+ { unP :: String+ } deriving (Eq)++instance Ord P where+ compare (P "base") (P "base") = EQ+ compare (P "base") _ = LT+ compare _ (P "base") = GT+ compare (P p1) (P p2) = compare p1 p2++showFlibType ForeignLibNativeShared = "native-shared"+showFlibType f = error $ show f++showFlibOpt ForeignLibStandalone = "standalone"++showLicense :: License -> String+showLicense MIT = "MIT"+showLicense BSD2 = "BSD2"+showLicense BSD3 = "BSD3"+showLicense BSD4 = "BSD4"+showLicense PublicDomain = "PublicDomain"+showLicense ISC = "ISC"+showLicense (MPL v) = showL "MPL" (Just v)+showLicense (LGPL v) = showL "LGPL" v+showLicense (GPL v) = showL "GPL" v+showLicense (AGPL v) = showL "AGPL" v+showLicense (Apache v) = showL "Apache" v+showLicense OtherLicense = "OtherLicense"+showLicense x = error $ show x++showL :: String -> Maybe Version -> String+showL s Nothing = s+showL s (Just v) = s ++ "-" ++ showVersion v++renderTestedWith =+ fillSep .+ punctuate comma .+ map (\(compiler, vers) -> showVersioned (showCompiler compiler, vers))+ where+ showCompiler (OtherCompiler x) = x+ showCompiler HaskellSuite {} =+ error "Not sure what to do with HaskellSuite value in tested-with field"+ showCompiler x = show x++showVersioned :: (String, VersionRange) -> Doc+showVersioned (pn, v')+ | v' == anyVersion = string pn+ | otherwise = string pn <+> renderVersion v'++renderVersion =+ foldVersionRange'+ empty+ (\v -> green "==" <+> dullyellow (string (showVersion v)))+ (\v -> green ">" <+> dullyellow (string (showVersion v)))+ (\v -> green "<" <+> dullyellow (string (showVersion v)))+ (\v -> green ">=" <+> dullyellow (string (showVersion v)))+ (\v -> green "<=" <+> dullyellow (string (showVersion v)))+ (\v _ -> green "==" <+> dullyellow (string (showVersion v) <> ".*"))+ (\v _ -> green "^>=" <+> dullyellow (string (showVersion v)))+ (\a b -> a <+> green "||" <+> b)+ (\a b -> a <+> green "&&" <+> b)+ parens++filepath :: String -> Doc+filepath x+ | null x = string "\"\""+ | any isSpace x = string $ show x+ | otherwise = string x++moduleDoc = string . intercalate "." . components++rexpModuleDoc (ModuleReexport pkg origname name) =+ maybe empty (\f -> string (unPackageName f) <> colon) pkg <>+ (if origname == name+ then moduleDoc origname+ else moduleDoc origname <+> "as" <+> moduleDoc name)++showExtension (EnableExtension s) = show s+showExtension (DisableExtension s) = "No" ++ show s+showExtension x = error $ show x++exeDependencyAsDependency (ExeDependency pkg comp vers) =+ (P $ unPackageName pkg ++ ":" ++ unUnqualComponentName comp, vers)++renderBlockHead CustomSetup = dullgreen "custom-setup"+renderBlockHead (SourceRepo_ k) = dullgreen "source-repository" <+> showKind k+ where+ showKind RepoHead = "head"+ showKind RepoThis = "this"+ showKind (RepoKindUnknown x) = string x+renderBlockHead (Library_ Nothing) = dullgreen "library"+renderBlockHead (Library_ (Just l)) = dullgreen "library" <+> string l+renderBlockHead (ForeignLib_ l) = dullgreen "foreign-library" <+> string l+renderBlockHead (Exe_ e) = dullgreen "executable" <+> string e+renderBlockHead (TestSuite_ t) = dullgreen "test-suite" <+> string t+renderBlockHead (Benchmark_ b) = dullgreen "benchmark" <+> string b+renderBlockHead (Flag_ s) = dullgreen "flag" <+> string s+renderBlockHead (If c) = dullblue "if" <+> showPredicate c+renderBlockHead Else = dullblue "else"++showPredicate (Var x) = showVar x+showPredicate (CNot p) = dullmagenta (string "!") <> maybeParens p+showPredicate (CAnd a b) = maybeParens a <+> dullblue (string "&&") <+> maybeParens b+showPredicate (COr a b) = maybeParens a <+> dullblue (string "||") <+> maybeParens b+showPredicate (Lit b) = string $ show b++maybeParens p = case p of+ Lit {} -> showPredicate p+ Var {} -> showPredicate p+ CNot {} -> showPredicate p+ _ -> parens (showPredicate p)++showVar (Impl compiler vers) =+ dullgreen $+ string "impl" <> parens (dullblue $ showVersioned (map toLower $ show compiler, vers))+showVar (Flag f) = dullgreen $ string "flag" <> parens (dullblue $ string (unFlagName f))+showVar (OS w) =+ dullgreen $ string "os" <> parens (dullblue $ string $ map toLower $ show w)+showVar (Arch a) =+ dullgreen $ string "arch" <> parens (dullblue $ string $ map toLower $ show a)
+ src/StylishCabal.hs view
@@ -0,0 +1,16 @@+module StylishCabal+ ( pretty+ , displayError+ , printWarnings+ , Result (..)+ , parse+ ) where++import Data.Monoid+import Text.PrettyPrint.ANSI.Leijen (line)++import Parse+import Render+import Transform++pretty i gpd = uncurry (blockBodyToDoc i) (toBlocks gpd) <> line
+ src/Transform.hs view
@@ -0,0 +1,257 @@+{-# Language CPP #-}+{-# Language FlexibleContexts #-}+{-# Language RecordWildCards #-}++module Transform+ ( toBlocks+ ) where++import Control.Arrow+import Control.DeepSeq+import Control.Monad+import Data.Char+import Data.Either+import Data.Maybe+import Distribution.License+import Distribution.PackageDescription+import Distribution.Simple.BuildToolDepends+import Distribution.Types.CondTree+import Distribution.Types.ExecutableScope+import Distribution.Types.ForeignLib+import Distribution.Types.ForeignLibType+import Distribution.Types.PackageId+import Distribution.Types.PackageName+import Distribution.Types.UnqualComponentName+import Distribution.Version+#if __GLASGOW_HASKELL__ < 710+import Data.Functor ((<$>))+#endif++import Types.Block+import Types.Field++(<&>) = flip fmap++toBlocks GenericPackageDescription {..} =+ ( pdToFields packageDescription+ , concat+ [ map setupBuildInfoToBlock $ maybeToList (setupBuildInfo packageDescription)+ , map sourceRepoToBlock (sourceRepos packageDescription)+ , map flagToBlock genPackageFlags+ , map (libToBlock packageDescription Nothing) $ maybeToList condLibrary+ , map (uncurry (libToBlock packageDescription) . first Just) condSubLibraries+ , map (uncurry $ foreignLibToBlock packageDescription) condForeignLibs+ , map (uncurry $ exeToBlock packageDescription) condExecutables+ , map (uncurry $ testToBlock packageDescription) condTestSuites+ , map (uncurry $ benchToBlock packageDescription) condBenchmarks+ ])++setupBuildInfoToBlock SetupBuildInfo {..}+ -- defaultSetupDepends doesn't correspond to anything in the cabal file+ =+ defaultSetupDepends `seq`+ Block CustomSetup [nonEmpty (dependencies "setup-depends") setupDepends] []++sourceRepoToBlock SourceRepo {..} =+ Block+ (SourceRepo_ repoKind)+ [ stringField "type" . showType =<< repoType+ , stringField "location" =<< repoLocation+ , file "subdir" =<< repoSubdir+ , file "tag" =<< repoTag+ , file "branch" =<< repoBranch+ , file "module" =<< repoModule+ ]+ []+ where+ showType (OtherRepoType n) = n+ showType x = map toLower $ show x++pdToFields pd@PackageDescription {..} =+ [ guard newSpec >> cabalVersion "cabal-version" packageVersion+ , stringField "name" (unPackageName $ pkgName package)+ , version "version" (pkgVersion package)+ , nonEmpty (stringField "synopsis") synopsis+ , desc description+ , ffilter (/= UnspecifiedLicense) (licenseField "license") license+ , license' licenseFiles+ , nonEmpty (stringField "copyright") copyright+ , nonEmpty (stringField "author") author+ , nonEmpty (stringField "maintainer") maintainer+ , nonEmpty (stringField "stability") stability+ , nonEmpty (testedField "tested-with") testedWith+ , nonEmpty (stringField "category") category+ , nonEmpty (stringField "homepage") homepage+ , nonEmpty (stringField "package-url") pkgUrl+ , nonEmpty (stringField "bug-reports") bugReports+ , stringField "build-type" . show =<< buildType+ , nonEmpty (longList "extra-tmp-files") extraTmpFiles+ , nonEmpty (longList "extra-source-files") extraSrcFiles+ , nonEmpty (longList "extra-doc-files") extraDocFiles+ , nonEmpty (longList "data-files") dataFiles+ , nonEmpty (stringField "data-dir") dataDir+ , guard (not newSpec) >> cabalVersion "cabal-version" (specVersion pd)+ ] +++ map (uncurry stringField) customFieldsPD+ where+ newSpec = withinRange packageVersion (orLaterVersion $ mkVersion [2, 1])+ packageVersion = specVersion pd+ license' [] = Nothing+ license' [l] = file "license-file" l+ license' ls = commas "license-files" ls++flagToBlock MkFlag {..} =+ Block+ (Flag_ (unFlagName flagName))+ [ stringField "default" (show flagDefault)+ , ffilter id (stringField "manual" . show) flagManual+ , desc flagDescription+ ]+ []++libToBlock pkg libname CondNode {..} =+ deepseq condTreeConstraints $+ Block+ (Library_ $ unUnqualComponentName <$> libname)+ (libDataToFields condTreeData ++ buildInfoToFields pkg (libBuildInfo condTreeData))+ (nodesToBlocks pkg libBuildInfo libDataToFields condTreeComponents)++libDataToFields Library {..} =+ libName `seq`+ [ ffilter not (stringField "exposed" . show) libExposed+ , nonEmpty (modules "exposed-modules") exposedModules+ , nonEmpty (rexpModules "reexported-modules") reexportedModules+ , nonEmpty (modules "signatures") signatures+ ]++foreignLibToBlock pkg libname CondNode {..} =+ deepseq condTreeConstraints $+ Block+ (ForeignLib_ $ unUnqualComponentName libname)+ (foreignLibDataToFields condTreeData +++ buildInfoToFields pkg (foreignLibBuildInfo condTreeData))+ (nodesToBlocks pkg foreignLibBuildInfo foreignLibDataToFields condTreeComponents)++foreignLibDataToFields ForeignLib {..} =+ foreignLibName `seq`+ [ ffilter (== ForeignLibNativeShared) (flibType "type") foreignLibType+ , nonEmpty (flibOptions "options") foreignLibOptions+ , stringField "lib-version-info" . showLVI =<< foreignLibVersionInfo+ , version "lib-version-linux" =<< foreignLibVersionLinux+ , nonEmpty (commas "mod-def-file") foreignLibModDefFile+ ]+ where+ showLVI l =+ let (a, b, c) = libVersionInfoCRA l+ in show a ++ ":" ++ show b ++ ":" ++ show c++exeToBlock pkg exeName CondNode {..} =+ deepseq condTreeConstraints $+ Block+ (Exe_ (unUnqualComponentName exeName))+ (exeDataToFields condTreeData ++ buildInfoToFields pkg (buildInfo condTreeData))+ (nodesToBlocks pkg buildInfo exeDataToFields condTreeComponents)++exeDataToFields Executable {..} =+ exeName `seq`+ [ nonEmpty (stringField "main-is") modulePath+ , ffilter (== ExecutablePrivate) (\_ -> stringField "scope" "private") exeScope+ ]++testToBlock pkg testName CondNode {..} =+ deepseq condTreeConstraints $+ Block+ (TestSuite_ (unUnqualComponentName testName))+ (testDataToFields condTreeData +++ buildInfoToFields pkg (testBuildInfo condTreeData))+ (nodesToBlocks pkg testBuildInfo testDataToFields condTreeComponents)++testDataToFields TestSuite {..} =+ testName `seq`+ case testInterface of+ TestSuiteExeV10 v f ->+ v `seq` [stringField "type" "exitcode-stdio-1.0", stringField "main-is" f]+ TestSuiteLibV09 v m ->+ v `seq` [stringField "type" "detailed-0.9", module_ "test-module" m]+ _ -> []++benchToBlock pkg benchName CondNode {..} =+ deepseq condTreeConstraints $+ Block+ (Benchmark_ $ unUnqualComponentName benchName)+ (benchDataToFields condTreeData +++ buildInfoToFields pkg (benchmarkBuildInfo condTreeData))+ (nodesToBlocks pkg benchmarkBuildInfo benchDataToFields condTreeComponents)++benchDataToFields Benchmark {..} =+ benchmarkName `seq`+ case benchmarkInterface of+ BenchmarkExeV10 v f ->+ v `seq` [stringField "type" "exitcode-stdio-1.0", stringField "main-is" f]+ _ -> []++nodesToBlocks pkg f renderMore = concatMap (condNodeToBlock pkg f renderMore)++condNodeToBlock pkg getBuildInfo extra (CondBranch pred' branch1 branch2) =+ let b1 =+ deepseq (condTreeConstraints branch1) $+ Block+ (If pred')+ (extra (condTreeData branch1) +++ buildInfoToFields pkg (getBuildInfo $ condTreeData branch1))+ (nodesToBlocks pkg getBuildInfo extra (condTreeComponents branch1))+ b2 =+ branch2 <&> \b ->+ deepseq (condTreeConstraints b) $+ Block+ Else+ (extra (condTreeData b) +++ buildInfoToFields pkg (getBuildInfo $ condTreeData b))+ (nodesToBlocks pkg getBuildInfo extra (condTreeComponents b))+ in b1 : maybeToList b2++buildInfoToFields pkg BuildInfo {..} =+ [ nonEmpty (commas "other-languages" . map show) otherLanguages+ , nonEmpty (modules "other-modules") otherModules+ , nonEmpty (mixins_ "mixins") mixins+ , nonEmpty (modules "autogen-modules") autogenModules+ , nonEmpty (commas "hs-source-dirs") hsSourceDirs+ , buildDeps targetBuildDepends+ , stringField "default-language" . show =<< defaultLanguage+ , nonEmpty (extensions "default-extensions") defaultExtensions+ , nonEmpty (extensions "extensions") oldExtensions+ , nonEmpty (extensions "other-extensions") otherExtensions+ , nonEmpty (commas "extra-libraries") extraLibs+ , nonEmpty (commas "extra-ghci-libraries") extraGHCiLibs+ , nonEmpty (pcDepends "pkgconfig-depends") pkgconfigDepends+ , nonEmpty (commas "frameworks") frameworks+ , nonEmpty (commas "extra-framework-dirs") extraFrameworkDirs+ , nonEmpty (spaces "cpp-options") cppOptions+ , nonEmpty (spaces "cc-options") ccOptions+ , nonEmpty (spaces "ld-options") ldOptions+ , nonEmpty (commas "c-sources") cSources+ , nonEmpty (commas "extra-lib-dirs") extraLibDirs+ , nonEmpty (commas "includes") includes+ , nonEmpty (commas "install-includes") installIncludes+ , nonEmpty (commas "include-dirs") includeDirs+ , nonEmpty (commas "js-sources") jsSources+ , ffilter not (stringField "buildable" . show) buildable+ , nonEmpty (toolDepends "build-tool-depends") newTools+ , nonEmpty (oldToolDepends "build-tools") oldTools+ ] +++ map (optionToField "") options +++ map (optionToField "-prof") profOptions +++ map (optionToField "-shared") sharedOptions +++ map (uncurry stringField) customFieldsBI+ where+ (oldTools, newTools) =+ partitionEithers $+ map Right buildToolDepends +++ map+ (\dep ->+ case desugarBuildTool pkg dep of+ Just k -> Right k+ Nothing -> Left dep)+ buildTools++optionToField pref (f, args) = spaces (map toLower (show f) ++ pref ++ "-options") args
+ src/Types/Block.hs view
@@ -0,0 +1,28 @@+module Types.Block where++import Distribution.PackageDescription+import Types.Field++type File c = ([Maybe Field], [Block c])++data Block c = Block+ { title :: BlockHead c+ , fields :: [Maybe Field]+ , subBlocks :: [Block c]+ }+ deriving Show++data BlockHead c = If (Condition c)+ | Else+ | Benchmark_ String+ | TestSuite_ String+ | Exe_ String+ | Library_ (Maybe String)+ | ForeignLib_ String+ | Flag_ String+ | SourceRepo_ RepoKind+ | CustomSetup+ deriving Show++isElse Else = True+isElse _ = False
+ src/Types/Field.hs view
@@ -0,0 +1,129 @@+{-# Language NoMonomorphismRestriction #-}++module Types.Field+ ( Field(..)+ , FieldVal(..)+ , extensions+ , rexpModules+ , flibOptions+ , file+ , flibType+ , fieldName+ , spaces+ , commas+ , toolDepends+ , oldToolDepends+ , pcDepends+ , buildDeps+ , modules+ , module_+ , mixins_+ , desc+ , version+ , cabalVersion+ , longList+ , testedField+ , licenseField+ , dependencies+ , nonEmpty+ , stringField+ , ffilter+ ) where++import Distribution.Compiler+import Distribution.License+import Distribution.ModuleName+import Distribution.Types.Dependency+import Distribution.Types.ExeDependency+import Distribution.Types.ForeignLibOption+import Distribution.Types.ForeignLibType+import Distribution.Types.LegacyExeDependency+import Distribution.Types.Mixin+import Distribution.Types.ModuleReexport+import Distribution.Types.PkgconfigDependency+import Distribution.Version+import Language.Haskell.Extension++data FieldVal+ = Dependencies [Dependency]+ | Version Version+ | CabalVersion Version+ | License License+ | Str String+ | File String+ | Spaces [String]+ | Commas [String]+ | LongList [String]+ | Extensions [Extension]+ | Modules [ModuleName]+ | Module ModuleName+ | RexpModules [ModuleReexport]+ | TestedWith [(CompilerFlavor, VersionRange)]+ | ToolDepends [ExeDependency]+ | OldToolDepends [LegacyExeDependency]+ | PcDepends [PkgconfigDependency]+ | Mixins [Mixin]+ | FlibType ForeignLibType+ | FlibOptions [ForeignLibOption]+ deriving (Show)++data Field+ = Description String+ | Field String+ FieldVal+ deriving (Show)++flibType n p = Just $ Field n (FlibType p)++flibOptions n p = Just $ Field n (FlibOptions p)++toolDepends n as = Just $ Field n (ToolDepends as)++oldToolDepends n as = Just $ Field n (OldToolDepends as)++pcDepends n as = Just $ Field n (PcDepends as)++rexpModules n as = Just $ Field n (RexpModules as)++mixins_ n as = Just $ Field n (Mixins as)++dependencies n as = Just $ Field n (Dependencies as)++licenseField n a = Just $ Field n (License a)++file n a = Just $ Field n (File a)++spaces n as = Just $ Field n (Spaces as)++commas n as = Just $ Field n (Commas as)++longList n as = Just $ Field n (LongList as)++extensions n as = Just $ Field n (Extensions as)++version n a = Just $ Field n (Version a)++cabalVersion n a = Just $ Field n (CabalVersion a)++modules n as = Just $ Field n (Modules as)++module_ n a = Just $ Field n (Module a)++testedField n a = Just $ Field n (TestedWith a)++ffilter f g as+ | not (f as) = Nothing+ | otherwise = g as++nonEmpty = ffilter (not . null)++fieldName (Field s _) = s+fieldName (Description _) = "description"++desc [] = Nothing+desc vs = Just (Description vs)++buildDeps [] = Nothing+buildDeps vs = dependencies "build-depends" vs++stringField n p = Just (Field n (Str p))
+ stylish-cabal.cabal view
@@ -0,0 +1,124 @@+name: stylish-cabal+version: 0.1.0.0+synopsis: Format Cabal files+description: A tool for nicely formatting your Cabal file.+license: BSD3+license-file: LICENSE+author: Jude Taylor+maintainer: me@jude.xyz+tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2+category: Language+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >= 1.10++source-repository head+ type: git+ location: https://github.com/pikajude/stylish-cabal.git++flag test-hackage+ default: False+ manual: True+ description: Should I test all Hackage cabal files?++flag test-strictness+ default: False+ manual: True+ description:+ Run the strictness testsuite. This requires the StrictCheck package which is not yet+ on Hackage, and thus is disabled by default.++library+ exposed: False+ exposed-modules: StylishCabal+ other-modules: Parse+ Render+ Render.Lib+ Transform+ Types.Block+ Types.Field+ hs-source-dirs: src+ build-depends: base == 4.*, Cabal == 2.0.*, ansi-wl-pprint, deepseq, split+ default-language: Haskell2010+ default-extensions: NoMonomorphismRestriction+ ghc-options: -Wall -fno-warn-missing-signatures++executable stylish-cabal+ main-is: Main.hs+ build-depends: base, ansi-wl-pprint, optparse-applicative, stylish-cabal+ default-language: Haskell2010+ ghc-options: -Wall++test-suite hlint+ type: exitcode-stdio-1.0+ main-is: hlint.hs+ hs-source-dirs: tests+ build-depends: base, hlint+ default-language: Haskell2010++test-suite strictness+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Instances+ Pretty+ hs-source-dirs: tests/strictness+ build-depends: base+ , Cabal+ , StrictCheck+ , ansi-wl-pprint+ , bytestring+ , deepseq+ , generics-sop+ , hspec+ , hspec-expectations-pretty-diff+ , stylish-cabal+ default-language: Haskell2010+ default-extensions: CPP+ ghc-options: -freduction-depth=0++ if !(flag(test-strictness) && impl(ghc >= 8.2))+ buildable: False++test-suite roundtrip+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: SortedDesc+ Utils+ hs-source-dirs: tests/roundtrip+ build-depends: base+ , Cabal+ , ansi-wl-pprint+ , containers+ , hspec+ , hspec-core+ , hspec-expectations-pretty-diff+ , stylish-cabal+ default-language: Haskell2010+ default-extensions: CPP+ ghc-options: -Wall -fno-warn-missing-signatures++test-suite roundtrip-hackage+ type: exitcode-stdio-1.0+ main-is: Hackage.hs+ other-modules: SortedDesc+ Utils+ hs-source-dirs: tests/roundtrip+ build-depends: base+ , Cabal+ , aeson+ , ansi-wl-pprint+ , containers+ , hspec+ , hspec-core+ , hspec-expectations-pretty-diff+ , lens+ , mwc-random+ , stylish-cabal+ , utf8-string+ , vector+ , wreq+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-missing-signatures++ if !flag(test-hackage)+ buildable: False
+ tests/hlint.hs view
@@ -0,0 +1,6 @@+import Control.Monad+import Language.Haskell.HLint+import System.Exit++main :: IO ()+main = hlint [".", "--cpp-define=TEST_HACKAGE=1"] >>= \ hints -> unless (null hints) exitFailure
+ tests/roundtrip/Hackage.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+{-# Language OverloadedStrings #-}+{-# Language DeriveGeneric #-}++import Control.Lens+import Control.Monad+import Data.Aeson+import Data.ByteString.Lazy.UTF8 (toString)+import GHC.Generics+import Network.Wreq+import System.Random.MWC+import System.Random.MWC.Distributions+import System.IO+import Test.Hspec+import qualified Data.Vector as V+import Test.Hspec.Core.Spec+import Utils++newtype GetPackage = GetPackage+ { packageName :: String+ } deriving (Show, Generic)++data GetRevision = GetRevision+ { time :: String+ , user :: String+ , number :: Integer+ } deriving (Show, Generic)++instance FromJSON GetPackage++instance FromJSON GetRevision++getJson :: FromJSON b => String -> IO b+getJson x =+ fmap (view responseBody) $+ asJSON =<< getWith (defaults & header "Accept" .~ ["application/json"]) x++testHackage = do+ packages <-+ runIO $ do+ hSetBuffering stdout NoBuffering+ putStrLn "getting package list..."+ packages <- getJson "http://hackage.haskell.org/packages/"+ putStrLn "done, running tests..."+ gen <- createSystemRandom+ uniformShuffle (V.fromList packages) gen+ parallel $+ describe "for 100 random Hackage packages" $+ forM_ (V.take 100 packages) $ \(GetPackage pname) ->+ mapSpecItem_ applySkips $+ it (mkHeader pname) $ do+ revs <-+ getJson $+ "http://hackage.haskell.org/package/" ++ pname ++ "/revisions/"+ let recent = last revs+ cabalFile <-+ get $+ "http://hackage.haskell.org/package/" +++ pname ++ "/revision/" ++ show (number recent) ++ ".cabal"+ expectParse $ toString $ view responseBody cabalFile++main :: IO ()+main = hspec $ describe "comprehensive check" testHackage
+ tests/roundtrip/Main.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-signatures #-}++module Main where++import Test.Hspec+import Utils++main :: IO ()+main =+ hspec $+ describe "comprehensive check" $+ it "retains every attribute" $ expectParse =<< readFile "tests/example.cabal"
+ tests/roundtrip/SortedDesc.hs view
@@ -0,0 +1,268 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# Language NamedFieldPuns #-}+{-# Language RecordWildCards #-}+{-# Language StandaloneDeriving #-}+{-# Language TypeFamilies #-}++module SortedDesc+ ( from+ , SGenericPackageDescription+ ) where++import Data.Set (Set)+import qualified Data.Set as S+import Distribution.Compiler+import Distribution.License+import Distribution.ModuleName+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Types.LegacyExeDependency+import Distribution.Types.Mixin+import Distribution.Types.PkgconfigDependency+import Distribution.Types.UnqualComponentName+import Distribution.Version+import Language.Haskell.Extension+#if __GLASGOW_HASKELL__ < 710+import Data.Functor ((<$>))+#endif++data SGenericPackageDescription = SGenericPackageDescription+ { packageDescription :: SPackageDescription+ , genPackageFlags :: Set Flag+ -- , sCondLibrary :: Maybe (SCondTree SConfVar (Set SDependency) SLibrary)+ -- , SCondExecutables :: Set (String, SCondTree SConfVar (Set SDependency) SExecutable)+ } deriving (Eq, Show)++data SPackageDescription = SPackageDescription+ { package :: PackageIdentifier+ , license :: License+ , licenseFiles :: Set FilePath+ , copyright :: String+ , maintainer :: String+ , author :: String+ , stability :: String+ , testedWith :: Set (CompilerFlavor, VersionRange)+ , homepage :: String+ , pkgUrl :: String+ , bugReports :: String+ , sourceRepos :: Set SourceRepo+ , synopsis :: String+ , description :: String+ , category :: String+ , customFieldsPD :: Set (String, String)+ , specVersionRaw :: Either Version VersionRange+ , buildType :: Maybe BuildType+ , setupBuildInfo :: Maybe SSetupBuildInfo+ , library :: Maybe SLibrary+ , executables :: Set SExecutable+ , testSuites :: Set STestSuite+ , benchmarks :: Set SBenchmark+ , dataFiles :: Set FilePath+ , dataDir :: FilePath+ , extraSrcFiles :: Set FilePath+ , extraTmpFiles :: Set FilePath+ , extraDocFiles :: Set FilePath+ } deriving (Show, Eq)++data SLibrary = SLibrary+ { exposedModules :: Set ModuleName+ , reexportedModules :: Set ModuleReexport+ , signatures :: Set ModuleName+ , libExposed :: Bool+ , libBuildInfo :: SBuildInfo+ } deriving (Show, Eq)++data SExecutable = SExecutable+ { exeName :: UnqualComponentName+ , modulePath :: FilePath+ , buildInfo :: SBuildInfo+ } deriving (Show, Eq, Ord)++data STestSuite = STestSuite+ { testName :: UnqualComponentName+ , testInterface :: TestSuiteInterface+ , testBuildInfo :: SBuildInfo+ } deriving (Show, Eq, Ord)++data SBenchmark = SBenchmark+ { benchmarkName :: UnqualComponentName+ , benchmarkInterface :: BenchmarkInterface+ , benchmarkBuildInfo :: SBuildInfo+ } deriving (Show, Eq, Ord)++data SSetupBuildInfo = SSetupBuildInfo+ { setupDepends :: Set Dependency+ , defaultSetupDepends :: Bool+ } deriving (Show, Eq)++data SBuildInfo = SBuildInfo+ { buildable :: Bool+ , buildTools :: Set LegacyExeDependency+ , cppOptions :: Set String+ , ccOptions :: Set String+ , ldOptions :: Set String+ , pkgconfigDepends :: Set PkgconfigDependency+ , frameworks :: Set String+ , extraFrameworkDirs :: Set String+ , cSources :: Set FilePath+ , jsSources :: Set FilePath+ , hsSourceDirs :: Set FilePath+ , otherModules :: Set ModuleName+ , defaultLanguage :: Maybe Language+ , otherLanguages :: Set Language+ , defaultExtensions :: Set Extension+ , otherExtensions :: Set Extension+ , oldExtensions :: Set Extension+ , extraLibs :: Set String+ , extraGHCiLibs :: Set String+ , extraLibDirs :: Set String+ , includeDirs :: Set FilePath+ , includes :: Set FilePath+ , installIncludes :: Set FilePath+ , options :: Set (CompilerFlavor, Set String)+ , profOptions :: Set (CompilerFlavor, Set String)+ , sharedOptions :: Set (CompilerFlavor, Set String)+ , customFieldsBI :: Set (String, String)+ , targetBuildDepends :: Set Dependency+ , mixins :: Set Mixin+ } deriving (Show, Eq, Ord)++class Convert a where+ type From a+ from :: From a -> a++instance Convert SGenericPackageDescription where+ type From SGenericPackageDescription = GenericPackageDescription+ from GenericPackageDescription {..} =+ SGenericPackageDescription+ { packageDescription = from packageDescription+ , genPackageFlags =+ S.fromList $ map (\f -> f {flagDescription = ""}) genPackageFlags+ }++instance Convert SPackageDescription where+ type From SPackageDescription = PackageDescription+ from PackageDescription {..} =+ SPackageDescription+ { package+ , license+ , licenseFiles = S.fromList licenseFiles+ , copyright+ , maintainer+ , author+ , stability+ , testedWith = S.fromList testedWith+ , homepage+ , pkgUrl+ , bugReports+ , sourceRepos = S.fromList sourceRepos+ , synopsis+ , description = "" -- discard, matching formatting in tests is too much work+ , category+ , customFieldsPD = S.fromList customFieldsPD+ , specVersionRaw = Right anyVersion -- discard, cabal replaces * with >= 0 || <= 0+ , buildType+ , setupBuildInfo = from <$> setupBuildInfo+ , library = from <$> library+ , executables = S.fromList $ map from executables+ , testSuites = S.fromList $ map from testSuites+ , benchmarks = S.fromList $ map from benchmarks+ , dataFiles = S.fromList dataFiles+ , dataDir+ , extraSrcFiles = S.fromList extraSrcFiles+ , extraTmpFiles = S.fromList extraTmpFiles+ , extraDocFiles = S.fromList extraDocFiles+ }++instance Convert SSetupBuildInfo where+ type From SSetupBuildInfo = SetupBuildInfo+ from SetupBuildInfo {..} =+ SSetupBuildInfo {setupDepends = S.fromList setupDepends, defaultSetupDepends}++instance Convert SLibrary where+ type From SLibrary = Library+ from Library {..} =+ SLibrary+ { exposedModules = S.fromList exposedModules+ , reexportedModules = S.fromList reexportedModules+ , signatures = S.fromList signatures+ , libExposed+ , libBuildInfo = from libBuildInfo+ }++instance Convert SExecutable where+ type From SExecutable = Executable+ from Executable {..} = SExecutable {exeName, modulePath, buildInfo = from buildInfo}++instance Convert STestSuite where+ type From STestSuite = TestSuite+ from TestSuite {..} =+ STestSuite {testName, testInterface, testBuildInfo = from testBuildInfo}++instance Convert SBenchmark where+ type From SBenchmark = Benchmark+ from Benchmark {..} =+ SBenchmark+ { benchmarkName+ , benchmarkInterface+ , benchmarkBuildInfo = from benchmarkBuildInfo+ }++instance Convert SBuildInfo where+ type From SBuildInfo = BuildInfo+ from BuildInfo {..} =+ SBuildInfo+ { buildable+ , buildTools = S.fromList buildTools+ , cppOptions = S.fromList cppOptions+ , ccOptions = S.fromList ccOptions+ , ldOptions = S.fromList ldOptions+ , pkgconfigDepends = S.fromList pkgconfigDepends+ , frameworks = S.fromList frameworks+ , extraFrameworkDirs = S.fromList extraFrameworkDirs+ , cSources = S.fromList cSources+ , jsSources = S.fromList jsSources+ , hsSourceDirs = S.fromList hsSourceDirs+ , otherModules = S.fromList otherModules+ , defaultLanguage+ , otherLanguages = S.fromList otherLanguages+ , defaultExtensions = S.fromList defaultExtensions+ , otherExtensions = S.fromList otherExtensions+ , oldExtensions = S.fromList oldExtensions+ , extraLibs = S.fromList extraLibs+ , extraGHCiLibs = S.fromList extraGHCiLibs+ , extraLibDirs = S.fromList extraLibDirs+ , includeDirs = S.fromList includeDirs+ , includes = S.fromList includes+ , installIncludes = S.fromList installIncludes+ , options = S.fromList $ map (fmap S.fromList) options+ , profOptions = S.fromList $ map (fmap S.fromList) profOptions+ , sharedOptions = S.fromList $ map (fmap S.fromList) sharedOptions+ , customFieldsBI = S.fromList customFieldsBI+ , targetBuildDepends = S.fromList targetBuildDepends+ , mixins = S.fromList mixins+ }++deriving instance Ord Flag++deriving instance Ord VersionRange++deriving instance Ord SourceRepo++deriving instance Ord Dependency++deriving instance Ord Language++deriving instance Ord ModuleReexport++deriving instance Ord TestSuiteInterface++deriving instance Ord TestType++deriving instance Ord BenchmarkInterface++deriving instance Ord BenchmarkType++deriving instance Ord PkgconfigDependency++deriving instance Ord LegacyExeDependency
+ tests/roundtrip/Utils.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# Language CPP #-}+{-# Language StandaloneDeriving #-}++module Utils where++import Control.Monad+import Data.List+import Distribution.PackageDescription.Parse+import Distribution.ParseUtils (PWarning(..))+import SortedDesc+import StylishCabal+import Test.Hspec.Core.Spec+import Test.Hspec.Expectations.Pretty+import Text.PrettyPrint.ANSI.Leijen (displayS, plain, renderSmart)+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (pure)+import Data.Functor ((<$>))+#endif++deriving instance Eq a => Eq (ParseResult a)++expectParse cabalStr = do+ let doc = (`displayS` "") . renderSmart 1.0 80 . plain . pretty 2 <$> parse cabalStr+ case doc of+ StylishCabal.Success rendered -> do+ let original =+ from <$> parse' cabalStr :: ParseResult SGenericPackageDescription+ new = from <$> parse' rendered+ case new of+ ParseOk pws _ -> skipIfRedFlags pws+ _ -> pure ()+ shouldBe original new+ Warn {} ->+ expectationFailure+ "SKIP Warnings generated from original file, cannot guarantee consistency of output"+ StylishCabal.Error {} ->+ expectationFailure "SKIP Original cabal file does not parse"+ where+ skipIfRedFlags [] = return ()+ skipIfRedFlags pws =+ when (any (\(PWarning p) -> "must specify at least" `isInfixOf` p) pws) $+ expectationFailure+ "SKIP Original specified cabal-version is too old for section syntax"+ parse' = parseGenericPackageDescription++applySkips i =+ i+ { itemExample =+ \a b c -> do+ result <- itemExample i a b c+ case result of+ Right (Failure _ (Reason r))+ | "SKIP " `isPrefixOf` r ->+ pure $ Right $ Pending $ Just $ drop 5 r+ x -> return x+ }++mkHeader p = "parses " ++ p
+ tests/strictness/Instances.hs view
@@ -0,0 +1,126 @@+{-# Language DataKinds #-}+{-# Language DeriveAnyClass #-}+{-# Language TemplateHaskell #-}+{-# Language TypeFamilies #-}+{-# Language StandaloneDeriving #-}++#define PRIM(c) instance Shaped c where type Shape c = Prim c; project = projectPrim; embed = embedPrim; match = matchPrim; render = prettyPrim++#define DERIVE(c) deriveGeneric ''c; instance Shaped c+#define DERIVEN(c) DERIVE(c); deriving instance NFData c++module Instances where++import Data.ByteString.Short+import Data.Word+import Distribution.Compiler+import Control.DeepSeq+import Distribution.License+import Distribution.ModuleName+import Distribution.Types.Benchmark+import Distribution.Types.Condition+import Distribution.System+import Distribution.Types.BenchmarkInterface+import Distribution.Types.BenchmarkType+import Distribution.Types.BuildInfo+import Distribution.Types.BuildType+import Distribution.Types.CondTree+import Distribution.Types.Dependency+import Distribution.Types.ExeDependency+import Distribution.Types.Executable+import Distribution.Types.ExecutableScope+import Distribution.Types.ForeignLib+import Distribution.Types.ForeignLibOption+import Distribution.Types.ForeignLibType+import Distribution.Types.GenericPackageDescription+import Distribution.Types.IncludeRenaming+import Distribution.Types.LegacyExeDependency+import Distribution.Types.Library+import Distribution.Types.Mixin+import Distribution.Types.ModuleReexport+import Distribution.Types.ModuleRenaming+import Distribution.Types.PackageDescription+import Distribution.Types.PackageId+import Distribution.Types.PackageName+import Distribution.Types.PkgconfigDependency+import Distribution.Types.PkgconfigName+import Distribution.Types.SetupBuildInfo+import Distribution.Types.SourceRepo+import Distribution.Types.TestSuite+import Distribution.Types.TestSuiteInterface+import Distribution.Types.TestType+import Distribution.Types.UnqualComponentName+import Distribution.Utils.ShortText+import Distribution.Version+import Generics.SOP.TH+import Language.Haskell.Extension+import Test.StrictCheck.Instances+import Test.StrictCheck.Instances.Tools+import Test.StrictCheck.Shaped++DERIVE(Arch)+DERIVE(BuildType)+DERIVE(ConfVar)+DERIVE(Dependency)+DERIVE(ExeDependency)+DERIVE(Flag)+DERIVE(FlagName)+DERIVE(GenericPackageDescription)+DERIVE(LegacyExeDependency)+DERIVE(License)+DERIVE(OS)+DERIVE(PackageDescription)+DERIVE(PackageIdentifier)+DERIVE(PackageName)+DERIVE(PkgconfigDependency)+DERIVE(PkgconfigName)+DERIVE(RepoKind)+DERIVE(RepoType)+DERIVE(SetupBuildInfo)+DERIVE(ShortText)+DERIVE(SourceRepo)+DERIVE(UnqualComponentName)+DERIVE(Version)+DERIVE(VersionRange)++DERIVEN(Benchmark)+DERIVEN(BenchmarkInterface)+DERIVEN(BenchmarkType)+DERIVEN(BuildInfo)+DERIVEN(CompilerFlavor)+DERIVEN(Executable)+DERIVEN(ExecutableScope)+DERIVEN(Extension)+DERIVEN(ForeignLib)+DERIVEN(ForeignLibOption)+DERIVEN(ForeignLibType)+DERIVEN(IncludeRenaming)+DERIVEN(KnownExtension)+DERIVEN(Language)+DERIVEN(LibVersionInfo)+DERIVEN(Library)+DERIVEN(Mixin)+DERIVEN(ModuleReexport)+DERIVEN(ModuleRenaming)+DERIVEN(TestSuite)+DERIVEN(TestSuiteInterface)+DERIVEN(TestType)++deriveGeneric ''CondTree++deriveGeneric ''CondBranch++deriveGeneric ''Condition++instance (Shaped a, Shaped b, Shaped c) => Shaped (CondTree a b c)++instance (Shaped a, Shaped b, Shaped c) => Shaped (CondBranch a b c)++instance Shaped a => Shaped (Condition a)++PRIM(Bool)+PRIM(Char)+PRIM(Int)+PRIM(ModuleName) -- contains ShortTextLst, which isn't exported+PRIM(ShortByteString)+PRIM(Word64)
+ tests/strictness/Main.hs view
@@ -0,0 +1,48 @@+{-# Language FlexibleContexts #-}++import Control.DeepSeq+import Data.Word+import Distribution.License+import Distribution.PackageDescription+import qualified Distribution.PackageDescription as C+import Distribution.PackageDescription.Parse+import Distribution.Version+import qualified GHC.Generics as GHC+import Generics.SOP+import Generics.SOP.TH+import Instances+import Pretty+import StylishCabal+import Test.Hspec hiding (shouldBe)+import Test.Hspec.Expectations.Pretty+import Test.StrictCheck.Demands+import Test.StrictCheck.Instances+import Test.StrictCheck.Instances.Tools+import Test.StrictCheck.Observe+import Test.StrictCheck.Shaped++whnfContext = flip seq ()++process gpd =+ deepseq+ ( C.library pd+ , C.subLibraries pd+ , C.executables pd+ , C.buildDepends pd+ , C.foreignLibs pd+ , C.testSuites pd+ , C.benchmarks pd)+ (length $ show $ pretty 2 gpd)+ where+ pd = packageDescription gpd++main :: IO ()+main =+ hspec $ do+ ParseOk _ gpd <-+ runIO $ parseGenericPackageDescription <$> readFile "tests/example.cabal"+ describe "pretty" $+ it "should fully evaluate the package description" $ do+ let expected = nf gpd+ (_, actual) = observe1 whnfContext process gpd+ pprint actual `shouldBe` pprint expected
+ tests/strictness/Pretty.hs view
@@ -0,0 +1,66 @@+{-# Language OverloadedStrings #-}+{-# Language NoMonomorphismRestriction #-}++module Pretty where++import Data.Bifunctor+import Generics.SOP (Associativity(..))+import Test.StrictCheck.Observe+import Test.StrictCheck.Shaped+import Text.PrettyPrint.ANSI.Leijen++pprint = showThunk False "_" 10++showThunk a b c d = flip displayS "" $ renderPretty 1.0 90 $ go a b c (renderfold d)+ where+ go _ thunk _ (RWrap T) = thunk+ go qualify thunk prec (RWrap (E pd)) =+ case pd of+ ConstructorD name [] -> withParens False (string $ qualify' name)+ ConstructorD name fields ->+ withParens (prec > 10 && not (null fields)) $+ string (qualify' name) <$$>+ indent 2 (align (sep (map (go qualify thunk 11) fields)))+ RecordD name [] -> withParens (prec > 10) (string (qualify' name))+ RecordD name recfields ->+ withParens (prec > 10) $+ string (qualify' name) <$$>+ indent+ 2+ (encloseSep (lbrace <> space) (softbreak <> rbrace) (comma <> space) $+ map+ (\(fName, x) ->+ string (qualify' fName) <+>+ char '=' <+> go qualify thunk 11 x)+ recfields)+ CustomD fixity list ->+ withParens (prec > fixity) $+ hcat $+ flip fmap list $+ extractEither .+ bimap (string . qualifyEither) (uncurry $ go qualify thunk)+ InfixD name assoc fixity l r ->+ withParens (prec > fixity) $+ let (lprec, rprec) =+ case assoc of+ LeftAssociative -> (fixity, fixity + 1)+ RightAssociative -> (fixity + 1, fixity)+ NotAssociative -> (fixity + 1, fixity + 1)+ in fillSep+ [ go qualify thunk lprec l+ , string (qualify' name)+ , go qualify thunk rprec r+ ]+ where+ withParens False = id+ withParens True = parens+ extractEither = either id id+ qualify' (m, _, n) =+ if qualify+ then m ++ "." ++ n+ else n+ qualifyEither (Left s) = s+ qualifyEither (Right (m, n)) =+ if qualify+ then m ++ "." ++ n+ else n