diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/aihc-cabal-syntax.cabal b/aihc-cabal-syntax.cabal --- a/aihc-cabal-syntax.cabal +++ b/aihc-cabal-syntax.cabal @@ -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 diff --git a/src/Aihc/Cabal.hs b/src/Aihc/Cabal.hs --- a/src/Aihc/Cabal.hs +++ b/src/Aihc/Cabal.hs @@ -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 diff --git a/src/Aihc/Cabal/Internal/Condition.hs b/src/Aihc/Cabal/Internal/Condition.hs --- a/src/Aihc/Cabal/Internal/Condition.hs +++ b/src/Aihc/Cabal/Internal/Condition.hs @@ -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))) diff --git a/src/Aihc/Cabal/Internal/Parser.hs b/src/Aihc/Cabal/Internal/Parser.hs --- a/src/Aihc/Cabal/Internal/Parser.hs +++ b/src/Aihc/Cabal/Internal/Parser.hs @@ -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) diff --git a/src/Aihc/Cabal/Internal/Platform.hs b/src/Aihc/Cabal/Internal/Platform.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal/Internal/Platform.hs @@ -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"] + _ -> [] diff --git a/src/Aihc/Cabal/Internal/Resolve.hs b/src/Aihc/Cabal/Internal/Resolve.hs --- a/src/Aihc/Cabal/Internal/Resolve.hs +++ b/src/Aihc/Cabal/Internal/Resolve.hs @@ -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. -- diff --git a/src/Aihc/Cabal/Internal/Types.hs b/src/Aihc/Cabal/Internal/Types.hs --- a/src/Aihc/Cabal/Internal/Types.hs +++ b/src/Aihc/Cabal/Internal/Types.hs @@ -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 diff --git a/src/Aihc/Cabal/Internal/Values.hs b/src/Aihc/Cabal/Internal/Values.hs --- a/src/Aihc/Cabal/Internal/Values.hs +++ b/src/Aihc/Cabal/Internal/Values.hs @@ -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 :| [] diff --git a/src/Aihc/Cabal/Internal/Version.hs b/src/Aihc/Cabal/Internal/Version.hs --- a/src/Aihc/Cabal/Internal/Version.hs +++ b/src/Aihc/Cabal/Internal/Version.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ()