Better support for multiline literals

.github/workflows/build.yml

@@ -33,9 +33,9 @@ jobs:
           - '9.12'
         include:
           - os: macos-latest
-            ghc: '9.10'
+            ghc: '9.12'
           - os: windows-latest
-            ghc: '9.10'
+            ghc: '9.12'
     steps:
       - uses: actions/checkout@v5
       - uses: hspec/setup-haskell@v1

src/Hpack/Render.hs

@@ -31,7 +31,6 @@ module Hpack.Render (
 , renderFlag
 , renderSourceRepository
 , renderDirectories
-, formatDescription
 #endif
 ) where
 
@@ -46,7 +45,7 @@ import           Control.Monad.Reader
 import           Hpack.Util
 import           Hpack.Config
 import           Hpack.Render.Hints
-import           Hpack.Render.Dsl hiding (sortFieldsBy)
+import           Hpack.Render.Dsl hiding (RenderSettings(..), defaultRenderSettings, sortFieldsBy)
 import qualified Hpack.Render.Dsl as Dsl
 
 data RenderEnv = RenderEnv {
@@ -65,18 +64,24 @@ getPackageName = asks renderEnvPackageName
 renderPackage :: [String] -> Package -> String
 renderPackage oldCabalFile = renderPackageWith settings headerFieldsAlignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder
   where
-    FormattingHints{..} = sniffFormattingHints oldCabalFile
+    hints@FormattingHints{..} = sniffFormattingHints oldCabalFile
     headerFieldsAlignment = fromMaybe 16 formattingHintsAlignment
-    settings = formattingHintsRenderSettings
+    settings = formattingHintsRenderSettings hints
 
 renderPackageWith :: RenderSettings -> Alignment -> [String] -> [(String, [String])] -> Package -> String
-renderPackageWith settings headerFieldsAlignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks)
+renderPackageWith RenderSettings{..} headerFieldsAlignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks)
   where
+    settings :: Dsl.RenderSettings
+    settings = Dsl.RenderSettings {
+      renderSettingsEmptyLinesAsDot = packageCabalVersion < makeCabalVersion [3]
+    , ..
+    }
+
     chunks :: [String]
     chunks = map unlines . filter (not . null) . map (render settings 0) $ sortStanzaFields sectionsFieldOrder stanzas
 
     header :: [String]
-    header = concatMap (render settings {renderSettingsFieldAlignment = headerFieldsAlignment} 0) packageFields
+    header = concatMap (render settings {Dsl.renderSettingsFieldAlignment = headerFieldsAlignment} 0) packageFields
 
     packageFields :: [Element]
     packageFields = addVerbatim packageVerbatim . sortFieldsBy existingFieldOrder $
@@ -117,7 +122,7 @@ renderPackageWith settings headerFieldsAlignment existingFieldOrder sectionsFiel
         ("name", Just packageName)
       , ("version", Just packageVersion)
       , ("synopsis", packageSynopsis)
-      , ("description", (formatDescription packageCabalVersion headerFieldsAlignment <$> packageDescription))
+      , ("description", packageDescription)
       , formatList "category" packageCategory
       , ("stability", packageStability)
       , ("homepage", packageHomepage)
@@ -139,9 +144,7 @@ renderPackageWith settings headerFieldsAlignment existingFieldOrder sectionsFiel
         formatValues values = guard (not $ null values) >> (Just $ intercalate separator values)
           where
             separator :: String
-            separator = ",\n" ++ replicate n ' '
-              where
-                Alignment n = max headerFieldsAlignment (Alignment $ length field + 2)
+            separator = ",\n"
 
 sortStanzaFields :: [(String, [String])] -> [Element] -> [Element]
 sortStanzaFields sectionsFieldOrder = go
@@ -151,33 +154,6 @@ sortStanzaFields sectionsFieldOrder = go
       Stanza name fields : xs | Just fieldOrder <- lookup name sectionsFieldOrder -> Stanza name (sortFieldsBy fieldOrder fields) : go xs
       x : xs -> x : go xs
 
-formatDescription :: CabalVersion -> Alignment -> String -> String
-formatDescription cabalVersion (Alignment alignment) description = case map emptyLineToDot $ lines description of
-  x : xs -> intercalate "\n" (x : indent xs)
-  [] -> ""
-  where
-    n :: Int
-    n = max alignment (length ("description: " :: String))
-
-    indentation :: String
-    indentation = replicate n ' '
-
-    emptyLineToDot :: String -> String
-    emptyLineToDot xs
-      | isEmptyLine xs && cabalVersion < makeCabalVersion [3] = "."
-      | otherwise = xs
-
-    indent :: [String] -> [String]
-    indent = map indentLine
-
-    indentLine :: String -> String
-    indentLine xs
-      | isEmptyLine xs = ""
-      | otherwise = indentation ++ xs
-
-    isEmptyLine :: String -> Bool
-    isEmptyLine = all isSpace
-
 renderSourceRepository :: SourceRepository -> Element
 renderSourceRepository SourceRepository{..} = Stanza "source-repository head" [
     Field "type" "git"

src/Hpack/Render/Dsl.hs

@@ -20,12 +20,14 @@ module Hpack.Render.Dsl (
 
 #ifdef TEST
 , Lines (..)
+, IndentOrAlign (..)
 , renderValue
 , addSortKey
 #endif
 ) where
 
 import           Imports
+import           Data.Char (isSpace)
 
 data Element = Stanza String [Element] | Group Element Element | Field String Value | Verbatim String
   deriving (Eq, Show)
@@ -37,7 +39,26 @@ data Value =
   | WordList [String]
   deriving (Eq, Show)
 
-data Lines = SingleLine String | MultipleLines [String]
+data Lines = SingleLine String | MultipleLines IndentOrAlign [String]
+  deriving (Eq, Show)
+
+data IndentOrAlign =
+  Indent
+  -- ^
+  -- Indent lines, e.g.
+  --
+  -- description:
+  --   some
+  --   multiline
+  --   description
+  |
+  Align
+  -- ^
+  -- Align lines with field labels, e.g.
+  --
+  -- description: some
+  --              multiline
+  --              description
   deriving (Eq, Show)
 
 data CommaStyle = LeadingCommas | TrailingCommas
@@ -53,10 +74,11 @@ data RenderSettings = RenderSettings {
   renderSettingsIndentation :: Int
 , renderSettingsFieldAlignment :: Alignment
 , renderSettingsCommaStyle :: CommaStyle
+, renderSettingsEmptyLinesAsDot :: Bool
 } deriving (Eq, Show)
 
 defaultRenderSettings :: RenderSettings
-defaultRenderSettings = RenderSettings 2 0 LeadingCommas
+defaultRenderSettings = RenderSettings 2 0 LeadingCommas True
 
 render :: RenderSettings -> Nesting -> Element -> [String]
 render settings nesting = \ case
@@ -69,31 +91,55 @@ renderElements :: RenderSettings -> Nesting -> [Element] -> [String]
 renderElements settings nesting = concatMap (render settings nesting)
 
 renderField :: RenderSettings -> String -> Value -> [String]
-renderField settings@RenderSettings{..} name value = case renderValue settings value of
+renderField settings@RenderSettings{..} name = renderValue settings >>> \ case
   SingleLine "" -> []
-  SingleLine x -> [name ++ ": " ++ padding ++ x]
-  MultipleLines [] -> []
-  MultipleLines xs -> (name ++ ":") : map (indent settings 1) xs
+  SingleLine value -> [fieldName ++ value]
+  MultipleLines _ [] -> []
+  MultipleLines Indent values -> (name ++ ":") : map (indent settings 1) values
+  MultipleLines Align (value : values) -> (fieldName ++ value) : map align values
   where
     Alignment fieldAlignment = renderSettingsFieldAlignment
-    padding = replicate (fieldAlignment - length name - 2) ' '
+
+    fieldName :: String
+    fieldName = name ++ ": " ++ fieldNamePadding
+
+    fieldNamePadding :: String
+    fieldNamePadding = replicate (fieldAlignment - length name - 2) ' '
+
+    align :: String -> String
+    align = \ case
+      "" -> ""
+      value -> padding ++ value
+
+    padding :: String
+    padding = replicate (length fieldName) ' '
 
 renderValue :: RenderSettings -> Value -> Lines
-renderValue RenderSettings{..} v = case v of
-  Literal s -> SingleLine s
+renderValue RenderSettings{..} = \ case
+  Literal string -> case lines string of
+    [value] -> SingleLine value
+    values -> MultipleLines Align $ map emptyLineToDot values
   WordList ws -> SingleLine $ unwords ws
   LineSeparatedList xs -> renderLineSeparatedList renderSettingsCommaStyle xs
   CommaSeparatedList xs -> renderCommaSeparatedList renderSettingsCommaStyle xs
+  where
+    emptyLineToDot :: String -> String
+    emptyLineToDot xs
+      | isEmptyLine xs && renderSettingsEmptyLinesAsDot = "."
+      | otherwise = xs
+
+    isEmptyLine :: String -> Bool
+    isEmptyLine = all isSpace
 
 renderLineSeparatedList :: CommaStyle -> [String] -> Lines
-renderLineSeparatedList style = MultipleLines . map (padding ++)
+renderLineSeparatedList style = MultipleLines Indent . map (padding ++)
   where
     padding = case style of
       LeadingCommas -> "  "
       TrailingCommas -> ""
 
 renderCommaSeparatedList :: CommaStyle -> [String] -> Lines
-renderCommaSeparatedList style = MultipleLines . case style of
+renderCommaSeparatedList style = MultipleLines Indent . case style of
   LeadingCommas -> map renderLeadingComma . zip (True : repeat False)
   TrailingCommas -> map renderTrailingComma . reverse . zip (True : repeat False) . reverse
   where
@@ -111,7 +157,9 @@ instance IsString Value where
   fromString = Literal
 
 indent :: RenderSettings -> Nesting -> String -> String
-indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s
+indent RenderSettings{..} (Nesting nesting) = \ case
+  "" -> ""
+  s -> replicate (nesting * renderSettingsIndentation) ' ' ++ s
 
 sortFieldsBy :: [String] -> [Element] -> [Element]
 sortFieldsBy existingFieldOrder =

src/Hpack/Render/Hints.hs

@@ -1,10 +1,13 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
 module Hpack.Render.Hints (
   FormattingHints (..)
 , sniffFormattingHints
+, RenderSettings (..)
+, defaultRenderSettings
+, formattingHintsRenderSettings
 #ifdef TEST
-, sniffRenderSettings
 , extractFieldOrder
 , extractSectionsFieldOrder
 , sanitize
@@ -21,22 +24,25 @@ import           Imports
 import           Data.Char
 import           Data.Maybe
 
-import           Hpack.Render.Dsl
+import           Hpack.Render.Dsl (Alignment(..), CommaStyle(..))
+import qualified Hpack.Render.Dsl as Dsl
 import           Hpack.Util
 
 data FormattingHints = FormattingHints {
   formattingHintsFieldOrder :: [String]
 , formattingHintsSectionsFieldOrder :: [(String, [String])]
 , formattingHintsAlignment :: Maybe Alignment
-, formattingHintsRenderSettings :: RenderSettings
+, formattingHintsIndentation :: Maybe Int
+, formattingHintsCommaStyle :: Maybe CommaStyle
 } deriving (Eq, Show)
 
 sniffFormattingHints :: [String] -> FormattingHints
 sniffFormattingHints (sanitize -> input) = FormattingHints {
   formattingHintsFieldOrder = extractFieldOrder input
 , formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input
 , formattingHintsAlignment = sniffAlignment input
-, formattingHintsRenderSettings = sniffRenderSettings input
+, formattingHintsIndentation = sniffIndentation input
+, formattingHintsCommaStyle = sniffCommaStyle input
 }
 
 sanitize :: [String] -> [String]
@@ -124,11 +130,20 @@ sniffCommaStyle input
   where
     startsWithComma = isPrefixOf "," . dropWhile isSpace
 
-sniffRenderSettings :: [String] -> RenderSettings
-sniffRenderSettings input = RenderSettings indentation fieldAlignment commaStyle
-  where
-    indentation = max def $ fromMaybe def (sniffIndentation input)
-      where def = renderSettingsIndentation defaultRenderSettings
+data RenderSettings = RenderSettings {
+  renderSettingsIndentation :: Int
+, renderSettingsFieldAlignment :: Alignment
+, renderSettingsCommaStyle :: CommaStyle
+} deriving (Eq, Show)
 
-    fieldAlignment = renderSettingsFieldAlignment defaultRenderSettings
-    commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input)
+defaultRenderSettings :: RenderSettings
+defaultRenderSettings = let Dsl.RenderSettings{..} = Dsl.defaultRenderSettings in RenderSettings{..}
+
+formattingHintsRenderSettings :: FormattingHints -> RenderSettings
+formattingHintsRenderSettings FormattingHints{..} = defaultRenderSettings {
+  renderSettingsIndentation = indentation
+, renderSettingsCommaStyle = commaStyle
+} where
+    indentation = max def $ fromMaybe def formattingHintsIndentation
+      where def = renderSettingsIndentation defaultRenderSettings
+    commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) formattingHintsCommaStyle

