cabal-gild 1.8.3.0 → 1.8.4.0

raw patch · 8 files changed

+359/−6 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +61/−0
• cabal-gild.cabal +2/−1
• source/library/CabalGild/Unstable/Action/EvaluatePragmas.hs +4/−1
• source/library/CabalGild/Unstable/Action/EvaluatePragmas/Fragment.hs +143/−0
• source/library/CabalGild/Unstable/Action/EvaluatePragmas/WarnUnknown.hs +2/−0
• source/library/CabalGild/Unstable/Extra/String.hs +4/−0
• source/library/CabalGild/Unstable/Main.hs +6/−4
• source/test-suite/Main.hs +137/−0

@@ -306,3 +306,64 @@ On subsequent runs, the generated comment will be updated to reflect the current version of Gild. The pragma itself is left unchanged. This pragma can be used on any field or section.++#### `fragment`++```+-- cabal-gild: fragment FILE+```++This pragma will replace the contents of a field or section with the contents+of the given file. The file path is resolved relative to the directory of the+package description. This is useful for sharing configuration between multiple+packages. For example, given this input:++``` cabal+-- cabal-gild: fragment common.fragment+common warnings+```++And a file called `common.fragment` with this content:++``` cabal+common warnings+  ghc-options:+    -Wall+    -Wcompat+```++Gild will produce this output:++``` cabal+-- cabal-gild: fragment common.fragment+common warnings+  ghc-options:+    -Wall+    -Wcompat+```++This pragma works on both fields and sections. For fields, the fragment file+must contain a field with the same name. For sections, it must contain a+section with the same name and arguments. For example:++``` cabal+library+  -- cabal-gild: fragment build-deps.fragment+  build-depends: ...+```++With a `build-deps.fragment` file containing:++``` cabal+build-depends:+  base,+  containers,+```++On subsequent runs, the field or section contents will be replaced again with+the contents of the fragment file, making the operation idempotent. The pragma+itself is left unchanged.++If the fragment file cannot be read or parsed, or if the field or section name+does not match, a warning is emitted and the field or section is left+unchanged. Recursive fragment expansion is not supported.

@@ -11,7 +11,7 @@ maintainer: Taylor Fausak name: cabal-gild synopsis: Formats package descriptions.-version: 1.8.3.0+version: 1.8.4.0  source-repository head   type: git@@ -70,6 +70,7 @@     CabalGild.Unstable.Action.AttachComments     CabalGild.Unstable.Action.EvaluatePragmas     CabalGild.Unstable.Action.EvaluatePragmas.Discover+    CabalGild.Unstable.Action.EvaluatePragmas.Fragment     CabalGild.Unstable.Action.EvaluatePragmas.Require     CabalGild.Unstable.Action.EvaluatePragmas.Version     CabalGild.Unstable.Action.EvaluatePragmas.WarnUnknown

@@ -1,9 +1,11 @@ module CabalGild.Unstable.Action.EvaluatePragmas where  import qualified CabalGild.Unstable.Action.EvaluatePragmas.Discover as EvaluateDiscover+import qualified CabalGild.Unstable.Action.EvaluatePragmas.Fragment as EvaluateFragment import qualified CabalGild.Unstable.Action.EvaluatePragmas.Require as EvaluateRequire import qualified CabalGild.Unstable.Action.EvaluatePragmas.Version as EvaluateVersion import qualified CabalGild.Unstable.Action.EvaluatePragmas.WarnUnknown as WarnUnknown+import qualified CabalGild.Unstable.Class.MonadRead as MonadRead import qualified CabalGild.Unstable.Class.MonadWalk as MonadWalk import qualified CabalGild.Unstable.Class.MonadWarn as MonadWarn import qualified CabalGild.Unstable.Type.Comment as Comment@@ -15,7 +17,7 @@ -- | High level wrapper around 'field' that makes this action easier to compose -- with other actions. run ::-  (Exception.MonadThrow m, MonadWalk.MonadWalk m, MonadWarn.MonadWarn m) =>+  (Exception.MonadCatch m, MonadRead.MonadRead m, MonadWalk.MonadWalk m, MonadWarn.MonadWarn m) =>   FilePath ->   ([Fields.Field (p, Comments.Comments q)], [Comment.Comment q]) ->   m ([Fields.Field (p, Comments.Comments q)], [Comment.Comment q])@@ -24,3 +26,4 @@     Monad.>=> EvaluateRequire.run     Monad.>=> EvaluateVersion.run     Monad.>=> EvaluateDiscover.run p+    Monad.>=> EvaluateFragment.run p

