diff --git a/.travis.yml b/.travis.yml index 089c0c1f..c4bcfcd6 100644 --- a/.travis.yml +++ b/.travis.yml @@ -100,6 +100,9 @@ install: - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - echo 'package haskell-ci' >> cabal.project - "echo ' ghc-options: -Werror' >> cabal.project" + - "echo 'keep-going: False' >> cabal.project" + - echo 'package bytestring' >> cabal.project + - "echo ' tests: False' >> cabal.project" - touch cabal.project.local - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(Cabal|haskell-ci)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true @@ -128,6 +131,9 @@ script: - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - echo 'package haskell-ci' >> cabal.project - "echo ' ghc-options: -Werror' >> cabal.project" + - "echo 'keep-going: False' >> cabal.project" + - echo 'package bytestring' >> cabal.project + - "echo ' tests: False' >> cabal.project" - touch cabal.project.local - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(Cabal|haskell-ci)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true diff --git a/cabal.haskell-ci b/cabal.haskell-ci index c2f30013..66ab8b43 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -57,3 +57,9 @@ doctest-options: --fast constraint-set deepseq-1.4 ghc: (>= 7.8 && <7.10) || == 8.2.2 constraints: deepseq ==1.4.* + +-- Include these fields "as is" in generated cabal.project +raw-project + keep-going: False + package bytestring + tests: False diff --git a/haskell-ci.cabal b/haskell-ci.cabal index df2bb141..3e16f35c 100644 --- a/haskell-ci.cabal +++ b/haskell-ci.cabal @@ -84,6 +84,10 @@ library HaskellCI.Project HaskellCI.TestedWith + -- vendored from Cabal development version + other-modules: + Distribution.Fields.Pretty + ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances diff --git a/src/Distribution/Fields/Pretty.hs b/src/Distribution/Fields/Pretty.hs new file mode 100644 index 00000000..2bb6bfbd --- /dev/null +++ b/src/Distribution/Fields/Pretty.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE BangPatterns #-} +-- | Cabal-like file AST types: 'Field', 'Section' etc, +-- +-- This (intermediate) data type is used for pretty-printing. +-- +-- @since 3.0.0.0 +-- +module Distribution.Fields.Pretty ( + -- * Fields + PrettyField (..), + showFields, + showFields', + -- * Transformation from 'P.Field' + fromParsecFields, + genericFromParsecFields, + prettyFieldLines, + prettySectionArgs, + ) where + +import Data.Functor.Identity (Identity (..)) +import Distribution.Pretty (showToken) + +import Distribution.Parsec.Field (FieldName) +import Distribution.Simple.Utils (fromUTF8BS) + +import qualified Distribution.Parsec.Parser as P + +import qualified Data.ByteString as BS +import qualified Text.PrettyPrint as PP + +data PrettyField + = PrettyField FieldName PP.Doc + | PrettySection FieldName [PP.Doc] [PrettyField] + deriving Show + +-- | Prettyprint a list of fields. +showFields :: [PrettyField] -> String +showFields = showFields' 4 + +-- | 'showFields' with user specified indentation. +showFields' :: Int -> [PrettyField] -> String +showFields' n = unlines . renderFields indent where + -- few hardcoded, "unrolled" variants. + indent | n == 4 = indent4 + | n == 2 = indent2 + | otherwise = (replicate (max n 1) ' ' ++) + + indent4 :: String -> String + indent4 [] = [] + indent4 xs = ' ' : ' ' : ' ' : ' ' : xs + + indent2 :: String -> String + indent2 [] = [] + indent2 xs = ' ' : ' ' : xs + +renderFields :: (String -> String) -> [PrettyField] -> [String] +renderFields indent fields = flattenBlocks $ map (renderField indent len) fields + where + len = maxNameLength 0 fields + + maxNameLength !acc [] = acc + maxNameLength !acc (PrettyField name _ : rest) = maxNameLength (max acc (BS.length name)) rest + maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest + +-- | Block of lines, +-- Boolean parameter tells whether block should be surrounded by empty lines +data Block = Block Bool [String] + +flattenBlocks :: [Block] -> [String] +flattenBlocks = go0 where + go0 [] = [] + go0 (Block surr strs : blocks) = strs ++ go surr blocks + + go _surr' [] = [] + go surr' (Block surr strs : blocks) = ins $ strs ++ go surr blocks where + ins | surr' || surr = ("" :) + | otherwise = id + +renderField :: (String -> String) -> Int -> PrettyField -> Block +renderField indent fw (PrettyField name doc) = Block False $ case lines narrow of + [] -> [ name' ++ ":" ] + [singleLine] | length singleLine < 60 + -> [ name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow ] + _ -> (name' ++ ":") : map indent (lines (PP.render doc)) + where + name' = fromUTF8BS name + narrow = PP.renderStyle narrowStyle doc + + narrowStyle :: PP.Style + narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw } + +renderField indent _ (PrettySection name args fields) = Block True $ + [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ] + ++ + (map indent $ renderFields indent fields) + +------------------------------------------------------------------------------- +-- Transform from Parsec.Field +------------------------------------------------------------------------------- + +genericFromParsecFields + :: Applicative f + => (FieldName -> [P.FieldLine ann] -> f PP.Doc) -- ^ transform field contents + -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments + -> [P.Field ann] + -> f [PrettyField] +genericFromParsecFields f g = goMany where + goMany = traverse go + + go (P.Field (P.Name _ann name) fls) = PrettyField name <$> f name fls + go (P.Section (P.Name _ann name) secargs fs) = PrettySection name <$> g name secargs <*> goMany fs + +-- | Used in 'fromParsecFields'. +prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc +prettyFieldLines _ fls = PP.vcat + [ PP.text $ fromUTF8BS bs + | P.FieldLine _ bs <- fls + ] + +-- | Used in 'fromParsecFields'. +prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc] +prettySectionArgs _ = map $ \sa -> case sa of + P.SecArgName _ bs -> showToken $ fromUTF8BS bs + P.SecArgStr _ bs -> showToken $ fromUTF8BS bs + P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs + +-- | Simple variant of 'genericFromParsecField' +fromParsecFields :: [P.Field ann] -> [PrettyField] +fromParsecFields = runIdentity . genericFromParsecFields + (Identity .: prettyFieldLines) + (Identity .: prettySectionArgs) + where + (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b) + (f .: g) x y = f (g x y) diff --git a/src/HaskellCI.hs b/src/HaskellCI.hs index 3660866b..53f9aa5a 100644 --- a/src/HaskellCI.hs +++ b/src/HaskellCI.hs @@ -71,6 +71,7 @@ import Distribution.Verbosity (Verbosity) #endif import qualified Distribution.FieldGrammar as C +import qualified Distribution.Fields.Pretty as C import qualified Distribution.PackageDescription.FieldGrammar as C import qualified Distribution.Types.SourceRepo as C import qualified Text.PrettyPrint as PP @@ -953,6 +954,12 @@ genTravisFromConfigs argv opts isCabalProject config prj@Project { prjPackages = tellStrLns [ sh $ "echo 'source-repository-package' >> cabal.project" ] tellStrLns [ sh $ "echo ' " ++ l ++ "' >> cabal.project" | l <- lines repo' ] + unless (null (cfgRawProject config)) $ tellStrLns + [ sh $ "echo '" ++ l ++ "' >> cabal.project" + | l <- lines $ C.showFields' 2 $ cfgRawProject config + , not (null l) + ] + -- also write cabal.project.local file with -- @ -- constraints: base installed diff --git a/src/HaskellCI/Config.hs b/src/HaskellCI/Config.hs index e3fc784b..048a32bf 100644 --- a/src/HaskellCI/Config.hs +++ b/src/HaskellCI/Config.hs @@ -25,6 +25,7 @@ import qualified Distribution.Parsec.Common as C import qualified Distribution.Parsec.Newtypes as C import qualified Distribution.Parsec.Parser as C import qualified Distribution.Parsec.ParseResult as C +import qualified Distribution.Fields.Pretty as C import qualified Distribution.Pretty as C import qualified Distribution.Types.Version as C import qualified Text.PrettyPrint as PP @@ -67,6 +68,7 @@ data Config = Config , cfgDoctest :: !DoctestConfig , cfgHLint :: !HLintConfig , cfgConstraintSets :: [ConstraintSet] + , cfgRawProject :: [C.PrettyField] } deriving (Show, Generic) @@ -110,6 +112,7 @@ emptyConfig = Config , cfgLastInSeries = False , cfgOsx = S.empty , cfgApt = S.empty + , cfgRawProject = [] } ------------------------------------------------------------------------------- @@ -166,7 +169,8 @@ configGrammar = Config ^^^ metahelp "PKG" "Additional apt packages to install" <*> C.blurFieldGrammar #cfgDoctest doctestConfigGrammar <*> C.blurFieldGrammar #cfgHLint hlintConfigGrammar - <*> pure [] + <*> pure [] -- constraint sets + <*> pure [] -- raw project fields ------------------------------------------------------------------------------- -- Reading @@ -190,6 +194,9 @@ parseConfigFile fields0 = do let (fs, _sections) = C.partitionFields cfields cs <- C.parseFieldGrammar C.cabalSpecLatest fs (constraintSetGrammar name') return $ over #cfgConstraintSets (++ [cs]) + | name == "raw-project" = do + let fs = C.fromParsecFields cfields + return $ over #cfgRawProject (++ fs) | otherwise = do C.parseWarning pos C.PWTUnknownSection $ "Unknown section " ++ fromUTF8BS name return id