test/EndToEndSpec.hs

@@ -20,7 +20,7 @@ import           Data.Version (showVersion)
 
 import qualified Hpack.Render as Hpack
 import           Hpack.Config (packageConfig, readPackageConfig, DecodeOptions(..), defaultDecodeOptions, DecodeResult(..))
-import           Hpack.Render.Hints (FormattingHints(..), sniffFormattingHints)
+import           Hpack.Render.Hints (FormattingHints(..), sniffFormattingHints, formattingHintsRenderSettings)
 
 import qualified Paths_hpack as Hpack (version)
 
@@ -378,6 +378,26 @@ spec = around_ (inTempDirectoryNamed "my-package") $ do
             location: https://github.com/hspec/hspec
           |]
 
+    describe "flags" $ do
+      it "accepts multi-line flag descriptions" $ do
+        [i|
+        flags:
+          some-flag:
+            description: |
+              some
+              flag
+              description
+            manual: True
+            default: False
+        |] `shouldRenderTo` package [i|
+        flag some-flag
+          description: some
+                       flag
+                       description
+          manual: True
+          default: False
+        |]
+
     describe "defaults" $ do
       it "accepts global defaults" $ do
         writeFile "defaults/sol/hpack-template/2017/defaults.yaml" [i|
@@ -2113,9 +2133,9 @@ run_ userDataDir c old = do
   return $ case mPackage of
     Right (DecodeResult pkg cabalVersion _ warnings) ->
       let
-        FormattingHints{..} = sniffFormattingHints (lines old)
+        hints@FormattingHints{..} = sniffFormattingHints (lines old)
         alignment = fromMaybe 0 formattingHintsAlignment
-        settings = formattingHintsRenderSettings
+        settings = formattingHintsRenderSettings hints
         output = cabalVersion ++ Hpack.renderPackageWith settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg
       in
         Right (warnings, output)