@@ -0,0 +1,143 @@+{-# LANGUAGE ScopedTypeVariables #-}++module CabalGild.Unstable.Action.EvaluatePragmas.Fragment where++import qualified CabalGild.Unstable.Class.MonadRead as MonadRead+import qualified CabalGild.Unstable.Class.MonadWarn as MonadWarn+import qualified CabalGild.Unstable.Extra.Name as Name+import qualified CabalGild.Unstable.Extra.SectionArg as SectionArg+import qualified CabalGild.Unstable.Extra.String as String+import qualified CabalGild.Unstable.Type.Comment as Comment+import qualified CabalGild.Unstable.Type.Comments as Comments+import qualified CabalGild.Unstable.Type.Input as Input+import qualified CabalGild.Unstable.Type.Pragma as Pragma+import qualified Control.Exception as IO+import qualified Control.Monad as Monad+import qualified Control.Monad.Catch as Exception+import qualified Distribution.Compat.CharParsing as CharParsing+import qualified Distribution.FieldGrammar.Newtypes as Newtypes+import qualified Distribution.Fields as Fields+import qualified Distribution.Parsec as Parsec+import qualified Distribution.Utils.Generic as Utils+import qualified System.FilePath as FilePath++-- | High level wrapper that traverses all fields and evaluates fragment pragmas.+run ::+  (Exception.MonadCatch m, MonadRead.MonadRead m, MonadWarn.MonadWarn m) =>+  FilePath ->+  ([Fields.Field (p, Comments.Comments q)], [Comment.Comment q]) ->+  m ([Fields.Field (p, Comments.Comments q)], [Comment.Comment q])+run p (fs, cs) = (,) <$> traverse (field p) fs <*> pure cs++-- | Evaluates fragment pragmas on a single field or section. For sections,+-- recurses into child fields.+field ::+  (Exception.MonadCatch m, MonadRead.MonadRead m, MonadWarn.MonadWarn m) =>+  FilePath ->+  Fields.Field (p, Comments.Comments q) ->+  m (Fields.Field (p, Comments.Comments q))+field p f = case f of+  Fields.Field n _ -> do+    result <- tryFragment p n+    case result of+      Nothing -> pure f+      Just fragmentFields -> case fragmentFields of+        [] -> do+          MonadWarn.warnLn "warning: fragment file is empty"+          pure f+        Fields.Section {} : _ -> do+          MonadWarn.warnLn+            "warning: fragment contains a section, but the pragma is on a field"+          pure f+        Fields.Field (Fields.Name _ n') fls' : _ -> do+          if Name.value n == n'+            then+              let position = fst $ Name.annotation n+               in pure . Fields.Field n $+                    fmap ((position, Comments.empty) <$) fls'+            else do+              MonadWarn.warnLn $+                "warning: fragment contains field \""+                  <> String.fromUtf8 n'+                  <> "\", but expected \""+                  <> String.fromUtf8 (Name.value n)+                  <> "\""+              pure f+  Fields.Section n sas children -> do+    result <- tryFragment p n+    case result of+      Nothing -> Fields.Section n sas <$> traverse (field p) children+      Just fragmentFields -> case fragmentFields of+        [] -> do+          MonadWarn.warnLn "warning: fragment file is empty"+          Fields.Section n sas <$> traverse (field p) children+        Fields.Field (Fields.Name _ n') _ : _ -> do+          MonadWarn.warnLn $+            "warning: fragment contains a field \""+              <> String.fromUtf8 n'+              <> "\", but the pragma is on a section"+          Fields.Section n sas <$> traverse (field p) children+        Fields.Section (Fields.Name _ n') sas' fs' : _ -> do+          if Name.value n == n' && fmap SectionArg.value sas == fmap SectionArg.value sas'+            then+              let position = fst $ Name.annotation n+               in pure . Fields.Section n sas $+                    fmap (fmap (const (position, Comments.empty))) fs'+            else do+              MonadWarn.warnLn $+                "warning: fragment contains section \""+                  <> showSection n' sas'+                  <> "\", but expected \""+                  <> showSection (Name.value n) sas+                  <> "\""+              Fields.Section n sas <$> traverse (field p) children++-- | Tries to find and read a fragment pragma from the last "before" comment on+-- a field/section name. Returns 'Nothing' if no fragment pragma is present.+-- Returns 'Just fields' with the parsed fragment content on success, or+-- 'Nothing' on read/parse failure (with a warning emitted).+tryFragment ::+  (Exception.MonadCatch m, MonadRead.MonadRead m, MonadWarn.MonadWarn m) =>+  FilePath ->+  Fields.Name (p, Comments.Comments q) ->+  m (Maybe [Fields.Field Parsec.Position])+tryFragment p n = do+  let comments = Comments.toList . snd $ Name.annotation n+  case Utils.safeLast comments of+    Nothing -> pure Nothing+    Just comment -> case Parsec.simpleParsecBS $ Comment.value comment of+      Nothing -> pure Nothing+      Just (Pragma.Pragma (Fragment token)) -> do+        let root = FilePath.takeDirectory p+            path = FilePath.normalise $ FilePath.combine root token+        result <- Exception.try $ MonadRead.read (Input.File path)+        case result of+          Left (_ :: IO.IOException) -> do+            MonadWarn.warnLn $+              "warning: could not read fragment " <> show path+            pure Nothing+          Right contents -> case Fields.readFields contents of+            Left _ -> do+              MonadWarn.warnLn $+                "warning: could not parse fragment " <> show path+              pure Nothing+            Right fields -> pure $ Just fields++-- | Renders a section name and its arguments as a human-readable string for+-- use in warning messages.+showSection :: Fields.FieldName -> [Fields.SectionArg a] -> String+showSection n [] = String.fromUtf8 n+showSection n args =+  String.fromUtf8 n+    <> " "+    <> unwords (fmap (String.fromUtf8 . SectionArg.value) args)++-- | The fragment pragma type. Parsed from @-- cabal-gild: fragment FILE@.+newtype Fragment = Fragment String+  deriving (Eq, Show)++instance Parsec.Parsec Fragment where+  parsec = do+    Monad.void $ CharParsing.string "fragment"+    CharParsing.skipSpaces1+    Fragment . Newtypes.getToken' <$> Parsec.parsec

@@ -1,6 +1,7 @@ module CabalGild.Unstable.Action.EvaluatePragmas.WarnUnknown where  import qualified CabalGild.Unstable.Action.EvaluatePragmas.Discover as Discover+import qualified CabalGild.Unstable.Action.EvaluatePragmas.Fragment as Fragment import qualified CabalGild.Unstable.Action.EvaluatePragmas.Require as Require import qualified CabalGild.Unstable.Action.EvaluatePragmas.Version as Version import qualified CabalGild.Unstable.Class.MonadWarn as MonadWarn@@ -61,6 +62,7 @@ isKnownPragma :: ByteString.ByteString -> Bool isKnownPragma bs =   Maybe.isJust (Parsec.simpleParsecBS bs :: Maybe (Pragma.Pragma Discover.Discover))+    || Maybe.isJust (Parsec.simpleParsecBS bs :: Maybe (Pragma.Pragma Fragment.Fragment))     || Maybe.isJust (Parsec.simpleParsecBS bs :: Maybe (Pragma.Pragma Require.Require))     || Maybe.isJust (Parsec.simpleParsecBS bs :: Maybe (Pragma.Pragma Version.Version)) 

@@ -10,3 +10,7 @@ -- | Converts the given 'String' into a UTF-8 encoded 'ByteString.ByteString'. toUtf8 :: String -> ByteString.ByteString toUtf8 = Encoding.encodeUtf8 . Text.pack++-- | Converts a UTF-8 encoded 'ByteString.ByteString' into a 'String'.+fromUtf8 :: ByteString.ByteString -> String+fromUtf8 = Text.unpack . Encoding.decodeUtf8Lenient

@@ -102,7 +102,7 @@  processFile ::   ( MonadRead.MonadRead m,-    Exception.MonadThrow m,+    Exception.MonadCatch m,     MonadWalk.MonadWalk m,     MonadWarn.MonadWarn m,     MonadWrite.MonadWrite m@@ -121,7 +121,7 @@  processOne ::   ( MonadRead.MonadRead m,-    Exception.MonadThrow m,+    Exception.MonadCatch m,     MonadWalk.MonadWalk m,     MonadWarn.MonadWarn m,     MonadWrite.MonadWrite m@@ -142,9 +142,11 @@ -- | Formats the given input using the provided file path as the apparent -- source file (see 'Context.stdin'). An exception will be thrown if the input -- is invalid. The 'MonadWalk.MonadWalk' constraint is used to discover modules--- on the file system. Typically @m@ will be 'IO'.+-- on the file system, 'MonadRead.MonadRead' is used to read fragment files,+-- and 'Exception.MonadCatch' is used to catch errors in these operations and+-- report them as warnings. Typically @m@ will be 'IO'. format ::-  (Exception.MonadThrow m, MonadWalk.MonadWalk m, MonadWarn.MonadWarn m) =>+  (Exception.MonadCatch m, MonadRead.MonadRead m, MonadWalk.MonadWalk m, MonadWarn.MonadWarn m) =>   FilePath ->   ByteString.ByteString ->   m ByteString.ByteString

@@ -1735,6 +1735,101 @@         _ -> fail $ "impossible: " <> show s       actual `Hspec.shouldBe` String.toUtf8 "-- cabal-gild: require < 0 trailing-garbage\n" +  Hspec.describe "fragment" $ do+    Hspec.it "replaces a field value from a fragment file" $ do+      expectFragment+        [(Input.File "build-deps.fragment", String.toUtf8 "build-depends: base, containers")]+        "library\n -- cabal-gild: fragment build-deps.fragment\n build-depends: old-dep"+        "library\n  -- cabal-gild: fragment build-deps.fragment\n  build-depends:\n    base,\n    containers\n"++    Hspec.it "replaces a section body from a fragment file" $ do+      expectFragment+        [(Input.File "common.fragment", String.toUtf8 "common deps\n  build-depends: base\n  ghc-options: -Wall")]+        "-- cabal-gild: fragment common.fragment\ncommon deps"+        "-- cabal-gild: fragment common.fragment\ncommon deps\n  build-depends: base\n  ghc-options: -Wall\n"++    Hspec.it "warns when fragment file is missing" $ do+      expectFragmentWarning+        []+        "library\n -- cabal-gild: fragment missing.fragment\n build-depends: base"+        "library\n  -- cabal-gild: fragment missing.fragment\n  build-depends: base\n"+        ["warning: could not read fragment \"missing.fragment\""]++    Hspec.it "warns when fragment has wrong field name" $ do+      expectFragmentWarning+        [(Input.File "tested-with.fragment", String.toUtf8 "tested-with: GHC ==8.0.2")]+        "library\n -- cabal-gild: fragment tested-with.fragment\n build-depends: base"+        "library\n  -- cabal-gild: fragment tested-with.fragment\n  build-depends: base\n"+        ["warning: fragment contains field \"tested-with\", but expected \"build-depends\""]++    Hspec.it "warns when fragment contains section but pragma is on field" $ do+      expectFragmentWarning+        [(Input.File "common.fragment", String.toUtf8 "common deps\n  build-depends: base")]+        "library\n -- cabal-gild: fragment common.fragment\n build-depends: base"+        "library\n  -- cabal-gild: fragment common.fragment\n  build-depends: base\n"+        ["warning: fragment contains a section, but the pragma is on a field"]++    Hspec.it "warns when fragment contains field but pragma is on section" $ do+      expectFragmentWarning+        [(Input.File "field.fragment", String.toUtf8 "build-depends: base")]+        "-- cabal-gild: fragment field.fragment\ncommon deps\n  ghc-options: -Wall"+        "-- cabal-gild: fragment field.fragment\ncommon deps\n  ghc-options: -Wall\n"+        ["warning: fragment contains a field \"build-depends\", but the pragma is on a section"]++    Hspec.it "warns when fragment file is empty" $ do+      expectFragmentWarning+        [(Input.File "empty.fragment", String.toUtf8 "")]+        "library\n -- cabal-gild: fragment empty.fragment\n build-depends: base"+        "library\n  -- cabal-gild: fragment empty.fragment\n  build-depends: base\n"+        ["warning: fragment file is empty"]++    Hspec.it "replaces an empty field value" $ do+      expectFragment+        [(Input.File "deps.fragment", String.toUtf8 "build-depends: base")]+        "library\n -- cabal-gild: fragment deps.fragment\n build-depends:"+        "library\n  -- cabal-gild: fragment deps.fragment\n  build-depends: base\n"++    Hspec.it "is recognized as a known pragma" $ do+      -- Should not produce "unknown pragma" warning (only the missing file warning)+      expectFragmentWarning+        []+        "-- cabal-gild: fragment missing.fragment\nname: test"+        "-- cabal-gild: fragment missing.fragment\nname: test\n"+        ["warning: could not read fragment \"missing.fragment\""]++    Hspec.it "warns when fragment file cannot be parsed" $ do+      expectFragmentWarning+        [(Input.File "bad.fragment", String.toUtf8 "not valid {cabal} syntax [")]+        "library\n -- cabal-gild: fragment bad.fragment\n build-depends: base"+        "library\n  -- cabal-gild: fragment bad.fragment\n  build-depends: base\n"+        ["warning: could not parse fragment \"bad.fragment\""]++    Hspec.it "warns when fragment section args do not match" $ do+      expectFragmentWarning+        [(Input.File "common.fragment", String.toUtf8 "common other\n  ghc-options: -Wall")]+        "-- cabal-gild: fragment common.fragment\ncommon deps\n  build-depends: base"+        "-- cabal-gild: fragment common.fragment\ncommon deps\n  build-depends: base\n"+        ["warning: fragment contains section \"common other\", but expected \"common deps\""]++    Hspec.it "resolves fragment paths relative to the cabal file directory" $ do+      let allInputs =+            [ (Input.Stdin, String.toUtf8 "library\n -- cabal-gild: fragment deps.fragment\n build-depends: old"),+              (Input.File (FilePath.combine "subdir" "deps.fragment"), String.toUtf8 "build-depends: base")+            ]+          (a, s, w) = runGild ["--stdin", "subdir/test.cabal"] allInputs (".", []) False+      a `Hspec.shouldSatisfy` Either.isRight+      w `Hspec.shouldBe` []+      actual <- case Map.toList s of+        [(Output.Stdout, x)] -> pure x+        _ -> fail $ "impossible: " <> show s+      actual `Hspec.shouldBe` String.toUtf8 "library\n  -- cabal-gild: fragment deps.fragment\n  build-depends: base\n"++    Hspec.it "replaces a top-level field value" $ do+      expectFragment+        [(Input.File "tested.fragment", String.toUtf8 "tested-with: GHC ==9.10.1")]+        "name: test\n-- cabal-gild: fragment tested.fragment\ntested-with: GHC ==8.0.2"+        "name: test\n-- cabal-gild: fragment tested.fragment\ntested-with: ghc ==9.10.1\n"+   Hspec.it "parses an empty brace section" $ do     expectGilded       "s{}"@@ -2249,6 +2344,48 @@     _ -> fail $ "impossible: " <> show s   actual `Hspec.shouldBe` String.toUtf8 expected   expectStable files actual++expectFragment ::+  (Stack.HasCallStack) =>+  [(Input.Input, ByteString.ByteString)] ->+  String ->+  String ->+  Hspec.Expectation+expectFragment extraInputs input expected = do+  let allInputs = (Input.Stdin, String.toUtf8 input) : extraInputs+      (a, s, w) = runGild [] allInputs (".", []) False+  a `Hspec.shouldSatisfy` Either.isRight+  w `Hspec.shouldBe` []+  actual <- case Map.toList s of+    [(Output.Stdout, x)] -> pure x+    _ -> fail $ "impossible: " <> show s+  actual `Hspec.shouldBe` String.toUtf8 expected+  -- Check idempotency: running again should produce the same output.+  let allInputs2 = (Input.Stdin, actual) : extraInputs+      (a2, s2, w2) = runGild [] allInputs2 (".", []) False+  a2 `Hspec.shouldSatisfy` Either.isRight+  w2 `Hspec.shouldBe` []+  actual2 <- case Map.toList s2 of+    [(Output.Stdout, x)] -> pure x+    _ -> fail $ "impossible: " <> show s2+  actual2 `Hspec.shouldBe` actual++expectFragmentWarning ::+  (Stack.HasCallStack) =>+  [(Input.Input, ByteString.ByteString)] ->+  String ->+  String ->+  [String] ->+  Hspec.Expectation+expectFragmentWarning extraInputs input expected expectedWarnings = do+  let allInputs = (Input.Stdin, String.toUtf8 input) : extraInputs+      (a, s, w) = runGild [] allInputs (".", []) False+  a `Hspec.shouldSatisfy` Either.isRight+  w `Hspec.shouldBe` expectedWarnings+  actual <- case Map.toList s of+    [(Output.Stdout, x)] -> pure x+    _ -> fail $ "impossible: " <> show s+  actual `Hspec.shouldBe` String.toUtf8 expected  runGild ::   [String] ->