Add raw-project stanza

.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

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

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

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)

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

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