stylish-cabal 0.4.1.0 → 0.5.0.0
raw patch · 14 files changed
+641/−666 lines, 14 filesdep −ghc-primdep ~Cabaldep ~base-compatdep ~haddock-library
Dependencies removed: ghc-prim
Dependency ranges changed: Cabal, base-compat, haddock-library
Files
- src/Parse.hs +46/−58
- src/Render.hs +2/−2
- src/Render/Lib.hs +91/−81
- src/Render/Lib/Haddock.hs +103/−96
- src/Render/Options.hs +12/−8
- src/StylishCabal.hs +18/−12
- src/Transform.hs +203/−200
- src/Types/Block.hs +4/−4
- src/Types/Field.hs +28/−27
- stylish-cabal.cabal +6/−11
- tests/utils/Expectations.hs +28/−25
- tests/utils/MultiSet.hs +3/−3
- tests/utils/SortedPackageDescription.hs +91/−94
- tests/utils/SortedPackageDescription/TH.hs +6/−45
src/Parse.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -12,65 +11,52 @@ , printWarnings , Result(..) , result- ) where--import Control.DeepSeq-import Control.Monad.Compat-import Data.Data-import Data.Maybe-import Distribution.PackageDescription-import Distribution.PackageDescription.Parsec- ( parseGenericPackageDescription- , runParseResult )-import Distribution.Parsec.Common-import Distribution.Simple.Utils-import Distribution.Verbosity-import Distribution.Version-import GHC.Generics-import Prelude.Compat-import System.Exit-#if MIN_VERSION_base(4,9,0)-import Data.Functor.Classes-#endif+where++import Control.DeepSeq+import Control.Monad.Compat+import Data.Data+import Data.Maybe+import Distribution.PackageDescription+import Distribution.PackageDescription.Parsec+ ( parseGenericPackageDescription+ , runParseResult+ )+import Distribution.Parsec.Common+import Distribution.Simple.Utils+import Distribution.Verbosity+import Distribution.Version+import GHC.Generics+import Prelude.Compat+import System.Exit+import Data.Functor.Classes+ -- | Like Cabal's @ParseResult@, but treats warnings as a separate failure -- case. data Result a = Error [PError] -- ^ Parse errors. | Warn [PWarning] -- ^ Warnings emitted during parse. | Success a -- ^ The input is a compliant package description.- deriving (Show, Eq, Functor, Generic, Typeable, Data)-#if MIN_VERSION_base(4,6,0)-deriving instance Generic1 Result-#endif--#if !MIN_VERSION_base(4,8,0)-deriving instance Typeable PError--deriving instance Typeable Position--deriving instance Typeable PWarnType-#endif+ deriving (Show, Eq, Functor, Generic, Typeable, Data, Generic1) -#if MIN_VERSION_base(4,9,0) instance Show1 Result where- liftShowsPrec sp _ p (Success n) = showsUnaryWith sp "Success" p n- liftShowsPrec _ _ p (Warn pws) = showsUnaryWith showsPrec "Warn" p pws- liftShowsPrec _ _ p (Error s) = showsUnaryWith showsPrec "Error" p s+ liftShowsPrec sp _ p (Success n ) = showsUnaryWith sp "Success" p n+ liftShowsPrec _ _ p (Warn pws) = showsUnaryWith showsPrec "Warn" p pws+ liftShowsPrec _ _ p (Error s ) = showsUnaryWith showsPrec "Error" p s instance Eq1 Result where- liftEq eq (Success a) (Success b) = eq a b- liftEq _ (Error s) (Error s2) = s == s2- liftEq _ (Warn pws) (Warn pws2) = pws == pws2- liftEq _ _ _ = False-#endif+ liftEq eq (Success a ) (Success b ) = eq a b+ liftEq _ (Error s ) (Error s2 ) = s == s2+ liftEq _ (Warn pws) (Warn pws2) = pws == pws2+ liftEq _ _ _ = False+ -- | Case analysis for 'Result'. result :: ([PError] -> b) -> ([PWarning] -> b) -> (a -> b) -> Result a -> b-result e w s p =- case p of- Error l -> e l- Warn ws -> w ws- Success r -> s r+result e w s p = case p of+ Error l -> e l+ Warn ws -> w ws+ Success r -> s r deriving instance Data PError @@ -95,32 +81,34 @@ -- it safe here. parsePackageDescription input = let (warnings, r) = runParseResult $ parseGenericPackageDescription input- in case r of+ in case r of Left (_, errors) -> Error errors- Right x- | null warnings -> parseResult x- | otherwise -> Warn warnings+ Right x | null warnings -> parseResult x+ | otherwise -> Warn warnings where parseResult gpd = if specVersionRaw (packageDescription gpd) == Right anyVersion then Warn [PWarning PWTOther zeroPos versWarning] else Success gpd- versWarning =- "File does not specify a cabal-version. stylish-cabal requires at least 1.2"+ versWarning+ = "File does not specify a cabal-version. stylish-cabal requires at least 1.2" -- | Shorthand to combine 'parsePackageDescription' and one of 'printWarnings' or -- 'displayError'. The given 'FilePath' is used only for error messages and -- is not read from. readPackageDescription fpath =- result (displayError fpath) (printWarnings fpath) return . parsePackageDescription+ result (displayError fpath) (printWarnings fpath) return+ . parsePackageDescription --- | Print some warnings to 'stderr' and exit.+-- | Print some warnings to 'System.IO.stderr' and exit. printWarnings :: Maybe FilePath -> [PWarning] -> IO a printWarnings fpath ps =- mapM_ (warn normal . showPWarning (fromMaybe "<input>" fpath)) ps >> exitFailure+ mapM_ (warn normal . showPWarning (fromMaybe "<input>" fpath)) ps+ >> exitFailure --- | Print a parse error to 'stderr', annotated with filepath if available,+-- | Print a parse error to 'System.IO.stderr', annotated with filepath if available, -- then exit. displayError :: Maybe FilePath -> [PError] -> IO a displayError fpath warns =- mapM_ (warn normal . showPError (fromMaybe "<input>" fpath)) warns >> exitFailure+ mapM_ (warn normal . showPError (fromMaybe "<input>" fpath)) warns+ >> exitFailure
src/Render.hs view
@@ -89,7 +89,7 @@ deps lsep = enclose (string lsep) empty $ hcat $- intersperse (hardline <> string ", ") $ map showField $ sortBy (comparing fst) bs+ intersperse (hardline <> string ", ") $ map showField $ sortOn fst bs longest = maximum $ map (length . unP . fst) bs hasRequires = any (\(_, c) -> not (isDefaultRenaming $ includeRequiresRn c)) bs showField (P fName, i@IncludeRenaming {..})@@ -130,7 +130,7 @@ | otherwise = fmap (\r -> colon <> indent (k - 1) r) (deps " ") where deps lsep = do- fs <- mapM showField $ sortBy (comparing fst) bs+ fs <- mapM showField $ sortOn fst bs return $ encloseSep (string lsep) empty (string ", ") fs longest = maximum $ map (length . unP . fst) bs showField (P fName, fieldVal)
src/Render/Lib.hs view
@@ -11,25 +11,29 @@ , renderTestedWith , exeDependencyAsDependency , renderDescription- ) where+ )+where -import Data.Char-import Data.List.Compat-import Data.Monoid.Compat-import Distribution.Compiler-import Distribution.ModuleName-import Distribution.PackageDescription-import Distribution.Pretty-import Distribution.Types.ExeDependency-import Distribution.Types.PackageName-import Distribution.Types.UnqualComponentName-import Distribution.Version-import Prelude.Compat-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))+import Data.Char+import Data.List.Compat+import Data.Monoid.Compat+import Distribution.Compiler+import Distribution.ModuleName+import Distribution.PackageDescription+import Distribution.Pretty+import Distribution.Types.ExeDependency+import Distribution.Types.PackageName+import Distribution.Types.UnqualComponentName+import Distribution.Version+import Prelude.Compat+import Text.PrettyPrint.ANSI.Leijen+ hiding ( (<$>)+ , (<>)+ ) -import Render.Lib.Haddock (renderDescription)-import Render.Options-import Types.Block+import Render.Lib.Haddock ( renderDescription )+import Render.Options+import Types.Block newtype P = P { unP :: String@@ -37,103 +41,109 @@ 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+ compare (P "base") _ = LT+ compare _ (P "base") = GT+ compare (P p1) (P p2 ) = compare p1 p2 renderTestedWith ts =- fillSep . punctuate comma <$>- mapM (\(compiler, vers) -> showVersioned (showCompiler compiler, vers)) ts+ fillSep+ . punctuate comma+ <$> mapM+ (\(compiler, vers) -> showVersioned (showCompiler compiler, vers))+ ts where showCompiler (OtherCompiler x) = x- showCompiler (HaskellSuite x) = x- showCompiler x = show x+ showCompiler (HaskellSuite x) = x+ showCompiler x = show x showVersioned :: (String, VersionRange) -> Render Doc-showVersioned (pn, v')- | v' == anyVersion = pure $ string pn- | otherwise = fmap (string pn <+>) (showVersionRange v')+showVersioned (pn, v') | v' == anyVersion = pure $ string pn+ | otherwise = fmap (string pn <+>) (showVersionRange v') showVersionRange r = do opts <- ask- return $- cataVersionRange fold' $- (if simplifyVersions opts- then simplifyVersionRange- else id)- r+ return+ $ cataVersionRange fold'+ $ (if simplifyVersions opts then simplifyVersionRange else id) r where- fold' AnyVersionF = empty- fold' (ThisVersionF v) = green "==" <+> dullyellow (string (prettyShow v))+ fold' AnyVersionF = empty+ fold' (ThisVersionF v) = green "==" <+> dullyellow (string (prettyShow v)) fold' (LaterVersionF v) = green ">" <+> dullyellow (string (prettyShow v))- fold' (OrLaterVersionF v) = green ">=" <+> dullyellow (string (prettyShow v))- fold' (EarlierVersionF v) = green "<" <+> dullyellow (string (prettyShow v))- fold' (OrEarlierVersionF v) = green "<=" <+> dullyellow (string (prettyShow v))- fold' (WildcardVersionF v) = green "==" <+> dullyellow (string (prettyShow v) <> ".*")- fold' (MajorBoundVersionF v) = green "^>=" <+> dullyellow (string (prettyShow v))- fold' (UnionVersionRangesF a b) = a <+> green "||" <+> b+ fold' (OrLaterVersionF v) =+ green ">=" <+> dullyellow (string (prettyShow v))+ fold' (EarlierVersionF v) =+ green "<" <+> dullyellow (string (prettyShow v))+ fold' (OrEarlierVersionF v) =+ green "<=" <+> dullyellow (string (prettyShow v))+ fold' (WildcardVersionF v) =+ green "==" <+> dullyellow (string (prettyShow v) <> ".*")+ fold' (MajorBoundVersionF v) =+ green "^>=" <+> dullyellow (string (prettyShow v))+ fold' (UnionVersionRangesF a b) = a <+> green "||" <+> b fold' (IntersectVersionRangesF a b) = a <+> green "&&" <+> b- fold' (VersionRangeParensF a) = parens a+ fold' (VersionRangeParensF a ) = parens a filepath :: String -> Doc-filepath x- | null x = string "\"\""- | any isSpace x = string $ show x- | otherwise = string x+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)+ maybe empty (\f -> string (unPackageName f) <> colon) pkg+ <> (if origname == name+ then moduleDoc origname+ else moduleDoc origname <+> "as" <+> moduleDoc name+ ) exeDependencyAsDependency (ExeDependency pkg comp vers) = (P $ unPackageName pkg ++ ":" ++ unUnqualComponentName comp, vers) renderBlockHead (If c) = (dullblue "if" <+>) <$> showPredicate c-renderBlockHead x = pure $ r x+renderBlockHead x = pure $ r x where- r CustomSetup = dullgreen "custom-setup"+ r CustomSetup = dullgreen "custom-setup" r (SourceRepo_ k) = dullgreen "source-repository" <+> showKind k where- showKind RepoHead = "head"- showKind RepoThis = "this"+ showKind RepoHead = "head"+ showKind RepoThis = "this" showKind (RepoKindUnknown y) = string y- r (Library_ Nothing) = dullgreen "library"- r (Library_ (Just l)) = dullgreen "library" <+> string l- r (ForeignLib_ l) = dullgreen "foreign-library" <+> string l- r (Exe_ e) = dullgreen "executable" <+> string e- r (TestSuite_ t) = dullgreen "test-suite" <+> string t- r (Benchmark_ b) = dullgreen "benchmark" <+> string b- r (Flag_ s) = dullgreen "flag" <+> string s- r Else = dullblue "else"- r _ = error "unreachable"+ r (Library_ Nothing ) = dullgreen "library"+ r (Library_ (Just l)) = dullgreen "library" <+> string l+ r (ForeignLib_ l ) = dullgreen "foreign-library" <+> string l+ r (Exe_ e ) = dullgreen "executable" <+> string e+ r (TestSuite_ t ) = dullgreen "test-suite" <+> string t+ r (Benchmark_ b ) = dullgreen "benchmark" <+> string b+ r (Flag_ s ) = dullgreen "flag" <+> string s+ r Else = dullblue "else"+ r _ = error "unreachable" showPredicate :: Condition ConfVar -> Render Doc-showPredicate (Var x) = showVar x-showPredicate (CNot p) = fmap (dullmagenta (string "!") <>) (maybeParens p)-showPredicate (CAnd a b) =- liftM2 (\x y -> x <+> dullblue (string "&&") <+> y) (maybeParens a) (maybeParens b)-showPredicate (COr a b) =- liftM2 (\x y -> x <+> dullblue (string "||") <+> y) (maybeParens a) (maybeParens b)+showPredicate (Var x ) = showVar x+showPredicate (CNot p ) = fmap (dullmagenta (string "!") <>) (maybeParens p)+showPredicate (CAnd a b) = liftM2+ (\x y -> x <+> dullblue (string "&&") <+> y)+ (maybeParens a)+ (maybeParens b)+showPredicate (COr a b) = liftM2 (\x y -> x <+> dullblue (string "||") <+> y)+ (maybeParens a)+ (maybeParens b) showPredicate (Lit b) = pure $ string $ show b -maybeParens p =- case p of- Lit {} -> showPredicate p- Var {} -> showPredicate p- CNot {} -> showPredicate p- _ -> parens <$> showPredicate p+maybeParens p = case p of+ Lit{} -> showPredicate p+ Var{} -> showPredicate p+ CNot{} -> showPredicate p+ _ -> parens <$> showPredicate p showVar :: ConfVar -> Render Doc showVar (Impl compiler vers) = do v <- showVersioned (prettyShow compiler, vers) pure $ dullgreen $ string "impl" <> parens (dullblue v)-showVar (Flag f) =- pure $ dullgreen $ string "flag" <> parens (dullblue $ string (unFlagName f))-showVar (OS w) =- pure $ dullgreen $ string "os" <> parens (dullblue $ string $ map toLower $ show w)-showVar (Arch a) =- pure $ dullgreen $ string "arch" <> parens (dullblue $ string $ map toLower $ show a)+showVar (Flag f) = pure $ dullgreen $ string "flag" <> parens+ (dullblue $ string (unFlagName f))+showVar (OS w) = pure $ dullgreen $ string "os" <> parens+ (dullblue $ string $ map toLower $ show w)+showVar (Arch a) = pure $ dullgreen $ string "arch" <> parens+ (dullblue $ string $ map toLower $ show a)
src/Render/Lib/Haddock.hs view
@@ -4,15 +4,18 @@ module Render.Lib.Haddock where -import Control.Monad.Reader-import Data.Char (isSpace)-import Data.List.Compat-import Data.List.Split-import Data.Monoid.Compat-import Documentation.Haddock.Parser (Identifier)-import Documentation.Haddock.Types-import Prelude.Compat-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))+import Control.Monad.Reader+import Data.Char ( isSpace )+import Data.List.Compat+import Data.List.Split+import Data.Monoid.Compat+import Documentation.Haddock.Parser ( Identifier )+import Documentation.Haddock.Types+import Prelude.Compat+import Text.PrettyPrint.ANSI.Leijen+ hiding ( (<$>)+ , (<>)+ ) data FlattenBehavior = Flatten@@ -29,13 +32,14 @@ , listContext :: Bool } -flattenedBody = withReader $ \d -> d {flattenBehavior = Flatten, textPosition = Body}+flattenedBody =+ withReader $ \d -> d { flattenBehavior = Flatten, textPosition = Body } -inPara = withReader $ \d -> d {textPosition = ParaStart}+inPara = withReader $ \d -> d { textPosition = ParaStart } -inBody = withReader $ \d -> d {textPosition = Body}+inBody = withReader $ \d -> d { textPosition = Body } -inList = withReader $ \d -> d {listContext = True}+inList = withReader $ \d -> d { listContext = True } defaultDocContext = DocContext WordBreak ParaStart False @@ -43,123 +47,126 @@ -- to change rendering logic entirely inside a code block (i.e. don't -- fillSep words). renderDescription =- vcat . intersperse (green ".") . map ((`runReader` defaultDocContext) . go) . flatten+ vcat+ . intersperse (green ".")+ . map ((`runReader` defaultDocContext) . go)+ . flatten where flatten (DocAppend d1 d2) = flatten d1 ++ flatten d2- flatten d = [d]+ flatten d = [d] -- flatten inline styling which the haddock parser doesn't preserve -- across line boundaries go :: DocH () Identifier -> Reader DocContext Doc go DocEmpty = pure empty- go (DocEmphasis d) = enclose (green "/") (green "/") <$> flattenedBody (go d)- go (DocMonospaced d) = enclose (green "@") (green "@") <$> flattenedBody (go d)+ go (DocEmphasis d) =+ enclose (green "/") (green "/") <$> flattenedBody (go d)+ go (DocMonospaced d) =+ enclose (green "@") (green "@") <$> flattenedBody (go d) go (DocBold d) = enclose (green "__") (green "__") <$> flattenedBody (go d) go (DocHeader (Header l t)) = (green (strBody $ replicate l '=') <+>) <$> inBody (go t)- go (DocAppend a b) = liftM2 (<>) (go a) (inBody $ go b)- go (DocParagraph d) = inPara $ go d+ go (DocAppend a b ) = liftM2 (<>) (go a) (inBody $ go b)+ go (DocParagraph d ) = inPara $ go d go (DocUnorderedList ds) = do- docs <-- forM ds $ \item -> do- doc <- inList $ inPara $ go item- return $ hang 2 $ string "*" <+> doc+ docs <- forM ds $ \item -> do+ doc <- inList $ inPara $ go item+ return $ hang 2 $ string "*" <+> doc return $ vcat docs go (DocOrderedList ds) = do- docs <-- forM (zip [1 ..] ds) $ \(n, item) -> do- doc <- inList $ inPara $ go item- return $ hang 3 $ integer n <> "." <+> doc+ docs <- forM (zip [1 ..] ds) $ \(n, item) -> do+ doc <- inList $ inPara $ go item+ return $ hang 3 $ integer n <> "." <+> doc return $ vcat docs go (DocCodeBlock cb) = do DocContext {..} <- ask- return $- case cb of- DocString s- | all (`notElem` ['{', '}']) s && not listContext ->- green ">" <+> arrowblock s- | listContext && notElem '\n' s -> cat [green "@", string s, green "@"]- y -> vcat [green "@", goplain y <> green "@"]+ return $ case cb of+ DocString s+ | all (`notElem` ['{', '}']) s && not listContext -> green ">"+ <+> arrowblock s+ | listContext && notElem '\n' s -> cat+ [green "@", string s, green "@"]+ y -> vcat [green "@", goplain y <> green "@"] go (DocString s) = do DocContext {..} <- ask- return $- case flattenBehavior of- Flatten ->- case textPosition of- Body -> strBody s- ParaStart -> strPara s- WordBreak ->- fillSep $- (if textPosition == ParaStart- then map2 strPara strBody- else map strBody) $- splitWhen isSpace s+ return $ case flattenBehavior of+ Flatten -> case textPosition of+ Body -> strBody s+ ParaStart -> strPara s+ WordBreak ->+ fillSep+ $ (if textPosition == ParaStart+ then map2 strPara strBody+ else map strBody+ )+ $ splitWhen isSpace s go (DocDefList ds) = do- docs <-- forM ds $ \(hdr, body) -> do- rhdr <- inBody $ go hdr- rbdy <- inBody $ go body- return $ enclose (green "[") (green "]") rhdr <+> rbdy+ docs <- forM ds $ \(hdr, body) -> do+ rhdr <- inBody $ go hdr+ rbdy <- inBody $ go body+ return $ enclose (green "[") (green "]") rhdr <+> rbdy return $ vcat docs- go (DocExamples es) =- return $- vcat $- map- (\Example {..} ->- vcat $ (green ">>>" <+> string exampleExpression) : map string exampleResult)- es+ go (DocExamples es) = return $ vcat $ map+ (\Example {..} ->+ vcat+ $ (green ">>>" <+> string exampleExpression)+ : map string exampleResult+ )+ es go (DocModule x) = return $ enclose (green "\"") (green "\"") (strBody x) go (DocIdentifier (c, x, c2)) = return $ enclose (green $ char c) (green $ char c2) (string x)- go (DocMathDisplay x) = return $ enclose (green "\\[") (green "\\]") (strBody x)- go (DocMathInline x) = return $ enclose (green "\\(") (green "\\)") (strBody x)+ go (DocMathDisplay x) =+ return $ enclose (green "\\[") (green "\\]") (strBody x)+ go (DocMathInline x) =+ return $ enclose (green "\\(") (green "\\)") (strBody x) -- go (DocAName x) = return $ enclose (green "#") (green "#") (strBody x)- go (DocHyperlink (Hyperlink h l)) =- return $- enclose (green "<") (green ">") (string $ h ++ maybe "" (" " ++) (unNl <$> l))- go (DocPic (Picture p t)) =- return $- enclose (green "<<") (green ">>") (string $ p ++ maybe "" (" " ++) (unNl <$> t))+ go (DocHyperlink (Hyperlink h l)) = return $ enclose+ (green "<")+ (green ">")+ (string $ h ++ maybe "" (" " ++) (unNl <$> l))+ go (DocPic (Picture p t)) = return $ enclose+ (green "<<")+ (green ">>")+ (string $ p ++ maybe "" (" " ++) (unNl <$> t)) go x = error $ "Unhandled Haddock AST node: " ++ show x- unNl =- map- (\x ->- if x == '\n'- then ' '- else x)- goplain (DocString s) = strPara $ escapeHtml s+ unNl = map (\x -> if x == '\n' then ' ' else x)+ goplain (DocString s ) = strPara $ escapeHtml s goplain (DocAppend a b) = goplain a <> goplain b goplain (DocIdentifier (a, b, c)) = enclose (green (char a)) (green (char c)) (string b) goplain (DocEmphasis x) = enclose (green "/") (green "/") (goplain x)- goplain (DocModule x) = enclose (green "\"") (green "\"") (string x)- goplain n = error $ "Unhandled in goplain: " ++ show n+ goplain (DocModule x) = enclose (green "\"") (green "\"") (string x)+ goplain n = error $ "Unhandled in goplain: " ++ show n -map2 f g (x:xs) = f x : map g xs-map2 _ _ [] = []+map2 f g (x : xs) = f x : map g xs+map2 _ _ [] = [] -arrowblock ('\n':ys) = line <> green "> " <> arrowblock ys-arrowblock (x:xs) = char x <> arrowblock xs-arrowblock "" = empty+arrowblock ('\n' : ys) = line <> green "> " <> arrowblock ys+arrowblock (x : xs) = char x <> arrowblock xs+arrowblock "" = empty -escapeHtml "" = ""-escapeHtml ('\n':'\n':xs) = '\n' : '.' : '\n' : escapeHtml xs-escapeHtml ('\n':xs)- | (spcs, '-':chrs) <- span isSpace xs = '\n' : spcs ++ ('\1' : '-' : escapeHtml chrs)-escapeHtml (c:cs) = c : escapeHtml cs+escapeHtml "" = ""+escapeHtml ('\n' : '\n' : xs) = '\n' : '.' : '\n' : escapeHtml xs+escapeHtml ('\n' : xs) | (spcs, '-' : chrs) <- span isSpace xs =+ '\n' : spcs ++ ('\1' : '-' : escapeHtml chrs)+escapeHtml (c : cs) = c : escapeHtml cs -strPara ('>':'>':'>':cs) = text "\\>>>" <> strBody cs-strPara (x:cs)+strPara ('>' : '>' : '>' : cs) = text "\\>>>" <> strBody cs+strPara (x : cs) | -- >, *, and - are mentioned by the haddock docks, but [ is also -- a special character b/c it starts a definition list- | x `elem` ['>', '*', '-', '['] = char '\\' <> char x <> strBody cs+ x `elem` ['>', '*', '-', '['] =+ char '\\' <> char x <> strBody cs strPara x = strBody x -strBody ('\n':x) = line <> strPara x-strBody ('{':xs) = "{" <> strBody xs-strBody ('}':xs) = "}" <> strBody xs-strBody (x:xs)- | x `elem` ['\\', '/', '\'', '`', '"', '@', '<', '#'] =- char '\\' <> char x <> strBody xs- | x == '\1' = char '\\' <> strBody xs- | otherwise = char x <> strBody xs+strBody ('\n' : x ) = line <> strPara x+strBody ('{' : xs) = "{" <> strBody xs+strBody ('}' : xs) = "}" <> strBody xs+strBody (x : xs)+ | x `elem` ['\\', '/', '\'', '`', '"', '@', '<', '#']+ = char '\\' <> char x <> strBody xs+ | x == '\1'+ = char '\\' <> strBody xs+ | otherwise+ = char x <> strBody xs strBody "" = empty
src/Render/Options.hs view
@@ -5,14 +5,18 @@ module Render.Options ( module Render.Options , module Control.Monad.Reader- ) where+ )+where -import Control.Monad.Reader hiding (mapM)-import Data.Data-import Data.Default-import GHC.Generics-import Prelude.Compat-import Text.PrettyPrint.ANSI.Leijen (Doc, indent, width)+import Control.Monad.Reader hiding ( mapM )+import Data.Data+import Data.Default+import GHC.Generics+import Prelude.Compat+import Text.PrettyPrint.ANSI.Leijen ( Doc+ , indent+ , width+ ) type Render = Reader RenderOptions @@ -27,7 +31,7 @@ } deriving (Show, Eq, Generic, Typeable, Data) instance Default RenderOptions where- def = RenderOptions {indentSize = 2, simplifyVersions = False}+ def = RenderOptions { indentSize = 2, simplifyVersions = False } indentM :: Doc -> Render Doc indentM k = do
src/StylishCabal.hs view
@@ -21,19 +21,24 @@ , plain , displayIO , displayS- ) where+ )+where -import Data.Default-import Data.Monoid.Compat-import Distribution.PackageDescription (GenericPackageDescription)-import Distribution.Parsec.Common-import Prelude.Compat-import Text.PrettyPrint.ANSI.Leijen hiding ((<>), pretty)+import Data.Default+import Data.Monoid.Compat+import Distribution.PackageDescription+ ( GenericPackageDescription )+import Distribution.Parsec.Common+import Prelude.Compat+import Text.PrettyPrint.ANSI.Leijen+ hiding ( (<>)+ , pretty+ ) -import Parse-import Render-import Render.Options-import Transform+import Parse+import Render+import Render.Options+import Transform -- | @pretty pkg@ produces a colorized, formatted textual representation of -- a given 'Distribution.PackageDescription.GenericPackageDescription',@@ -45,7 +50,8 @@ -- | 'pretty' with specified options. prettyOpts :: RenderOptions -> GenericPackageDescription -> Doc-prettyOpts opts gpd = runReader (uncurry blockBodyToDoc $ toBlocks gpd) opts <> line+prettyOpts opts gpd =+ runReader (uncurry blockBodyToDoc $ toBlocks gpd) opts <> line -- | Render the given 'Doc' with the given width. render :: Int -> Doc -> SimpleDoc
src/Transform.hs view
@@ -3,186 +3,190 @@ module Transform ( toBlocks- ) where+ )+where -import Control.Arrow-import Control.DeepSeq-import Control.Monad-import Data.Char-import Data.Maybe-import Distribution.License-import Distribution.PackageDescription-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-import Prelude.Compat+import Control.Arrow+import Control.DeepSeq+import Control.Monad+import Data.Char+import Data.Maybe+import Distribution.License+import Distribution.PackageDescription+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+import Prelude.Compat -import Types.Block-import Types.Field+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- ])+ [ 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 {..}+setupBuildInfoToBlock SetupBuildInfo {..} =+ defaultSetupDepends+ `seq` Block CustomSetup+ [nonEmpty (dependencies "setup-depends") setupDepends]+ [] -- 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- ]- []+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+ showType x = map toLower $ show x pdToFields pd@PackageDescription {..} = [ guard newSpec >> cabalVersion "cabal-version" specVersionRaw- , stringField "name" (unPackageName $ pkgName package)- , version "version" (pkgVersion package)- , nonEmpty (stringField "synopsis") synopsis- , desc description- , either- (spdxLicenseField "license")- (ffilter (/= UnspecifiedLicense) (licenseField "license"))- licenseRaw- , 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 =<< buildTypeRaw- , 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" specVersionRaw- ] ++- map (uncurry stringField) customFieldsPD+ , stringField "name" (unPackageName $ pkgName package)+ , version "version" (pkgVersion package)+ , nonEmpty (stringField "synopsis") synopsis+ , desc description+ , either (spdxLicenseField "license")+ (ffilter (/= UnspecifiedLicense) (licenseField "license"))+ licenseRaw+ , 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 =<< buildTypeRaw+ , 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" specVersionRaw+ ]+ ++ map (uncurry stringField) customFieldsPD where newSpec = withinRange packageVersion (orLaterVersion $ mkVersion [2, 1]) packageVersion = specVersion pd- license' [] = Nothing+ license' [] = Nothing license' [l] = file "license-file" l- license' ls = commas "license-files" ls+ license' ls = commas "license-files" ls -flagToBlock MkFlag {..} =- Block- (Flag_ (unFlagName flagName))- [ stringField "default" (show flagDefault)- , ffilter id (stringField "manual" . show) flagManual- , desc flagDescription- ]- []+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)+libToBlock pkg libname CondNode {..} = deepseq condTreeConstraints $ Block+ (Library_ $ unUnqualComponentName <$> libname)+ ( libDataToFields condTreeData+ ++ buildInfoToFields pkg (libBuildInfo condTreeData)+ )+ (nodesToBlocks pkg libBuildInfo libDataToFields condTreeComponents) libDataToFields Library {..} =- libName `deepseq`- [ ffilter not (stringField "exposed" . show) libExposed- , nonEmpty (modules "exposed-modules") exposedModules- , nonEmpty (rexpModules "reexported-modules") reexportedModules- , nonEmpty (modules "signatures") signatures- ]+ libName+ `deepseq` [ ffilter not (stringField "exposed" . show) libExposed+ , nonEmpty (modules "exposed-modules") exposedModules+ , nonEmpty (rexpModules "reexported-modules") reexportedModules+ , nonEmpty (modules "signatures") signatures+ ] foreignLibToBlock pkg libname CondNode {..} =- condTreeConstraints `deepseq`- Block+ condTreeConstraints `deepseq` Block (ForeignLib_ $ unUnqualComponentName libname)- (foreignLibDataToFields condTreeData ++- buildInfoToFields pkg (foreignLibBuildInfo condTreeData))- (nodesToBlocks pkg foreignLibBuildInfo foreignLibDataToFields condTreeComponents)+ ( 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- ]+ 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+ 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)+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- ]+ 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)+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]- _ -> []+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)+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+ benchmarkName `seq` case benchmarkInterface of BenchmarkExeV10 v f -> v `seq` [stringField "type" "exitcode-stdio-1.0", stringField "main-is" f] _ -> []@@ -190,66 +194,65 @@ 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+ 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 _ BuildInfo {..} =- staticOptions `seq` -- staticOptions isn't in the parser yet- [ nonEmpty (commas "other-languages" . map show) otherLanguages- , nonEmpty (modules "other-modules") otherModules- , nonEmpty (modules "virtual-modules") virtualModules- , 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-library-flavours") extraLibFlavours- , nonEmpty (commas "extra-libraries") extraLibs- , nonEmpty (commas "extra-ghci-libraries") extraGHCiLibs- , nonEmpty (commas "extra-bundled-libraries") extraBundledLibs- , nonEmpty (pcDepends "pkgconfig-depends") pkgconfigDepends- , nonEmpty (commas "frameworks") frameworks- , nonEmpty (commas "extra-framework-dirs") extraFrameworkDirs- , nonEmpty (spaces "cc-options") ccOptions- , nonEmpty (spaces "cxx-options") cxxOptions- , nonEmpty (spaces "cmm-options") cmmOptions- , nonEmpty (spaces "asm-options") asmOptions- , nonEmpty (spaces "cpp-options") cppOptions- , nonEmpty (spaces "ld-options") ldOptions- , nonEmpty (commas "js-sources") jsSources- , nonEmpty (commas "cxx-sources") cxxSources- , nonEmpty (commas "c-sources") cSources- , nonEmpty (commas "cmm-sources") cmmSources- , nonEmpty (commas "asm-sources") asmSources- , nonEmpty (commas "extra-lib-dirs") extraLibDirs- , nonEmpty (commas "includes") includes- , nonEmpty (commas "install-includes") installIncludes- , nonEmpty (commas "include-dirs") includeDirs- , 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) = (buildTools, buildToolDepends)+ staticOptions+ `seq` -- staticOptions isn't in the parser yet+ [ nonEmpty (commas "other-languages" . map show) otherLanguages+ , nonEmpty (modules "other-modules") otherModules+ , nonEmpty (modules "virtual-modules") virtualModules+ , 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-library-flavours") extraLibFlavours+ , nonEmpty (commas "extra-libraries") extraLibs+ , nonEmpty (commas "extra-ghci-libraries") extraGHCiLibs+ , nonEmpty (commas "extra-bundled-libraries") extraBundledLibs+ , nonEmpty (pcDepends "pkgconfig-depends") pkgconfigDepends+ , nonEmpty (commas "frameworks") frameworks+ , nonEmpty (commas "extra-framework-dirs") extraFrameworkDirs+ , nonEmpty (spaces "cc-options") ccOptions+ , nonEmpty (spaces "cxx-options") cxxOptions+ , nonEmpty (spaces "cmm-options") cmmOptions+ , nonEmpty (spaces "asm-options") asmOptions+ , nonEmpty (spaces "cpp-options") cppOptions+ , nonEmpty (spaces "ld-options") ldOptions+ , nonEmpty (commas "js-sources") jsSources+ , nonEmpty (commas "cxx-sources") cxxSources+ , nonEmpty (commas "c-sources") cSources+ , nonEmpty (commas "cmm-sources") cmmSources+ , nonEmpty (commas "asm-sources") asmSources+ , nonEmpty (commas "extra-lib-dirs") extraLibDirs+ , nonEmpty (commas "includes") includes+ , nonEmpty (commas "install-includes") installIncludes+ , nonEmpty (commas "include-dirs") includeDirs+ , 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) = (buildTools, buildToolDepends) -optionToField pref (f, args) = spaces (map toLower (show f) ++ pref ++ "-options") args+optionToField pref (f, args) =+ spaces (map toLower (show f) ++ pref ++ "-options") args
src/Types/Block.hs view
@@ -1,8 +1,8 @@ module Types.Block where -import Distribution.PackageDescription-import Prelude.Compat-import Types.Field+import Distribution.PackageDescription+import Prelude.Compat+import Types.Field type File = ([Maybe Field], [Block]) @@ -26,4 +26,4 @@ deriving (Show) isElse Else = True-isElse _ = False+isElse _ = False
src/Types/Field.hs view
@@ -29,25 +29,28 @@ , nonEmpty , stringField , ffilter- ) where+ )+where -import Distribution.Compiler-import Distribution.License-import Distribution.ModuleName-import qualified Distribution.SPDX as SPDX-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 Documentation.Haddock.Parser-import Documentation.Haddock.Types (DocH, _doc)-import Language.Haskell.Extension-import Prelude.Compat+import Distribution.Compiler+import Distribution.License+import Distribution.ModuleName+import qualified Distribution.SPDX as SPDX+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 Documentation.Haddock.Parser+import Documentation.Haddock.Types ( DocH+ , _doc+ )+import Language.Haskell.Extension+import Prelude.Compat data FieldVal = Dependencies [Dependency]@@ -97,7 +100,7 @@ licenseField n a = Just $ Field n (License a) -spdxLicenseField _ SPDX.NONE = Nothing+spdxLicenseField _ SPDX.NONE = Nothing spdxLicenseField n (SPDX.License a) = Just $ Field n (SPDXLicense a) file n a = Just $ Field n (File a)@@ -112,9 +115,8 @@ version n a = Just $ Field n (Version a) -cabalVersion _ (Right vr)- | vr == anyVersion = Nothing-cabalVersion n a = Just $ Field n (CabalVersion a)+cabalVersion _ (Right vr) | vr == anyVersion = Nothing+cabalVersion n a = Just $ Field n (CabalVersion a) modules n as = Just $ Field n (Modules as) @@ -122,17 +124,16 @@ testedField n a = Just $ Field n (TestedWith a) -ffilter f g as- | not (f as) = Nothing- | otherwise = g as+ffilter f g as | not (f as) = Nothing+ | otherwise = g as nonEmpty = ffilter (not . null) -fieldName (Field s _) = s+fieldName (Field s _ ) = s fieldName (Description _) = "description" desc [] = Nothing-desc vs = Just (Description $ _doc $ parseParas vs)+desc vs = Just (Description $ _doc $ parseParas Nothing vs) buildDeps [] = Nothing buildDeps vs = dependencies "build-depends" vs
stylish-cabal.cabal view
@@ -1,13 +1,12 @@ name: stylish-cabal-version: 0.4.1.0+version: 0.5.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.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2,- GHC == 8.2.2, GHC == 8.4.3+tested-with: GHC == 8.6.1 category: Language build-type: Simple extra-source-files: ChangeLog.md@@ -31,8 +30,7 @@ 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.+ description: Run the strictness testsuite. (Used to verify that the entire package description is processed.) library exposed-modules: StylishCabal@@ -46,12 +44,12 @@ Types.Field hs-source-dirs: src build-depends: base == 4.*- , Cabal ^>= 2.2+ , Cabal ^>= 2.4 , ansi-wl-pprint- , base-compat == 0.10.*+ , base-compat , data-default , deepseq- , haddock-library ^>= 1.5+ , haddock-library ^>= 1.7 , microlens , mtl , split@@ -59,9 +57,6 @@ default-extensions: NoMonomorphismRestriction NoImplicitPrelude ghc-options: -Wall -fno-warn-missing-signatures-- if impl(ghc < 7.6)- build-depends: ghc-prim if flag(werror) ghc-options: -Werror
tests/utils/Expectations.hs view
@@ -1,34 +1,37 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# Language StandaloneDeriving #-} module Expectations where -import qualified Data.ByteString.UTF8 as U-import Data.List.Compat-import Distribution.PackageDescription.Parsec-import Prelude.Compat-import SortedPackageDescription-import StylishCabal as S-import Test.Hspec-import Test.Hspec.Core.Spec-import Test.Hspec.Core.Runner+import qualified Data.ByteString.UTF8 as U+import Data.List.Compat+import Distribution.PackageDescription.Parsec+import Prelude.Compat+import SortedPackageDescription+import StylishCabal as S+import Test.Hspec+import Test.Hspec.Core.Runner -hspecColor = hspecWith (defaultConfig {configColorMode = ColorAlways})+hspecColor = hspecWith (defaultConfig { configColorMode = ColorAlways }) expectParse cabalStr = do- let doc =- U.fromString . (`displayS` "") . render 80 . plain . pretty <$>- S.parsePackageDescription cabalStr- case doc of- S.Success rendered -> do- let ([], Right original) = fmap sortGenericPackageDescription <$> parse' cabalStr- ([], Right new) = fmap sortGenericPackageDescription <$> parse' rendered- shouldBe original new- Warn {} ->- pendingWith- "Warnings generated from original file, cannot guarantee consistency of output"- S.Error {} -> pendingWith "Original cabal file does not parse"- where- parse' = runParseResult . parseGenericPackageDescription+ let doc =+ U.fromString+ . (`displayS` "")+ . render 80+ . plain+ . pretty+ <$> S.parsePackageDescription cabalStr+ case doc of+ S.Success rendered -> do+ let ([], Right original) =+ fmap sortGenericPackageDescription <$> parse' cabalStr+ ([], Right new) =+ fmap sortGenericPackageDescription <$> parse' rendered+ shouldBe original new+ Warn{} ->+ pendingWith+ "Warnings generated from original file, cannot guarantee consistency of output"+ S.Error{} -> pendingWith "Original cabal file does not parse"+ where parse' = runParseResult . parseGenericPackageDescription mkHeader n p = "parses #" ++ show n ++ ": " ++ p
tests/utils/MultiSet.hs view
@@ -2,9 +2,9 @@ module MultiSet where -import qualified Data.Map as M-import Prelude.Compat+import qualified Data.Map as M+import Prelude.Compat newtype MultiSet a = MultiSet { unMultiSet :: M.Map a Int } deriving (Eq, Ord, Show) -fromList = MultiSet . foldr (\ v -> M.insertWith (+) v 1) M.empty+fromList = MultiSet . foldr (\v -> M.insertWith (+) v 1) M.empty
tests/utils/SortedPackageDescription.hs view
@@ -10,47 +10,48 @@ {-# Language TypeFamilies #-} module SortedPackageDescription- ( Sortable(..)- , sortGenericPackageDescription- , MkSortGenericPackageDescription(..)- ) where+ ( Sortable(..)+ , sortGenericPackageDescription+ , MkSortGenericPackageDescription(..)+ )+where -import Data.Char (isSpace)-import Data.List (sortBy)-import Data.List.Split-import Data.Ord (comparing)-import Data.Word-import Distribution.Compiler-import Distribution.License-import Distribution.ModuleName-import Distribution.PackageDescription-import qualified Distribution.SPDX as SPDX-import Distribution.System-import Distribution.Types.CondTree-import Distribution.Types.Dependency-import Distribution.Types.ExeDependency-import Distribution.Types.ExecutableScope-import Distribution.Types.ForeignLib-import Distribution.Types.ForeignLibOption-import Distribution.Types.ForeignLibType-import Distribution.Types.IncludeRenaming-import Lens.Micro.TH-import Lens.Micro-import Distribution.Types.LegacyExeDependency-import Distribution.Types.Mixin-import Distribution.Types.PackageId-import Distribution.Types.PackageName-import Distribution.Types.PkgconfigDependency-import Distribution.Types.PkgconfigName-import Distribution.Types.UnqualComponentName-import Distribution.Types.Version-import Distribution.Types.VersionRange-import Documentation.Haddock.Types hiding (Version)-import Documentation.Haddock.Parser-import Distribution.Utils.ShortText-import Language.Haskell.Extension-import Prelude.Compat-import SortedPackageDescription.TH+import Data.Char ( isSpace )+import Data.List ( sortOn )+import Data.List.Split+import Data.Word+import Distribution.Compiler+import Distribution.License+import Distribution.ModuleName+import Distribution.PackageDescription+import qualified Distribution.SPDX as SPDX+import Distribution.System+import Distribution.Types.CondTree+import Distribution.Types.Dependency+import Distribution.Types.ExeDependency+import Distribution.Types.ExecutableScope+import Distribution.Types.ForeignLib+import Distribution.Types.ForeignLibOption+import Distribution.Types.ForeignLibType+import Distribution.Types.IncludeRenaming+import Lens.Micro.TH+import Lens.Micro+import Distribution.Types.LegacyExeDependency+import Distribution.Types.Mixin+import Distribution.Types.PackageId+import Distribution.Types.PackageName+import Distribution.Types.PkgconfigDependency+import Distribution.Types.PkgconfigName+import Distribution.Types.UnqualComponentName+import Distribution.Types.Version+import Distribution.Types.VersionRange+import Documentation.Haddock.Types+ hiding ( Version )+import Documentation.Haddock.Parser+import Distribution.Utils.ShortText+import Language.Haskell.Extension+import Prelude.Compat+import SortedPackageDescription.TH deriving instance (Ord a, Ord b) => Ord (DocH a b) @@ -75,53 +76,51 @@ [("description", "descriptionL"), ("synopsis", "synopsisL")] ''PackageDescription -sortGenericPackageDescription ::- GenericPackageDescription- -> ([DocH () String], MkSortable GenericPackageDescription)+sortGenericPackageDescription+ :: GenericPackageDescription+ -> ([DocH () String], MkSortable GenericPackageDescription) sortGenericPackageDescription gpd = (descriptions, sortable desc) where (descriptions, desc) = extractDescs gpd- flagDescriptionL = lens flagDescription (\f d -> f {flagDescription = d})+ flagDescriptionL = lens flagDescription (\f d -> f { flagDescription = d }) extractDescs g =- let (dsc, gpd1) = g & (packageDescriptionL . descriptionL) <<.~ ""- (syn, gpd2) = gpd1 & (packageDescriptionL . synopsisL) <<.~ ""- (fs, gpd3) =- gpd2 &- (genPackageFlagsL . traverse) (\x -> ([x], x {flagDescription = ""}))- sortedFlags = sortBy (comparing flagName) fs- in ( map (unNl . toRegular . _doc . parseParas) $- dsc : syn : map flagDescription sortedFlags- , gpd3)+ let+ (dsc, gpd1) = g & (packageDescriptionL . descriptionL) <<.~ ""+ (syn, gpd2) = gpd1 & (packageDescriptionL . synopsisL) <<.~ ""+ (fs, gpd3) =+ gpd2 & (genPackageFlagsL . traverse)+ (\x -> ([x], x { flagDescription = "" }))+ sortedFlags = sortOn flagName fs+ in+ ( map (unNl . toRegular . _doc . parseParas Nothing)+ $ dsc+ : syn+ : map flagDescription sortedFlags+ , gpd3+ ) unNl :: DocH () String -> DocH () String unNl (DocString s) = DocString $ unwords $ wordsBy isSpace s- unNl (DocEmphasis x) = DocEmphasis $ unNl x- unNl (DocAppend a b) = DocAppend (unNl a) (unNl b)- unNl (DocParagraph d) = DocParagraph $ unNl d- unNl (DocBold d) = DocBold (unNl d)- unNl (DocCodeBlock d) = DocCodeBlock $ unNl d+ unNl (DocEmphasis x ) = DocEmphasis $ unNl x+ unNl (DocAppend a b ) = DocAppend (unNl a) (unNl b)+ unNl (DocParagraph d ) = DocParagraph $ unNl d+ unNl (DocBold d ) = DocBold (unNl d)+ unNl (DocCodeBlock d ) = DocCodeBlock $ unNl d unNl (DocDefList bs) = DocDefList $ map (\(x, y) -> (unNl x, unNl y)) bs- unNl (DocUnorderedList b) = DocUnorderedList (map unNl b)- unNl (DocMonospaced d) = DocMonospaced (unNl d)- unNl (DocOrderedList ds) = DocOrderedList (map unNl ds)- unNl DocEmpty = DocEmpty- unNl d@DocHeader {} = d- unNl d@DocMathDisplay {} = d- unNl d@DocExamples {} = d- unNl d@DocPic {} = d- unNl (DocHyperlink (Hyperlink h l)) =- DocHyperlink $- Hyperlink- h- (map (\x ->- if x == '\n'- then ' '- else x) <$>- l)- unNl d@DocIdentifier {} = d- unNl d@DocModule {} = d- unNl d@DocMathInline {} = d- unNl d@DocAName {} = d- unNl x = error $ show x+ unNl (DocUnorderedList b ) = DocUnorderedList (map unNl b)+ unNl (DocMonospaced d ) = DocMonospaced (unNl d)+ unNl (DocOrderedList ds) = DocOrderedList (map unNl ds)+ unNl DocEmpty = DocEmpty+ unNl d@DocHeader{} = d+ unNl d@DocMathDisplay{} = d+ unNl d@DocExamples{} = d+ unNl d@DocPic{} = d+ unNl (DocHyperlink (Hyperlink h l)) = DocHyperlink+ $ Hyperlink h (map (\x -> if x == '\n' then ' ' else x) <$> l)+ unNl d@DocIdentifier{} = d+ unNl d@DocModule{} = d+ unNl d@DocMathInline{} = d+ unNl d@DocAName{} = d+ unNl x = error $ show x prim [''ModuleName, ''ShortText, ''Char, ''Word64, ''PackageName, ''Int, ''Bool] @@ -181,8 +180,6 @@ , ''BenchmarkType ] -deriving instance Ord SourceRepo- deriving instance (Ord a, Ord b, Ord c) => Ord (CondTree a b c) deriving instance (Ord a, Ord b, Ord c) => Ord (CondBranch a b c)@@ -248,12 +245,12 @@ (MkSortable (Condition c)) instance Sortable a => Sortable (Condition a) where- type MkSortable (Condition a) = MkSortCondition a- sortable (Var arg) = MkSortVar (sortable arg)- sortable (Lit arg) = MkSortLit (sortable arg)- sortable (CNot arg) = MkSortCNot (sortable arg)- sortable (COr arg arg2) = MkSortCOr (sortable arg) (sortable arg2)- sortable (CAnd arg arg2) = MkSortCAnd (sortable arg) (sortable arg2)+ type MkSortable (Condition a) = MkSortCondition a+ sortable (Var arg ) = MkSortVar (sortable arg)+ sortable (Lit arg ) = MkSortLit (sortable arg)+ sortable (CNot arg ) = MkSortCNot (sortable arg)+ sortable (COr arg arg2) = MkSortCOr (sortable arg) (sortable arg2)+ sortable (CAnd arg arg2) = MkSortCAnd (sortable arg) (sortable arg2) data MkSortCondTree v c a = MkSortCondNode { mkSortCondTreeData :: MkSortable a@@ -301,9 +298,9 @@ , Ord (MkSortable c) ) => Sortable (CondTree a b c) where- type MkSortable (CondTree a b c) = MkSortCondTree a b c- sortable (CondNode arg arg2 arg3) =- MkSortCondNode (sortable arg) (sortable arg2) (sortable arg3)+ type MkSortable (CondTree a b c) = MkSortCondTree a b c+ sortable (CondNode arg arg2 arg3) =+ MkSortCondNode (sortable arg) (sortable arg2) (sortable arg3) data MkSortCondBranch v c a = MkSortCondBranch { mkSortCondBranchCondition :: MkSortable (Condition v)@@ -319,8 +316,8 @@ , Ord (MkSortable c) ) => Sortable (CondBranch a b c) where- type MkSortable (CondBranch a b c) = MkSortCondBranch a b c- sortable (CondBranch arg arg2 arg3) =- MkSortCondBranch (sortable arg) (sortable arg2) (sortable arg3)+ type MkSortable (CondBranch a b c) = MkSortCondBranch a b c+ sortable (CondBranch arg arg2 arg3) =+ MkSortCondBranch (sortable arg) (sortable arg2) (sortable arg3) deriveSortable [''GenericPackageDescription]
tests/utils/SortedPackageDescription/TH.hs view
@@ -1,4 +1,3 @@-{-# Language CPP #-} {-# Language DefaultSignatures #-} {-# Language FlexibleContexts #-} {-# Language FlexibleInstances #-}@@ -8,10 +7,6 @@ {-# Language TypeSynonymInstances #-} {-# Language UndecidableInstances #-} -#if __GLASGOW_HASKELL__ < 706-{-# LANGUAGE ConstraintKinds #-}-#endif- module SortedPackageDescription.TH where import Control.Monad.Compat@@ -54,28 +49,12 @@ [ instanceD (cxt []) [t|Sortable $(conT n)|]-#if MIN_VERSION_template_haskell(2,9,0) [ tySynInstD ''MkSortable (tySynEqn [conT n] (conT n))-#else- [ tySynInstD ''MkSortable [conT n] (conT n)-#endif , funD 'sortable [clause [] (normalB [|id|]) []] ] ] -#if MIN_VERSION_template_haskell(2,11,0)-#define KIND_ARG _k-#else-#define KIND_ARG-#endif--#if MIN_VERSION_template_haskell(2,12,0) commonDerivClause = [derivClause Nothing [[t|Show|], [t|Ord|], [t|Eq|]]]-#elif MIN_VERSION_template_haskell(2,11,0)-commonDerivClause = cxt [[t|Show|], [t|Ord|], [t|Eq|]]-#else-commonDerivClause = [''Show, ''Ord, ''Eq]-#endif deriveSortable :: [Name] -> DecsQ deriveSortable = deriveSortable_ ""@@ -92,55 +71,37 @@ , instanceD (cxt []) [t|Sortable $(tyhead)|]-#if MIN_VERSION_template_haskell(2,9,0) [ tySynInstD ''MkSortable (tySynEqn [tyhead] (conT dty))-#else- [ tySynInstD ''MkSortable [tyhead] (conT dty)-#endif , funD 'sortable (mkSortableImpl prefix x) ] ] -mkSortableDataD prefix (DataD cx tyName [] KIND_ARG cons _) =+mkSortableDataD prefix (DataD cx tyName [] _k cons _) = (,) newname <$>- dataD (pure cx) newname [] KIND_ARG (map (mkSortableCon prefix) cons) commonDerivClause+ dataD (pure cx) newname [] _k (map (mkSortableCon prefix) cons) commonDerivClause where newname = sortedTyName prefix tyName-mkSortableDataD prefix (NewtypeD cx tyName [] KIND_ARG con _) =+mkSortableDataD prefix (NewtypeD cx tyName [] _k con _) = (,) newname <$>- newtypeD (pure cx) newname [] KIND_ARG (mkSortableCon prefix con) commonDerivClause+ newtypeD (pure cx) newname [] _k (mkSortableCon prefix con) commonDerivClause where newname = sortedTyName prefix tyName mkSortableDataD _ x = error $ "Unhandled: mkSortableDataD " ++ show x -#if MIN_VERSION_template_haskell(2,11,0) bangDef = bang noSourceUnpackedness noSourceStrictness-#else-bangDef = pure NotStrict-#endif mkSortableCon prefix (RecC recName fields) = recC (sortedTyName prefix recName) (map mkSortedField fields) where mkSortedField (varname, _, varty) =-#if MIN_VERSION_template_haskell(2,11,0) varBangType (sortedValName varname) (bangType bangDef [t|MkSortable $(pure varty)|])-#else- varStrictType- (sortedValName varname)- (strictType bangDef [t|MkSortable $(pure varty)|])-#endif mkSortableCon prefix (NormalC nm tys) = normalC (sortedTyName prefix nm) (map mkSortedField tys) where mkSortedField (_, varty) =-#if MIN_VERSION_template_haskell(2,11,0) bangType bangDef [t|MkSortable $(pure varty)|]-#else- strictType bangDef [t|MkSortable $(pure varty)|]-#endif mkSortableCon _ x = error $ "Unhandled case in mkSortableCon: " ++ show x sortedTyName pref = mkName . ("MkSort" ++) . (pref ++) . nameBase@@ -150,8 +111,8 @@ firstToUpper (x:xs) = toUpper x : xs firstToUpper [] = [] -mkSortableImpl pref (DataD _ _ _ KIND_ARG cons _) = map (mkSortableImplClause pref) cons-mkSortableImpl pref (NewtypeD _ _ _ KIND_ARG con _) = [mkSortableImplClause pref con]+mkSortableImpl pref (DataD _ _ _ _k cons _) = map (mkSortableImplClause pref) cons+mkSortableImpl pref (NewtypeD _ _ _ _k con _) = [mkSortableImplClause pref con] mkSortableImpl _ x = error $ "Unhandled: mkSortableImpl " ++ show x mkSortableImplClause pref con = do