packages feed

aihc-cabal-syntax 1.0.0.1 → 2.0.0.0

raw patch · 11 files changed

+456/−14 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Aihc.Cabal: fieldPaths :: Version -> FieldValue -> Either Diagnostic [FilePath]
+ Aihc.Cabal: parseDependency :: Text -> Either Text Dependency
+ Aihc.Cabal: parsePackageIdentifier :: Text -> Either Text (Text, Maybe Version)
+ Aihc.Cabal: renderDiagnostic :: Diagnostic -> Text
+ Aihc.Cabal: simplifyVersionRange :: VersionRange -> VersionRange

Files

CHANGELOG.md view
@@ -4,6 +4,23 @@  This project uses the format from [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). +## [2.0.0.0] - 2026-09-30++### Added++- Add `parseDependency` to read one `build-depends` entry.+- Add `parsePackageIdentifier` to read a package name with an optional version.+- Add `renderDiagnostic` to show a diagnostic as text for a user.+- Add `simplifyVersionRange`. It gives the same versions as a union of separate intervals in increasing order.+- Add `fieldPaths` to read a custom field as a path list, with the rules of `c-sources`.++### Fixed++- Apply the Cabal-syntax aliases for operating system and architecture names.+  The parser changes an alias in `os(...)` to its canonical name, for example `darwin` to `osx`.+  `evaluateCondition` applies the aliases for host names to the `Environment` names.+  A name in `arch(...)` has no aliases, as in Cabal-syntax.+ ## [1.0.0.1] - 2026-09-29  ### Changed
aihc-cabal-syntax.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: aihc-cabal-syntax-version: 1.0.0.1+version: 2.0.0.0 synopsis: Parse Cabal files for aihc description: Parse Cabal package files for the aihc compiler.   Read package data, version ranges, and condition expressions.@@ -18,6 +18,7 @@     Aihc.Cabal.Internal.Condition     Aihc.Cabal.Internal.Lexer     Aihc.Cabal.Internal.Parser+    Aihc.Cabal.Internal.Platform     Aihc.Cabal.Internal.Quirks     Aihc.Cabal.Internal.Resolve     Aihc.Cabal.Internal.Types
src/Aihc/Cabal.hs view
@@ -47,15 +47,18 @@ --   a t'BuildInfo' field stay in 'extraFields' as text. The parser does not --   check these values. -- * The parser stops at the first error.--- * There is no version range simplifier and no package printer.+-- * There is no package printer. -- * The library does not solve dependencies, find source files, or run --   configure scripts. module Aihc.Cabal   ( -- * Parsing     parsePackage   , parseHookedBuildInfo+  , parseDependency+  , parsePackageIdentifier   , ParseResult (..)   , Diagnostic (..)+  , renderDiagnostic   , Position (..)     -- * Packages   , Package (..)@@ -65,6 +68,7 @@   , FieldValue (..)   , FieldLine (..)   , fieldText+  , fieldPaths     -- * Components   , Component (..)   , ComponentKind (..)@@ -101,6 +105,7 @@   , withinVersion   , intersectRanges   , unionRanges+  , simplifyVersionRange   , withinRange   , parseVersionRange   , renderVersionRange@@ -109,4 +114,5 @@ import Aihc.Cabal.Internal.Parser import Aihc.Cabal.Internal.Resolve import Aihc.Cabal.Internal.Types+import Aihc.Cabal.Internal.Values (parseDependency, parsePackageIdentifier) import Aihc.Cabal.Internal.Version
src/Aihc/Cabal/Internal/Condition.hs view
@@ -14,6 +14,7 @@ import qualified Text.Megaparsec as M import Text.Megaparsec.Char (char) import Aihc.Cabal.Internal.Lexer (SectionArg (..))+import Aihc.Cabal.Internal.Platform (Strictness (..), canonicalOS) import Aihc.Cabal.Internal.Types (Condition (..)) import Aihc.Cabal.Internal.Values (flagNameValue, identifier) import Aihc.Cabal.Internal.Version@@ -100,7 +101,7 @@     condOr = foldl1 Or <$> sepBy1 condAnd (oper "||")     condAnd = foldl1 And <$> sepBy1 cond (oper "&&")     cond = boolean <|> parens condOr <|> (Not <$> (oper "!" *> cond))-      <|> (word "os" *> parens (OS <$> value identifier))+      <|> (word "os" *> parens (OS . canonicalOS Compat <$> value identifier))       <|> (word "arch" *> parens (Arch <$> value identifier))       <|> (word "flag" *> parens (FlagValue <$> value flagNameValue))       <|> (word "impl" *> parens (Impl <$> value compiler <*> (versionRange <|> pure anyVersion)))
src/Aihc/Cabal/Internal/Parser.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | Read package descriptions. The rules follow the package parser of -- Cabal-syntax 3.18. The parser accepts Cabal format versions up to 3.18.-module Aihc.Cabal.Internal.Parser (parsePackage, parseHookedBuildInfo) where+module Aihc.Cabal.Internal.Parser (parsePackage, parseHookedBuildInfo, fieldPaths) where  import Control.Monad (foldM, guard, unless, when) import Data.Bits (shiftL, (.&.), (.|.))@@ -89,6 +89,15 @@ optionalField :: Parser a -> [FieldValue] -> Result (Maybe a) optionalField p = fmap (>>= id) . singular one   where one fv = if null (fieldLines fv) then Right Nothing else Just <$> parseField p fv++-- | Read a field value as a list of paths, with the rules of @c-sources@ for+-- a Cabal format version. Use it for a custom field in 'extraFields', for+-- example @x-aihc-lir-sources@. Give the 'cabalVersion' of the package,+-- because the list rules change with the format version. Spaces or commas+-- separate the paths, and a path in quotation marks can contain a space.+-- An error has the position of the field name.+fieldPaths :: Version -> FieldValue -> Either Diagnostic [FilePath]+fieldPaths spec = fmap (map T.unpack) . parseField (spaceList spec filePath)  monoidal :: Parser [a] -> [FieldValue] -> Result [a] monoidal p = fmap concat . mapM (parseField p)
+ src/Aihc/Cabal/Internal/Platform.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Operating system and architecture names, with the aliases of+-- Cabal-syntax 3.18.1.0 (@Distribution.System@).+--+-- Cabal-syntax uses three alias tables. The names in @os(...)@ conditions+-- use the Compat table. The names in @arch(...)@ conditions use the Strict+-- table, which has no aliases. The names of the host platform use the+-- Permissive table.+module Aihc.Cabal.Internal.Platform+  ( Strictness (..)+  , canonicalOS+  , canonicalArch+  ) where++import Data.Text (Text)+import qualified Data.Text as T++-- | The alias table that Cabal-syntax uses for a name.+data Strictness = Strict | Compat | Permissive+  deriving (Eq, Show)++-- | The canonical name of an operating system, for example @osx@ for+-- @darwin@. A known name becomes lower case. An unknown name does not change.+canonicalOS :: Strictness -> Text -> Text+canonicalOS strictness name =+  case lookup (T.toLower name) table of+    Just canonical -> canonical+    Nothing -> name+  where+    table = [(alias, os) | os <- knownOSs, alias <- os : osAliases strictness os]++-- | The canonical name of an architecture, for example @aarch64@ for+-- @arm64@. A known name becomes lower case. An unknown name does not change.+canonicalArch :: Strictness -> Text -> Text+canonicalArch strictness name =+  case lookup (T.toLower name) table of+    Just canonical -> canonical+    Nothing -> name+  where+    table = [(alias, arch) | arch <- knownArches, alias <- arch : archAliases strictness arch]++knownOSs :: [Text]+knownOSs =+  [ "linux", "windows", "osx", "freebsd", "openbsd", "netbsd", "dragonfly", "solaris", "aix", "hpux"+  , "irix", "halvm", "hurd", "ios", "android", "ghcjs", "wasi", "haiku" ]++osAliases :: Strictness -> Text -> [Text]+osAliases strictness os = case (strictness, os) of+  (Permissive, "windows") -> ["mingw32", "win32", "cygwin32"]+  (Compat, "windows") -> ["mingw32", "win32"]+  (_, "osx") -> ["darwin"]+  (_, "hurd") -> ["gnu"]+  (Permissive, "freebsd") -> ["kfreebsdgnu"]+  (Compat, "freebsd") -> ["kfreebsdgnu"]+  (Permissive, "solaris") -> ["solaris2"]+  (Compat, "solaris") -> ["solaris2"]+  (Permissive, "android") -> ["linux-android", "linux-androideabi", "linux-androideabihf"]+  (Compat, "android") -> ["linux-android"]+  _ -> []++knownArches :: [Text]+knownArches =+  [ "i386", "x86_64", "ppc", "ppc64", "ppc64le", "sparc", "sparc64", "arm", "aarch64", "mips", "sh"+  , "ia64", "s390", "s390x", "alpha", "hppa", "rs6000", "m68k", "vax", "riscv64", "loongarch64"+  , "javascript", "wasm32" ]++archAliases :: Strictness -> Text -> [Text]+archAliases strictness arch = case (strictness, arch) of+  (Permissive, "ppc") -> ["powerpc"]+  (Permissive, "ppc64") -> ["powerpc64"]+  (Permissive, "ppc64le") -> ["powerpc64le"]+  (Permissive, "mips") -> ["mipsel", "mipseb"]+  (Permissive, "arm") -> ["armeb", "armel"]+  (Permissive, "aarch64") -> ["arm64"]+  _ -> []
src/Aihc/Cabal/Internal/Resolve.hs view
@@ -6,6 +6,7 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T+import Aihc.Cabal.Internal.Platform (Strictness (..), canonicalArch, canonicalOS) import Aihc.Cabal.Internal.Types import Aihc.Cabal.Internal.Values (freeText) import Aihc.Cabal.Internal.Version (withinRange)@@ -13,16 +14,25 @@ -- | Evaluate a condition for a target and a flag assignment. A flag that is -- not in the assignment is 'False'. Names of operating systems, -- architectures, and compilers compare without case.+--+-- The names get the aliases of Cabal-syntax before the comparison. A name in+-- @os(...)@ uses the aliases for conditions, so @os(darwin)@ is true for the+-- target @osx@. A name in @arch(...)@ has no aliases, so @arch(arm64)@ is+-- false for the target @aarch64@, as in Cabal. The target names use the+-- aliases for host names, so the target @darwin@ is @osx@ and the target+-- @arm64@ is @aarch64@. evaluateCondition :: Environment -> FlagAssignment -> Condition -> Bool evaluateCondition env flags cond = case cond of   Literal b -> b-  OS x -> T.toLower x == T.toLower (targetOS env)-  Arch x -> T.toLower x == T.toLower (targetArch env)+  OS x -> sameName (canonicalOS Compat x) (canonicalOS Permissive (targetOS env))+  Arch x -> sameName (canonicalArch Strict x) (canonicalArch Permissive (targetArch env))   Impl x range -> T.toLower x == T.toLower (compiler env) && withinRange (compilerVersion env) range   FlagValue x -> Map.findWithDefault False x flags   Not a -> not (evaluateCondition env flags a)   And a b -> evaluateCondition env flags a && evaluateCondition env flags b   Or a b -> evaluateCondition env flags a || evaluateCondition env flags b+  where+    sameName a b = T.toLower a == T.toLower b  -- | Evaluate the conditions of all components and apply defaults. --
src/Aihc/Cabal/Internal/Types.hs view
@@ -32,6 +32,15 @@   , diagnosticMessage :: Text   } deriving (Eq, Show) +-- | The text of a diagnostic for a user, for example+-- @line 12, column 3: Unexpected token@. Without a position, the text is the+-- message only. The column counts UTF-8 bytes, as in 'Position'.+renderDiagnostic :: Diagnostic -> Text+renderDiagnostic d = case diagnosticPosition d of+  Just (Position row column) ->+    "line " <> T.pack (show row) <> ", column " <> T.pack (show column) <> ": " <> diagnosticMessage d+  Nothing -> diagnosticMessage d+ -- | The result of a parse. The parser stops at the first error, so the -- error side holds one diagnostic. Warnings are present with an error and -- with a value. The parser gives one warning: @Legacy cabal file@ for a@@ -133,7 +142,9 @@ data Condition   = Literal Bool   | OS Text-  -- ^ @os(name)@. The comparison ignores case.+  -- ^ @os(name)@. The comparison ignores case. The parser changes an alias+  -- to its canonical name, as Cabal-syntax does. For example, @darwin@+  -- becomes @osx@, and @mingw32@ becomes @windows@.   | Arch Text   -- ^ @arch(name)@. The comparison ignores case.   | Impl Text VersionRange@@ -374,9 +385,11 @@ -- library does not read the host platform or an installed compiler. data Environment = Environment   { targetOS :: Text-  -- ^ For @os(...)@, for example @linux@. Case does not matter.+  -- ^ For @os(...)@, for example @linux@. Case does not matter. The+  -- aliases of Cabal-syntax for host names apply, so @darwin@ is @osx@.   , targetArch :: Text-  -- ^ For @arch(...)@, for example @x86_64@. Case does not matter.+  -- ^ For @arch(...)@, for example @x86_64@. Case does not matter. The+  -- aliases of Cabal-syntax for host names apply, so @arm64@ is @aarch64@.   , compiler :: Text   -- ^ For @impl(...)@, for example @ghc@. Case does not matter.   , compilerVersion :: Version
src/Aihc/Cabal/Internal/Values.hs view
@@ -6,6 +6,7 @@   ( runValue, token, token', filePath, quoted, commaList, spaceList, optionList   , componentName, moduleName, identifier, languageName, bool, buildTypeValue   , dependency, exeDependency, legacyExeDependency, mixin, flagNameValue, specAtLeast, freeText+  , parseDependency, parsePackageIdentifier   ) where  import Control.Applicative (optional, (<|>))@@ -215,6 +216,36 @@       x <- library <* space       xs <- many (comma *> library <* space)       pure (x :| xs)++-- | Parse one @build-depends@ entry, for example @base >=4 && <5@ or+-- @pkg:{a, b} ^>=1.2@. The rules are the rules of the newest Cabal format+-- version, as in @simpleParsec@ of Cabal-syntax. Spaces after the value are+-- permitted. Spaces before the value are not permitted.+parseDependency :: Text -> Either Text Dependency+parseDependency = runSimple (dependency latestSpec)++-- | Parse a package identifier: a package name with an optional version, for+-- example @foo@ or @foo-bar-1.2.3@. The last part after a @-@ is the version+-- when it is a valid version. Each part of the name must not contain a dot+-- and must not be all digits. This follows @simpleParsec@ of Cabal-syntax.+parsePackageIdentifier :: Text -> Either Text (Text, Maybe Version)+parsePackageIdentifier = runSimple $ do+  parts <- component `sepBy1` char '-'+  let (nameParts, version) = case runSimple versionParser (last parts) of+        Right v -> (init parts, Just v)+        Left _ -> (parts, Nothing)+  if not (null nameParts) && all (\x -> not (T.any (== '.') x) && not (T.all isDigit x)) nameParts+    then pure (T.intercalate "-" nameParts, version)+    else fail "all digits or a dot in a portion of package name"+  where+    component = takeWhile1P (Just "package identifier") (\c -> isAlphaNum c || c == '.')++-- | Run a parser as @simpleParsec@ of Cabal-syntax does: spaces after the+-- value are permitted.+runSimple :: Parser a -> Text -> Either Text a+runSimple p input = case runParser (p <* space <* eof) "value" input of+  Left err -> Left (T.pack (errorBundlePretty err))+  Right x -> Right x  mainLibrary :: NonEmpty LibraryTarget mainLibrary = MainLibrary :| []
src/Aihc/Cabal/Internal/Version.hs view
@@ -6,7 +6,7 @@   ( -- * Public     Version, versionNumbers, mkVersion, parseVersion, renderVersion   , VersionRange (..), anyVersion, noVersion, thisVersion, withinVersion, withinRange, intersectRanges-  , unionRanges, parseVersionRange, renderVersionRange+  , unionRanges, simplifyVersionRange, parseVersionRange, renderVersionRange     -- * Internal   , Parser, specVersion, latestSpec, versionParser, versionDigits, rangeParser   ) where@@ -14,6 +14,7 @@ import Control.Applicative ((<|>)) import Control.Monad (when) import Data.Char (isAlphaNum, isDigit)+import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Text (Text)@@ -115,7 +116,8 @@ thisVersion :: Version -> VersionRange thisVersion = Equal --- | The range @a && b@ or @a || b@. The functions do not simplify.+-- | The range @a && b@ or @a || b@. The functions do not simplify. Use+-- 'simplifyVersionRange' for that. intersectRanges, unionRanges :: VersionRange -> VersionRange -> VersionRange intersectRanges = Both unionRanges = EitherRange@@ -232,3 +234,89 @@     isBoth _ = False     isEither EitherRange {} = True     isEither _ = False++-- | The same set of versions as a union of separate intervals in increasing+-- order. An empty range gives 'noVersion'. A range of all versions gives+-- 'anyVersion'.+--+-- An interval becomes @==v@, a bound, or two bounds with @&&@. The bounds+-- keep their operators, so @>1@ stays @>1@. A @^>=@ bound and a @==v.*@ range+-- become two bounds. The unions associate to the right, as the parser reads+-- them.+--+-- Version @0@ is the smallest version, so a lower bound @>=0@ has no effect.+-- No version is between @v@ and @v.0@, so @>1 && <1.0@ is empty and+-- @>1 && <=1.0@ is @==1.0@.+simplifyVersionRange :: VersionRange -> VersionRange+simplifyVersionRange range = case map fromInterval (intervals range) of+  [] -> noVersion+  parts -> foldr1 EitherRange parts+  where+    fromInterval (Interval low high)+      | Just high' <- high, upperKey high' == successor (lowerKey low) = Equal (lowerKey low)+      | otherwise = case (lowerPart, upperPart) of+          (Nothing, Nothing) -> AnyVersion+          (Just a, Nothing) -> a+          (Nothing, Just b) -> b+          (Just a, Just b) -> Both a b+      where+        lowerPart+          | lowerKey low == zero = Nothing+          | otherwise = Just (let Bound v inclusive = low in if inclusive then AtLeast v else Later v)+        upperPart = fmap (\(Bound v inclusive) -> if inclusive then AtMost v else Earlier v) high++-- | A bound version, and whether the version itself is in the interval.+data Bound = Bound Version Bool++-- | An interval from a lower bound to an upper bound. 'Nothing' is no upper+-- bound.+data Interval = Interval Bound (Maybe Bound)++zero :: Version+zero = Version (0 :| [])++-- | The next version: no version is between @v@ and @v.0@.+successor :: Version -> Version+successor (Version ns) = Version (ns <> (0 :| []))++-- | The smallest version in the interval above a lower bound.+lowerKey :: Bound -> Version+lowerKey (Bound v inclusive) = if inclusive then v else successor v++-- | The smallest version above the interval below an upper bound.+upperKey :: Bound -> Version+upperKey (Bound v inclusive) = if inclusive then successor v else v++-- | Separate, nonempty intervals in increasing order.+intervals :: VersionRange -> [Interval]+intervals range = case range of+  AnyVersion -> [Interval (Bound zero True) Nothing]+  Equal v -> [Interval (Bound v True) (Just (Bound v True))]+  Later v -> [Interval (Bound v False) Nothing]+  Earlier v -> normalize [Interval (Bound zero True) (Just (Bound v False))]+  AtLeast v -> [Interval (Bound v True) Nothing]+  AtMost v -> [Interval (Bound zero True) (Just (Bound v True))]+  MajorBound v -> normalize [Interval (Bound v True) (Just (Bound (majorUpperBound v) False))]+  EitherRange a b -> normalize (intervals a ++ intervals b)+  Both a b -> normalize [intersect x y | x <- intervals a, y <- intervals b]+  where+    intersect (Interval low high) (Interval low' high') =+      Interval (if lowerKey low' > lowerKey low then low' else low) (minUpper high high')+    minUpper Nothing b = b+    minUpper a Nothing = a+    minUpper (Just a) (Just b) = Just (if upperKey b < upperKey a then b else a)++normalize :: [Interval] -> [Interval]+normalize = merge . sortOn (\(Interval low _) -> lowerKey low) . filter nonEmpty+  where+    nonEmpty (Interval _ Nothing) = True+    nonEmpty (Interval low (Just high)) = lowerKey low < upperKey high+    merge (Interval low high : Interval low' high' : rest)+      | touches high low' = merge (Interval low (maxUpper high high') : rest)+    merge (x : rest) = x : merge rest+    merge [] = []+    touches Nothing _ = True+    touches (Just high) low' = lowerKey low' <= upperKey high+    maxUpper Nothing _ = Nothing+    maxUpper _ Nothing = Nothing+    maxUpper (Just a) (Just b) = Just (if upperKey b > upperKey a then b else a)
test/Main.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Monad (forM_, unless)+import Control.Monad (forM_, unless, when) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.List.NonEmpty (NonEmpty (..))@@ -16,6 +16,8 @@ import qualified Distribution.PackageDescription.Parsec as C import qualified Distribution.Parsec as C import qualified Distribution.Pretty as C+import qualified Distribution.Compat.NonEmptySet as C+import qualified Distribution.System as C import qualified Distribution.Types.Version as C import qualified Distribution.Types.VersionRange as C import qualified Distribution.Utils.Path as C@@ -96,6 +98,10 @@   testOlderToolDependencies   testRepeatedPackageFields   testNewFormatVersions+  testSingleValues+  testPlatformAliases+  testSimplifyVersionRange+  testFieldPaths   testErrors   putStrLn "All parser checks passed" @@ -449,6 +455,183 @@   pkg <- parse "cabal-version: 3.18\nname: sample\nversion: 1\n"   assert "Newest format version" (version "3.18") (cabalVersion pkg) +-- | 'parseDependency' and 'parsePackageIdentifier' accept the same inputs as+-- 'C.simpleParsec' and give the same values.+testSingleValues :: IO ()+testSingleValues = do+  forM_ dependencyInputs $ \input ->+    case (parseDependency (T.pack input), C.simpleParsec input :: Maybe C.Dependency) of+      (Left _, Nothing) -> pure ()+      (Right ours, Just ref) -> do+        assert ("Dependency name: " ++ input) (T.pack (C.unPackageName (C.depPkgName ref))) (dependencyPackage ours)+        assert ("Dependency libraries: " ++ input)+          (map libraryText (C.toList (C.depLibraries ref))) (map ourLibrary (NE.toList (dependencyLibraries ours)))+        forM_ sampleVersions $ \ns -> do+          v <- maybe (fail "Invalid test version") pure (mkVersion (map toInteger ns))+          assert ("Dependency range: " ++ input ++ " " ++ show ns)+            (C.withinRange (C.mkVersion ns) (C.depVerRange ref)) (withinRange v (dependencyRange ours))+      (ours, ref) -> fail ("Dependency acceptance differs for " ++ show input ++ ": " ++ show ours ++ " " ++ show ref)+  forM_ identifierInputs $ \input ->+    case (parsePackageIdentifier (T.pack input), C.simpleParsec input :: Maybe C.PackageIdentifier) of+      (Left _, Nothing) -> pure ()+      (Right (name, ours), Just ref) -> do+        assert ("Identifier name: " ++ input) (T.pack (C.unPackageName (C.pkgName ref))) name+        assert ("Identifier version: " ++ input)+          (if C.pkgVersion ref == C.nullVersion then Nothing else Just (C.versionNumbers (C.pkgVersion ref)))+          (map fromInteger . NE.toList . versionNumbers <$> ours)+      (ours, ref) -> fail ("Identifier acceptance differs for " ++ show input ++ ": " ++ show ours ++ " " ++ show ref)+  where+    libraryText C.LMainLibName = Nothing+    libraryText (C.LSubLibName n) = Just (T.pack (C.unUnqualComponentName n))+    ourLibrary MainLibrary = Nothing+    ourLibrary (NamedLibrary n) = Just n+    sampleVersions = [[0], [1], [1, 2], [1, 2, 3], [2], [3], [3, 9], [4], [4, 18], [4, 18, 0, 0], [5], [9, 9]]+    dependencyInputs =+      [ "base", "base >=4 && <5", "base>=4", "base ^>=4.18", "base ==4.*", "base -any", "base -none"+      , "pkg:sub", "pkg:{a,b} >=1", "pkg:{ a , b }", "pkg:pkg", "base >= 4 || == 3", "base (>=1 && <2) || >3"+      , "Base", "base-1", "1base", "base-", "", " base", "base ", "foo_bar", "base >=4.0.0.0-rc1"+      , "base ==1.2.3.4", "base {", "base >=01", "base <1 && >", "base ==1.2.*.3", "base =={1.2,1.3}"+      , "base:{}", "base >1 ||", "a-b-c <2" ]+    identifierInputs =+      [ "foo", "foo-1.2", "foo-bar-1.2.3", "foo-bar", "foo-1.2-3", "foo-1a", "foo-01", "1-2", "foo.bar-1"+      , "foo-1.2.", "", "foo-", "-foo", "foo--1", "foo-1.2 ", " foo", "base-4.18.0.0", "a-b-c"+      , "foo-1.2 bar", "foo-0", "foo-1234567890", "foo_bar-1", "FOO-1" ]++-- | Cabal-syntax gives aliases to the names in @os(...)@ with its Compat+-- table, and to the names in @arch(...)@ with its Strict table, which has no+-- aliases. It gives aliases to the host names with its Permissive table.+-- A condition is true when the two classified names are equal.+testPlatformAliases :: IO ()+testPlatformAliases = do+  forM_ osNames $ \name -> do+    reference <- referenceCondition ("os(" <> name <> ")")+    forM_ osTargets $ \target -> do+      let expected = case reference of+            C.Var (C.OS os) -> os == C.classifyOS C.Permissive target+            other -> error ("Unexpected reference condition: " ++ show other)+      assert ("os(" ++ name ++ ") on " ++ target) expected+        (evaluate ("os(" <> name <> ")") (Environment (T.pack target) "x86_64" "ghc" (version "9.12.2")))+  forM_ archNames $ \name -> do+    reference <- referenceCondition ("arch(" <> name <> ")")+    forM_ archTargets $ \target -> do+      let expected = case reference of+            C.Var (C.Arch arch) -> arch == C.classifyArch C.Permissive target+            other -> error ("Unexpected reference condition: " ++ show other)+      assert ("arch(" ++ name ++ ") on " ++ target) expected+        (evaluate ("arch(" <> name <> ")") (Environment "linux" (T.pack target) "ghc" (version "9.12.2")))+  where+    osNames = ["darwin", "osx", "OSX", "Darwin", "mingw32", "win32", "cygwin32", "windows", "gnu", "hurd"+      , "kfreebsdgnu", "freebsd", "solaris2", "linux-android", "linux-androideabi", "linux", "wasi", "other"]+    osTargets = ["osx", "darwin", "windows", "mingw32", "cygwin32", "hurd", "gnu", "freebsd", "kfreebsdgnu"+      , "solaris", "solaris2", "android", "linux-android", "linux-androideabi", "linux", "wasi", "other"]+    archNames = ["arm64", "aarch64", "AArch64", "amd64", "x86_64", "i386", "i686", "x86", "powerpc", "ppc"+      , "armel", "arm", "wasm32", "other"]+    archTargets = ["aarch64", "arm64", "x86_64", "amd64", "i386", "i686", "ppc", "powerpc", "arm", "armel"+      , "wasm32", "other"]+    source cond = BSC.unlines (map BSC.pack (header ++ ["library", "  if " ++ cond, "    cpp-options: -DTRUE"]))+    referenceCondition cond = do+      ref <- right (snd (runResult (C.parseGenericPackageDescription (source cond))))+      case C.condLibrary ref of+        Just (C.CondNode _ [C.CondBranch c _ _]) -> pure c+        _ -> fail ("Missing reference branch for " ++ cond)+    evaluate cond env = case parseValue (parsePackage (source cond)) of+      Right pkg -> case packageComponents pkg of+        [Component _ (Conditional _ [Branch c _ _])] -> evaluateCondition env Map.empty c+        _ -> error ("Missing branch for " ++ cond)+      Left e -> error (show e)++-- | 'simplifyVersionRange' keeps the set of versions and gives separate+-- intervals in increasing order. The test examines all ranges with one or two+-- simple parts, and some ranges with three parts, over versions near each+-- bound.+testSimplifyVersionRange :: IO ()+testSimplifyVersionRange = do+  forM_ ranges $ \range -> do+    let simple = simplifyVersionRange range+        label = T.unpack (renderVersionRange range)+    forM_ grid $ \v ->+      assert ("Same versions: " ++ label ++ " at " ++ T.unpack (renderVersion v)) (withinRange v range) (withinRange v simple)+    assert ("Idempotent: " ++ label) simple (simplifyVersionRange simple)+    let members = [v | v <- grid, withinRange v range]+    when (null members) $ assert ("Empty: " ++ label) noVersion simple+    when (length members == length grid) $ assert ("All versions: " ++ label) anyVersion simple+    let parts = unionParts simple+        firstMember part = [v | v <- grid, withinRange v part]+    forM_ (zip parts (drop 1 parts)) $ \(a, b) ->+      case (firstMember a, firstMember b) of+        (xs@(_ : _), y : _) -> assert ("Increasing parts: " ++ label) True (maximum xs < y)+        _ -> pure ()+  forM_ examples $ \(input, expected) -> do+    range <- right (parseVersionRange input)+    assert ("Simplify " ++ T.unpack input) expected (renderVersionRange (simplifyVersionRange range))+  where+    points = map version ["0", "1", "1.0", "1.2", "1.2.0", "1.3", "2", "2.0.1"]+    atoms =+      [anyVersion, noVersion]+        ++ [f p | p <- points, f <- [Equal, Later, Earlier, AtLeast, AtMost, MajorBound, withinVersion]]+    pairs = [c a b | a <- atoms, b <- atoms, c <- [Both, EitherRange]]+    triples = [c a (d b e) | a <- take 12 atoms, b <- take 12 (drop 12 atoms), e <- take 12 (drop 30 atoms)+      , c <- [Both, EitherRange], d <- [Both, EitherRange]]+    ranges = atoms ++ pairs ++ triples+    grid = map version+      [ "0", "0.0", "0.1", "1", "1.0", "1.0.0", "1.0.1", "1.1", "1.2", "1.2.0", "1.2.0.0", "1.2.1", "1.3"+      , "1.3.0", "1.4", "2", "2.0", "2.0.0", "2.0.1", "2.0.1.0", "2.0.2", "2.1", "3", "3.0", "10" ]+    -- The grid holds the smallest version of each interval and of each gap+    -- between intervals for the points above. Thus a range without a grid+    -- version is empty, and a range with all grid versions has all versions.+    unionParts (EitherRange a b) = unionParts a ++ unionParts b+    unionParts r = [r]+    examples =+      [ (">=1 && <2 || >=1.5 && <3", ">=1 && <3")+      , ("<1.1 || >1.1", "<1.1 || >1.1")+      , (">1 && <1.0", "<0")+      , (">1 && <=1.0", "==1.0")+      , ("^>=1.2", ">=1.2 && <1.3")+      , ("==1.* && <1.5 || >=1.5 && <2", ">=1 && <2")+      , (">=0", "-any")+      , ("<3 || >=2", "-any")+      , (">=2 && <3 || <1", "<1 || >=2 && <3")+      , ("<=1 || >=1.0", "-any")+      , (">=1 && <=1", "==1")+      ]++-- | 'fieldPaths' reads a custom field as @c-sources@ reads its value, for+-- each Cabal format version.+testFieldPaths :: IO ()+testFieldPaths = do+  forM_ ["1.10", "2.2", "3.0", "3.18"] $ \spec ->+    forM_ values $ \value@(firstLine, otherLines) -> do+      let file field = BSC.unlines (map BSC.pack+            ([ "cabal-version: " ++ (if spec < "2.2" then ">=" else "") ++ spec, "name: sample", "version: 1"+             , "build-type: Simple", "library", "  " ++ field ++ ": " ++ firstLine ] ++ map ("    " ++) otherLines))+          label = spec ++ " " ++ show value+      case (parseValue (parsePackage (file "c-sources")), parseValue (parsePackage (file "x-paths"))) of+        (reference, Right pkg) -> do+          custom <- case packageComponents pkg of+            [Component _ tree] -> pure (Map.findWithDefault [] "x-paths" (extraFields (unconditional tree)))+            _ -> fail "Missing library"+          let ours = concat <$> mapM (fieldPaths (cabalVersion pkg)) custom+          case reference of+            Right cpkg -> do+              expected <- case packageComponents cpkg of+                [Component _ tree] -> pure (cSources (unconditional tree))+                _ -> fail "Missing library"+              assert ("Field paths: " ++ label) (Right expected) (either (Left . diagnosticMessage) Right ours)+            Left _ -> case ours of+              Left d -> assert ("Field path error position: " ++ label) (Just (Position 6 3)) (diagnosticPosition d)+              Right paths -> fail ("Paths accepted that c-sources rejects: " ++ label ++ ": " ++ show paths)+        (_, Left e) -> fail ("Custom field rejected: " ++ label ++ ": " ++ show e)+  pkg <- parse (BSC.unlines (map BSC.pack (header ++ ["library", "  x-aihc-lir-sources: \"lir/with space.lir\", lir/b.lir"])))+  custom <- case packageComponents pkg of+    [Component _ tree] -> pure (extraFields (unconditional tree))+    _ -> fail "Missing library"+  assert "Quoted path with a space" (Right ["lir/with space.lir", "lir/b.lir"])+    (either (Left . diagnosticMessage) Right (concat <$> mapM (fieldPaths (cabalVersion pkg)) (Map.findWithDefault [] "x-aihc-lir-sources" custom)))+  where+    values =+      [ ("a.c b.c", []), ("a.c, b.c", []), ("a.c,b.c", []), (", a.c, b.c", []), ("\"dir with space/a.c\" b.c", [])+      , ("a.c", ["b.c"]), ("a.c,", ["b.c"]), ("a.c,,b.c", []), ("a.c b.c, c.c", []), ("\"unterminated", []) ]+ testErrors :: IO () testErrors = do   forM_@@ -475,11 +658,19 @@   reject (BS.pack [255,254])   let bad = parsePackage (BSC.unlines (map BSC.pack (header ++ ["library", "  buildable: invalid"])))   case parseValue bad of-    Left d -> assert "Error source position" (Just (Position 5 3)) (diagnosticPosition d)+    Left d -> do+      assert "Error source position" (Just (Position 5 3)) (diagnosticPosition d)+      assert "Error text with a position" ("line 5, column 3: " <> diagnosticMessage d) (renderDiagnostic d)     Right _ -> fail "Invalid input accepted"   case parseValue (parsePackage "version: 1\n") of-    Left d -> assert "Package check has no position" Nothing (diagnosticPosition d)+    Left d -> do+      assert "Package check has no position" Nothing (diagnosticPosition d)+      assert "Error text without a position" (diagnosticMessage d) (renderDiagnostic d)     Right _ -> fail "Invalid input accepted"+  assert "Diagnostic text" "line 12, column 3: Unexpected token"+    (renderDiagnostic (Diagnostic (Just (Position 12 3)) "Unexpected token"))+  assert "Diagnostic text without a position" "Missing field: name"+    (renderDiagnostic (Diagnostic Nothing "Missing field: name"))   where     reject bytes = case parseValue (parsePackage bytes) of       Left _ -> pure ()