diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,17 @@ +# Changelog + +All notable changes to this project are recorded in this file. + +This project uses the format from [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). + +## [1.0.0.1] - 2026-09-29 + +### Changed + +- Add dependency bounds and package metadata. + +## [1.0.0.0] - 2026-09-29 + +### Added + +- Add a Cabal parser that is 100% compatible with Cabal-syntax. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,62 @@ + +# aihc-cabal-syntax + +A small Haskell library that parses `.cabal` files for the aihc compiler. +It provides package data, version ranges, and condition evaluation without a runtime dependency on Cabal or Cabal-syntax. +It uses Megaparsec. It does not solve dependencies or build packages. + +## Hackage results + +The fixed Hackage index contains **200,642 file revisions**. +The reference parser is **Cabal-syntax 3.18.1.0**. + +| Result | Files | All files | +| --- | ---: | ---: | +| aihc-cabal-syntax accepts | 200,642 | 100.00% | +| Cabal-syntax accepts | 200,642 | 100.00% | +| Equal converted data | 200,642 | 100.00% | + +An accepted file does not prove full compliance. +The equality test compares complete `GenericPackageDescription` values after conversion of our AST. +Conversion limits can also cause differences. This library is not a complete replacement for Cabal-syntax. + +## Stackage LTS results + +The Stackage test uses **Stackage LTS 24.38** with **3,370 packages**. +The pinned Nixpkgs revision supplies the package list. +The test uses the last revision of each package version in the fixed Hackage index. + +| Result | Packages | All packages | +| --- | ---: | ---: | +| aihc-cabal-syntax accepts | 3,370 | 100.00% | +| Cabal-syntax accepts | 3,370 | 100.00% | +| Equal converted data | 3,370 | 100.00% | + +The Nix check fails if a package in the snapshot does not have equal converted data. + +## Parse benchmark + +Each parser reads all **200,642 revisions** in a separate process on the same machine. + +| Measurement | aihc-cabal-syntax | Cabal-syntax | aihc / Cabal-syntax | +| --- | ---: | ---: | ---: | +| Elapsed time | 47.64 s | 132.77 s | 0.36× | +| Peak process memory (RSS) | 23.20 MiB | 37.56 MiB | 0.62× | + +A ratio below 1 means less time or memory than Cabal-syntax. +Measured on `aarch64-darwin` with GHC 9.10.3, `-O2`, and one RTS capability. +Time includes archive input, parsing, and result evaluation through `show`. +The benchmark includes rejected files. It discards each result before the next file. +Each parser has one measured run. Machine load and file caching affect the time. +The parsers produce different data and accept different numbers of files; these ratios include that difference. + +## Build and update + +```sh +nix build --no-update-lock-file +nix flake check --no-update-lock-file +nix run .#update-readme --no-update-lock-file +``` + +The update command runs the full comparison and a new benchmark, then writes this README and the measurement data. +Nix pins the tools and test data. See [test details](docs/hackage.md) and [API use and limits](docs/api.md). diff --git a/aihc-cabal-syntax.cabal b/aihc-cabal-syntax.cabal new file mode 100644 --- /dev/null +++ b/aihc-cabal-syntax.cabal @@ -0,0 +1,57 @@ +cabal-version: 3.0 +name: aihc-cabal-syntax +version: 1.0.0.1 +synopsis: Parse Cabal files for aihc +description: Parse Cabal package files for the aihc compiler. + Read package data, version ranges, and condition expressions. +category: Parsing +maintainer: David Himmelstrup +license: Unlicense +license-file: LICENSE +build-type: Simple +extra-doc-files: CHANGELOG.md +extra-source-files: README.md test/fixtures/*.cabal + +library + exposed-modules: Aihc.Cabal + other-modules: + Aihc.Cabal.Internal.Condition + Aihc.Cabal.Internal.Lexer + Aihc.Cabal.Internal.Parser + Aihc.Cabal.Internal.Quirks + Aihc.Cabal.Internal.Resolve + Aihc.Cabal.Internal.Types + Aihc.Cabal.Internal.Values + Aihc.Cabal.Internal.Version + hs-source-dirs: src + build-depends: base >=4.16 && <5, bytestring <0.13, containers <0.9, text <2.2, megaparsec >=9 && <10, parser-combinators <1.4 + default-language: Haskell2010 + ghc-options: -Wall + +test-suite parser-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: base, aihc-cabal-syntax, bytestring <0.13, containers <0.9, text <2.2, Cabal-syntax >=3.18.1 && <3.19 + default-language: Haskell2010 + ghc-options: -Wall + +test-suite hackage-compliance + type: exitcode-stdio-1.0 + main-is: Hackage.hs + hs-source-dirs: test + other-modules: Compliance.Adapter Compliance.Compare Compliance.Tests + build-depends: base, aihc-cabal-syntax, bytestring <0.13, containers <0.9, text <2.2, + Cabal-syntax >=3.18.1 && <3.19, aeson <2.3, tar <0.7, directory <1.4, filepath <1.6 + default-language: Haskell2010 + ghc-options: -Wall -rtsopts + +test-suite pretty-roundtrip + type: exitcode-stdio-1.0 + main-is: RoundTrip.hs + hs-source-dirs: test + other-modules: Compliance.Adapter + build-depends: base, aihc-cabal-syntax, bytestring <0.13, containers <0.9, text <2.2, + Cabal-syntax >=3.18.1 && <3.19, hedgehog >=1.5 && <1.6 + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Aihc/Cabal.hs b/src/Aihc/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal.hs @@ -0,0 +1,112 @@ +-- | Parse Cabal package descriptions for the aihc compiler. +-- +-- This is the only public module of the package. It has no dependency on +-- Cabal or Cabal-syntax. The parser follows the package parser of +-- Cabal-syntax 3.18.1.0 and accepts format versions 1.0 through 3.18. +-- +-- The record field names are short, for example 'buildable' and +-- 'dependencies'. Import the module qualified to keep them out of your +-- namespace. +-- +-- = Use +-- +-- Read a package, evaluate its conditions for one target, and read the +-- fields of the main library: +-- +-- @ +-- import qualified Aihc.Cabal as Cabal +-- import qualified Data.ByteString as BS +-- import qualified Data.Map.Strict as Map +-- +-- main :: IO () +-- main = do +-- bytes <- BS.readFile \"text.cabal\" +-- package <- either (fail . show) pure (Cabal.parseValue (Cabal.parsePackage bytes)) +-- ghc <- either (fail . show) pure (Cabal.parseVersion \"9.12.2\") +-- let environment = Cabal.Environment \"linux\" \"x86_64\" \"ghc\" ghc +-- overrides = Map.fromList [(\"simdutf\", False)] +-- resolved = Cabal.resolvePackage environment overrides package +-- case [bi | Cabal.Component (Cabal.Library Cabal.MainLibrary) bi <- Cabal.resolvedComponents resolved] of +-- [library] -> do +-- print (Cabal.exposedModules library) +-- print (map Cabal.dependencyPackage (Cabal.dependencies library)) +-- print (map Cabal.fieldText (Map.findWithDefault [] \"x-aihc-lir-sources\" (Cabal.extraFields library))) +-- _ -> fail \"No main library\" +-- @ +-- +-- 'parsePackage' keeps conditions. 'resolvePackage' evaluates them for an +-- t'Environment' and a 'FlagAssignment', merges the active parts, and applies +-- defaults. The caller selects the components to build. A dependency solver +-- can inspect the t'Conditional' values of a t'Package' before it selects +-- flags. +-- +-- = Limits +-- +-- * Package fields other than @name@, @version@, @cabal-version@, and +-- @build-type@ stay in 'packageFields' as text. Component fields without +-- 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. +-- * The library does not solve dependencies, find source files, or run +-- configure scripts. +module Aihc.Cabal + ( -- * Parsing + parsePackage + , parseHookedBuildInfo + , ParseResult (..) + , Diagnostic (..) + , Position (..) + -- * Packages + , Package (..) + , packageFieldText + , Flag (..) + , SourceRepository (..) + , FieldValue (..) + , FieldLine (..) + , fieldText + -- * Components + , Component (..) + , ComponentKind (..) + , LibraryTarget (..) + , Conditional (..) + , Branch (..) + , Condition (..) + -- * Build information + , BuildInfo (..) + , emptyBuildInfo + , mergeBuildInfo + , Dependency (..) + , ToolDependency (..) + , Mixin (..) + , ModuleRenaming (..) + , HookedBuildInfo (..) + -- * Resolution + , Environment (..) + , FlagAssignment + , evaluateCondition + , resolvePackage + , ResolvedPackage (..) + -- * Versions + , Version + , mkVersion + , versionNumbers + , parseVersion + , renderVersion + -- * Version ranges + , VersionRange (..) + , anyVersion + , noVersion + , thisVersion + , withinVersion + , intersectRanges + , unionRanges + , withinRange + , parseVersionRange + , renderVersionRange + ) where + +import Aihc.Cabal.Internal.Parser +import Aihc.Cabal.Internal.Resolve +import Aihc.Cabal.Internal.Types +import Aihc.Cabal.Internal.Version diff --git a/src/Aihc/Cabal/Internal/Condition.hs b/src/Aihc/Cabal/Internal/Condition.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal/Internal/Condition.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Parse a condition from the arguments of an @if@ or @elif@ section. +-- This module follows the condition parser of Cabal-syntax 3.12. The parser +-- reads section argument tokens, not text. +module Aihc.Cabal.Internal.Condition (parseCondition) where + +import Control.Applicative (Alternative (..)) +import Control.Monad (ap) +import Data.Char (isDigit, isAlphaNum) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import qualified Data.Text as T +import Text.Megaparsec (eof, runParser, satisfy, takeWhile1P) +import qualified Text.Megaparsec as M +import Text.Megaparsec.Char (char) +import Aihc.Cabal.Internal.Lexer (SectionArg (..)) +import Aihc.Cabal.Internal.Types (Condition (..)) +import Aihc.Cabal.Internal.Values (flagNameValue, identifier) +import Aihc.Cabal.Internal.Version + +-- | A parser with Parsec semantics: an alternative runs only when the first +-- parser fails without input consumption. +newtype P a = P { runP :: [SectionArg] -> Reply a } + +data Reply a = Ok a [SectionArg] Bool | Err Bool + +instance Functor P where + fmap f (P p) = P $ \s -> case p s of + Ok a r c -> Ok (f a) r c + Err c -> Err c + +instance Applicative P where + pure x = P (\s -> Ok x s False) + (<*>) = ap + +instance Monad P where + P p >>= k = P $ \s -> case p s of + Err c -> Err c + Ok a r c -> case runP (k a) r of + Ok b r' c' -> Ok b r' (c || c') + Err c' -> Err (c || c') + +instance Alternative P where + empty = P (const (Err False)) + P p <|> P q = P $ \s -> case p s of + Err False -> q s + reply -> reply + many p = some p <|> pure [] + some p = (:) <$> p <*> many p + +instance MonadFail P where + fail _ = empty + +try :: P a -> P a +try (P p) = P $ \s -> case p s of + Err _ -> Err False + reply -> reply + +tokenWith :: (SectionArg -> Maybe a) -> P a +tokenWith f = P $ \s -> case s of + x : rest | Just a <- f x -> Ok a rest True + _ -> Err False + +name :: P Text +name = tokenWith $ \t -> case t of + ArgName _ x -> Just x + _ -> Nothing + +word :: Text -> P () +word w = tokenWith $ \t -> case t of + ArgName _ x | x == w -> Just () + _ -> Nothing + +oper :: Text -> P () +oper o = tokenWith $ \t -> case t of + ArgOther _ x | x == o -> Just () + _ -> Nothing + +-- | Consume a name token and parse it completely. A parse error after the +-- token is an error with input consumption. +value :: Parser a -> P a +value p = do + x <- name + case runParser (p <* eof) "" x of + Left _ -> P (const (Err True)) + Right a -> pure a + +parens :: P a -> P a +parens p = oper "(" *> p <* oper ")" + +sepBy1 :: P a -> P s -> P (NE.NonEmpty a) +sepBy1 p s = (NE.:|) <$> p <*> many (s *> p) + +parseCondition :: [SectionArg] -> Maybe Condition +parseCondition args = case runP (condOr <* end) args of + Ok c _ _ -> Just c + Err _ -> Nothing + where + end = P $ \s -> if null s then Ok () s False else Err False + 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 "arch" *> parens (Arch <$> value identifier)) + <|> (word "flag" *> parens (FlagValue <$> value flagNameValue)) + <|> (word "impl" *> parens (Impl <$> value compiler <*> (versionRange <|> pure anyVersion))) + boolean = tokenWith $ \t -> case t of + ArgName _ x + | x `elem` ["True", "true"] -> Just (Literal True) + | x `elem` ["False", "false"] -> Just (Literal False) + _ -> Nothing + compiler = do + x <- takeWhile1P Nothing isAlphaNum + if T.all isDigit x then fail "all digits compiler name" else pure x + versionRange = expr + where + expr = foldl1 EitherRange <$> sepBy1 term (oper "||") + term = foldl1 Both <$> sepBy1 factor (oper "&&") + factor = parens expr + <|> (AnyVersion <$ word "-any") + <|> (noVersion <$ word "-none") + <|> try (withinVersion <$> (oper "==" *> value versionStar) <* oper "*") + <|> foldr1 (<|>) [try (f <$> (oper o *> value versionParser)) | (o, f) <- operators] + operators = + [ ("<", Earlier), ("<=", AtMost), (">", Later), (">=", AtLeast) + , ("^>=", MajorBound), ("==", Equal) ] + versionStar = specVersion <$> M.some (read <$> M.some (satisfy isDigit) <* char '.') diff --git a/src/Aihc/Cabal/Internal/Lexer.hs b/src/Aihc/Cabal/Internal/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal/Internal/Lexer.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Read the outline of a Cabal file: fields, sections, and their positions. +-- This module follows the lexer and the outline parser of Cabal-syntax 3.12. +module Aihc.Cabal.Internal.Lexer + ( Field (..), SectionArg (..), readFields, sectionArgText + ) where + +import Data.Char (isAsciiUpper, ord, toLower) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Aihc.Cabal.Internal.Types (Diagnostic (..), FieldLine (..), Position (..)) + +data Field + = Field !Position Text [FieldLine] + | Section !Position Text [SectionArg] [Field] + deriving Show + +data SectionArg + = ArgName !Position Text + | ArgString !Position Text + | ArgOther !Position Text + deriving Show + +sectionArgText :: SectionArg -> Text +sectionArgText (ArgName _ t) = t +sectionArgText (ArgString _ t) = t +sectionArgText (ArgOther _ t) = t + +data Token + = TokSym Text | TokStr Text | TokOther Text | Indent Int | TokFieldLine Text + | Colon | OpenBrace | CloseBrace | EOF | LexicalError + deriving (Eq, Show) + +data Mode = BolSection | InSection | BolFieldLayout | InFieldLayout | BolFieldBraces | InFieldBraces + deriving (Eq, Show) + +-- | The state before a token. The token and the next state are computed +-- on demand, as in the Cabal-syntax parser. +data LexState = LexState + { lexRow :: !Int + , lexColumn :: !Int + , lexInput :: !Text + , lexMode :: !Mode + } + +data Stream = Stream LexState (Position, Token, Stream) + +stream :: LexState -> Stream +stream st = Stream st (lexToken st) + +setMode :: Mode -> Stream -> Stream +setMode m (Stream st _) = stream st {lexMode = m} + +peek :: Stream -> (Position, Token) +peek (Stream _ (p, t, _)) = (p, t) + +advance :: Stream -> Stream +advance (Stream _ (_, _, next)) = next + +-- | The number of bytes in the UTF-8 encoding. Cabal-syntax counts columns in bytes. +width :: Char -> Int +width c + | n < 0x80 = 1 + | n < 0x800 = 2 + | n < 0x10000 = 3 + | otherwise = 4 + where n = ord c + +widthOf :: Text -> Int +widthOf = T.foldl' (\a c -> a + width c) 0 + +isSpaceTab :: Char -> Bool +isSpaceTab c = c == ' ' || c == '\t' + +-- | Characters in the Cabal lexer class @$printable@. +isPrintable :: Char -> Bool +isPrintable c = c > '\x1f' && c /= '\x7f' + +isSymbol' :: Char -> Bool +isSymbol' c = c `elem` (",=<>+*&|!$%^@#?/\\~" :: String) + +isNameChar :: Char -> Bool +isNameChar c = isPrintable c && not (c `elem` (" :\"{}()[]" :: String)) && not (isSymbol' c) + +isOpChar :: Char -> Bool +isOpChar c = isSymbol' c || c == '-' || c == '.' + +isParen :: Char -> Bool +isParen c = c `elem` ("()[]" :: String) + +-- | Split a line break at the start of the text: @\\n@, @\\r\\n@, or @\\r@. +newline :: Text -> Maybe Text +newline t = case T.uncons t of + Just ('\n', rest) -> Just rest + Just ('\r', rest) -> Just (fromMaybe rest (T.stripPrefix "\n" rest)) + _ -> Nothing + +lexToken :: LexState -> (Position, Token, Stream) +lexToken st@(LexState row col input mode) = case mode of + BolSection -> bol st $ \ws rest -> case T.uncons rest of + Just ('{', r) | T.all isSpaceTab ws -> token col OpenBrace (LexState row (col + T.length ws + 1) r BolSection) + Just ('}', r) | T.all isSpaceTab ws -> token col CloseBrace (LexState row (col + T.length ws + 1) r BolSection) + _ -> indentation ws rest InSection + BolFieldLayout -> bol st $ \ws rest -> indentation ws rest InFieldLayout + BolFieldBraces -> bol st $ \_ _ -> lexToken st {lexMode = InFieldBraces} + InSection -> case T.uncons input of + Nothing -> token col EOF st + Just (c, rest) + | isSpaceTab c -> let (ws, r) = T.span isSpaceTab input in lexToken st {lexColumn = col + T.length ws, lexInput = r} + | "--" `T.isPrefixOf` input -> + let (comment, r) = T.span isCommentChar input + in lexToken st {lexColumn = col + widthOf comment, lexInput = r} + | Just r <- newline input -> lexToken (LexState (row + 1) 1 r BolSection) + | c == ':' -> token col Colon st {lexColumn = col + 1, lexInput = rest} + | c == '{' -> token col OpenBrace st {lexColumn = col + 1, lexInput = rest} + | c == '}' -> token col CloseBrace st {lexColumn = col + 1, lexInput = rest} + | c == '"' -> case stringToken rest of + Just (s, r) -> token col (TokStr s) st {lexColumn = col + widthOf s + 2, lexInput = r} + Nothing -> token col LexicalError st {lexInput = ""} + | isParen c -> token col (TokOther (T.singleton c)) st {lexColumn = col + 1, lexInput = rest} + | otherwise -> + -- The longest match wins. A name wins a tie with an operator. + let nameLen = T.length (T.takeWhile isNameChar input) + opLen = T.length (T.takeWhile isOpChar input) + in if nameLen == 0 && opLen == 0 then token col LexicalError st {lexInput = ""} + else if nameLen >= opLen then word TokSym nameLen + else word TokOther opLen + InFieldLayout -> fieldLine (const True) + InFieldBraces -> case T.uncons input of + Just ('{', rest) -> token col OpenBrace st {lexColumn = col + 1, lexInput = rest} + Just ('}', rest) -> token col CloseBrace st {lexColumn = col + 1, lexInput = rest} + _ -> fieldLine (\c -> c /= '{' && c /= '}') + where + token c t next = (Position row c, t, stream next) + word constructor n = + let (w, rest) = T.splitAt n input + in token col (constructor w) st {lexColumn = col + widthOf w, lexInput = rest} + isCommentChar c = isPrintable c || c == '\t' + -- Skip blank lines and comment lines at the start of a line. + bol s k = + let (ws, rest) = T.span (\c -> isSpaceTab c || c == '\xa0') (lexInput s) + in case newline rest of + Just r -> lexToken s {lexRow = lexRow s + 1, lexColumn = 1, lexInput = r} + Nothing + | "--" `T.isPrefixOf` T.dropWhile isSpaceTab (lexInput s) -> + let (sp, afterSp) = T.span isSpaceTab (lexInput s) + (comment, r) = T.span isCommentChar afterSp + in lexToken s {lexColumn = lexColumn s + T.length sp + widthOf comment, lexInput = r} + | otherwise -> k ws rest + indentation ws rest next + | T.null rest = (Position row col, EOF, stream st) + | otherwise = + let n = T.length ws + in token col (Indent n) (LexState row (col + n) rest next) + fieldLine allowed = case T.uncons input of + Nothing -> token col EOF st + Just (c, _) + | isSpaceTab c -> let (ws, r) = T.span isSpaceTab input in lexToken st {lexColumn = col + T.length ws, lexInput = r} + | Just r <- newline input -> + lexToken (LexState (row + 1) 1 r (if mode == InFieldLayout then BolFieldLayout else BolFieldBraces)) + | isPrintable c && allowed c -> + let (line, r) = T.span (\x -> (isPrintable x || x == '\t') && allowed x) input + in token col (TokFieldLine line) st {lexColumn = col + widthOf line, lexInput = r} + | otherwise -> token col LexicalError st {lexInput = ""} + +-- | The contents of a string token without its quotes. Escapes stay in the text. +-- The lexer uses the longest match: a quotation mark after a backslash can end +-- the string or continue it. +stringToken :: Text -> Maybe (Text, Text) +stringToken t = (\n -> (T.take n t, T.drop (n + 1) t)) <$> go Nothing ' ' 0 (T.unpack t) + where + go :: Maybe Int -> Char -> Int -> String -> Maybe Int + go end _ _ [] = end + go end previous !n (c : cs) + | c == '"' = if previous == '\\' then go (Just n) c (n + 1) cs else Just n + | isPrintable c = go end c (n + 1) cs + | otherwise = end + +type Parse a = Stream -> Either Diagnostic (a, Stream) + +parseError :: Position -> Token -> Either Diagnostic a +parseError p t = Left (Diagnostic (Just p) ("Unexpected " <> describe t)) + where + describe x = case x of + TokSym s -> "symbol " <> T.pack (show s) + TokStr s -> "string " <> T.pack (show s) + TokOther s -> "operator " <> T.pack (show s) + Indent _ -> "new line" + TokFieldLine _ -> "field content" + Colon -> "\":\"" + OpenBrace -> "\"{\"" + CloseBrace -> "\"}\"" + EOF -> "end of file" + LexicalError -> "character in input" + +lowerName :: Text -> Text +lowerName = T.map (\c -> if isAsciiUpper c then toLower c else c) + +-- | Read the fields and sections of a file. The input has no byte order mark. +readFields :: Text -> Either Diagnostic [Field] +readFields input = do + (fields, s) <- elements 0 (stream (LexState 1 1 input BolSection)) + case peek s of + (_, EOF) -> Right fields + (p, t) -> parseError p t + +elements :: Int -> Parse [Field] +elements level = go [] + where + go acc s = case peek s of + (_, Indent j) | j >= level -> do + let s1 = advance s + case peek s1 of + (p, TokSym n) -> do + (f, s2) <- layoutElement (j + 1) p (lowerName n) (advance s1) + go (f : acc) s2 + (p, t) -> parseError p t + (p, TokSym n) -> do + (f, s1) <- bracesElement p (lowerName n) (advance s) + go (f : acc) s1 + _ -> Right (reverse acc, s) + +sectionArgs :: Stream -> ([SectionArg], Stream) +sectionArgs = go [] + where + go acc s = case peek s of + (p, TokSym x) -> go (ArgName p x : acc) (advance s) + (p, TokStr x) -> go (ArgString p x : acc) (advance s) + (p, TokOther x) -> go (ArgOther p x : acc) (advance s) + _ -> (reverse acc, s) + +layoutElement :: Int -> Position -> Text -> Parse Field +layoutElement level p n s = case peek s of + (_, Colon) -> fieldLayoutOrBraces level p n (advance s) + _ -> do + let (args, s1) = sectionArgs s + case peek s1 of + (_, OpenBrace) -> do + (fields, s2) <- bracesBody (advance s1) + Right (Section p n args fields, s2) + _ -> do + (fields, s2) <- elements level s1 + Right (Section p n args fields, s2) + +bracesElement :: Position -> Text -> Parse Field +bracesElement p n s = case peek s of + (_, Colon) -> do + let s1 = advance s + case peek s1 of + (_, OpenBrace) -> fieldBraces p n (advance s1) + _ -> do + let s2 = setMode InFieldBraces s1 + case peek s2 of + (q, TokFieldLine l) -> Right (Field p n [FieldLine q l], setMode InSection (advance s2)) + _ -> Right (Field p n [], setMode InSection s2) + _ -> do + let (args, s1) = sectionArgs s + case peek s1 of + (_, OpenBrace) -> do + (fields, s2) <- bracesBody (advance s1) + Right (Section p n args fields, s2) + (q, t) -> parseError q t + +bracesBody :: Parse [Field] +bracesBody s = do + (fields, s1) <- elements 0 s + let s2 = case peek s1 of + (_, Indent _) -> advance s1 + _ -> s1 + case peek s2 of + (_, CloseBrace) -> Right (fields, advance s2) + (q, t) -> parseError q t + +fieldLayoutOrBraces :: Int -> Position -> Text -> Parse Field +fieldLayoutOrBraces level p n s = case peek s of + (_, OpenBrace) -> fieldBraces p n (advance s) + _ -> do + let s1 = setMode InFieldLayout s + (first, s2) = case peek s1 of + (q, TokFieldLine l) -> ([FieldLine q l], advance s1) + _ -> ([], s1) + rest acc st = case peek st of + (_, Indent j) | j >= level -> case peek (advance st) of + (q, TokFieldLine l) -> rest (FieldLine q l : acc) (advance (advance st)) + (q, t) -> parseError q t + _ -> Right (reverse acc, st) + (more, s3) <- rest [] s2 + Right (Field p n (first ++ more), setMode InSection s3) + +fieldBraces :: Position -> Text -> Parse Field +fieldBraces p n s = do + let go acc st = case peek st of + (q, TokFieldLine l) -> go (FieldLine q l : acc) (advance st) + _ -> (reverse acc, setMode InSection st) + (ls, s1) = go [] (setMode InFieldBraces s) + case peek s1 of + (_, CloseBrace) -> Right (Field p n ls, advance s1) + (q, t) -> parseError q t diff --git a/src/Aihc/Cabal/Internal/Parser.hs b/src/Aihc/Cabal/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal/Internal/Parser.hs @@ -0,0 +1,551 @@ +{-# LANGUAGE BangPatterns #-} +{-# 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 + +import Control.Monad (foldM, guard, unless, when) +import Data.Bits (shiftL, (.&.), (.|.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (isAlphaNum) +import Data.List (find, partition) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Text.Megaparsec (eof, runParser, takeWhile1P, (<|>)) +import Text.Megaparsec.Char (space) +import Aihc.Cabal.Internal.Condition (parseCondition) +import Aihc.Cabal.Internal.Lexer (Field (..), SectionArg (..), readFields) +import Aihc.Cabal.Internal.Quirks (patchQuirks) +import Aihc.Cabal.Internal.Types +import Aihc.Cabal.Internal.Values +import Aihc.Cabal.Internal.Version + +type Result a = Either Diagnostic a + +type Fields = Map Text [FieldValue] + +-- | A section inside a list of fields: position, name, arguments, and contents. +data SectionInfo = SectionInfo Position Text [SectionArg] [Field] + +failAt :: Position -> Text -> Result a +failAt p = Left . Diagnostic (Just p) + +-- | An error of a check on the complete package. It has no position. +failPackage :: Text -> Result a +failPackage = Left . Diagnostic Nothing + +report :: Result a -> ParseResult a +report = ParseResult [] + +-- | Decode UTF-8 text. For invalid input, use the Cabal-syntax decoder: it +-- replaces each invalid sequence with U+FFFD and continues. +decode :: BS.ByteString -> Text +decode bytes = either (const (T.pack (lenient (BS.unpack bytes)))) id (TE.decodeUtf8' bytes) + where + lenient [] = [] + lenient (c : cs) + | c <= 0x7f = toEnum (fromIntegral c) : lenient cs + | c <= 0xbf = replacement : lenient cs + | c <= 0xdf = case cs of + c1 : rest | c1 .&. 0xc0 == 0x80 -> + let d = (fromIntegral (c .&. 0x1f) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3f) + in (if d >= 0x80 then toEnum d else replacement) : lenient rest + _ -> replacement : lenient cs + | c <= 0xef = more (3 :: Int) 0x800 cs (fromIntegral (c .&. 0xf)) + | c <= 0xf7 = more 4 0x10000 cs (fromIntegral (c .&. 0x7)) + | c <= 0xfb = more 5 0x200000 cs (fromIntegral (c .&. 0x3)) + | c <= 0xfd = more 6 0x4000000 cs (fromIntegral (c .&. 0x1)) + | otherwise = replacement : lenient cs + more 1 overlong cs acc + | overlong <= acc && acc <= 0x10ffff && (acc < 0xd800 || 0xdfff < acc) = toEnum acc : lenient cs + | otherwise = replacement : lenient cs + more n overlong (c : cs) acc + | c .&. 0xc0 == 0x80 = more (n - 1) overlong cs ((acc `shiftL` 6) .|. fromIntegral (c .&. 0x3f)) + more _ _ cs _ = replacement : lenient cs + replacement = '\xfffd' + +readInput :: BS.ByteString -> Result [Field] +readInput bytes = readFields (fromMaybe text (T.stripPrefix "\xfeff" text)) + where text = decode bytes + +parseField :: Parser a -> FieldValue -> Result a +parseField p fv = either (failAt (fieldPosition fv)) Right (runValue p (fieldText fv)) + +-- | A singular field. The last value wins. As in Cabal-syntax, the first of +-- several values is not parsed. +singular :: (FieldValue -> Result a) -> [FieldValue] -> Result (Maybe a) +singular _ [] = Right Nothing +singular f [x] = Just <$> f x +singular f (_ : xs) = Just . last <$> mapM f xs + +-- | A singular field that has no value when its text is empty. +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 + +monoidal :: Parser [a] -> [FieldValue] -> Result [a] +monoidal p = fmap concat . mapM (parseField p) + +takeFields :: [Field] -> (Fields, [Field]) +takeFields fields = (collect [(n, FieldValue p ls) | Field p n ls <- leading], rest) + where (leading, rest) = span isField fields + +isField :: Field -> Bool +isField Field {} = True +isField Section {} = False + +collect :: [(Text, FieldValue)] -> Fields +collect xs = Map.fromListWith (flip (++)) [(k, [v]) | (k, v) <- xs] + +-- | Separate fields from sections. Consecutive sections form one group. +partitionFields :: [Field] -> (Fields, [[SectionInfo]]) +partitionFields fields = (collect [(n, FieldValue p ls) | Field p n ls <- fields], groups fields) + where + groups xs = case dropWhile isField xs of + [] -> [] + ys -> let (ss, rest) = break isField ys + in [SectionInfo p n a b | Section p n a b <- ss] : groups rest + +-- | Fields of a section that cannot contain sections. +plainFields :: [Field] -> Result Fields +plainFields body = case sections of + SectionInfo p n _ _ : _ -> failAt p ("invalid subsection " <> T.pack (show n)) + [] -> Right fs + where (fs, sections) = fmap concat (partitionFields body) + +-- | The Cabal specification version for version digits, or 'Nothing' for an +-- unknown version. +knownSpec :: NonEmpty Integer -> Maybe Version +knownSpec ds = case NE.toList ds of + v | v `elem` [[3, 18], [3, 16], [3, 14], [3, 12], [3, 8], [3, 6], [3, 4], [3, 0], [2, 4], [2, 2], [2, 0]] -> Just (specVersion v) + | v >= [1, 25] -> Nothing + | otherwise -> specVersion . snd <$> find ((v >=) . fst) older + where + older = + [ ([1, 23], [1, 24]), ([1, 21], [1, 22]), ([1, 19], [1, 20]), ([1, 17], [1, 18]) + , ([1, 11], [1, 12]), ([1, 9], [1, 10]), ([1, 7], [1, 8]), ([1, 5], [1, 6]) + , ([1, 3], [1, 4]), ([1, 1], [1, 2]), ([], [1, 0]) ] + +-- | The value of a @cabal-version@ field: a version or a range. +specVersionParser :: Version -> Parser Version +specVersionParser spec = do + v <- versionParser <|> range + maybe (fail ("Unknown cabal spec version specified: " ++ T.unpack (renderVersion v))) pure (knownSpec (versionNumbers v)) + where + range = do + v <- lowestVersion <$> rangeParser spec + when (v >= specVersion [2, 1]) (fail "cabal-version higher than 2.2 cannot be specified as a range") + pure v + +-- | The smallest lower bound of a range. An empty range gives version 0. +lowestVersion :: VersionRange -> Version +lowestVersion range = case [v | ((v, _), _) <- intervals range] of + [] -> zero + vs -> minimum vs + where + zero = specVersion [0] + intervals r = case r of + AnyVersion -> [((zero, True), Nothing)] + Equal v -> [((v, True), Just (v, True))] + Later v -> [((v, False), Nothing)] + AtLeast v -> [((v, True), Nothing)] + Earlier v -> nonEmpty ((zero, True), Just (v, False)) + AtMost v -> [((zero, True), Just (v, True))] + MajorBound v -> intervals (Both (AtLeast v) (Earlier (majorUpper v))) + Both a b -> concat [nonEmpty (maxLower l1 l2, minUpper u1 u2) | (l1, u1) <- intervals a, (l2, u2) <- intervals b] + EitherRange a b -> intervals a ++ intervals b + nonEmpty i@((l, li), u) = case u of + Nothing -> [i] + Just (h, hi) | l < h || (l == h && li && hi) -> [i] + | otherwise -> [] + maxLower a@(v, i) b@(w, j) + | v /= w = if v > w then a else b + | otherwise = (v, i && j) + minUpper Nothing u = u + minUpper u Nothing = u + minUpper (Just a@(v, i)) (Just b@(w, j)) + | v /= w = Just (if v < w then a else b) + | otherwise = Just (v, i && j) + majorUpper v = case NE.toList (versionNumbers v) of + [x] -> specVersion [x, 1] + x : y : _ -> specVersion [x, y + 1] + [] -> zero + +-- | Read the version on the first line, as in @cabal-version: 3.0@. +scanSpecVersion :: BS.ByteString -> Maybe Version +scanSpecVersion bytes = do + line : _ <- Just (BS8.lines bytes) + let normalized = BS.map lower (BS.filter (/= 0x20) line) + [key, text] <- Just (BS8.split ':' normalized) + guard (key == "cabal-version") + v <- either (const Nothing) Just (runParser (versionParser <* space <* eof) "" (decode text)) + guard (length (versionNumbers v) `elem` [2, 3]) + pure v + where + lower w = if w > 0x40 && w < 0x5b then w + 0x20 else w + +-- | Change a file without sections to the section format. +sectionize :: [Field] -> [Field] +sectionize fields + | not (all isField fields) = fields + | otherwise = header ++ library ++ executables exes0 + where + name (Field _ n _) = n + name (Section _ n _ _) = n + (header0, exes0) = break ((== "executable") . name) fields + (header, libraryFields0) = partition ((`notElem` libraryFieldNames) . name) header0 + (deps, libraryFields) = partition ((== "build-depends") . name) libraryFields0 + library = case libraryFields of + [] -> [] + f : _ -> [Section (fieldPos f) "library" [] (deps ++ libraryFields)] + executables (Field p "executable" ls : rest) = + let (body, after) = break ((== "executable") . name) rest + exeName = T.dropWhile (== ' ') (T.dropWhileEnd (== ' ') (T.intercalate "\n" (map fieldLineText ls))) + in Section p "executable" [ArgName p exeName] (deps ++ body) : executables after + executables _ = [] + fieldPos (Field p _ _) = p + fieldPos (Section p _ _ _) = p + +-- | Fields of the build information grammar of Cabal-syntax. +buildInfoFieldNames :: [Text] +buildInfoFieldNames = + [ "buildable", "build-tools", "build-tool-depends", "cpp-options", "asm-options", "cmm-options" + , "cc-options", "cxx-options", "ld-options", "hsc2hs-options", "pkgconfig-depends", "frameworks" + , "extra-framework-dirs", "asm-sources", "cmm-sources", "c-sources", "cxx-sources", "js-sources" + , "hs-source-dirs", "hs-source-dir", "other-modules", "virtual-modules", "autogen-modules" + , "default-language", "other-languages", "default-extensions", "other-extensions", "extensions" + , "extra-libraries", "extra-libraries-static", "extra-ghci-libraries", "extra-bundled-libraries" + , "extra-library-flavours", "extra-dynamic-library-flavours", "extra-lib-dirs" + , "extra-lib-dirs-static", "include-dirs", "includes", "autogen-includes", "install-includes" + , "ghc-options", "ghcjs-options", "jhc-options", "hugs-options", "nhc98-options" + , "ghc-prof-options", "ghcjs-prof-options", "ghc-shared-options", "ghcjs-shared-options" + , "build-depends", "mixins" ] + +libraryFieldNames :: [Text] +libraryFieldNames = ["exposed-modules", "reexported-modules", "signatures", "exposed"] ++ buildInfoFieldNames + +data Kind = CommonKind | LibraryKind | ExecutableKind | TestKind | BenchmarkKind | ForeignKind + deriving Eq + +type Commons = Map Text (Conditional BuildInfo) + +mergeTree :: Conditional BuildInfo -> Conditional BuildInfo -> Conditional BuildInfo +mergeTree (Conditional a bs) (Conditional b cs) = Conditional (mergeBuildInfo a b) (bs ++ cs) + +isImport :: Field -> Bool +isImport (Field _ "import" _) = True +isImport _ = False + +-- | Read the imports at the start of a list of fields. Cabal-syntax ignores +-- the other imports with a warning. +imports :: Version -> Commons -> [Field] -> Result ([Conditional BuildInfo], [Field]) +imports spec commons + | specAtLeast [2, 2] spec = go [] + | otherwise = \fields -> Right ([], filter (not . isImport) fields) + where + go acc (Field p "import" ls : rest) = do + names <- parseField (commaList spec token) (FieldValue p ls) + trees <- mapM (\n -> maybe (failAt p ("Undefined common stanza imported: " <> n)) Right (Map.lookup n commons)) names + go (acc ++ trees) rest + go acc rest = Right (acc, filter (not . isImport) rest) + +stanza :: Version -> Kind -> Commons -> [Field] -> Result (Conditional BuildInfo) +stanza spec kind commons fields = do + (imported, rest) <- imports spec commons fields + tree <- condTree spec kind commons rest + pure (foldr mergeTree tree imported) + +condTree :: Version -> Kind -> Commons -> [Field] -> Result (Conditional BuildInfo) +condTree spec kind commons fields0 = do + (imported, fields) <- if specAtLeast [3, 0] spec + then imports spec commons fields0 + else Right ([], filter (not . isImport) fields0) + let (fs, groups) = partitionFields fields + info <- buildInfoFields spec kind fs + branches' <- concat <$> mapM ifs groups + pure (foldr mergeTree (Conditional info branches') imported) + where + subtree = condTree spec kind commons + ifs [] = Right [] + ifs (SectionInfo p "if" args body : rest) = do + c <- conditionAt p args + yes <- subtree body + (no, rest') <- elses rest + pure (Branch c yes no : rest') + ifs (_ : rest) = ifs rest + elses (SectionInfo p "else" args body : rest) = do + unless (null args) (failAt p "`else` section has section arguments") + no <- subtree body + rest' <- ifs rest + pure (Just no, rest') + elses (SectionInfo p "elif" args body : rest) + | specAtLeast [2, 2] spec = do + c <- conditionAt p args + yes <- subtree body + (no, rest') <- elses rest + pure (Just (Conditional emptyBuildInfo [Branch c yes no]), rest') + | otherwise = (,) Nothing <$> ifs rest + elses rest = (,) Nothing <$> ifs rest + conditionAt p args = maybe (failAt p "Invalid condition") Right (parseCondition args) + +-- | Parse the fields of one section level. Fields that the Cabal +-- specification version does not support are ignored. +buildInfoFields :: Version -> Kind -> Fields -> Result BuildInfo +buildInfoFields spec kind fs = do + mapM_ removed [([3, 0], "hs-source-dir"), ([3, 0], "extensions"), ([3, 0], "build-tools")] + buildable' <- singular (parseField bool) (get "buildable") + dirs <- monoidal (spaceList spec filePath) (get "hs-source-dirs") + oldDirs <- monoidal (spaceList spec filePath) (get "hs-source-dir") + exposed <- if kind == LibraryKind then modules (get "exposed-modules") else pure [] + other <- modules (get "other-modules") + autogen <- modules (since [2, 0] "autogen-modules") + virtual <- modules (since [2, 2] "virtual-modules") + main <- if kind `elem` [ExecutableKind, TestKind, BenchmarkKind] + then optionalField filePath (get "main-is") else pure Nothing + language <- optionalField (quoted languageName) (since [1, 10] "default-language") + otherLanguages' <- names (since [1, 10] "other-languages") + extensions' <- names (since [1, 10] "default-extensions") + otherExtensions' <- names (get "other-extensions") + legacy <- names (get "extensions") + deps <- monoidal (commaList spec (dependency spec)) (get "build-depends") + mixins' <- monoidal (commaList spec (mixin spec)) (since [2, 0] "mixins") + legacyTools <- monoidal (commaList spec (legacyExeDependency spec)) (get "build-tools") + tools <- monoidal (commaList spec (exeDependency spec)) (get "build-tool-depends") + cs <- paths (get "c-sources") + cxx <- paths (since [2, 2] "cxx-sources") + asm <- paths (since [3, 0] "asm-sources") + cmm <- paths (since [3, 0] "cmm-sources") + js <- paths (get "js-sources") + includeDirs' <- paths (get "include-dirs") + includes' <- paths (get "includes") + installIncludes' <- paths (get "install-includes") + autogenIncludes' <- paths (since [3, 0] "autogen-includes") + libDirs <- paths (get "extra-lib-dirs") + staticLibDirs <- paths (since [3, 8] "extra-lib-dirs-static") + frameworks' <- monoidal (spaceList spec token) (get "frameworks") + frameworkDirs <- paths (get "extra-framework-dirs") + cpp <- options (get "cpp-options") + cc <- options (get "cc-options") + cxxOpts <- options (since [2, 2] "cxx-options") + ghc <- options (get "ghc-options") + -- Evaluate the other fields now. Then the parsed field lines are not kept. + let !rest = Map.filterWithKey keep fs + pure BuildInfo + { buildable = buildable', sourceDirs = map T.unpack (dirs ++ oldDirs), exposedModules = exposed + , otherModules = other, autogenModules = autogen, virtualModules = virtual + , mainIs = T.unpack <$> main, defaultLanguage = language, otherLanguages = otherLanguages' + , extensions = extensions', otherExtensions = otherExtensions', legacyExtensions = legacy + , dependencies = deps, mixins = mixins', buildTools = legacyTools ++ tools, cSources = map T.unpack cs + , cxxSources = map T.unpack cxx, asmSources = map T.unpack asm, cmmSources = map T.unpack cmm + , jsSources = map T.unpack js, includeDirs = map T.unpack includeDirs' + , includes = map T.unpack includes', installIncludes = map T.unpack installIncludes' + , autogenIncludes = map T.unpack autogenIncludes', extraLibDirs = map T.unpack libDirs + , extraLibDirsStatic = map T.unpack staticLibDirs, frameworks = frameworks' + , extraFrameworkDirs = map T.unpack frameworkDirs, cppOptions = cpp, ccOptions = cc + , cxxOptions = cxxOpts, ghcOptions = ghc, extraFields = rest + } + where + get k = Map.findWithDefault [] k fs + since v k = if specAtLeast v spec then get k else [] + removed (v, k) = case get k of + fv : _ | specAtLeast v spec -> + failAt (fieldPosition fv) ("The field " <> k <> " is removed in cabal-version " <> renderVersion (specVersion v)) + _ -> Right () + modules = monoidal (spaceList spec (quoted moduleName)) + names = monoidal (spaceList spec (quoted languageName)) + paths = monoidal (spaceList spec filePath) + options = monoidal (optionList token') + typed = typedFields ++ ["exposed-modules" | kind == LibraryKind] + ++ ["main-is" | kind `elem` [ExecutableKind, TestKind, BenchmarkKind]] + keep k _ + | k `elem` typed = False + | kind == CommonKind = k `elem` buildInfoFieldNames || "x-" `T.isPrefixOf` k + | otherwise = True + +typedFields :: [Text] +typedFields = + [ "buildable", "hs-source-dirs", "hs-source-dir", "other-modules", "autogen-modules" + , "virtual-modules", "default-language", "other-languages", "default-extensions" + , "other-extensions", "extensions", "build-depends", "mixins", "build-tools", "build-tool-depends" + , "c-sources", "cxx-sources", "asm-sources", "cmm-sources", "js-sources", "include-dirs" + , "includes", "install-includes", "autogen-includes", "extra-lib-dirs", "extra-lib-dirs-static" + , "frameworks", "extra-framework-dirs", "cpp-options", "cc-options", "cxx-options", "ghc-options" ] + +-- | The name argument of a component, common stanza, or flag section. +sectionName :: Position -> [SectionArg] -> Result Text +sectionName p args = case args of + [ArgName _ x] -> Right x + [ArgString _ x] -> Right x + [] -> failAt p "name required" + _ -> failAt p "Invalid name" + +data State = State + { stateCommons :: Commons + , stateFlags :: [Flag] + , stateComponents :: [Component (Conditional BuildInfo)] + , stateRepositories :: [SourceRepository] + , stateSetup :: Maybe [Dependency] + } + +-- | Parse a package description. First apply the Cabal-syntax patches for +-- known Hackage files. A patched file gets a warning, as in Cabal-syntax. +parsePackage :: BS.ByteString -> ParseResult Package +parsePackage input = case patchQuirks input of + (patched, bytes) -> (report (parsePatched bytes)) + { parseWarnings = [Diagnostic Nothing "Legacy cabal file" | patched] } + +parsePatched :: BS.ByteString -> Result Package +parsePatched bytes = do + fields0 <- readInput bytes + let (top, sections) = takeFields (sectionize fields0) + get k = Map.findWithDefault [] k top + spec <- case scanSpecVersion bytes of + Just v -> maybe (failPackage "Unsupported cabal format version") Right (knownSpec (versionNumbers v)) + Nothing -> case get "cabal-version" of + [] -> Right (specVersion [1, 0]) + values -> do + v <- parseField (specVersionParser (specVersion [1, 24])) (last values) + when (v >= specVersion [2, 2]) (failAt (fieldPosition (last values)) + "cabal-version should be at the beginning of the file starting with spec version 2.2") + pure v + parsedSpec <- optionalField (specVersionParser spec) (get "cabal-version") + unless (fromMaybe (specVersion [1, 0]) parsedSpec == spec) + (failPackage "Scanned and parsed cabal-versions don't match") + pkg <- required "name" componentName top + version <- required "version" versionParser top + rawBuildType <- optionalField (buildTypeValue spec) (get "build-type") + State _ flags components repositories setup <- foldM (section spec) (State Map.empty [] [] [] Nothing) sections + let bt = fromMaybe (if specAtLeast [2, 2] spec && not (isJust setup) then "Simple" else "Custom") rawBuildType + knownFlags = map flagName flags + when (bt == "Custom" && not (isJust setup) && specAtLeast [1, 24] spec) + (failPackage "Since cabal-version: 1.24 specifying custom-setup section is mandatory") + when (bt == "Hooks" && not (isJust setup)) + (failPackage "Packages with build-type: Hooks require a custom-setup stanza") + mapM_ (checkFlags knownFlags . componentData) components + let libraries = [x | not (specAtLeast [3, 4] spec), Component (Library (NamedLibrary x)) _ <- components] + internal = internalDependencies pkg libraries + internalMixin m + | mixinPackage m `elem` libraries, mixinLibrary m == MainLibrary = + m {mixinPackage = pkg, mixinLibrary = if mixinPackage m == pkg then MainLibrary else NamedLibrary (mixinPackage m)} + | otherwise = m + pure Package + { packageName = pkg, packageVersion = version, cabalVersion = spec, buildType = bt + , packageFlags = flags + , packageComponents = + [ Component k (mapTree (\bi -> bi {dependencies = internal (dependencies bi), mixins = map internalMixin (mixins bi)}) t) + | Component k t <- components ] + , packageFields = top, packageSourceRepositories = repositories + , packageSetupDependencies = internal <$> setup + } + +required :: Text -> Parser a -> Fields -> Result a +required key p fields = do + value <- singular (parseField p) (Map.findWithDefault [] key fields) + maybe (failPackage (T.pack (show key) <> " field missing")) Right value + +section :: Version -> State -> Field -> Result State +section _ st Field {} = Right st +section spec st (Section p name args body) = case name of + "common" + | not (specAtLeast [2, 2] spec) -> Right st + | otherwise -> do + key <- sectionName p args + tree <- stanza spec CommonKind commons body + when (Map.member key commons) (failAt p ("Duplicate common stanza: " <> key)) + Right st {stateCommons = Map.insert key tree commons} + "library" + | null args -> do + when (any isMainLibrary (stateComponents st)) + (failAt p "Multiple main libraries; have you forgotten to specify a name for an internal library?") + component (Library MainLibrary) LibraryKind + | otherwise -> sectionName p args >>= \n -> component (Library (NamedLibrary n)) LibraryKind + "foreign-library" -> sectionName p args >>= \n -> component (ForeignLibrary n) ForeignKind + "executable" -> sectionName p args >>= \n -> component (Executable n) ExecutableKind + "test-suite" -> sectionName p args >>= \n -> component (TestSuite n) TestKind + "benchmark" -> sectionName p args >>= \n -> component (Benchmark n) BenchmarkKind + "flag" -> do + n <- sectionName p args + key <- either (failAt p) Right (runValue flagNameValue n) + fields <- plainFields body + let get k = Map.findWithDefault [] k fields + def <- singular (parseField bool) (get "default") + manual <- singular (parseField bool) (get "manual") + let description = maybe "" (freeText spec . last) (nonEmpty (get "description")) + Right st {stateFlags = stateFlags st ++ [Flag key (fromMaybe True def) (fromMaybe False manual) description]} + "custom-setup" | null args -> do + fields <- plainFields body + deps <- monoidal (commaList spec (dependency spec)) (Map.findWithDefault [] "setup-depends" fields) + Right st {stateSetup = Just deps} + "source-repository" -> case args of + [ArgName q kind] -> do + kind' <- either (failAt q) Right (runValue (takeWhile1P Nothing (\c -> isAlphaNum c || c == '_' || c == '-')) kind) + fields <- plainFields body + Right st {stateRepositories = stateRepositories st ++ [SourceRepository kind' fields]} + [] -> failAt p "'source-repository' requires exactly one argument" + _ -> failAt p "Invalid source-repository kind" + _ -> Right st + where + commons = stateCommons st + component kind grammar = do + tree <- stanza spec grammar commons body + Right st {stateComponents = stateComponents st ++ [Component kind tree]} + isMainLibrary (Component (Library MainLibrary) _) = True + isMainLibrary _ = False + nonEmpty [] = Nothing + nonEmpty xs = Just xs + +mapTree :: (BuildInfo -> BuildInfo) -> Conditional BuildInfo -> Conditional BuildInfo +mapTree f (Conditional bi bs) = Conditional (f bi) [Branch c (mapTree f t) (mapTree f <$> e) | Branch c t e <- bs] + +-- | Before cabal-version 3.4, the name of an internal library refers to that +-- library of the same package. If the dependency also names other libraries, +-- Cabal-syntax 3.12 keeps the original dependency after the new one. +internalDependencies :: Text -> [Text] -> [Dependency] -> [Dependency] +internalDependencies pkg libraries = concatMap change + where + change d@(Dependency name range libs) + | name `elem` libraries, MainLibrary `elem` libs = + Dependency pkg range (NamedLibrary name :| []) : [d | any (/= MainLibrary) libs] + | otherwise = [d] + +checkFlags :: [Text] -> Conditional BuildInfo -> Result () +checkFlags known tree = mapM_ check (branches tree) + where + check (Branch c t e) = checkCondition c *> checkFlags known t *> mapM_ (checkFlags known) e + checkCondition c = case c of + FlagValue f | f `notElem` known -> failPackage ("These flags are used without having been defined: " <> f) + Not a -> checkCondition a + And a b -> checkCondition a *> checkCondition b + Or a b -> checkCondition a *> checkCondition b + _ -> Right () + +-- | Read a @.buildinfo@ file, as Cabal-syntax reads hooked build information. +parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo +parseHookedBuildInfo bytes = report $ do + fields <- readInput bytes + let (header, rest) = break isExecutable fields + libraryFields <- plainFields header + lib <- if Map.null libraryFields then pure Nothing else Just <$> buildInfoFields latestSpec CommonKind libraryFields + exes <- groups rest + ensureUnique (map fst exes) + pure (HookedBuildInfo lib (Map.fromList exes)) + where + isExecutable (Field _ "executable" _) = True + isExecutable _ = False + groups (Field p "executable" ls : rest) = do + exe <- parseField componentName (FieldValue p ls) + let (body, after) = break isExecutable rest + fs <- plainFields body + bi <- buildInfoFields latestSpec CommonKind fs + ((exe, bi) :) <$> groups after + groups _ = Right [] + ensureUnique names = case [n | (i, n) <- zip [0 :: Int ..] names, n `elem` take i names] of + n : _ -> failPackage ("Duplicate executable: " <> n) + [] -> Right () diff --git a/src/Aihc/Cabal/Internal/Quirks.hs b/src/Aihc/Cabal/Internal/Quirks.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal/Internal/Quirks.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Patches for known Hackage files. Cabal-syntax applies the same patches +-- before it parses a file. The data comes from +-- @Distribution.PackageDescription.Quirks@ in Cabal-syntax 3.18.1.0. +module Aihc.Cabal.Internal.Quirks (patchQuirks) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BSU +import qualified Data.Map.Strict as Map +import Foreign.Ptr (castPtr) +import GHC.Fingerprint (Fingerprint (..), fingerprintData) +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- | A change to the file bytes. Each change applies to the first match only. +data Edit + = Replace BS.ByteString BS.ByteString + -- ^ Replace the first match. If there is no match, keep the bytes. + | Remove BS.ByteString + -- ^ Remove the first match. + | RemoveFrom BS.ByteString + -- ^ Remove the first match and all bytes after it. + +-- | Patch the bytes of a known file. 'True' shows that the bytes changed. +-- A patch applies only if the MD5 hash of the input and the MD5 hash of the +-- result are the expected values. +patchQuirks :: BS.ByteString -> (Bool, BS.ByteString) +patchQuirks bytes = case Map.lookup (md5 bytes) patches of + Just (expected, edits) + | md5 output == expected -> (True, output) + where output = foldl (flip edit) bytes edits + _ -> (False, bytes) + +edit :: Edit -> BS.ByteString -> BS.ByteString +edit change bytes = case change of + Replace needle new + | BS.null after -> bytes + | otherwise -> BS.concat [before, new, BS.drop (BS.length needle) after] + where (before, after) = BS.breakSubstring needle bytes + Remove needle -> case BS.breakSubstring needle bytes of + (before, after) -> before <> BS.drop (BS.length needle) after + RemoveFrom needle -> fst (BS.breakSubstring needle bytes) + +md5 :: BS.ByteString -> Fingerprint +md5 bytes = unsafeDupablePerformIO $ BSU.unsafeUseAsCStringLen bytes $ \(ptr, size) -> + fingerprintData (castPtr ptr) size + +entry :: Fingerprint -> Fingerprint -> [Edit] -> (Fingerprint, (Fingerprint, [Edit])) +entry input output edits = (input, (output, edits)) + +-- | Each entry has the input hash, the result hash, and the changes in order. +patches :: Map.Map Fingerprint (Fingerprint, [Edit]) +patches = Map.fromList + [ -- unicode-transforms 0.3.3 + entry (Fingerprint 15958160436627155571 10318709190730872881) (Fingerprint 11008465475756725834 13815629925116264363) + [Remove " other-modules:\n .\n"] + , -- DSTM 0.1.2 + entry (Fingerprint 6919263071548559054 9050746360708965827) (Fingerprint 17015177514298962556 11943164891661867280) + [Replace "Other modules:" "-- "] + , -- DSTM 0.1.1 + entry (Fingerprint 17313105789069667153 9610429408495338584) (Fingerprint 17250946493484671738 17629939328766863497) + [Replace "Other modules:" "-- "] + , -- DSTM 0.1 + entry (Fingerprint 10502599650530614586 16424112934471063115) (Fingerprint 13562014713536696107 17899511905611879358) + [Replace "Other modules:" "-- "] + , -- control-monad-exception-mtl 0.10.3 + entry (Fingerprint 18274748422558568404 4043538769550834851) (Fingerprint 11395257416101232635 4303318131190196308) + [Replace " default- extensions:" "unknown-section"] + , -- vacuum-opengl 0.0 + entry (Fingerprint 5946760521961682577 16933361639326309422) (Fingerprint 14034745101467101555 14024175957788447824) + [Remove "\DEL"] + , -- vacuum-opengl 0.0.1 + entry (Fingerprint 10790950110330119503 1309560249972452700) (Fingerprint 1565743557025952928 13645502325715033593) + [Remove "\DEL"] + , -- ixset 1.0.4 + entry (Fingerprint 11886092342440414185 4150518943472101551) (Fingerprint 5731367240051983879 17473925006273577821) + [RemoveFrom "{-"] + , -- ds-kanren 0.2.0.0 + entry (Fingerprint 2804006762382336875 9677726932108735838) (Fingerprint 9830506174094917897 12812107316777006473) + [Replace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"", Replace "Test-Suite test-unify:" "Test-Suite \"test-unify:\""] + , -- ds-kanren 0.2.0.1 + entry (Fingerprint 9130259649220396193 2155671144384738932) (Fingerprint 1847988234352024240 4597789823227580457) + [Replace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"", Replace "Test-Suite test-unify:" "Test-Suite \"test-unify:\""] + , -- metric 0.1.4 + entry (Fingerprint 6150019278861565482 3066802658031228162) (Fingerprint 9124826020564520548 15629704249829132420) + [Replace "test-suite metric-tests:" "test-suite \"metric-tests:\""] + , -- metric 0.2.0 + entry (Fingerprint 4639805967994715694 7859317050376284551) (Fingerprint 5566222290622325231 873197212916959151) + [Replace "test-suite metric-tests:" "test-suite \"metric-tests:\""] + , -- phasechange 0.1 + entry (Fingerprint 10546509771395401582 245508422312751943) (Fingerprint 5169853482576003304 7247091607933993833) + [Replace "impl(ghc >= 7.6):" "erroneous-section", Replace "impl(ghc >= 7.4):" "erroneous-section"] + , -- smartword 0.0.0.5 + entry (Fingerprint 7803544783533485151 10807347873998191750) (Fingerprint 1665635316718752601 16212378357991151549) + [Replace "build depends:" "--"] + , -- shelltestrunner 1.3 + entry (Fingerprint 4403237110790078829 15392625961066653722) (Fingerprint 10218887328390239431 4644205837817510221) + [Replace "other modules:" "--"] + , -- hblas 0.2.0.0 + entry (Fingerprint 8570120150072467041 18315524331351505945) (Fingerprint 10838007242302656005 16026440017674974175) + [Replace "&&!" "&& !"] + , -- hblas 0.3.0.0 + entry (Fingerprint 5262875856214215155 10846626274067555320) (Fingerprint 3022954285783401045 13395975869915955260) + [Replace "&&!" "&& !"] + , -- hblas 0.3.0.1 + entry (Fingerprint 54222628930951453 5526514916844166577) (Fingerprint 1749630806887010665 8607076506606977549) + [Replace "&&!" "&& !"] + , -- hblas 0.3.1.0 + entry (Fingerprint 6817250511240350300 15278852712000783849) (Fingerprint 15757717081429529536 15542551865099640223) + [Replace "&&!" "&& !"] + , -- hblas 0.3.1.1 + entry (Fingerprint 8310050400349211976 201317952074418615) (Fingerprint 10283381191257209624 4231947623042413334) + [Replace "&&!" "&& !"] + , -- hblas 0.3.2.1 + entry (Fingerprint 7010988292906098371 11591884496857936132) (Fingerprint 6158672440010710301 6419743768695725095) + [Replace "&&!" "&& !"] + , -- hblas 0.3.2.1, revision 1 + entry (Fingerprint 2076850805659055833 16615160726215879467) (Fingerprint 10634706281258477722 5285812379517916984) + [Replace "&&!" "&& !"] + , -- hblas 0.3.2.1, revision 2 + entry (Fingerprint 11850020631622781099 11956481969231030830) (Fingerprint 13702868780337762025 13383526367149067158) + [Replace "&&!" "&& !"] + , -- hblas 0.4.0.0 + entry (Fingerprint 13690322768477779172 19704059263540994) (Fingerprint 11189374824645442376 8363528115442591078) + [Replace "&&!" "&& !"] + , -- brainheck 0.1.0.2 + entry (Fingerprint 6910727116443152200 15401634478524888973) (Fingerprint 16551412117098094368 16260377389127603629) + [Replace "flag(llvm-fast)" "False"] + , -- brainheck 0.1.0.2, revision 1 + entry (Fingerprint 14320987921316832277 10031098243571536929) (Fingerprint 7959395602414037224 13279941216182213050) + [Replace "flag(llvm-fast)" "False"] + , -- brainheck 0.1.0.2, revision 2 + entry (Fingerprint 3809078390223299128 10796026010775813741) (Fingerprint 1127231189459220796 12088367524333209349) + [Replace "flag(llvm-fast)" "False"] + , -- brainheck 0.1.0.2, revision 3 + entry (Fingerprint 13860013038089410950 12479824176801390651) (Fingerprint 4687484721703340391 8013395164515771785) + [Replace "flag(llvm-fast)" "False"] + , -- wordchoice 0.1.0.1 + entry (Fingerprint 16215911397419608203 15594928482155652475) (Fingerprint 15120681510314491047 2666192399775157359) + [Replace "flag(llvm-fast)" "False"] + , -- wordchoice 0.1.0.1, revision 1 + entry (Fingerprint 16593139224723441188 4052919014346212001) (Fingerprint 3577381082410411593 11481899387780544641) + [Replace "flag(llvm-fast)" "False"] + , -- wordchoice 0.1.0.2 + entry (Fingerprint 9321301260802539374 1316392715016096607) (Fingerprint 3784628652257760949 12662640594755291035) + [Replace "flag(llvm-fast)" "False"] + , -- wordchoice 0.1.0.2, revision 1 + entry (Fingerprint 2546901804824433337 2059732715322561176) (Fingerprint 8082068680348326500 615008613291421947) + [Replace "flag(llvm-fast)" "False"] + , -- wordchoice 0.1.0.3 + entry (Fingerprint 2282380737467965407 12457554753171662424) (Fingerprint 17324757216926991616 17172911843227482125) + [Replace "flag(llvm-fast)" "False"] + , -- wordchoice 0.1.0.3, revision 1 + entry (Fingerprint 12907988890480595481 11078473638628359710) (Fingerprint 13246185333368731848 4663060731847518614) + [Replace "flag(llvm-fast)" "False"] + , -- hw-prim-bits 0.1.0.0 + entry (Fingerprint 12386777729082870356 17414156731912743711) (Fingerprint 3452290353395041602 14102887112483033720) + [Replace "flag(sse42)" "False"] + , -- hw-prim-bits 0.1.0.1 + entry (Fingerprint 6870520675313101180 14553457351296240636) (Fingerprint 12481021059537696455 14711088786769892762) + [Replace "flag(sse42)" "False"] + , -- Sit 0.2017.2.26 + entry (Fingerprint 8458530898096910998 3228538743646501413) (Fingerprint 14470502514907936793 17514354054641875371) + [Replace "0.2017.02.26" "0.2017.2.26"] + , -- Sit 0.2017.5.1 + entry (Fingerprint 1450130849535097473 11742099607098860444) (Fingerprint 16679762943850814021 4253724355613883542) + [Replace "0.2017.05.01" "0.2017.5.1"] + , -- Sit 0.2017.5.2 + entry (Fingerprint 297248532398492441 17322625167861324800) (Fingerprint 634812045126693280 1755581866539318862) + [Replace "0.2017.05.02" "0.2017.5.2"] + , -- Sit 0.2017.5.2, revision 1 + entry (Fingerprint 3697869560530373941 3942982281026987312) (Fingerprint 14344526114710295386 16386400353475114712) + [Replace "0.2017.5.02" "0.2017.5.2"] + , -- MiniAgda 0.2017.2.18 + entry (Fingerprint 17167128953451088679 4300350537748753465) (Fingerprint 12402236925293025673 7715084875284020606) + [Replace "0.2017.02.18" "0.2017.2.18"] + , -- fast-downward 0.1.0.0 + entry (Fingerprint 11256076039027887363 6867903407496243216) (Fingerprint 12159816716813155434 5278015399212299853) + [Replace "1.2.03.0" "1.2.3.0"] + , -- fast-downward 0.1.0.0, revision 1 + entry (Fingerprint 9216193973149680231 893446343655828508) (Fingerprint 10020169545407746427 1828336750379510675) + [Replace "1.2.03.0" "1.2.3.0"] + , -- fast-downward 0.1.0.1 + entry (Fingerprint 9899886602574848632 5980433644983783334) (Fingerprint 12007469255857289958 8321466548645225439) + [Replace "1.2.03.0" "1.2.3.0"] + , -- fast-downward 0.1.1.0 + entry (Fingerprint 12694656661460787751 1902242956706735615) (Fingerprint 15433152131513403849 2284712791516353264) + [Replace "1.2.03.0" "1.2.3.0"] + , -- SGplus 1.1 + entry (Fingerprint 17735649550442248029 11493772714725351354) (Fingerprint 9565458801063261772 15955773698774721052) + [Replace "1000000000" "100000000"] + , -- control-dotdotdot 0.1.0.1 + entry (Fingerprint 1514257173776509942 7756050823377346485) (Fingerprint 14082092642045505999 18415918653404121035) + [Replace "9223372036854775807" "5"] + , -- data-foldapp 0.1.1.0 + entry (Fingerprint 4511234156311243251 11701153011544112556) (Fingerprint 11820542702491924189 4902231447612406724) + [Replace "9223372036854775807" "999", Replace "9223372036854775807" "999"] + , -- data-list-zigzag 0.1.1.1 + entry (Fingerprint 12475837388692175691 18053834261188158945) (Fingerprint 16279938253437334942 15753349540193002309) + [Replace "9223372036854775807" "999"] + , -- nat 0.1 + entry (Fingerprint 9222512268705577108 13085311382746579495) (Fingerprint 17468921266614378430 13221316288008291892) + [Replace "\xf6" "\xc3\xb6"] + , -- streaming-bracketed 0.1.0.0 + entry (Fingerprint 14670044663153191927 1427497586294143829) (Fingerprint 9233007756654759985 6571998449003682006) + [Replace "cabal-version: 2" "cabal-version: 2.0"] + , -- streaming-bracketed 0.1.0.1 + entry (Fingerprint 7298738862909203815 10141693276062967842) (Fingerprint 1349949738792220441 3593683359695349293) + [Replace "cabal-version: 2" "cabal-version: 2.0"] + , -- zsyntax 0.2.0.0 + entry (Fingerprint 17812331267506881875 3005293725141563863) (Fingerprint 3445957263137759540 12472369104312474458) + [Replace "cabal-version: 2" "cabal-version: 2.0"] + , -- wai-middleware-hmac-client 0.1.0.1 + entry (Fingerprint 3112606538775065787 11984607507024462091) (Fingerprint 6916432989977230500 6621389616675138128) + [Replace "\"\"" "."] + , -- wai-middleware-hmac-client 0.1.0.2 + entry (Fingerprint 12566783342663020458 17562089389615949789) (Fingerprint 15745683452603944938 10556498036622072844) + [Replace "\"\"" "."] + , -- reheat 0.1.4 + entry (Fingerprint 9155400339287317061 14812953666990892802) (Fingerprint 7687053346032173923 15384472501136606592) + [Replace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" ""] + , -- reheat 0.1.5 + entry (Fingerprint 2984391146441073709 11728234882049907993) (Fingerprint 12058479081855347701 14017937756688869826) + [Replace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" ""] + ] diff --git a/src/Aihc/Cabal/Internal/Resolve.hs b/src/Aihc/Cabal/Internal/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal/Internal/Resolve.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Condition evaluation and flag resolution. +module Aihc.Cabal.Internal.Resolve (evaluateCondition, resolvePackage, packageFieldText) where + +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Aihc.Cabal.Internal.Types +import Aihc.Cabal.Internal.Values (freeText) +import Aihc.Cabal.Internal.Version (withinRange) + +-- | 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. +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) + 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 + +-- | Evaluate the conditions of all components and apply defaults. +-- +-- The flag assignment is the given assignment over the flag defaults of the +-- package. A given flag that the package does not declare has no effect. +-- The active parts of each component merge in source order with the +-- 'Semigroup' instance of t'BuildInfo'. Then an absent 'buildable' becomes +-- 'True', and an empty 'sourceDirs' becomes @[\".\"]@. An absent +-- 'defaultLanguage' stays 'Nothing'. +-- +-- The result has all components. The caller selects the components to +-- build. +resolvePackage :: Environment -> FlagAssignment -> Package -> ResolvedPackage +resolvePackage env overrides pkg = ResolvedPackage flags components + where + defaults = Map.fromList [(flagName f, flagDefault f) | f <- packageFlags pkg] + flags = Map.union (Map.intersection overrides defaults) defaults + components = [Component k (finish (resolve t)) | Component k t <- packageComponents pkg] + resolve (Conditional info bs) = mconcat (info : concatMap branch bs) + branch (Branch c t e) + | evaluateCondition env flags c = [resolve t] + | otherwise = maybe [] (pure . resolve) e + finish bi = bi + { buildable = Just (fromMaybe True (buildable bi)) + , sourceDirs = if null (sourceDirs bi) then ["."] else sourceDirs bi + } + +-- | The text of a package field, such as @description@ or @synopsis@, after +-- the Cabal free text rules of the file's format version. If the field +-- occurs more than one time, the last value wins, as in Cabal-syntax. The +-- result is 'Nothing' for an absent field. +-- +-- Before @cabal-version@ 3.0, each line loses its leading and trailing +-- spaces, and a line with one dot becomes an empty line. From +-- @cabal-version@ 3.0, the text keeps blank lines and relative indentation. +packageFieldText :: Package -> Text -> Maybe Text +packageFieldText pkg name = case Map.findWithDefault [] (T.toLower name) (packageFields pkg) of + [] -> Nothing + values -> Just (freeText (cabalVersion pkg) (last values)) diff --git a/src/Aihc/Cabal/Internal/Types.hs b/src/Aihc/Cabal/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal/Internal/Types.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | The data types of the library. "Aihc.Cabal" exports all of them. +-- +-- The types keep the data of a Cabal file as the file gives it. Names, +-- modules, and options are 'Text'. Paths are 'FilePath', because the caller +-- joins them with directories. A scalar field that is absent is 'Nothing'. +-- A list field that is absent is @[]@. Defaults are applied by +-- 'Aihc.Cabal.resolvePackage', not by the parser. +module Aihc.Cabal.Internal.Types where + +import Data.List (nub) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Aihc.Cabal.Internal.Version (Version, VersionRange) + +-- * Positions and diagnostics + +-- | A source position. Rows start at 1. Columns start at 1 and count UTF-8 +-- bytes, as in Cabal-syntax. +data Position = Position + { positionRow :: !Int + , positionColumn :: !Int + } deriving (Eq, Ord, Show) + +-- | An error or a warning from the parser. A check of the complete package +-- has no position. +data Diagnostic = Diagnostic + { diagnosticPosition :: Maybe Position + , diagnosticMessage :: Text + } deriving (Eq, Show) + +-- | 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 +-- file that gets a Cabal-syntax patch. +data ParseResult a = ParseResult + { parseWarnings :: [Diagnostic] + , parseValue :: Either Diagnostic a + } deriving (Eq, Show) + +-- * Field values + +-- | One line of a field value. The text has no leading spaces or line break. +data FieldLine = FieldLine + { fieldLinePosition :: !Position + , fieldLineText :: !Text + } deriving (Eq, Show) + +-- | A field value as the source file gives it. The position is the position +-- of the field name. The lines are in source order. Comment lines and blank +-- lines are not included. +-- +-- Field values occur in 'packageFields', 'extraFields', and +-- 'sourceRepositoryFields'. The parser does not check these values. +data FieldValue = FieldValue + { fieldPosition :: !Position + , fieldLines :: [FieldLine] + } deriving (Eq, Show) + +-- | The lines of a field value, joined with line breaks. For a free text +-- field, such as @description@, use 'Aihc.Cabal.packageFieldText'. +fieldText :: FieldValue -> Text +fieldText = T.intercalate "\n" . map fieldLineText . fieldLines + +-- * Dependencies + +-- | A library of a package. 'MainLibrary' is the library without a name. +data LibraryTarget = MainLibrary | NamedLibrary Text deriving (Eq, Ord, Show) + +-- | One entry of a @build-depends@ or @setup-depends@ field. +-- +-- Before @cabal-version@ 3.4, a dependency on the name of an internal +-- library of the same package refers to that library. The parser changes +-- such a dependency to the package name and the 'NamedLibrary' target. +data Dependency = Dependency + { dependencyPackage :: Text + , dependencyRange :: VersionRange + -- ^ 'Aihc.Cabal.anyVersion' when the field gives no range. + , dependencyLibraries :: NonEmpty LibraryTarget + -- ^ The libraries in @pkg:{a, b}@ syntax. Without that syntax, the main + -- library. + } deriving (Eq, Show) + +-- | Module visibility for a mixin or a package dependency. +data ModuleRenaming + = DefaultRenaming + -- ^ All exposed modules with their names. + | ModuleRenaming [(Text, Text)] + -- ^ Only the given modules, each with a new name. + | HidingRenaming [Text] + -- ^ All exposed modules except the given modules. + deriving (Eq, Show) + +-- | A Backpack mixin from a @mixins@ field. +data Mixin = Mixin + { mixinPackage :: Text + , mixinLibrary :: LibraryTarget + , mixinProvides :: ModuleRenaming + , mixinRequires :: ModuleRenaming + } deriving (Eq, Show) + +-- | One entry of a @build-tool-depends@ or a legacy @build-tools@ field. +data ToolDependency = ToolDependency + { toolPackage :: Maybe Text + -- ^ The package in @pkg:exe@ syntax. 'Nothing' for a @build-tools@ entry, + -- which names only the tool. + , toolName :: Text + , toolRange :: VersionRange + -- ^ 'Aihc.Cabal.anyVersion' when the field gives no range. + } deriving (Eq, Show) + +-- * Flags and conditions + +-- | A @flag@ section. Flag names are lower case. +data Flag = Flag + { flagName :: Text + , flagDefault :: Bool + -- ^ The @default@ field. 'True' when the field is absent. + , flagManual :: Bool + -- ^ The @manual@ field. 'False' when the field is absent. + , flagDescription :: Text + -- ^ The @description@ field after the Cabal free text rules. @\"\"@ when + -- the field is absent. + } deriving (Eq, Show) + +-- | Flag values by flag name. +type FlagAssignment = Map Text Bool + +-- | The condition of an @if@ or @elif@ section. +data Condition + = Literal Bool + | OS Text + -- ^ @os(name)@. The comparison ignores case. + | Arch Text + -- ^ @arch(name)@. The comparison ignores case. + | Impl Text VersionRange + -- ^ @impl(compiler range)@. Without a range, 'Aihc.Cabal.anyVersion'. + -- The comparison of the compiler name ignores case. + | FlagValue Text + -- ^ @flag(name)@. The name is lower case. + | Not Condition + | And Condition Condition + | Or Condition Condition + deriving (Eq, Show) + +-- | Data with conditional parts, as one section of a Cabal file gives it. +-- 'unconditional' holds the fields outside @if@ sections. 'branches' holds +-- the @if@ sections in source order. +data Conditional a = Conditional + { unconditional :: a + , branches :: [Branch a] + } deriving (Eq, Show) + +-- | An @if@ section with its optional @else@ or @elif@ part. An @elif@ part +-- becomes an @else@ part with one branch. +data Branch a = Branch + { condition :: Condition + , whenTrue :: Conditional a + , whenFalse :: Maybe (Conditional a) + } deriving (Eq, Show) + +-- * Components + +-- | The kind and name of a component section. +data ComponentKind + = Library LibraryTarget + | Executable Text + | TestSuite Text + | Benchmark Text + | ForeignLibrary Text + deriving (Eq, Ord, Show) + +-- | A component of a package. In a t'Package', the data is a +-- @t'Conditional' t'BuildInfo'@. In a t'ResolvedPackage', the data is a +-- t'BuildInfo'. +data Component a = Component + { componentKind :: ComponentKind + , componentData :: a + } deriving (Eq, Show) + +-- | The build fields of one section level, before defaults. Lists keep +-- their source order. A field that the Cabal format version of the file +-- does not support is absent. +-- +-- The 'Semigroup' instance merges two parts as Cabal-syntax merges build +-- information. Values in the second part come after values in the first +-- part. Some lists do not keep duplicate values. A scalar value in the +-- second part replaces the scalar value in the first part. The parser uses +-- the merge for common stanza imports. 'Aihc.Cabal.resolvePackage' uses it +-- for active conditional branches. +data BuildInfo = BuildInfo + { buildable :: Maybe Bool + -- ^ @buildable@. Two values merge with 'Bool' and. + , sourceDirs :: [FilePath] + -- ^ @hs-source-dirs@, then the older @hs-source-dir@ values. + , exposedModules :: [Text] + -- ^ @exposed-modules@. Only a library has this field. + , otherModules :: [Text] + -- ^ @other-modules@. + , autogenModules :: [Text] + -- ^ @autogen-modules@, from @cabal-version@ 2.0. + , virtualModules :: [Text] + -- ^ @virtual-modules@, from @cabal-version@ 2.2. + , mainIs :: Maybe FilePath + -- ^ @main-is@. Only an executable, a test suite, or a benchmark has this + -- field. + , defaultLanguage :: Maybe Text + -- ^ @default-language@, from @cabal-version@ 1.10. 'Nothing' means the + -- Haskell98 default of Cabal. + , otherLanguages :: [Text] + -- ^ @other-languages@, from @cabal-version@ 1.10. + , extensions :: [Text] + -- ^ @default-extensions@, from @cabal-version@ 1.10. + , otherExtensions :: [Text] + -- ^ @other-extensions@. + , legacyExtensions :: [Text] + -- ^ The older @extensions@ field. It is an error from @cabal-version@ 3.0. + -- Use it with 'extensions' when you select compiler extensions. + , dependencies :: [Dependency] + -- ^ @build-depends@. + , mixins :: [Mixin] + -- ^ @mixins@, from @cabal-version@ 2.0. + , buildTools :: [ToolDependency] + -- ^ The legacy @build-tools@ values, then the @build-tool-depends@ values. + , cSources :: [FilePath] + -- ^ @c-sources@. + , cxxSources :: [FilePath] + -- ^ @cxx-sources@, from @cabal-version@ 2.2. + , asmSources :: [FilePath] + -- ^ @asm-sources@, from @cabal-version@ 3.0. + , cmmSources :: [FilePath] + -- ^ @cmm-sources@, from @cabal-version@ 3.0. + , jsSources :: [FilePath] + -- ^ @js-sources@. + , includeDirs :: [FilePath] + -- ^ @include-dirs@. + , includes :: [FilePath] + -- ^ @includes@. + , installIncludes :: [FilePath] + -- ^ @install-includes@. + , autogenIncludes :: [FilePath] + -- ^ @autogen-includes@, from @cabal-version@ 3.0. + , extraLibDirs :: [FilePath] + -- ^ @extra-lib-dirs@. + , extraLibDirsStatic :: [FilePath] + -- ^ @extra-lib-dirs-static@, from @cabal-version@ 3.8. + , frameworks :: [Text] + -- ^ @frameworks@. + , extraFrameworkDirs :: [FilePath] + -- ^ @extra-framework-dirs@. + , cppOptions :: [Text] + -- ^ @cpp-options@. Options keep all values, also duplicates. + , ccOptions :: [Text] + -- ^ @cc-options@. + , cxxOptions :: [Text] + -- ^ @cxx-options@, from @cabal-version@ 2.2. + , ghcOptions :: [Text] + -- ^ @ghc-options@. + , extraFields :: Map Text [FieldValue] + -- ^ All other fields of the section, by lower case name, with their values + -- in source order. This includes @x-@ fields, for example + -- @x-aihc-lir-sources@. Use 'fieldText' to read a value. + } deriving (Eq, Show) + +-- | A t'BuildInfo' without fields. Use it with record syntax to make a value. +emptyBuildInfo :: BuildInfo +emptyBuildInfo = BuildInfo + { buildable = Nothing, sourceDirs = [], exposedModules = [], otherModules = [] + , autogenModules = [], virtualModules = [], mainIs = Nothing, defaultLanguage = Nothing + , otherLanguages = [], extensions = [], otherExtensions = [], legacyExtensions = [] + , dependencies = [], mixins = [], buildTools = [], cSources = [], cxxSources = [], asmSources = [] + , cmmSources = [], jsSources = [], includeDirs = [], includes = [], installIncludes = [] + , autogenIncludes = [], extraLibDirs = [], extraLibDirsStatic = [], frameworks = [] + , extraFrameworkDirs = [], cppOptions = [], ccOptions = [], cxxOptions = [] + , ghcOptions = [], extraFields = Map.empty + } + +-- | Merge two parts. See the 'Semigroup' instance of t'BuildInfo'. +mergeBuildInfo :: BuildInfo -> BuildInfo -> BuildInfo +mergeBuildInfo a b = BuildInfo + { buildable = case (buildable a, buildable b) of + (Nothing, y) -> y + (x, Nothing) -> x + (Just x, Just y) -> Just (x && y) + , sourceDirs = unique sourceDirs + , exposedModules = both exposedModules + , otherModules = unique otherModules + , autogenModules = unique autogenModules + , virtualModules = unique virtualModules + , mainIs = prefer (mainIs a) (mainIs b) + , defaultLanguage = prefer (defaultLanguage a) (defaultLanguage b) + , otherLanguages = unique otherLanguages + , extensions = unique extensions + , otherExtensions = unique otherExtensions + , legacyExtensions = unique legacyExtensions + , dependencies = unique dependencies + , mixins = both mixins + , buildTools = both buildTools + , cSources = unique cSources + , cxxSources = unique cxxSources + , asmSources = unique asmSources + , cmmSources = unique cmmSources + , jsSources = unique jsSources + , includeDirs = unique includeDirs + , includes = unique includes + , installIncludes = unique installIncludes + , autogenIncludes = unique autogenIncludes + , extraLibDirs = unique extraLibDirs + , extraLibDirsStatic = unique extraLibDirsStatic + , frameworks = unique frameworks + , extraFrameworkDirs = unique extraFrameworkDirs + , cppOptions = both cppOptions + , ccOptions = both ccOptions + , cxxOptions = both cxxOptions + , ghcOptions = both ghcOptions + , extraFields = Map.unionWith (++) (extraFields a) (extraFields b) + } + where + both f = f a ++ f b + unique f = nub (both f) + prefer x Nothing = x + prefer _ y = y + +instance Semigroup BuildInfo where + (<>) = mergeBuildInfo + +instance Monoid BuildInfo where + mempty = emptyBuildInfo + +-- * Packages + +-- | A @source-repository@ section. Repeated fields keep their values in +-- source order. The values keep quotation marks. +data SourceRepository = SourceRepository + { sourceRepositoryKind :: Text + -- ^ The section argument, for example @head@ or @this@. + , sourceRepositoryFields :: Map Text [FieldValue] + } deriving (Eq, Show) + +-- | A parsed package description. Conditions are not evaluated. Use +-- 'Aihc.Cabal.resolvePackage' to get a t'ResolvedPackage'. +data Package = Package + { packageName :: Text + , packageVersion :: Version + , cabalVersion :: Version + -- ^ The Cabal format version that Cabal-syntax uses for the file. A range + -- such as @>=1.9@ gives the version that Cabal-syntax selects, here 1.10. + -- A file without a @cabal-version@ field has version 1.0. + , buildType :: Text + -- ^ The build type that Cabal-syntax uses: @Simple@, @Configure@, + -- @Custom@, @Make@, or @Hooks@. Without a @build-type@ field, the value is + -- @Simple@ from @cabal-version@ 2.2 and @Custom@ before it. A + -- @custom-setup@ section gives @Custom@. + , packageFlags :: [Flag] + -- ^ The @flag@ sections in source order. + , packageComponents :: [Component (Conditional BuildInfo)] + -- ^ The component sections in source order. + , packageFields :: Map Text [FieldValue] + -- ^ All fields before the first section, by lower case name, with their + -- values in source order. This includes @name@, @version@, + -- @cabal-version@, and @build-type@. Use 'Aihc.Cabal.packageFieldText' + -- to read a value. + , packageSourceRepositories :: [SourceRepository] + -- ^ The @source-repository@ sections in source order. + , packageSetupDependencies :: Maybe [Dependency] + -- ^ The @setup-depends@ values of a @custom-setup@ section. 'Nothing' + -- without that section. + } deriving (Eq, Show) + +-- | The target that 'Aihc.Cabal.evaluateCondition' compares with. The +-- 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. + , targetArch :: Text + -- ^ For @arch(...)@, for example @x86_64@. Case does not matter. + , compiler :: Text + -- ^ For @impl(...)@, for example @ghc@. Case does not matter. + , compilerVersion :: Version + -- ^ The version that the compiler reports. + } deriving (Eq, Show) + +-- | A package after condition evaluation and defaults. See +-- 'Aihc.Cabal.resolvePackage'. +data ResolvedPackage = ResolvedPackage + { resolvedFlags :: FlagAssignment + -- ^ The value of each declared flag. + , resolvedComponents :: [Component BuildInfo] + -- ^ All components, in source order. This includes components with + -- @buildable: False@. The caller selects the components to build. + } deriving (Eq, Show) + +-- | The contents of a @.buildinfo@ file, as a configure script writes it. +data HookedBuildInfo = HookedBuildInfo + { hookedLibrary :: Maybe BuildInfo + -- ^ The fields before the first @executable@ field. + , hookedExecutables :: Map Text BuildInfo + -- ^ The fields after each @executable: name@ field. + } deriving (Eq, Show) diff --git a/src/Aihc/Cabal/Internal/Values.hs b/src/Aihc/Cabal/Internal/Values.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal/Internal/Values.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Parsers for field values, and the free text rules. Each parser follows +-- the Cabal-syntax 3.12 parser for the same value. +module Aihc.Cabal.Internal.Values + ( runValue, token, token', filePath, quoted, commaList, spaceList, optionList + , componentName, moduleName, identifier, languageName, bool, buildTypeValue + , dependency, exeDependency, legacyExeDependency, mixin, flagNameValue, specAtLeast, freeText + ) where + +import Control.Applicative (optional, (<|>)) +import Control.Monad (void, when) +import Data.Char (chr, digitToInt, isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit, isSpace, isUpper, toLower) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Text.Megaparsec (between, choice, eof, errorBundlePretty, getInput, many, manyTill, option, runParser, satisfy, some, takeP, takeWhile1P, takeWhileP, try) +import Text.Megaparsec.Char (char, space, spaceChar, string) +import Aihc.Cabal.Internal.Types +import Aihc.Cabal.Internal.Version + +specAtLeast :: [Integer] -> Version -> Bool +specAtLeast digits spec = spec >= specVersion digits + +-- | Run a field parser on complete field text, as Cabal-syntax does. +runValue :: Parser a -> Text -> Either Text a +runValue p input = case runParser (space *> p <* space <* eof) "field" input of + Left err -> Left (T.pack (errorBundlePretty err)) + Right x -> Right x + +-- | A Haskell string literal. +haskellString :: Parser Text +haskellString = T.pack . catMaybes <$> (char '"' *> manyTill stringChar (char '"')) + where + stringChar = Just <$> satisfy (\c -> c /= '"' && c /= '\\' && c > '\026') <|> (char '\\' *> escape) + escape = Nothing <$ (some (satisfy isSpace) *> char '\\') + <|> Nothing <$ char '&' + <|> Just <$> escapeCode + escapeCode = choice (map (\(c, code) -> code <$ char c) (zip "abfnrtv\\\"'" "\a\b\f\n\r\t\v\\\"'")) + <|> number 10 isDigit (pure ()) + <|> number 8 isOctDigit (void (char 'o')) + <|> number 16 isHexDigit (void (char 'x')) + <|> choice [try (code <$ string name) | (name, code) <- asciiCodes] + <|> (char '^' *> ((\c -> chr (fromEnum c - fromEnum '@')) <$> satisfy (\c -> isUpper c || c == '@'))) + number :: Int -> (Char -> Bool) -> Parser () -> Parser Char + number base valid prefix = do + prefix + ds <- some (satisfy valid) + let n = foldl (\a d -> a * base + digitToInt d) 0 ds + if n > 0x10FFFF then fail "out-of-range numeric escape sequence" else pure (chr n) + asciiCodes = zip + [ "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "DLE", "DC1", "DC2", "DC3", "DC4" + , "NAK", "SYN", "ETB", "CAN", "SUB", "ESC", "DEL", "BS", "HT", "LF", "VT", "FF", "CR", "SO" + , "SI", "EM", "FS", "GS", "RS", "US", "SP" ] + "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" + +-- | A string or characters other than space and comma. +token :: Parser Text +token = haskellString <|> takeWhile1P (Just "identifier") (\c -> not (isSpace c) && c /= ',') + +-- | A string or characters other than space. +token' :: Parser Text +token' = haskellString <|> takeWhile1P (Just "token") (not . isSpace) + +-- | A token that is not empty. +filePath :: Parser Text +filePath = do + x <- token + when (T.null x) (fail "empty FilePath") + pure x + +quoted :: Parser a -> Parser a +quoted p = between (char '"') (char '"') p <|> p + +comma :: Parser () +comma = char ',' *> space + +-- | The list format of @CommaVCat@ and @CommaFSep@ fields. +commaList :: Version -> Parser a -> Parser [a] +commaList spec p + | specAtLeast [2, 2] spec = do + c <- optional comma + case c of + Nothing -> sepEndBy1 item comma <|> pure [] + Just _ -> sepBy1 item comma + | otherwise = sepBy item comma + where item = p <* space + +-- | The list format of @VCat@ and @FSep@ fields. +spaceList :: Version -> Parser a -> Parser [a] +spaceList spec p + | specAtLeast [3, 0] spec = do + c <- optional comma + case c of + Nothing -> start <|> pure [] + Just _ -> sepBy1 item comma + | otherwise = sepBy item (optional comma) + where + item = p <* space + start = do + x <- item + c <- optional comma + case c of + Nothing -> (x :) <$> many item + Just _ -> (x :) <$> sepEndBy item comma + +-- | The list format of @NoCommaFSep@ fields. +optionList :: Parser a -> Parser [a] +optionList p = many (p <* space) + +sepBy :: Parser a -> Parser s -> Parser [a] +sepBy p s = sepBy1 p s <|> pure [] + +sepBy1 :: Parser a -> Parser s -> Parser [a] +sepBy1 p s = (:) <$> p <*> many (s *> p) + +sepEndBy :: Parser a -> Parser s -> Parser [a] +sepEndBy p s = sepEndBy1 p s <|> pure [] + +sepEndBy1 :: Parser a -> Parser s -> Parser [a] +sepEndBy1 p s = do + x <- p + (s *> ((x :) <$> sepEndBy p s)) <|> pure [x] + +-- | Take the longest prefix that the predicate accepts, if the check accepts +-- that prefix. Otherwise use the fallback parser. The result is a slice of the +-- input: a list of characters is not kept. +validPrefix :: (Char -> Bool) -> (Text -> Bool) -> Parser Text -> Parser Text +validPrefix allowed valid fallback = do + input <- getInput + let x = T.takeWhile allowed input + if valid x then takeP Nothing (T.length x) else fallback + +-- | A package or component name. Each part has a letter. +componentName :: Parser Text +componentName = validPrefix (\c -> isAlphaNum c || c == '-') valid (T.pack <$> state0 []) + where + valid x = not (T.null x) && all (\part -> not (T.null part) && not (T.all isDigit part)) (T.splitOn "-" x) + ch = satisfy (\c -> isAlphaNum c || c == '-') + state0 acc = do + c <- ch + if isDigit c then state0 (c : acc) + else if isAlphaNum c then state1 (c : acc) + else fail ("Empty component, after " ++ reverse acc) + state1 acc = (do + c <- ch + if isAlphaNum c then state1 (c : acc) else state0 (c : acc)) <|> pure (reverse acc) + +moduleName :: Parser Text +moduleName = validPrefix (\c -> isAlphaNum c || c == '_' || c == '\'' || c == '.') valid (T.pack <$> state0 []) + where + valid x = not (T.null x) && all (\part -> maybe False (isUpper . fst) (T.uncons part)) (T.splitOn "." x) + state0 acc = do + c <- satisfy isUpper + state1 (c : acc) + state1 acc = (do + c <- satisfy (\c -> isAlphaNum c || c == '_' || c == '\'' || c == '.') + if c == '.' then state0 (c : acc) else state1 (c : acc)) <|> pure (reverse acc) + +-- | A name for an operating system or an architecture. +identifier :: Parser Text +identifier = T.cons <$> satisfy isAlpha <*> takeWhileP Nothing (\c -> isAlphaNum c || c == '_' || c == '-') + +languageName :: Parser Text +languageName = takeWhile1P (Just "name") isAlphaNum + +bool :: Parser Bool +bool = do + x <- takeWhile1P (Just "boolean") isAlpha + case T.toLower x of + "true" -> pure True + "false" -> pure False + _ -> fail ("Not a boolean: " ++ T.unpack x) + +-- | A build type. @Default@ is @Custom@ before cabal-version 1.20. +-- @Make@ is not permitted from cabal-version 3.18. @Hooks@ is permitted +-- from cabal-version 3.14. +buildTypeValue :: Version -> Parser Text +buildTypeValue spec = do + x <- takeWhile1P (Just "build type") isAlphaNum + case x of + _ | x `elem` ["Simple", "Configure", "Custom"] -> pure x + "Make" | not (specAtLeast [3, 18] spec) -> pure x + | otherwise -> fail "build-type: 'Make'. This feature requires cabal-version <= 3.18." + "Hooks" | specAtLeast [3, 14] spec -> pure x + | otherwise -> fail "build-type: 'Hooks'. This feature requires cabal-version >= 3.14." + "Default" | not (specAtLeast [1, 20] spec) -> pure "Custom" + _ -> fail ("unknown build-type: '" ++ T.unpack x ++ "'") + +flagNameValue :: Parser Text +flagNameValue = do + c <- satisfy (\x -> isAlphaNum x || x == '_') + rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_' || x == '-') + pure (T.map toLower (T.cons c rest)) + +dependency :: Version -> Parser Dependency +dependency spec = do + name <- componentName + libs <- optional $ do + _ <- char ':' + unless3 (fail "Sublibrary dependency syntax used") + ((:| []) <$> library) <|> between (char '{' *> space) (space *> char '}') libraries + space + range <- optional (rangeParser spec) + let normalize (NamedLibrary x) | x == name = MainLibrary + normalize x = x + -- Most dependencies have no library list. They share one value. + !targets = maybe mainLibrary (fmap normalize) libs + pure (Dependency name (fromMaybe anyVersion range) targets) + where + unless3 failure = when (not (specAtLeast [3, 0] spec)) failure + library = NamedLibrary <$> componentName + libraries = do + x <- library <* space + xs <- many (comma *> library <* space) + pure (x :| xs) + +mainLibrary :: NonEmpty LibraryTarget +mainLibrary = MainLibrary :| [] +{-# NOINLINE mainLibrary #-} + +exeDependency :: Version -> Parser ToolDependency +exeDependency spec = do + pkg <- componentName + _ <- char ':' + exe <- componentName <* space + range <- optional (rangeParser spec) + pure (ToolDependency (Just pkg) exe (fromMaybe anyVersion range)) + +legacyExeDependency :: Version -> Parser ToolDependency +legacyExeDependency spec = do + name <- quoted legacyName + space + range <- optional (quoted (rangeParser spec)) + pure (ToolDependency Nothing name (fromMaybe anyVersion range)) + where + legacyName = T.intercalate "-" <$> sepBy1 part (char '-') + part = do + x <- takeWhile1P (Just "name") (\c -> isAlphaNum c || c == '+' || c == '_') + if T.all isDigit x then fail "invalid component" else pure x + +-- | A mixin: a package, an optional library, and module renamings. +mixin :: Version -> Parser Mixin +mixin spec = do + pkg <- componentName + lib <- option MainLibrary $ do + _ <- char ':' + when (not (specAtLeast [3, 4] spec)) (fail "Sublibrary mixin syntax used") + NamedLibrary <$> componentName + space + provides <- renaming + requires <- option DefaultRenaming (try (space *> string "requires" *> space *> renaming)) + let lib' = case lib of + NamedLibrary x | x == pkg -> MainLibrary + _ -> lib + pure (Mixin pkg lib' provides requires) + where + lax = specAtLeast [3, 0] spec + parens p + | lax = between (char '(' *> space) (char ')' *> space) p + | otherwise = between (char '(' *> optional (spaceChar *> fail "space after parenthesis")) (char ')') p + listed = if lax then moduleName <* space else moduleName + renaming = choice + [ ModuleRenaming <$> parens (sepBy entry comma) <* space + , HidingRenaming <$> (string "hiding" *> space *> parens (sepBy listed comma)) + , pure DefaultRenaming ] + entry = do + old <- moduleName <* space + option (old, old) $ do + _ <- string "as" + _ <- some (satisfy isSpace) + new <- moduleName <* space + pure (old, new) + +-- | Cabal-syntax gives free text with two sets of rules. From cabal-version +-- 3.0, it keeps blank lines and relative indentation. +freeText :: Version -> FieldValue -> Text +freeText spec (FieldValue pos ls) = case ls of + [] -> "" + _ | specAtLeast [3, 0] spec -> freeText3 pos ls + [FieldLine _ "."] -> "." + _ -> T.intercalate "\n" [if t == "." then "" else t | FieldLine _ x <- ls, let t = T.strip x] + +freeText3 :: Position -> [FieldLine] -> Text +freeText3 _ [] = "" +freeText3 _ [FieldLine _ x] = x +freeText3 pos (FieldLine p1 x1 : rest@(FieldLine p2 _ : _)) + | positionRow pos == positionRow p1 = T.concat (x1 : lines' (minimum (column p1 : column p2 : map lineColumn rest))) + | otherwise = + let c = minimum (column p1 : map lineColumn rest) + in T.concat (T.replicate (column p1 - c) " " : x1 : lines' c) + where + column = positionColumn + lineColumn = column . fieldLinePosition + lines' c = zipWith (line c) (p1 : map fieldLinePosition rest) rest + line c previous (FieldLine q x) = + T.replicate (positionRow q - positionRow previous) "\n" <> T.replicate (column q - c) " " <> x diff --git a/src/Aihc/Cabal/Internal/Version.hs b/src/Aihc/Cabal/Internal/Version.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cabal/Internal/Version.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Versions and version ranges. "Aihc.Cabal" exports the public part. The +-- parsers and the specification version helpers are for the other internal +-- modules. +module Aihc.Cabal.Internal.Version + ( -- * Public + Version, versionNumbers, mkVersion, parseVersion, renderVersion + , VersionRange (..), anyVersion, noVersion, thisVersion, withinVersion, withinRange, intersectRanges + , unionRanges, parseVersionRange, renderVersionRange + -- * Internal + , Parser, specVersion, latestSpec, versionParser, versionDigits, rangeParser + ) where + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Data.Char (isAlphaNum, isDigit) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) +import Text.Megaparsec (Parsec, between, eof, errorBundlePretty, many, runParser, satisfy, sepBy1, some, takeWhile1P) +import Text.Megaparsec.Char (char, space, string) + +-- | A version: one or more numbers that are not negative. Versions compare +-- as lists, so @1.2@ is before @1.2.0@. +newtype Version = Version (NonEmpty Integer) deriving (Eq, Ord, Show) + +-- | A version range as a Cabal file gives it. The constructors are exported +-- so that the caller can examine, simplify, or show a range. Equality is +-- structural: a @^>=@ bound and its expanded intersection are different +-- values. Use 'withinRange' to test membership. +data VersionRange + = AnyVersion + -- ^ @-any@, or an absent range. The same set of versions as @>= 0@. + | Equal Version + -- ^ @== v@ + | Later Version + -- ^ @> v@ + | Earlier Version + -- ^ @< v@ + | AtLeast Version + -- ^ @>= v@ + | AtMost Version + -- ^ @<= v@ + | MajorBound Version + -- ^ @^>= v@ + | Both VersionRange VersionRange + -- ^ @a && b@ + | EitherRange VersionRange VersionRange + -- ^ @a || b@ + deriving (Eq, Show) + +type Parser = Parsec Void Text + +-- | The numbers of a version. +versionNumbers :: Version -> NonEmpty Integer +versionNumbers (Version ns) = ns + +-- | Make a version from its numbers. The result is 'Nothing' for an empty +-- list and for a negative number. +mkVersion :: [Integer] -> Maybe Version +mkVersion ns = case NE.nonEmpty ns of + Just xs | all (>= 0) xs -> Just (Version xs) + _ -> Nothing + +-- | A known Cabal specification version, for example @specVersion [2, 2]@. +specVersion :: [Integer] -> Version +specVersion = Version . NE.fromList + +-- | The newest Cabal specification version that the parser knows. +latestSpec :: Version +latestSpec = specVersion [3, 14] + +-- | A version number part: at most nine digits and no leading zero. +versionDigits :: Parser Integer +versionDigits = do + ds <- some (satisfy isDigit) + case ds of + "0" -> pure 0 + '0' : _ -> fail "Version digit with leading zero" + _ | length ds > 9 -> fail "At most 9 numbers are allowed per version number part" + | otherwise -> pure (read ds) + +-- | A version with optional tags, for example @1.2.3-rc1@. The tags are not kept. +versionParser :: Parser Version +versionParser = Version . NE.fromList <$> versionDigits `sepBy1` char '.' <* tags + +tags :: Parser () +tags = () <$ many (char '-' *> some (satisfy isAlphaNum)) + +parseWith :: Parser a -> Text -> Either Text a +parseWith p input = case runParser (space *> p <* space <* eof) "" input of + Left err -> Left (T.pack (errorBundlePretty err)) + Right value -> Right value + +-- | Parse a version such as @9.12.2@. Spaces around the version are +-- permitted. Tags such as @-rc1@ are accepted and not kept. +parseVersion :: Text -> Either Text Version +parseVersion = parseWith versionParser + +-- | Show a version with dots, as in @9.12.2@. +renderVersion :: Version -> Text +renderVersion (Version ns) = T.intercalate "." (map (T.pack . show) (NE.toList ns)) + +-- | The range of all versions. +anyVersion :: VersionRange +anyVersion = AnyVersion + +-- | The empty range @-none@, as @< 0@. +noVersion :: VersionRange +noVersion = Earlier (Version (0 :| [])) + +-- | The range @== v@. +thisVersion :: Version -> VersionRange +thisVersion = Equal + +-- | The range @a && b@ or @a || b@. The functions do not simplify. +intersectRanges, unionRanges :: VersionRange -> VersionRange -> VersionRange +intersectRanges = Both +unionRanges = EitherRange + +-- | Test if a version is in a range. +withinRange :: Version -> VersionRange -> Bool +withinRange v range = case range of + AnyVersion -> True + Equal w -> v == w + Later w -> v > w + Earlier w -> v < w + AtLeast w -> v >= w + AtMost w -> v <= w + MajorBound w -> v >= w && v < majorUpperBound w + Both a b -> withinRange v a && withinRange v b + EitherRange a b -> withinRange v a || withinRange v b + +-- | Parse a version range as Cabal-syntax does for the given specification version. +-- Unparenthesized @&&@ and @||@ associate to the right. +rangeParser :: Version -> Parser VersionRange +rangeParser spec = expr + where + expr = do + space + t <- term + space + (EitherRange t <$> (string "||" *> space *> expr)) <|> pure t + term = do + f <- factor + space + (Both f <$> (string "&&" *> space *> term)) <|> pure f + factor = parens <|> prim + parens = between (char '(' *> space) (char ')' *> space) (expr <* space) + prim = do + op <- takeWhile1P (Just "operator") isOpChar + case op of + "-" -> AnyVersion <$ string "any" <|> (string "none" *> none) + "==" -> space *> (wildOrVersion <|> (versionSet >>= set Equal)) + "^>=" -> space *> (major <|> (versionSet >>= set MajorBound)) + _ -> do + space + (wild, v) <- versionOrWild + when wild (fail ("wild-card version after non-== operator: " ++ T.unpack op)) + case op of + ">=" -> pure (AtLeast v) + "<" -> pure (Earlier v) + "<=" -> pure (AtMost v) + ">" -> pure (Later v) + _ -> fail ("Unknown version operator " ++ T.unpack op) + isOpChar c = c `elem` ("<=>^" :: String) || (c == '-' && spec < specVersion [3, 4]) + none + | spec >= specVersion [1, 22] = pure noVersion + | otherwise = fail "-none version range used" + wildOrVersion = do + (wild, v) <- versionOrWild + pure (if wild then withinVersion v else Equal v) + major = do + (wild, v) <- versionOrWild + when wild (fail "wild-card version after ^>= operator") + if spec >= specVersion [2, 0] then pure (MajorBound v) + else fail "major bounded version syntax (caret, ^>=) used" + set constructor vs + | spec >= specVersion [3, 0] = pure (foldr1 EitherRange (fmap constructor vs)) + | otherwise = fail "version set syntax used" + versionSet = do + _ <- char '{' *> space + v <- plain <* space + vs <- many (char ',' *> space *> plain <* space) + _ <- char '}' + pure (v :| vs) + plain = Version . NE.fromList <$> versionDigits `sepBy1` char '.' + versionOrWild = versionDigits >>= loop . pure + loop acc = (char '.' *> ((versionDigits >>= loop . (: acc)) <|> ((True, done acc) <$ char '*'))) + <|> ((False, done acc) <$ tags) + done = Version . NE.fromList . reverse + +-- | The range @== v.*@. +withinVersion :: Version -> VersionRange +withinVersion v = Both (AtLeast v) (Earlier (wildcardUpperBound v)) +wildcardUpperBound :: Version -> Version +wildcardUpperBound (Version ns) = Version (NE.fromList (NE.init ns ++ [NE.last ns + 1])) + +majorUpperBound :: Version -> Version +majorUpperBound (Version ns) = Version $ case ns of + x :| [] -> x :| [1] + x :| (y:_) -> x :| [y + 1] + +-- | Parse a version range. The parser accepts the syntax of all Cabal +-- format versions: @-any@, @-none@, @^>=@, and version sets. Operators +-- without parentheses associate to the right, as in Cabal-syntax. +parseVersionRange :: Text -> Either Text VersionRange +parseVersionRange = parseWith (rangeParser (specVersion [3, 0])) + +-- | Show a range in Cabal syntax, for example @>=1.2 && <1.3 || ==2.0@. +-- The text has parentheses only where the structure needs them. A @||@ +-- operand of @&&@ gets parentheses. A left operand with the same operator +-- gets parentheses, so that 'parseVersionRange' gives the same value. +renderVersionRange :: VersionRange -> Text +renderVersionRange r = case r of + AnyVersion -> "-any" + Equal v -> "==" <> renderVersion v + Later v -> ">" <> renderVersion v + Earlier v -> "<" <> renderVersion v + AtLeast v -> ">=" <> renderVersion v + AtMost v -> "<=" <> renderVersion v + MajorBound v -> "^>=" <> renderVersion v + Both a b -> parens (isBoth a || isEither a) a <> " && " <> parens (isEither b) b + EitherRange a b -> parens (isEither a) a <> " || " <> renderVersionRange b + where + parens needed x + | needed = "(" <> renderVersionRange x <> ")" + | otherwise = renderVersionRange x + isBoth Both {} = True + isBoth _ = False + isEither EitherRange {} = True + isEither _ = False diff --git a/test/Compliance/Adapter.hs b/test/Compliance/Adapter.hs new file mode 100644 --- /dev/null +++ b/test/Compliance/Adapter.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE OverloadedStrings #-} +module Compliance.Adapter (toCabal, runResult) where + +import Control.Monad (foldM) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Aihc.Cabal as A +import qualified Distribution.CabalSpecVersion as C +import qualified Distribution.Compat.NonEmptySet as NES +import qualified Distribution.Compiler as C +import qualified Distribution.FieldGrammar.Parsec as C +import qualified Distribution.Fields.Field as C +import qualified Distribution.Fields.ParseResult as C +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.FieldGrammar as C +import qualified Distribution.Parsec as C +import qualified Distribution.Types.Version as C +import qualified Distribution.Types.VersionRange as C +import qualified Distribution.Utils.Path as C + +-- Only fields retained as text use Cabal field grammars. Typed fields use +-- the project AST. This module cannot read the original file or reference AST. +toCabal :: A.Package -> Either String C.GenericPackageDescription +toCabal pkg = do + spec <- maybe (Left "Unsupported Cabal format version") Right + (C.cabalSpecFromVersionDigits (map fromInteger (NE.toList (A.versionNumbers (A.cabalVersion pkg))))) + -- The typed name, version, and format version replace the retained text. + let retained = foldr Map.delete (A.packageFields pkg) ["name", "version", "cabal-version"] + pd <- fields spec C.packageDescriptionFieldGrammar + (Map.insert "name" [text (A.packageName pkg)] (Map.insert "version" [text "0"] retained)) + repositories <- traverse (sourceRepository spec) (A.packageSourceRepositories pkg) + flags <- traverse (flag spec) (A.packageFlags pkg) + version <- convertVersion (A.packageVersion pkg) + -- The grammar tells if the file sets a build type. The value is typed. + buildType <- traverse (const (atom (A.buildType pkg))) (C.buildTypeRaw pd) + setup <- traverse (fmap (\deps -> C.SetupBuildInfo deps False) . traverse convertDependency) + (A.packageSetupDependencies pkg) + let description = pd + { C.package = C.PackageIdentifier (C.mkPackageName (T.unpack (A.packageName pkg))) version + , C.specVersion = spec + , C.buildTypeRaw = buildType + , C.setupBuildInfo = setup + , C.sourceRepos = repositories + } + initial = C.emptyGenericPackageDescription + { C.packageDescription = description, C.genPackageFlags = flags } + foldM (component spec) initial (A.packageComponents pkg) + +flag :: C.CabalSpecVersion -> A.Flag -> Either String C.PackageFlag +flag spec f = do + raw <- fields spec (C.flagFieldGrammar (C.mkFlagName (T.unpack (A.flagName f)))) + (Map.singleton "description" [text (A.flagDescription f)]) + pure raw { C.flagDefault = A.flagDefault f, C.flagManual = A.flagManual f } + +sourceRepository :: C.CabalSpecVersion -> A.SourceRepository -> Either String C.SourceRepo +sourceRepository spec repository = do + kind <- atom (A.sourceRepositoryKind repository) + fields spec (C.sourceRepoFieldGrammar kind) (A.sourceRepositoryFields repository) + +fields :: C.CabalSpecVersion -> C.ParsecFieldGrammar s a -> Map.Map Text [A.FieldValue] -> Either String a +fields spec grammar retained = either (Left . show) Right + (snd (runResult (C.parseFieldGrammar spec (fieldMap retained) grammar))) + where + -- Keep each occurrence, each line, and each source position. + fieldMap = Map.fromList . map (\(k, vs) -> (TE.encodeUtf8 k, map value vs)) . Map.toList + value (A.FieldValue p ls) = C.MkNamelessField (position p) + [C.FieldLine (position q) (TE.encodeUtf8 line) | A.FieldLine q line <- ls] + position (A.Position row column) = C.Position row column + +-- | Run a Cabal-syntax parser without a source name. The results keep the +-- error and warning format of Cabal-syntax 3.12. +runResult :: C.ParseResult () a + -> ([C.PWarning], Either (Maybe C.Version, NonEmpty C.PError) a) +runResult result = case C.runParseResult result of + (warnings, outcome) -> (map C.pwarning warnings, either (Left . fmap (fmap C.perror)) Right outcome) + +-- | A field value for text that has no source position. Each line gets a +-- new row, so that Cabal free text rules give the same text. +text :: Text -> A.FieldValue +text value = A.FieldValue (A.Position 0 0) + [A.FieldLine (A.Position row 1) line | not (T.null value), (row, line) <- zip [1 ..] (T.splitOn "\n" value)] + +-- | Cabal-syntax makes these paths without checks or normalization. +path :: FilePath -> C.SymbolicPathX allowAbsolute from to +path = C.unsafeMakeSymbolicPath + +atom :: C.Parsec a => Text -> Either String a +atom input = maybe (Left ("Cannot convert field value: " ++ T.unpack input)) Right (C.simpleParsec (T.unpack input)) + +convertVersion :: A.Version -> Either String C.Version +convertVersion v = do + let digits = NE.toList (A.versionNumbers v) + if any (> toInteger (maxBound :: Int)) digits + then Left "Version component exceeds the Cabal integer limit" + else Right (C.mkVersion (map fromInteger digits)) + +convertRange :: A.VersionRange -> Either String C.VersionRange +convertRange range = case range of + A.AnyVersion -> Right C.anyVersion + A.Equal v -> C.thisVersion <$> convertVersion v + A.Later v -> C.laterVersion <$> convertVersion v + A.Earlier v -> C.earlierVersion <$> convertVersion v + A.AtLeast v -> C.orLaterVersion <$> convertVersion v + A.AtMost v -> C.orEarlierVersion <$> convertVersion v + A.MajorBound v -> C.majorBoundVersion <$> convertVersion v + A.Both a b -> C.intersectVersionRanges <$> convertRange a <*> convertRange b + A.EitherRange a b -> C.unionVersionRanges <$> convertRange a <*> convertRange b + +convertDependency :: A.Dependency -> Either String C.Dependency +convertDependency dep = do + range <- convertRange (A.dependencyRange dep) + pure (C.Dependency (C.mkPackageName (T.unpack (A.dependencyPackage dep))) range + (NES.fromNonEmpty (fmap target (A.dependencyLibraries dep)))) + where + target A.MainLibrary = C.LMainLibName + target (A.NamedLibrary name) = C.LSubLibName (C.mkUnqualComponentName (T.unpack name)) + +convertMixin :: A.Mixin -> Either String C.Mixin +convertMixin (A.Mixin pkg lib provides requires) = do + provides' <- renaming provides + requires' <- renaming requires + pure (C.Mixin (C.mkPackageName (T.unpack pkg)) (library lib) (C.IncludeRenaming provides' requires')) + where + library A.MainLibrary = C.LMainLibName + library (A.NamedLibrary name) = C.LSubLibName (C.mkUnqualComponentName (T.unpack name)) + renaming A.DefaultRenaming = Right C.DefaultRenaming + renaming (A.ModuleRenaming pairs) = C.ModuleRenaming <$> traverse (\(a, b) -> (,) <$> atom a <*> atom b) pairs + renaming (A.HidingRenaming names) = C.HidingRenaming <$> traverse atom names + +convertBuildInfo :: C.BuildInfo -> A.BuildInfo -> Either String C.BuildInfo +convertBuildInfo raw bi = do + other <- traverse atom (A.otherModules bi) + autogen <- traverse atom (A.autogenModules bi) + virtual <- traverse atom (A.virtualModules bi) + language <- traverse atom (A.defaultLanguage bi) + otherLanguages <- traverse atom (A.otherLanguages bi) + extensions <- traverse atom (A.extensions bi) + otherExtensions <- traverse atom (A.otherExtensions bi) + legacyExtensions <- traverse atom (A.legacyExtensions bi) + dependencies <- traverse convertDependency (A.dependencies bi) + mixins <- traverse convertMixin (A.mixins bi) + modern <- traverse modernTool [t | t <- A.buildTools bi, Just _ <- [A.toolPackage t]] + legacy <- traverse legacyTool [t | t <- A.buildTools bi, Nothing <- [A.toolPackage t]] + let C.PerCompilerFlavor _ ghcjs = C.options raw + pure raw + { C.buildable = fromMaybe True (A.buildable bi) + , C.hsSourceDirs = map path (A.sourceDirs bi) + , C.otherModules = other + , C.autogenModules = autogen + , C.virtualModules = virtual + , C.defaultLanguage = language + , C.otherLanguages = otherLanguages + , C.defaultExtensions = extensions + , C.otherExtensions = otherExtensions + , C.oldExtensions = legacyExtensions + , C.targetBuildDepends = dependencies + , C.mixins = mixins + , C.buildTools = legacy + , C.buildToolDepends = modern + , C.cSources = map path (A.cSources bi) + , C.cxxSources = map path (A.cxxSources bi) + , C.asmSources = map path (A.asmSources bi) + , C.cmmSources = map path (A.cmmSources bi) + , C.jsSources = map path (A.jsSources bi) + , C.includeDirs = map path (A.includeDirs bi) + , C.includes = map path (A.includes bi) + , C.installIncludes = map path (A.installIncludes bi) + , C.autogenIncludes = map path (A.autogenIncludes bi) + , C.extraLibDirs = map path (A.extraLibDirs bi) + , C.extraLibDirsStatic = map path (A.extraLibDirsStatic bi) + , C.frameworks = map (path . T.unpack) (A.frameworks bi) + , C.extraFrameworkDirs = map path (A.extraFrameworkDirs bi) + , C.cppOptions = map T.unpack (A.cppOptions bi) + , C.ccOptions = map T.unpack (A.ccOptions bi) + , C.cxxOptions = map T.unpack (A.cxxOptions bi) + , C.options = C.PerCompilerFlavor (map T.unpack (A.ghcOptions bi)) ghcjs + } + where + modernTool tool = case A.toolPackage tool of + Nothing -> Left "Missing build tool package" + Just name -> C.ExeDependency (C.mkPackageName (T.unpack name)) + (C.mkUnqualComponentName (T.unpack (A.toolName tool))) <$> convertRange (A.toolRange tool) + legacyTool tool = C.LegacyExeDependency (T.unpack (A.toolName tool)) <$> convertRange (A.toolRange tool) + +convertCondition :: A.Condition -> Either String (C.Condition C.ConfVar) +convertCondition cond = case cond of + A.Literal b -> Right (C.Lit b) + A.OS name -> C.Var . C.OS <$> atom name + A.Arch name -> C.Var . C.Arch <$> atom name + A.Impl name range -> C.Var <$> (C.Impl <$> atom name <*> convertRange range) + A.FlagValue name -> Right (C.Var (C.PackageFlag (C.mkFlagName (T.unpack name)))) + A.Not a -> C.CNot <$> convertCondition a + A.And a b -> C.CAnd <$> convertCondition a <*> convertCondition b + A.Or a b -> C.COr <$> convertCondition a <*> convertCondition b + +convertTree :: (A.BuildInfo -> Either String a) + -> A.Conditional A.BuildInfo -> Either String (C.CondTree C.ConfVar a) +convertTree convert (A.Conditional bi branches) = do + value <- convert bi + children <- traverse branch branches + pure (C.CondNode value children) + where + branch (A.Branch cond yes no) = C.CondBranch <$> convertCondition cond + <*> convertTree convert yes <*> traverse (convertTree convert) no + +component :: C.CabalSpecVersion -> C.GenericPackageDescription + -> A.Component (A.Conditional A.BuildInfo) -> Either String C.GenericPackageDescription +component spec gpd (A.Component kind tree) = case kind of + A.Library target -> do + let libName = case target of + A.MainLibrary -> C.LMainLibName + A.NamedLibrary n -> C.LSubLibName (componentName n) + converted <- convertTree (library libName) tree + pure $ case target of + A.MainLibrary -> gpd { C.condLibrary = Just converted } + A.NamedLibrary n -> gpd { C.condSubLibraries = C.condSubLibraries gpd ++ [(componentName n, converted)] } + A.Executable name -> do + converted <- convertTree (executable (componentName name)) tree + pure gpd { C.condExecutables = C.condExecutables gpd ++ [(componentName name, converted)] } + A.ForeignLibrary name -> do + converted <- convertTree (foreignLibrary (componentName name)) tree + pure gpd { C.condForeignLibs = C.condForeignLibs gpd ++ [(componentName name, converted)] } + A.TestSuite name -> do + converted <- convertTree testSuite tree + pure gpd { C.condTestSuites = C.condTestSuites gpd ++ [(componentName name, converted)] } + A.Benchmark name -> do + converted <- convertTree benchmark tree + pure gpd { C.condBenchmarks = C.condBenchmarks gpd ++ [(componentName name, converted)] } + where + componentName = C.mkUnqualComponentName . T.unpack + library name bi = do + raw <- fields spec (C.libraryFieldGrammar name) (A.extraFields bi) + info <- convertBuildInfo (C.libBuildInfo raw) bi + exposed <- traverse atom (A.exposedModules bi) + pure raw { C.libBuildInfo = info, C.exposedModules = exposed } + executable name bi = do + raw <- fields spec (C.executableFieldGrammar name) (A.extraFields bi) + info <- convertBuildInfo (C.buildInfo raw) bi + pure raw { C.buildInfo = info, C.modulePath = path (fromMaybe "" (A.mainIs bi)) } + foreignLibrary name bi = do + raw <- fields spec (C.foreignLibFieldGrammar name) (A.extraFields bi) + info <- convertBuildInfo (C.foreignLibBuildInfo raw) bi + pure raw { C.foreignLibBuildInfo = info } + testSuite bi = do + raw <- fields spec C.testSuiteFieldGrammar (A.extraFields bi) + info <- convertBuildInfo (C._testStanzaBuildInfo raw) bi + result (C.validateTestSuite spec C.zeroPos raw + { C._testStanzaBuildInfo = info, C._testStanzaMainIs = path <$> A.mainIs bi }) + benchmark bi = do + raw <- fields spec C.benchmarkFieldGrammar (A.extraFields bi) + info <- convertBuildInfo (C._benchmarkStanzaBuildInfo raw) bi + result (C.validateBenchmark spec C.zeroPos raw + { C._benchmarkStanzaBuildInfo = info, C._benchmarkStanzaMainIs = path <$> A.mainIs bi }) + result = either (Left . show) Right . snd . runResult diff --git a/test/Compliance/Compare.hs b/test/Compliance/Compare.hs new file mode 100644 --- /dev/null +++ b/test/Compliance/Compare.hs @@ -0,0 +1,63 @@ +module Compliance.Compare + ( Outcome (..), Comparison (..), compareBytes, comparePackage, outcomeName ) where + +import qualified Data.ByteString as BS +import qualified Aihc.Cabal as A +import Compliance.Adapter (runResult, toCabal) +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.Parsec as C + +data Outcome = Match | Mismatch | ParserError | ReferenceError | BothRejected | ConversionError + deriving (Eq, Ord, Show, Enum, Bounded) + +data Comparison = Comparison + { outcome :: Outcome + , parserAccepted :: Bool + , referenceAccepted :: Bool + , parserWarnings :: Int + , referenceWarnings :: Int + , detail :: String + } deriving (Eq, Show) + +outcomeName :: Outcome -> String +outcomeName value = case value of + Match -> "match" + Mismatch -> "mismatch" + ParserError -> "parser_error" + ReferenceError -> "reference_error" + BothRejected -> "both_rejected" + ConversionError -> "conversion_error" + +compareBytes :: BS.ByteString -> Comparison +compareBytes bytes = case (A.parseValue ours, reference) of + (Left errors, Left refErrors) -> report BothRejected False False (show errors ++ "\n" ++ show refErrors) + (Left errors, Right _) -> report ParserError False True (show errors) + (Right _, Left errors) -> report ReferenceError True False (show errors) + (Right pkg, Right ref) -> let (status, message) = comparePackage pkg ref + in report status True True message + where + ours = A.parsePackage bytes + (warnings, reference) = runResult (C.parseGenericPackageDescription bytes) + report status accepted refAccepted message = Comparison status accepted refAccepted + (length (A.parseWarnings ours)) (length warnings) message + +comparePackage :: A.Package -> C.GenericPackageDescription -> (Outcome, String) +comparePackage pkg reference = case toCabal pkg of + Left errors -> (ConversionError, errors) + Right converted + | converted == reference -> (Match, "") + | otherwise -> (Mismatch, "Different fields: " ++ show (differences converted reference)) + +-- These labels explain failures. Equality always uses the complete value. +differences :: C.GenericPackageDescription -> C.GenericPackageDescription -> [String] +differences a b = [name | (name, different) <- + [ ("packageDescription", C.packageDescription a /= C.packageDescription b) + , ("gpdScannedVersion", C.gpdScannedVersion a /= C.gpdScannedVersion b) + , ("genPackageFlags", C.genPackageFlags a /= C.genPackageFlags b) + , ("condLibrary", C.condLibrary a /= C.condLibrary b) + , ("condSubLibraries", C.condSubLibraries a /= C.condSubLibraries b) + , ("condForeignLibs", C.condForeignLibs a /= C.condForeignLibs b) + , ("condExecutables", C.condExecutables a /= C.condExecutables b) + , ("condTestSuites", C.condTestSuites a /= C.condTestSuites b) + , ("condBenchmarks", C.condBenchmarks a /= C.condBenchmarks b) + ], different] diff --git a/test/Compliance/Tests.hs b/test/Compliance/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Compliance/Tests.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} +module Compliance.Tests (testCompliance) where + +import Control.Monad (forM_, unless) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Aihc.Cabal as A +import Compliance.Adapter (runResult, toCabal) +import Compliance.Compare +import qualified Distribution.PackageDescription.Parsec as C + +assert :: String -> Bool -> IO () +assert label success = unless success (fail label) + +header :: BS.ByteString +header = "cabal-version: 3.0\nname: sample\nversion: 1.0\n" + +value :: Text -> A.FieldValue +value text = A.FieldValue (A.Position 1 1) [A.FieldLine (A.Position 1 1) text] + +testCompliance :: IO () +testCompliance = do + forM_ ["1.0", "1.2", "1.4", "1.6", "1.8"] $ \spec -> + forM_ ["", ">="] $ \prefix -> do + let bytes = "cabal-version: " <> prefix <> spec + <> "\nname: sample\nversion: 1\nbuild-type: Simple\nlibrary\n exposed-modules: Sample\n build-depends: base >=3 && <5\n" + assert ("Compare older format " ++ BSC.unpack (prefix <> spec)) + (outcome (compareBytes bytes) == Match) + forM_ + [ "synopsis: Sample text \nauthor: A. Person \nhomepage: https://example.com/ \ndescription: First line \n Second line \nlibrary \n exposed-modules: Sample\n" + , "library\n exposed-modules: Sample\n build-depends: base >=4 && <5\n" + , "synopsis: Sample text \r\n \r\nlibrary \r\n -- A comment\r\n exposed-modules: Sample \r\n" + , "library\n" + , "library\n -- No fields\n" + , "flag fast\nlibrary\n if flag(fast)\n else\n cpp-options: -DSLOW\n" + , "library\n if True\n cpp-options: -DFAST\n else\n" + , "library\n if True\n else\n other-modules: Sample\n" + , "library\n if True\n if False\n else\n else\n cpp-options: -DSLOW\n" + , "common shared\nlibrary\n import: shared\n" + , "library internal\nlibrary\nexecutable tool\n main-is: Main.hs\n" + , "executable tool\n" + , "flag fast\n default: False\nlibrary\n if flag(fast)\n cpp-options: -DFAST\n else\n buildable: False\n" + , "common shared\n hs-source-dirs: src\n ghc-options: -Wall\nlibrary\n import: shared\n" + , "library internal\n exposed-modules: Internal\nexecutable tool\n main-is: Main.hs\n build-depends: sample:internal\n" + , "test-suite tests\n type: exitcode-stdio-1.0\n main-is: Test.hs\nbenchmark bench\n type: exitcode-stdio-1.0\n main-is: Bench.hs\n" + , "foreign-library native\n type: native-shared\n options: standalone\n c-sources: native.c\n" + , "synopsis: A sample\nauthor: A. Person\nlibrary\n extra-libraries: z\n x-example: retained\n" + , "source-repository head\n type: git\n location: https://example.com/sample\nlibrary\n buildable: True\n" + , "source-repository head\n type: cvs\n location: example.com:/source\n module: sample\n branch: main\nsource-repository this\n type: git\n location: https://example.com/sample\n tag: v1.0\n subdir: \"source files\"\nsource-repository head\n type: darcs\n location: https://example.com/mirror\n" + , "source-repository head\n type: hg\n location: https://example.com/first\n location: https://example.com/second\n x-note: first\n second\n" + , "source-repository future\n type: future\n" + , "source-repository HEAD\n type: GIT\n location: https://example.com/sample\n" + , "source-repository head\n type: git\n location: https://example.com/sample\n subdir:\n" + , "flag fast\n description: Use fast code\nlibrary\n buildable: True\n" + , "flag fast\n description: First line\n second line\n .\n Last line\n default: False\n manual: True\n" + , "flag fast\n description:\nflag slow\n description: \"Use slow code\"\n" + , "description:\n First line\n Second line\nflag fast\n description:\n First line\n Second line\n" + , "description: First line\n\n Indented line\n .\n Last line\nlibrary\n" + , "build-type: Custom\ncustom-setup\n setup-depends: base, Cabal\nlibrary\n buildable: True\n" + , "library { exposed-modules: Sample }\n" + , "library\n {\n exposed-modules: Sample\n }\n if os(linux) {\n cpp-options: -DLINUX\n } else {\n cpp-options: -DOTHER\n }\n" + , "library\n\tbuildable: True\n\texposed-modules: Sample\n" + , "library\n buildable: True\n other-modules: Sample\n" + , "Synopsis : Text\nlibrary\n Default-Language : Haskell2010\n" + , "library\n else\n buildable: False\n" + , "library\n other-modules: Sample\n import: missing\n" + , "unknown-section\n field: value\nlibrary\n" + , "library\n build-depends: base, base >=4\n hs-source-dirs: src src\n" + , "common one\n build-depends: base\n hs-source-dirs: src\n frameworks: A\nlibrary\n import: one\n build-depends: base\n hs-source-dirs: src\n frameworks: A\n" + , "common one\n exposed-modules: Lost\n visibility: public\n x-a: 1\nlibrary\n import: one\n x-b: 2\n exposed-modules: Sample\n" + , "library\n x-b: 2\n x-a: 1\n x-b: 3\n" + , "library\n mixins: base hiding (Prelude), containers (Data.Map as Map) requires (Sig as Impl)\n" + , "library\n default-language: Haskell98\n default-language: Haskell2010\n buildable: False\n buildable: True\n" + , "library\n build-depends:\n , base\n , containers\n other-modules:\n , A\n , B\n" + , "flag Fast\n default: false\nlibrary\n if flag(FAST) || !impl(ghc >= 9.0) && os(Linux)\n buildable: False\n if impl(ghc == 9.*) || impl(ghc >= 7 && < 8) || true\n buildable: True\n" + , "library\n if arch(x86_64)\n buildable: False\n elif os(windows)\n buildable: False\n else\n buildable: True\n" + , "library\r exposed-modules: Sample\r other-modules: Other\r" + , "library\n -- comment\n exposed-modules:\n Sample\n -- comment\n\n Other\n" + , "library\n build-depends: base >=4 && <5 || ==3.* , text ^>=2.0\n" + ] $ \body -> do + let result = compareBytes (header <> body) + assert ("Expected equal structures: " ++ show result ++ "\n" ++ BSC.unpack body) (outcome result == Match) + forM_ ["1.10", "2.0"] $ \spec -> + forM_ + [ " extensions: CPP, ForeignFunctionInterface\n" + , " extensions: CPP\n default-extensions: OverloadedStrings\n" + , " default-extensions: CPP\n extensions: CPP\n" + , " extensions: CPP\n if os(linux)\n extensions: ForeignFunctionInterface\n" + ] $ \body -> do + let bytes = "cabal-version: " <> spec <> "\nname: sample\nversion: 1\nbuild-type: Simple\nlibrary\n" <> body + assert ("Keep extension field values: " ++ show (compareBytes bytes) ++ BSC.unpack bytes) + (outcome (compareBytes bytes) == Match) + forM_ + [ "^>=1", "^>=1.2.3", "^>={1.2,2.3,3.4}" + , ">=1 && <2 && >1.1", "==1 || ==2 || ==3" + , "(==1 || ==2) || ==3", "^>=1.2 && (<1.3 || ==2)" + ] $ \range -> do + let bytes = header <> "library\n build-depends: base " <> range <> "\n" + assert ("Keep version range structure: " ++ BSC.unpack range) + (outcome (compareBytes bytes) == Match) + let extensionBytes = "cabal-version: 2.2\nname: sample\nversion: 1\nbuild-type: Simple\ncommon shared\n extensions: CPP\nlibrary\n import: shared\n default-extensions: OverloadedStrings\n" + extensionPackage <- either (fail . show) pure (A.parseValue (A.parsePackage extensionBytes)) + extensionReference <- either (fail . show) pure + (snd (runResult (C.parseGenericPackageDescription extensionBytes))) + assert "Convert imported older extensions" + (fst (comparePackage extensionPackage extensionReference) == Match) + let changedExtensions = extensionPackage { A.packageComponents = + [component { A.componentData = tree { A.unconditional = + (A.unconditional tree) { A.legacyExtensions = ["BangPatterns"] } } } + | component <- A.packageComponents extensionPackage, let tree = A.componentData component] } + assert "Use older extensions from the AST" + (fst (comparePackage changedExtensions extensionReference) == Mismatch) + forM_ ["==1 || ==2 || ==3", ">=1 && <3 && >1.1", "(==1 || ==2) || ==3"] $ \range -> do + let bytes = header <> "library\n if impl(ghc " <> range <> ")\n buildable: False\n" + assert "Keep compiler range structure" (outcome (compareBytes bytes) == Match) + let toolBytes = header <> "library\n build-tool-depends: alex:alex ^>=3.2.4\n if impl(ghc ^>=9.2)\n buildable: False\n" + assert "Keep tool and compiler major bounds" (outcome (compareBytes toolBytes) == Match) + forM_ + [ (">=1.10", "name: old\nversion: 1\nexposed-modules: Old\nbuild-depends: base\nexecutable: tool\nmain-is: Main.hs\n") + , (">=1.10", "name: old\nversion: 1\nbuild-type: Default\nlibrary\n cxx-sources: a.cpp\n autogen-modules: A\n default-language: Haskell2010\n") + , (">=1.10", "name: old\nversion: 1\nlibrary\n build-depends: sub\n mixins: sub\nlibrary sub\n") + , (">=1.10", "name: old\nversion: 1\nlibrary\n if os(linux)\n buildable: False\n elif os(osx)\n buildable: False\n") + , (">=1.2", "name: old\nversion: 1\ndescription: First\n .\n Second\nlibrary\n default-language: Haskell2010\n") + , ("3.0", "name: old\nversion: 1\nlibrary\n build-depends: sub, sub:{sub, other}\n mixins: sub\nlibrary sub\nlibrary other\n") + , ("2.2", "name: old\nversion: 1\ncommon one\n build-depends: base\nlibrary\n import: one\n if os(linux)\n import: one\n") + , (">=0.9", "name: old\nversion: 1\n") + ] $ \(spec, body) -> do + let bytes = "cabal-version: " <> spec <> "\n" <> body + result = compareBytes bytes + assert ("Expected equal structures for an older format: " ++ show result ++ "\n" ++ BSC.unpack bytes) (outcome result == Match) + let setupBytes = header <> "build-type: Custom\ncustom-setup\n setup-depends: base, Cabal\nlibrary\n buildable: True\n" + setupPackage <- either (fail . show) pure (A.parseValue (A.parsePackage setupBytes)) + setupReference <- either (fail . show) pure (snd (runResult (C.parseGenericPackageDescription setupBytes))) + assert "Lost data must fail equality" + (fst (comparePackage setupPackage { A.packageSetupDependencies = Nothing } setupReference) == Mismatch) + assert "Both parsers reject invalid input" (outcome (compareBytes "not a package") == BothRejected) + assert "Count a reference parse error" (outcome (compareBytes (header <> "test-suite bad\n type: exitcode-stdio-1.0\n")) == ReferenceError) + let bytes = header <> "library\n exposed-modules: Sample\n" + pkg <- either (fail . show) pure (A.parseValue (A.parsePackage bytes)) + ref <- either (fail . show) pure (snd (runResult (C.parseGenericPackageDescription bytes))) + let changed = pkg { A.packageName = "changed" } + assert "Use the typed AST instead of the original name field" (fst (comparePackage changed ref) == Mismatch) + let oldSpelling = pkg { A.packageFields = Map.insert "version" [value "1.00"] (A.packageFields pkg) } + assert "Convert typed versions without reading the old spelling" (fst (comparePackage oldSpelling ref) == Match) + let changedModule = pkg { A.packageComponents = + [A.Component (A.Library A.MainLibrary) (A.Conditional + (A.emptyBuildInfo { A.exposedModules = ["Changed"] }) [])] } + assert "Compare component fields" (fst (comparePackage changedModule ref) == Mismatch) + let invalid = pkg { A.packageComponents = + [A.Component (A.Library A.MainLibrary) (A.Conditional + (A.emptyBuildInfo { A.defaultLanguage = Just "invalid language" }) [])] } + assert "Count conversion errors" (fst (comparePackage invalid ref) == ConversionError) + let metadata = pkg { A.packageFields = Map.insert "synopsis" [value "Changed"] (A.packageFields pkg) } + assert "Convert retained metadata" (fst (comparePackage metadata ref) == Mismatch) + let repositoryBytes = header <> "source-repository head\n type: git\n location: https://example.com/sample\n" + repositoryPackage <- either (fail . show) pure (A.parseValue (A.parsePackage repositoryBytes)) + repositoryReference <- either (fail . show) pure + (snd (runResult (C.parseGenericPackageDescription repositoryBytes))) + let changedRepository = repositoryPackage { A.packageSourceRepositories = + [A.SourceRepository "this" (Map.fromList [("type", [value "git"]), ("tag", [value "v1.0"])])] } + assert "Compare repository data" + (fst (comparePackage changedRepository repositoryReference) == Mismatch) + let removedRepository = repositoryPackage { A.packageSourceRepositories = [] } + assert "Detect a missing repository" + (fst (comparePackage removedRepository repositoryReference) == Mismatch) + converted <- either fail pure (toCabal pkg) + assert "Full Cabal equality" (converted == ref) + forM_ ["1.10", "2.0", "3.0"] $ \spec -> do + let flagBytes = "cabal-version: " <> spec <> "\nname: sample\nversion: 1\nbuild-type: Simple\nflag fast\n description: First line\n second line\n .\n Last line\n default: False\n manual: True\n" + flagPackage <- either (fail . show) pure (A.parseValue (A.parsePackage flagBytes)) + flagReference <- either (fail . show) pure + (snd (runResult (C.parseGenericPackageDescription flagBytes))) + let expected = if spec == "3.0" then "First line\nsecond line\n.\nLast line" else "First line\nsecond line\n\nLast line" + assert "Keep flag description text" + (A.packageFlags flagPackage == [A.Flag "fast" False True expected]) + assert "Compare flag descriptions" (fst (comparePackage flagPackage flagReference) == Match) + let changedFlag = flagPackage { A.packageFlags = + [f { A.flagDescription = "Changed" } | f <- A.packageFlags flagPackage] } + assert "Use flag descriptions from the AST" + (fst (comparePackage changedFlag flagReference) == Mismatch) diff --git a/test/Hackage.hs b/test/Hackage.hs new file mode 100644 --- /dev/null +++ b/test/Hackage.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Codec.Archive.Tar as Tar +import Control.Exception (AsyncException, SomeException, evaluate, fromException, tryJust) +import Control.Monad (unless, when) +import Data.Aeson (Value, encode, object, (.=)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as Map +import Data.List (isSuffixOf) +import System.Directory (createDirectory) +import System.Environment (getArgs) +import System.FilePath (()) +import System.IO (Handle, IOMode (..), hPutStrLn, stderr, withBinaryFile) +import Compliance.Compare +import Compliance.Tests (testCompliance) + +data Counts = Counts + { total :: !Int + , accepted :: !Int + , refAccepted :: !Int + , warned :: !Int + , refWarned :: !Int + , outcomes :: !(Map.Map String Int) + } + +emptyCounts :: Counts +emptyCounts = Counts 0 0 0 0 0 (Map.fromList + ([(outcomeName status, 0) | status <- [minBound .. maxBound]] ++ [("exception", 0)])) + +summary :: Counts -> Value +summary counts = object + [ "reference" .= ("Cabal-syntax" :: String) + , "reference_version" .= (VERSION_Cabal_syntax :: String) + , "total" .= total counts + , "parser_accepted" .= accepted counts + , "reference_accepted" .= refAccepted counts + , "parser_with_warnings" .= warned counts + , "reference_with_warnings" .= refWarned counts + , "outcomes" .= outcomes counts + ] + +record :: Handle -> Value -> IO () +record handle value = LBS.hPut handle (encode value <> "\n") + +classify :: BS.ByteString -> IO (Either SomeException Comparison) +classify bytes = tryJust synchronous $ do + let comparison = compareBytes bytes + _ <- evaluate (length (show comparison)) + pure comparison + where + synchronous err = case fromException err :: Maybe AsyncException of + Just _ -> Nothing + Nothing -> Just err + +main :: IO () +main = do + args <- getArgs + case args of + [] -> testCompliance + ["--file", path] -> do + result <- BS.readFile path >>= classify + LBS.putStr (encode (case result of + Left err -> object ["status" .= ("exception" :: String), "detail" .= show err] + Right comparison -> comparisonJSON comparison) <> "\n") + [index, destination] -> do + -- Refuse to overwrite an earlier report. + createDirectory destination + counts <- withBinaryFile index ReadMode $ \source -> + withBinaryFile (destination "failures.jsonl") WriteMode $ \report -> do + bytes <- LBS.hGetContents source + walk report Map.empty emptyCounts (Tar.read bytes) + unless (total counts > 0) (fail "The index has no Cabal files") + LBS.writeFile (destination "summary.json") (encode (summary counts) <> "\n") + LBS.putStr (encode (summary counts) <> "\n") + _ -> fail "Use: hackage-compliance INDEX.tar REPORT-DIRECTORY, or --file FILE.cabal" + +comparisonJSON :: Comparison -> Value +comparisonJSON result = object + [ "status" .= outcomeName (outcome result) + , "parser_accepted" .= parserAccepted result + , "reference_accepted" .= referenceAccepted result + , "parser_warnings" .= parserWarnings result + , "reference_warnings" .= referenceWarnings result + , "detail" .= take 2000 (detail result) + ] + +walk :: Handle -> Map.Map FilePath Int -> Counts -> Tar.Entries Tar.FormatError -> IO Counts +walk _ _ counts Tar.Done = pure counts +walk _ _ _ (Tar.Fail err) = fail (show err) +walk report revisions counts (Tar.Next entry remaining) + | not (".cabal" `isSuffixOf` path) = walk report revisions counts remaining + | otherwise = case Tar.entryContent entry of + Tar.NormalFile bytes _ -> do + let revision = Map.findWithDefault 0 path revisions + revisions' = Map.insert path (revision + 1) revisions + result <- classify (LBS.toStrict bytes) + let (status, ours, reference, oursWarnings, refWarningsCount, details) = case result of + Left err -> ("exception", False, False, 0, 0, object ["detail" .= take 2000 (show err)]) + Right comparison -> (outcomeName (outcome comparison), parserAccepted comparison, + referenceAccepted comparison, parserWarnings comparison, referenceWarnings comparison, + comparisonJSON comparison) + counts' = Counts (total counts + 1) + (accepted counts + fromEnum ours) (refAccepted counts + fromEnum reference) + (warned counts + fromEnum (oursWarnings > 0)) (refWarned counts + fromEnum (refWarningsCount > 0)) + (Map.insertWith (+) status 1 (outcomes counts)) + when (status /= "match") $ record report $ object + [ "path" .= path, "revision" .= revision, "status" .= status, "result" .= details ] + when (total counts' `mod` 10000 == 0) (hPutStrLn stderr ("Compared " ++ show (total counts') ++ " files")) + walk report revisions' counts' remaining + _ -> fail ("Invalid Cabal entry: " ++ path) + where path = Tar.entryPath entry diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Monad (forM_, unless) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Aihc.Cabal +import qualified Distribution.Fields.ParseResult as C +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.Parsec as C +import qualified Distribution.Parsec as C +import qualified Distribution.Pretty as C +import qualified Distribution.Types.Version as C +import qualified Distribution.Types.VersionRange as C +import qualified Distribution.Utils.Path as C + +assert :: (Eq a, Show a) => String -> a -> a -> IO () +assert label expected actual = unless (expected == actual) + (fail (label ++ "\nExpected: " ++ show expected ++ "\nActual: " ++ show actual)) + +right :: Show e => Either e a -> IO a +right = either (fail . show) pure + +-- | Run a Cabal-syntax parser without a source name. The results keep the +-- error and warning format of Cabal-syntax 3.12. +runResult :: C.ParseResult () a + -> ([C.PWarning], Either (Maybe C.Version, NonEmpty C.PError) a) +runResult result = case C.runParseResult result of + (warnings, outcome) -> (map C.pwarning warnings, either (Left . fmap (fmap C.perror)) Right outcome) + +parse :: BSC.ByteString -> IO Package +parse = right . parseValue . parsePackage + +version :: Text -> Version +version = either (error . T.unpack) id . parseVersion + +environment :: Environment +environment = Environment "linux" "x86_64" "ghc" (version "9.12.2") + +resolve :: FlagAssignment -> Package -> IO [Component BuildInfo] +resolve flags pkg = pure (resolvedComponents (resolvePackage environment flags pkg)) + +header :: [String] +header = ["cabal-version: 3.0", "name: sample", "version: 1.2.3"] + +fixture :: BSC.ByteString +fixture = BSC.unlines (map BSC.pack (header ++ + [ "flag fast", " default: True", " manual: False" + , "common shared", " hs-source-dirs: src", " default-language: Haskell2010" + , " build-depends: base >=4.16 && <5" + , " cpp-options: -DROOT" + , " if flag(fast)", " cpp-options: -DFAST" + , "common native", " import: shared", " c-sources: cbits/a.c" + , " cxx-sources: cbits/b.cpp", " include-dirs: include", " install-includes: api.h" + , " autogen-includes: config.h", " cc-options: -std=c11", " cxx-options: -std=c++17" + , "library", " import: native", " exposed-modules: Sample" + , " other-modules: Sample.Internal", " autogen-modules: Paths_sample" + , " default-extensions: CPP, OverloadedStrings" + , " ghc-options: -F -pgmFtrhsx -optP-DPAIR=1,2" + , " x-aihc-lir-sources: lir/a.lir lir/b.lir" + , " build-depends: sample:internal, containers ^>=0.7" + , " build-tool-depends: alex:alex >=3.2" + , " if os(linux) && impl(ghc >=9.10) && flag(fast)" + , " exposed-modules: Sample.Fast", " cpp-options: -DSELECTED", " hs-source-dirs: src", " other-modules: Sample.Internal", " default-extensions: CPP" + , " if arch(x86_64)", " other-modules: Sample.X86" + , " else", " exposed-modules: Sample.Slow", " buildable: False" + , "library internal", " exposed-modules: Internal", " build-depends: base" + , "executable sample-tool", " main-is: Main.hs", " build-depends: internal" + , "test-suite tests", " type: exitcode-stdio-1.0", " main-is: Tests.hs" + , " build-depends: sample, base" + , "benchmark bench", " type: exitcode-stdio-1.0", " main-is: Bench.hs" + , "foreign-library native-lib", " type: native-shared", " build-tool-depends: hsc2hs:hsc2hs" + ])) + +main :: IO () +main = do + testVersions + testPackage + testConsumers + testDefaults + testEmptySections + testLegacy + testSourceRepositories + testBuildInfo + testConditionalSpelling + testElif + testImportCommas + testInternalLibraryNames + testRetainedFields + testOlderToolDependencies + testRepeatedPackageFields + testNewFormatVersions + testErrors + putStrLn "All parser checks passed" + +testVersions :: IO () +testVersions = do + forM_ ["0", "0.0", "1", "1.2", "1.2.0", "1.2.3", "1.3", "2", "2.0", "4.18", "9.12.2"] $ \v -> + assert "Version round trip" (Right (version v)) (parseVersion (renderVersion (version v))) + forM_ ["-any", "-none", "==1.2", "==1.2.*", ">=1.2 && <2", "^>=1.2.3", "^>=1", "^>=0.0.3", ">=1 && <3 && >1.2", "==1 || ==2 || ==3", "=={1.2,2.3}", "^>={1.2,2.3}", "<=1.2 || >2", "(>=1 && <2) || ==3"] $ \input -> do + range <- right (parseVersionRange input) + ref <- case input of + "-any" -> pure C.anyVersion + "-none" -> pure C.noVersion + _ -> maybe (fail ("Reference range parse failed: " ++ T.unpack input)) pure (C.simpleParsec (T.unpack input) :: Maybe C.VersionRange) + forM_ [[0], [0,0,3], [0,1], [1], [1,0], [1,1], [1,2], [1,2,0], [1,2,3], [1,2,4], [1,3], [2], [2,0], [3], [4,18]] $ \ns -> do + v <- maybe (fail "Invalid test version") pure (mkVersion (map toInteger ns)) + assert ("Range membership: " ++ T.unpack input ++ " " ++ show ns) + (C.withinRange (C.mkVersion ns) ref) (withinRange v range) + parsed <- right (parseVersionRange (renderVersionRange range)) + assert "Range round trip" range parsed + assert "Version ordering" True (version "1.2" < version "1.2.0") + assert "Negative version" Nothing (mkVersion [-1]) + assert "Empty version" Nothing (mkVersion []) + forM_ [(">=1.2 && <1.3 || ==2.0", ">=1.2 && <1.3 || ==2.0"), ("(>=1 && <2) || ==3", ">=1 && <2 || ==3"), ("^>=1.2 && (<1.3 || ==2)", "^>=1.2 && (<1.3 || ==2)"), ("(==1 || ==2) || ==3", "(==1 || ==2) || ==3"), ("(>=1 && <2) && >1.1", "(>=1 && <2) && >1.1"), ("-any", "-any"), ("-none", "<0")] $ \(input, expected) -> do + range <- right (parseVersionRange input) + assert ("Range rendering: " ++ T.unpack input) expected (renderVersionRange range) + forM_ ["", "1.", "-1", "1..2", "1a", "1.2 trailing"] $ \input -> + case parseVersion input of + Left _ -> pure () + Right _ -> fail "Invalid version accepted" + forM_ ["==", ">=1 trailing", "==1.*.*", "<1 &&", "1.2"] $ \input -> + case parseVersionRange input of + Left _ -> pure () + Right _ -> fail "Invalid range accepted" + +testPackage :: IO () +testPackage = do + pkg <- parse fixture + ref <- right (snd (runResult (C.parseGenericPackageDescription fixture))) + assert "Package name" "sample" (packageName pkg) + assert "No warnings for a file without patches" [] (parseWarnings (parsePackage fixture)) + assert "Component count" 6 (length (packageComponents pkg)) + assert "Flag declarations" [Flag "fast" True False ""] (packageFlags pkg) + forM_ [True, False] $ \fast -> do + cs <- resolve (Map.singleton "fast" fast) pkg + bi <- case cs of Component (Library MainLibrary) b:_ -> pure b; _ -> fail "Missing library" + tree <- maybe (fail "Missing reference library") pure (C.condLibrary ref) + let selected = collect fast tree + cbi = mconcat (map C.libBuildInfo selected) + assert "Buildable" (Just (C.buildable cbi)) (buildable bi) + assert "Source directories" (map C.getSymbolicPath (C.hsSourceDirs cbi)) (sourceDirs bi) + assert "Exposed modules" (map (T.pack . C.prettyShow) (concatMap C.exposedModules selected)) (exposedModules bi) + assert "Other modules" (map (T.pack . C.prettyShow) (C.otherModules cbi)) (otherModules bi) + assert "Generated modules" (map (T.pack . C.prettyShow) (C.autogenModules cbi)) (autogenModules bi) + assert "Language" (T.pack . C.prettyShow <$> C.defaultLanguage cbi) (defaultLanguage bi) + assert "Extensions" (map (T.pack . C.prettyShow) (C.defaultExtensions cbi)) (extensions bi) + assert "CPP options" (map T.pack (C.cppOptions cbi)) (cppOptions bi) + assert "C sources" (map C.getSymbolicPath (C.cSources cbi)) (cSources bi) + assert "C++ sources" (map C.getSymbolicPath (C.cxxSources cbi)) (cxxSources bi) + assert "C options" (map T.pack (C.ccOptions cbi)) (ccOptions bi) + assert "C++ options" (map T.pack (C.cxxOptions cbi)) (cxxOptions bi) + assert "Include directories" (map C.getSymbolicPath (C.includeDirs cbi)) (includeDirs bi) + assert "Public headers" (map C.getSymbolicPath (C.installIncludes cbi)) (installIncludes bi) + assert "Generated headers" (map C.getSymbolicPath (C.autogenIncludes cbi)) (autogenIncludes bi) + assert "Option commas" ["-F", "-pgmFtrhsx", "-optP-DPAIR=1,2"] (ghcOptions bi) + assert "Custom fields" (Just ["lir/a.lir lir/b.lir"]) (map fieldText <$> Map.lookup "x-aihc-lir-sources" (extraFields bi)) + assert "Dependency names" ["base", "sample", "containers"] (map dependencyPackage (dependencies bi)) + assert "Named dependency" (NamedLibrary "internal" :| []) (dependencyLibraries (dependencies bi !! 1)) + assert "Build tools" ["alex"] (map toolName (buildTools bi)) + assert "Tool packages" [Just "alex"] (map toolPackage (buildTools bi)) + let exe = componentData (cs !! 2) + assert "Legacy internal dependency" ["sample"] (map dependencyPackage (dependencies exe)) + assert "Legacy internal target" [NamedLibrary "internal" :| []] (map dependencyLibraries (dependencies exe)) + where + collect fast (C.CondNode a bs) = a : concatMap branch bs + where + branch (C.CondBranch c t e) = if eval c then collect fast t else maybe [] (collect fast) e + eval c = case c of + C.Lit b -> b + C.Var (C.PackageFlag _) -> fast + C.Var (C.OS os) -> C.prettyShow os == "linux" + C.Var (C.Arch arch) -> C.prettyShow arch == "x86_64" + C.Var (C.Impl flavor range) -> C.prettyShow flavor == "ghc" && C.withinRange (C.mkVersion [9,12,2]) range + C.CNot a' -> not (eval a') + C.CAnd a' b -> eval a' && eval b + C.COr a' b -> eval a' || eval b + +testConsumers :: IO () +testConsumers = forM_ ["aihc-hackage", "aihc-package-plan", "aihc-haddock"] $ \pkgName -> do + input <- BSC.readFile ("test/fixtures/" ++ pkgName ++ ".cabal") + pkg <- parse input + ref <- right (snd (runResult (C.parseGenericPackageDescription input))) + components <- resolve Map.empty pkg + assert "Consumer package name" (T.pack pkgName) (packageName pkg) + bi <- case components of + Component (Library MainLibrary) b:_ -> pure b + _ -> fail "Missing consumer library" + library <- maybe (fail "Missing reference library") (pure . C.condTreeData) (C.condLibrary ref) + let cbi = C.libBuildInfo library + assert "Consumer modules" (map (T.pack . C.prettyShow) (C.exposedModules library)) (exposedModules bi) + assert "Consumer source directories" (map C.getSymbolicPath (C.hsSourceDirs cbi)) (sourceDirs bi) + assert "Consumer language" (T.pack . C.prettyShow <$> C.defaultLanguage cbi) (defaultLanguage bi) + assert "Consumer dependency count" (length (C.targetBuildDepends cbi)) (length (dependencies bi)) + +testDefaults :: IO () +testDefaults = do + pkg <- parse (BSC.unlines (map BSC.pack (header ++ + ["flag chosen", " default: False", "library", " if !flag(chosen)", " hs-source-dirs: generated", " default-language: Haskell2010", " else", " buildable: False"]))) + [Component _ bi] <- resolve Map.empty pkg + assert "Branch directory excludes default" ["generated"] (sourceDirs bi) + assert "Branch language" (Just "Haskell2010") (defaultLanguage bi) + assert "Buildable default" (Just True) (buildable bi) + [Component _ other] <- resolve (Map.singleton "chosen" True) pkg + assert "Default directory" ["."] (sourceDirs other) + assert "Absent language stays absent" Nothing (defaultLanguage other) + assert "Buildable branch" (Just False) (buildable other) + assert "Unknown override has no effect" (Map.singleton "chosen" False) + (resolvedFlags (resolvePackage environment (Map.singleton "missing" True) pkg)) + quoted <- parse (BSC.unlines (map BSC.pack (header ++ ["library", " hs-source-dirs: \"source files\"", " cpp-options: \"-DNAME=hello world\"", " buildable: False", " if True", " buildable: True"]))) + [Component _ q] <- resolve Map.empty quoted + assert "Quoted path" ["source files"] (sourceDirs q) + assert "Quoted option" ["-DNAME=hello world"] (cppOptions q) + assert "Buildable conjunction" (Just False) (buildable q) + +testEmptySections :: IO () +testEmptySections = do + pkg <- parse "cabal-version: 3.0\nname: sample\nversion: 1\nflag fast\ncommon shared\nlibrary\n import: shared\n if flag(fast)\n else\n cpp-options: -DSLOW\n ghc-options: -Wall\nexecutable tool\n" + assert "Empty flag defaults" [Flag "fast" True False ""] (packageFlags pkg) + assert "Keep empty sections and branch boundaries" + [ Component (Library MainLibrary) (Conditional + (emptyBuildInfo { ghcOptions = ["-Wall"] }) + [Branch (FlagValue "fast") (Conditional emptyBuildInfo []) + (Just (Conditional (emptyBuildInfo { cppOptions = ["-DSLOW"] }) []))]) + , Component (Executable "tool") (Conditional emptyBuildInfo []) + ] (packageComponents pkg) + forM_ [True, False] $ \fast -> do + components <- resolve (Map.singleton "fast" fast) pkg + info <- case components of + Component (Library MainLibrary) bi : _ -> pure bi + _ -> fail "Missing library" + assert "Select an empty branch" (if fast then [] else ["-DSLOW"]) (cppOptions info) + assert "Keep fields after an empty branch" ["-Wall"] (ghcOptions info) + +testLegacy :: IO () +testLegacy = do + forM_ ["1.0", "1.2", "1.4", "1.6", "1.8"] $ \spec -> do + older <- parse ("cabal-version: >=" <> TE.encodeUtf8 spec + <> "\nname: sample\nversion: 1\nlibrary\n exposed-modules: Sample\n") + assert "Keep the older format version" (version spec) (cabalVersion older) + assert "Keep the older library modules" [["Sample"]] + (map (exposedModules . unconditional . componentData) (packageComponents older)) + let input = "cabal-version: >=1.10\nname: legacy\nversion: 1\nlibrary\n extensions: CPP\n build-tools: happy >=1.20\n" + pkg <- parse input + _ <- right (snd (runResult (C.parseGenericPackageDescription input))) + [Component _ bi] <- resolve Map.empty pkg + assert "Legacy extensions" ["CPP"] (legacyExtensions bi) + assert "Default extension field" [] (extensions bi) + let extensionInput = "cabal-version: 2.2\nname: sample\nversion: 1\ncommon shared\n extensions: CPP\n default-extensions: OverloadedStrings\nlibrary\n import: shared\n if os(linux)\n extensions: ForeignFunctionInterface\n default-extensions: BangPatterns\n" + extensionPackage <- parse extensionInput + [Component _ extensionInfo] <- resolve Map.empty extensionPackage + assert "Merge older extensions" ["CPP", "ForeignFunctionInterface"] (legacyExtensions extensionInfo) + assert "Merge default extensions" ["OverloadedStrings", "BangPatterns"] (extensions extensionInfo) + assert "Legacy tool name" ["happy"] (map toolName (buildTools bi)) + assert "Legacy tool package" [Nothing] (map toolPackage (buildTools bi)) + let setInput = BSC.unlines (map BSC.pack (header ++ + ["library", " build-depends: , base:{base} >=4, sample:{one,two} ^>={1.2,2.3}"])) + sets <- parse setInput + _ <- right (snd (runResult (C.parseGenericPackageDescription setInput))) + [Component _ setInfo] <- resolve Map.empty sets + assert "Main library target" (MainLibrary :| []) (dependencyLibraries (dependencies setInfo !! 0)) + assert "Library target set" (NamedLibrary "one" :| [NamedLibrary "two"]) + (dependencyLibraries (dependencies setInfo !! 1)) + +testSourceRepositories :: IO () +testSourceRepositories = do + let input = BSC.unlines (map BSC.pack (header ++ + [ "source-repository head", " type: git" + , " location: https://example.com/first", " location: https://example.com/second" + , " x-note: first", " second" + , "library", " exposed-modules: Sample" + , "source-repository this", " type: git", " tag: v1.2.3" + , " subdir: \"source files\"" + , "source-repository head", " type: darcs", " location: https://example.com/third" + ])) + pkg <- parse input + assert "Keep repository sections in source order" + [ ("head", Map.fromList + [ ("type", ["git"]) + , ("location", ["https://example.com/first", "https://example.com/second"]) + , ("x-note", ["first\nsecond"]) + ]) + , ("this", Map.fromList + [("type", ["git"]), ("tag", ["v1.2.3"]), ("subdir", ["\"source files\""])]) + , ("head", Map.fromList + [("type", ["darcs"]), ("location", ["https://example.com/third"])]) + ] [(k, Map.map (map fieldText) fs) | SourceRepository k fs <- packageSourceRepositories pkg] + assert "Keep field positions" + [Just [FieldValue (Position 8 3) [FieldLine (Position 8 11) "first", FieldLine (Position 9 5) "second"]]] + (take 1 [Map.lookup "x-note" fs | SourceRepository _ fs <- packageSourceRepositories pkg]) + empty <- parse (BSC.unlines (map BSC.pack header)) + assert "Absent repositories" [] (packageSourceRepositories empty) + +testBuildInfo :: IO () +testBuildInfo = do + let input = "cc-options: -DHOOKED\ncpp-options: -DHOOKED_HS\ninclude-dirs: generated\nc-sources: generated.c\nexecutable: sample-tool\ncpp-options: -DEXE\n" + ours <- right (parseValue (parseHookedBuildInfo input)) + (lib, exes) <- right (snd (runResult (C.parseHookedBuildInfo input))) + assert "Buildinfo C options" (map T.pack . C.ccOptions <$> lib) (ccOptions <$> hookedLibrary ours) + assert "Buildinfo executable count" (length exes) (Map.size (hookedExecutables ours)) + assert "Buildinfo executable options" (Just ["-DEXE"]) (cppOptions <$> Map.lookup "sample-tool" (hookedExecutables ours)) + empty <- right (parseValue (parseHookedBuildInfo "")) + assert "Empty buildinfo" (HookedBuildInfo Nothing Map.empty) empty + +-- | Cabal does not make a difference between upper case and lower case +-- in section keywords. A parenthesis can follow the keyword directly. +testConditionalSpelling :: IO () +testConditionalSpelling = do + pkg <- parse (BSC.unlines (map BSC.pack (header ++ + [ "flag fast", " default: False", "library" + , " If flag(fast)", " cpp-options: -DFAST" + , " Else", " cpp-options: -DSLOW" + , " if(os(linux))", " cpp-options: -DLINUX" + ]))) + [Component _ bi] <- resolve Map.empty pkg + assert "Keyword spelling" ["-DSLOW", "-DLINUX"] (cppOptions bi) + [Component _ fast] <- resolve (Map.singleton "fast" True) pkg + assert "Keyword spelling with a flag" ["-DFAST", "-DLINUX"] (cppOptions fast) + +testElif :: IO () +testElif = do + let input = BSC.unlines (map BSC.pack (header ++ + [ "library" + , " if arch(wasm32)", " hs-source-dirs: wasm" + , " elif os(osx)", " hs-source-dirs: darwin" + , " elif os(linux)", " hs-source-dirs: linux" + , " else", " hs-source-dirs: other" + ])) + pkg <- parse input + _ <- right (snd (runResult (C.parseGenericPackageDescription input))) + [Component _ bi] <- resolve Map.empty pkg + assert "Select an elif branch" ["linux"] (sourceDirs bi) + let at os arch = do + let resolved = resolvePackage (Environment os arch "ghc" (version "9.12.2")) Map.empty pkg + pure [sourceDirs b | Component _ b <- resolvedComponents resolved] + darwin <- at "osx" "aarch64" + assert "Select the first elif branch" [["darwin"]] darwin + wasm <- at "wasi" "wasm32" + assert "Select the if branch" [["wasm"]] wasm + other <- at "windows" "x86_64" + assert "Select the else branch" [["other"]] other + -- Before cabal-version 2.2, Cabal ignores elif and gives a warning. It also + -- ignores the else section after it, because no if section comes before it. + older <- parse "cabal-version: 2.0\nname: sample\nversion: 1\nbuild-type: Simple\nlibrary\n if os(osx)\n cpp-options: -DOSX\n elif os(linux)\n cpp-options: -DLINUX\n else\n cpp-options: -DOTHER\n" + [Component _ olderInfo] <- resolve Map.empty older + assert "Ignore elif before 2.2" [] (cppOptions olderInfo) + +testImportCommas :: IO () +testImportCommas = do + let input = BSC.unlines (map BSC.pack (header ++ + [ "common one", " cpp-options: -DONE", "common two", " cpp-options: -DTWO" + , "library", " import:", " , one", " , two" + ])) + pkg <- parse input + _ <- right (snd (runResult (C.parseGenericPackageDescription input))) + [Component _ bi] <- resolve Map.empty pkg + assert "Import list with leading commas" ["-DONE", "-DTWO"] (cppOptions bi) + +-- | Before cabal-version 3.4, an internal library name hides a package +-- with the same name. From 3.4, a dependency name always identifies a package. +testInternalLibraryNames :: IO () +testInternalLibraryNames = forM_ [("3.0", ("sample", NamedLibrary "mtl")), ("3.4", ("mtl", MainLibrary))] $ \(spec, expected) -> do + let input = BSC.unlines (map BSC.pack + [ "cabal-version: " ++ spec, "name: sample", "version: 1" + , "library", " build-depends: mtl", "library mtl", " build-depends: base" + ]) + pkg <- parse input + ref <- right (snd (runResult (C.parseGenericPackageDescription input))) + library <- maybe (fail "Missing reference library") (pure . C.libBuildInfo . C.condTreeData) (C.condLibrary ref) + (Component _ bi : _) <- resolve Map.empty pkg + assert ("Dependency name for " ++ spec) [expected] + [(dependencyPackage d, NE.head (dependencyLibraries d)) | d <- dependencies bi] + assert ("Reference dependency name for " ++ spec) [fst expected] + [T.pack (C.prettyShow (C.depPkgName d)) | d <- C.targetBuildDepends library] + +-- | The parser keeps fields that it does not interpret. +testRetainedFields :: IO () +testRetainedFields = do + pkg <- parse (BSC.unlines (map BSC.pack (header ++ + [ "library", " reexported-modules: Data.Other, Data.Alias as Alias" + , " mixins: base hiding (Prelude), containers (A as B) requires (C)", " signatures: Hole" + ]))) + [Component _ bi] <- resolve Map.empty pkg + assert "Module reexports" (Just ["Data.Other, Data.Alias as Alias"]) (map fieldText <$> Map.lookup "reexported-modules" (extraFields bi)) + assert "Mixins" + [ Mixin "base" MainLibrary (HidingRenaming ["Prelude"]) DefaultRenaming + , Mixin "containers" MainLibrary (ModuleRenaming [("A", "B")]) (ModuleRenaming [("C", "C")]) ] + (mixins bi) + assert "Signatures" (Just ["Hole"]) (map fieldText <$> Map.lookup "signatures" (extraFields bi)) + +-- | Before cabal-version 2.0, Cabal keeps build-tool-depends and gives a warning. +testOlderToolDependencies :: IO () +testOlderToolDependencies = do + let input = "cabal-version: >=1.10\nname: sample\nversion: 1\nlibrary\n build-tool-depends: hspec-discover:hspec-discover\n build-tools: happy\n" + pkg <- parse input + ref <- right (snd (runResult (C.parseGenericPackageDescription input))) + library <- maybe (fail "Missing reference library") (pure . C.libBuildInfo . C.condTreeData) (C.condLibrary ref) + [Component _ bi] <- resolve Map.empty pkg + assert "Reference keeps the field" 1 (length (C.buildToolDepends library)) + assert "Keep build-tool-depends after build-tools" [Nothing, Just "hspec-discover"] (map toolPackage (buildTools bi)) + +-- | Cabal accepts repeated package fields with a warning. For a field with +-- one value, the last value wins. +testRepeatedPackageFields :: IO () +testRepeatedPackageFields = do + pkg <- parse (BSC.unlines (map BSC.pack (header ++ + ["extra-source-files: a.txt", "tested-with: GHC == 9.10", "extra-source-files: b.txt"]))) + assert "Keep each value in source order" (Just ["a.txt", "b.txt"]) (map fieldText <$> Map.lookup "extra-source-files" (packageFields pkg)) + described <- parse (BSC.unlines (map BSC.pack (header ++ ["synopsis: Sample text", "description: First line", "", " Indented line", " .", " Last line"]))) + assert "Free text from 3.0" (Just "First line\n\n Indented line\n.\nLast line") (packageFieldText described "description") + assert "Free text field name case" (Just "Sample text") (packageFieldText described "Synopsis") + assert "Absent free text" Nothing (packageFieldText described "author") + older <- parse "cabal-version: >=1.10\nname: sample\nversion: 1\ndescription: First line\n .\n Last line\n" + assert "Free text before 3.0" (Just "First line\n\nLast line") (packageFieldText older "description") + renamed <- parse (BSC.unlines (map BSC.pack (header ++ ["name: other", "version: 2"]))) + assert "Last name wins" "other" (packageName renamed) + assert "Last version wins" (version "2") (packageVersion renamed) + forM_ ["cabal-version: 2.2", "version: 1..2"] $ \field -> + case parseValue (parsePackage (BSC.unlines (map BSC.pack (header ++ [field])))) of + Left _ -> pure () + Right _ -> fail ("Invalid repeated field accepted: " ++ field) + +-- | Format versions 3.16 and 3.18, the build type rules of Cabal-syntax +-- 3.18, and absolute source directories. +testNewFormatVersions :: IO () +testNewFormatVersions = do + forM_ + [ ("3.16", "build-type: Simple", True) + , ("3.18", "build-type: Simple", True) + , ("3.16", "build-type: Make", True) + , ("3.18", "build-type: Make", False) + , ("3.12", "build-type: Hooks\ncustom-setup\n setup-depends: base", False) + , ("3.14", "build-type: Hooks\ncustom-setup\n setup-depends: base", True) + , ("3.18", "build-type: Hooks\ncustom-setup\n setup-depends: base", True) + , ("3.14", "build-type: Hooks", False) + , ("3.18", "library\n hs-source-dirs: /absolute", True) + ] $ \(spec, body, accepted) -> do + let input = BSC.pack ("cabal-version: " ++ spec ++ "\nname: sample\nversion: 1\n" ++ body ++ "\n") + ours = either (const False) (const True) (parseValue (parsePackage input)) + reference = either (const False) (const True) (snd (runResult (C.parseGenericPackageDescription input))) + assert ("Reference acceptance: " ++ spec ++ " " ++ body) accepted reference + assert ("Acceptance: " ++ spec ++ " " ++ body) accepted ours + pkg <- parse "cabal-version: 3.18\nname: sample\nversion: 1\n" + assert "Newest format version" (version "3.18") (cabalVersion pkg) + +testErrors :: IO () +testErrors = do + forM_ + [ ["library", " build-tools: happy"] + , ["library", " if flag(missing)", " buildable: False"] + , ["library", " import: missing"] + , ["library", " buildable: maybe"] + , ["library", " build-depends: base >="] + , ["library", " exposed-modules: lower"] + , ["library { exposed-modules: Sample"] + , ["common a", " import: a", "library", " import: a"] + , ["library", " buildable: True", "library", " buildable: True"] + , ["source-repository head", " if True", " type: git"] + , ["library", " if"] + , ["library", " if flag(missing)"] + , ["library", " if os(linux) &&", " buildable: False"] + , ["flag bad name"] + , ["library", " build-depends: base:"] + ] $ \body -> reject (BSC.unlines (map BSC.pack (header ++ body))) + reject "version: 1\n" + reject "cabal-version: 99\nname: sample\nversion: 1\n" + reject "cabal-version: 3.10\nname: sample\nversion: 1\n" + reject "name: sample\nversion: 1\ncabal-version: 2.2\n" + 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) + Right _ -> fail "Invalid input accepted" + case parseValue (parsePackage "version: 1\n") of + Left d -> assert "Package check has no position" Nothing (diagnosticPosition d) + Right _ -> fail "Invalid input accepted" + where + reject bytes = case parseValue (parsePackage bytes) of + Left _ -> pure () + Right _ -> fail ("Invalid input accepted: " ++ BSC.unpack bytes) diff --git a/test/RoundTrip.hs b/test/RoundTrip.hs new file mode 100644 --- /dev/null +++ b/test/RoundTrip.hs @@ -0,0 +1,767 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +-- | Make random package descriptions with Hedgehog. Write each description +-- with the Cabal-syntax pretty-printer. Then read the text with the parser +-- and with Cabal-syntax. The two results must be equal. The Cabal-syntax +-- result must also be equal to the random description, so that the test +-- finds data that the text does not keep. +-- +-- The generator makes all values that the printer can write correctly. +-- A comment identifies each value that the generator does not make, and +-- gives the reason. +module Main (main) where + +import Control.Monad (unless) +import Data.List (nub) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Internal.Config as Config +import qualified Hedgehog.Internal.Property as Property +import qualified Hedgehog.Internal.Report as Report +import qualified Hedgehog.Internal.Runner as Runner +import qualified Hedgehog.Internal.Seed as Seed +import qualified Hedgehog.Range as Range +import System.Exit (exitFailure) +import qualified Aihc.Cabal as A +import Compliance.Adapter (runResult, toCabal) +import qualified Distribution.CabalSpecVersion as C +import qualified Distribution.Compat.NonEmptySet as NES +import qualified Distribution.Compiler as C +import qualified Distribution.License as L +import qualified Distribution.ModuleName as C +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.Parsec as C +import qualified Distribution.PackageDescription.PrettyPrint as C +import qualified Distribution.Parsec as C +import qualified Distribution.SPDX as SPDX +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 +import qualified Distribution.Utils.ShortText as C +import qualified Language.Haskell.Extension as C + +-- | The number of random packages in each test run. +testCount :: TestLimit +testCount = 2000 + +-- | A fixed seed makes each run test the same packages. +seed :: Seed.Seed +seed = Seed.from 20260928 + +main :: IO () +main = do + report <- Runner.checkReport (Property.propertyConfig prop) 0 seed (Property.propertyTest prop) (const (pure ())) + output <- Report.renderResult Config.DisableColor (Just "pretty-printer round trip") report + putStrLn output + unless (Report.reportStatus report == Report.OK) exitFailure + where + prop = withTests testCount prop_roundTrip + +prop_roundTrip :: Property +prop_roundTrip = property $ do + gpd <- forAllWith C.showGenericPackageDescription genPackage + let pd = C.packageDescription gpd + version = C.specVersion pd + cover 10 "format version before 1.10" (version < C.CabalSpecV1_10) + cover 5 "format version 3.16 or later" (version >= C.CabalSpecV3_16) + cover 50 "conditional branches" (hasBranches gpd) + cover 20 "multi-line description" ('\n' `elem` C.fromShortText (C.description pd)) + cover 30 "sub-libraries" (not (null (C.condSubLibraries gpd))) + cover 10 "custom-setup section" (C.setupBuildInfo pd /= Nothing) + let bytes = TE.encodeUtf8 (T.pack (C.showGenericPackageDescription gpd)) + reference <- evalEither (snd (runResult (C.parseGenericPackageDescription bytes))) + ours <- evalEither (A.parseValue (A.parsePackage bytes)) + converted <- evalEither (toCabal ours) + converted === reference + reference === gpd + +-- | True if a component has a conditional branch. +hasBranches :: C.GenericPackageDescription -> Bool +hasBranches gpd = or + [ maybe False branches (C.condLibrary gpd) + , any (branches . snd) (C.condSubLibraries gpd) + , any (branches . snd) (C.condExecutables gpd) + , any (branches . snd) (C.condForeignLibs gpd) + , any (branches . snd) (C.condTestSuites gpd) + , any (branches . snd) (C.condBenchmarks gpd) + ] + where + branches :: Tree a -> Bool + branches = not . null . C.condTreeComponents + +-- | The data that the generators of one package share. +data Context = Context + { contextSpec :: C.CabalSpecVersion + , packageName :: C.PackageName + , subLibraries :: [C.UnqualComponentName] + , flagNames :: [C.FlagName] + } + +since :: Context -> C.CabalSpecVersion -> Gen [a] -> Gen [a] +since ctx version gen = if contextSpec ctx >= version then gen else pure [] + +-- Names and atoms + +-- | Parse a generated atom with Cabal-syntax. The generators make only +-- valid text, so an error is a generator bug. +atom :: C.Parsec a => String -> a +atom input = fromMaybe (error ("Generator made an invalid value: " ++ input)) (C.simpleParsec input) + +-- | A letter. Some letters are not ASCII. +letter :: Gen Char +letter = Gen.frequency [(20, Gen.lower), (3, Gen.upper), (1, Gen.element ("éüßøλжé" :: String))] + +lowerWord :: Gen String +lowerWord = (:) <$> Gen.lower <*> Gen.string (Range.linear 0 6) (Gen.frequency [(5, Gen.lower), (1, Gen.digit)]) + +upperWord :: Gen String +upperWord = (:) <$> Gen.upper <*> Gen.string (Range.linear 0 6) + (Gen.frequency [(10, Gen.alphaNum), (1, Gen.element ("_'éλ" :: String))]) + +-- | A package or component name: parts with hyphens between them. Each +-- part contains a letter. Letters can be upper case or not ASCII. +genName :: Gen String +genName = concatWith '-' <$> Gen.list (Range.linear 1 3) part + where + part = do + before <- Gen.string (Range.linear 0 2) Gen.digit + first <- letter + after <- Gen.string (Range.linear 0 5) (Gen.frequency [(4, letter), (1, Gen.digit)]) + pure (before ++ first : after) + +concatWith :: Char -> [String] -> String +concatWith c = foldr1 (\a b -> a ++ c : b) + +genModuleName :: Gen C.ModuleName +genModuleName = atom . concatWith '.' <$> Gen.list (Range.linear 1 3) upperWord + +genModules :: Gen [C.ModuleName] +genModules = Gen.list (Range.linear 0 3) genModuleName + +genVersion :: Gen C.Version +genVersion = C.mkVersion <$> Gen.list (Range.linear 1 4) + (Gen.frequency [(10, Gen.int (Range.linear 0 20)), (1, Gen.int (Range.linear 0 999999999))]) + +-- | A path. Some paths contain spaces, characters that are not ASCII, or +-- glob characters. Some paths are absolute or start with "..". +genPath :: Gen FilePath +genPath = do + start <- Gen.frequency [(10, pure ""), (1, pure "/"), (1, pure "../"), (1, pure "./")] + parts <- Gen.list (Range.linear 1 3) segment + pure (start ++ concatWith '/' parts) + where + segment = Gen.frequency + [ (8, Gen.string (Range.linear 1 8) (Gen.frequency [(10, letter), (2, Gen.digit), (2, Gen.element ("-_." :: String))])) + , (1, (\a b -> a ++ " " ++ b) <$> lowerWord <*> lowerWord) + , (1, (++ ".hs") <$> upperWord) + , (1, ("*." ++) <$> lowerWord) + ] + +-- | A relative path. Paths with a leading slash are absolute. +genRelativePath :: Gen FilePath +genRelativePath = Gen.filter (\p -> take 1 p /= "/") genPath + +genPaths :: Gen [C.SymbolicPathX allowAbsolute from to] +genPaths = map C.unsafeMakeSymbolicPath . nub <$> Gen.list (Range.linear 0 3) genPath + +genRelativePaths :: Gen [C.SymbolicPathX allowAbsolute from to] +genRelativePaths = map C.unsafeMakeSymbolicPath . nub <$> Gen.list (Range.linear 0 3) genRelativePath + +-- | A command line option. Some options contain spaces, commas, or +-- characters that are not ASCII. The printer does not escape quotation +-- marks, so the options do not contain them. +genOption :: Gen String +genOption = Gen.frequency + [ (6, ('-' :) <$> Gen.string (Range.linear 1 10) (Gen.frequency [(5, letter), (3, Gen.element ("0123=-_.:/+@#$%^&*()[]{}<>;!?~|\\" :: String))])) + , (1, (\a b -> "-D" ++ a ++ "=" ++ b) <$> upperWord <*> lowerWord) + , (1, (\a b -> a ++ " " ++ b) <$> lowerWord <*> lowerWord) + , (1, (\a b -> a ++ "," ++ b) <$> lowerWord <*> lowerWord) + ] + +genOptions :: Gen [String] +genOptions = Gen.list (Range.linear 0 3) genOption + +-- | A token without spaces, for example a library name. +genToken :: Gen String +genToken = Gen.string (Range.linear 1 8) (Gen.frequency [(10, letter), (2, Gen.digit), (1, Gen.element ("-_.+" :: String))]) + +-- | One line of free text without leading or trailing spaces. A line does +-- not start with "--", because Cabal reads such a line as a comment. The +-- text does not contain braces, because Cabal reads them as layout. +genLine :: Gen String +genLine = unwords <$> Gen.list (Range.linear 1 5) word + where + word = Gen.frequency + [ (6, lowerWord) + , (1, upperWord) + , (1, Gen.element ["(a)", "x,y", "a--b", "é", "*", "λ", "a:b", "\"q\"", "

", "100%", "a;b", "#", "!"]) + ] + +genShortText :: Gen C.ShortText +genShortText = C.toShortText <$> Gen.frequency [(2, pure ""), (3, genLine)] + +-- | Free text with one or more lines. From format version 3.0, some lines +-- are empty or indented. The first line and the last line are not empty or +-- indented, because Cabal-syntax removes them. Before format version 3.0, Cabal-syntax removes +-- the indentation and ignores empty lines. +genFreeText :: C.CabalSpecVersion -> Gen String +genFreeText version = Gen.frequency + [ (2, pure "") + , (3, genLine) + , (2, concatWith '\n' <$> Gen.list (Range.linear 2 4) genLine) + , (if version >= C.CabalSpecV3_0 then 2 else 0, do + first <- genLine + middle <- Gen.list (Range.linear 1 4) (Gen.frequency + [ (3, genLine) + , (1, pure "") + , (1, (++) <$> Gen.string (Range.linear 1 4) (pure ' ') <*> genLine) + ]) + final <- genLine + pure (concatWith '\n' (first : middle ++ [final]))) + ] + +-- Versions and dependencies + +-- | A version range. The printer does not write parentheses around an +-- operand with the same operator. In a dependency, the parser groups such +-- operators to the right. Thus an operand at the left of an operator never +-- uses the same operator. The printer does not write a range that contains +-- all versions, so such a range becomes 'C.anyVersion'. +genRange :: Context -> Gen C.VersionRange +genRange = genRangeWith foldr1 + +-- | A version range in an impl condition. In a condition, the parser groups +-- operators to the left. +genConditionRange :: Context -> Gen C.VersionRange +genConditionRange = genRangeWith foldl1 + +genRangeWith :: (forall a. (a -> a -> a) -> [a] -> a) -> Context -> Gen C.VersionRange +genRangeWith fold ctx = Gen.frequency [(2, pure C.anyVersion), (5, anyVersion <$> go (2 :: Int))] + where + anyVersion range = if C.isAnyVersion range then C.anyVersion else range + go depth = fold C.unionVersionRanges <$> Gen.list (Range.linear 1 3) (conjunction depth) + -- A union in parentheses occurs only as an operand of an intersection. + conjunction depth = Gen.choice + [ simple + , fold C.intersectVersionRanges <$> Gen.list (Range.linear 2 3) (term depth) + ] + term depth + | depth == 0 = simple + | otherwise = Gen.frequency + [ (4, simple) + , (1, fold C.unionVersionRanges <$> Gen.list (Range.linear 2 3) (conjunction (depth - 1))) + ] + simple = Gen.element constructors <*> genVersion + constructors = [C.thisVersion, C.laterVersion, C.earlierVersion, C.orLaterVersion, C.orEarlierVersion] + ++ [C.majorBoundVersion | contextSpec ctx >= C.CabalSpecV2_0] + +-- | The name of a package that is not this package. Before format version +-- 3.4, the name of a sub-library refers to the sub-library, so the name +-- is not the name of a sub-library. +genOtherPackage :: Context -> Gen C.PackageName +genOtherPackage ctx = Gen.filter allowed (Gen.frequency + [ (3, C.mkPackageName <$> Gen.element ["base", "containers", "text", "bytestring", "mtl"]) + , (2, C.mkPackageName <$> genName) + , (if null (subLibraries ctx) then 0 else 1, C.unqualComponentNameToPackageName <$> Gen.element (subLibraries ctx)) + ]) + where + allowed name = name /= packageName ctx && (contextSpec ctx >= C.CabalSpecV3_4 + || C.packageNameToUnqualComponentName name `notElem` subLibraries ctx) + +genLibraryName :: Gen C.LibraryName +genLibraryName = Gen.frequency + [ (1, pure C.LMainLibName) + , (2, C.LSubLibName . C.mkUnqualComponentName <$> genName) + ] + +genDependency :: Context -> Gen C.Dependency +genDependency ctx = Gen.frequency + [ (4, C.Dependency <$> genOtherPackage ctx <*> genRange ctx <*> otherLibraries) + , (1, C.Dependency (packageName ctx) <$> genRange ctx <*> ownLibraries) + ] + where + -- The syntax for library sets starts in format version 3.0. + otherLibraries + | contextSpec ctx >= C.CabalSpecV3_0 = Gen.frequency + [ (4, pure (NES.singleton C.LMainLibName)) + , (1, NES.fromNonEmpty <$> Gen.nonEmpty (Range.linear 1 3) genLibraryName) + ] + | otherwise = pure (NES.singleton C.LMainLibName) + -- Before format version 3.0, the printer writes a dependency on a + -- sub-library of this package with the name of the sub-library. + ownLibraries + | contextSpec ctx >= C.CabalSpecV3_0 = otherLibraries + | otherwise = NES.singleton <$> Gen.element + (C.LMainLibName : map C.LSubLibName (subLibraries ctx)) + +genMixin :: Context -> Gen C.Mixin +genMixin ctx = do + (name, library) <- Gen.frequency + [ (4, (,) <$> genOtherPackage ctx <*> otherLibrary) + , (if null (subLibraries ctx) && contextSpec ctx < C.CabalSpecV3_4 then 0 else 1, (,) (packageName ctx) <$> ownLibrary) + ] + provides <- genRenaming + requires <- genRenaming + pure (C.mkMixin name library (C.IncludeRenaming provides requires)) + where + -- The syntax for a sub-library in a mixin starts in format version 3.4. + otherLibrary = if contextSpec ctx >= C.CabalSpecV3_4 then genLibraryName else pure C.LMainLibName + -- Before format version 3.4, the printer writes a mixin of a + -- sub-library of this package with the name of the sub-library. + ownLibrary = if contextSpec ctx >= C.CabalSpecV3_4 + then genLibraryName + else C.LSubLibName <$> Gen.element (subLibraries ctx) + genRenaming = Gen.choice + [ pure C.DefaultRenaming + , C.ModuleRenaming <$> Gen.list (Range.linear 0 3) ((,) <$> genModuleName <*> genModuleName) + , C.HidingRenaming <$> Gen.list (Range.linear 0 3) genModuleName + ] + +genToolDependency :: Context -> Gen C.ExeDependency +genToolDependency ctx = C.ExeDependency + <$> Gen.choice [genOtherPackage ctx, pure (packageName ctx)] + <*> (C.mkUnqualComponentName <$> genName) <*> genRange ctx + +genLegacyTool :: Context -> Gen C.LegacyExeDependency +genLegacyTool ctx = C.LegacyExeDependency + <$> Gen.frequency [(1, Gen.element ["happy", "alex", "c2hs", "hsc2hs", "cpphs"]), (2, genName)] + <*> genRange ctx + +-- | A pkg-config dependency. Versions with letters start in format version 3.0. +genPkgconfigDependency :: Context -> Gen C.PkgconfigDependency +genPkgconfigDependency ctx = do + name <- genToken + range <- Gen.element (["", " >= 1.2", " < 3 || > 4.1", " >= 1 && < 2"] + ++ [" == 2.0.1a" | contextSpec ctx >= C.CabalSpecV3_0]) + let input = name ++ range + pure (fromMaybe (error ("Generator made an invalid value: " ++ input)) (C.simpleParsec' (contextSpec ctx) input)) + +-- | An extension. The name of an unknown extension contains only letters +-- and digits. +genExtension :: Gen C.Extension +genExtension = Gen.frequency + [ (10, C.EnableExtension <$> Gen.enumBounded) + , (3, C.DisableExtension <$> Gen.enumBounded) + , (1, C.UnknownExtension . ("Unknown" ++) <$> Gen.string (Range.linear 1 6) Gen.alphaNum) + ] + +genLanguage :: Gen C.Language +genLanguage = Gen.frequency + [ (4, Gen.element C.knownLanguages) + , (1, C.UnknownLanguage . ("Unknown" ++) <$> Gen.string (Range.linear 1 6) Gen.alphaNum) + ] + +-- Build information + +-- | Build information for the format version of the context. A field that +-- the format version does not support stays empty. The grammar has no field +-- for 'C.staticOptions', so that value stays empty. +genBuildInfo :: Context -> Gen C.BuildInfo +genBuildInfo ctx = do + buildable <- Gen.frequency [(4, pure True), (1, pure False)] + sourceDirs <- genPaths + other <- genModules + autogen <- since' C.CabalSpecV2_0 genModules + virtual <- since' C.CabalSpecV2_2 genModules + language <- if contextSpec ctx >= C.CabalSpecV1_10 then Gen.maybe genLanguage else pure Nothing + otherLanguages <- since' C.CabalSpecV1_10 (Gen.list (Range.linear 0 2) genLanguage) + extensions <- since' C.CabalSpecV1_10 genExtensions + otherExtensions <- since' C.CabalSpecV1_10 genExtensions + -- The extensions field is not available from format version 3.0. + oldExtensions <- if contextSpec ctx < C.CabalSpecV3_0 then genExtensions else pure [] + dependencies <- Gen.list (Range.linear 0 4) (genDependency ctx) + mixins <- since' C.CabalSpecV2_0 (Gen.list (Range.linear 0 2) (genMixin ctx)) + tools <- Gen.list (Range.linear 0 2) (genToolDependency ctx) + -- The build-tools field is not available from format version 3.0. + legacyTools <- if contextSpec ctx < C.CabalSpecV3_0 then Gen.list (Range.linear 0 2) (genLegacyTool ctx) else pure [] + cSources <- genPaths + cxxSources <- since' C.CabalSpecV2_2 genPaths + asmSources <- since' C.CabalSpecV3_0 genPaths + cmmSources <- since' C.CabalSpecV3_0 genPaths + jsSources <- genPaths + includeDirs <- genPaths + includes <- genPaths + installIncludes <- genRelativePaths + autogenIncludes <- since' C.CabalSpecV3_0 genRelativePaths + extraLibDirs <- genPaths + extraLibDirsStatic <- since' C.CabalSpecV3_8 genPaths + frameworks <- genRelativePaths + frameworkDirs <- genPaths + cppOptions <- genOptions + ccOptions <- genOptions + cxxOptions <- since' C.CabalSpecV2_2 genOptions + jsppOptions <- since' C.CabalSpecV3_16 genOptions + ldOptions <- genOptions + asmOptions <- since' C.CabalSpecV3_0 genOptions + cmmOptions <- since' C.CabalSpecV3_0 genOptions + hsc2hsOptions <- since' C.CabalSpecV3_6 genOptions + ghcOptions <- genOptions + ghcjsOptions <- genOptions + profOptions <- genOptions + profjsOptions <- genOptions + sharedOptions <- genOptions + sharedjsOptions <- genOptions + profSharedOptions <- since' C.CabalSpecV3_14 genOptions + profSharedjsOptions <- since' C.CabalSpecV3_14 genOptions + extraLibraries <- tokens + extraLibrariesStatic <- since' C.CabalSpecV3_8 tokens + extraGHCiLibraries <- tokens + extraBundledLibraries <- tokens + extraLibraryFlavours <- tokens + extraDynamicFlavours <- since' C.CabalSpecV3_0 tokens + pkgconfig <- Gen.list (Range.linear 0 2) (genPkgconfigDependency ctx) + custom <- genCustomFields + pure C.emptyBuildInfo + { C.buildable = buildable + , C.hsSourceDirs = sourceDirs + , C.otherModules = other + , C.autogenModules = autogen + , C.virtualModules = virtual + , C.defaultLanguage = language + , C.otherLanguages = otherLanguages + , C.defaultExtensions = extensions + , C.otherExtensions = otherExtensions + , C.oldExtensions = oldExtensions + , C.targetBuildDepends = dependencies + , C.mixins = mixins + , C.buildToolDepends = tools + , C.buildTools = legacyTools + , C.cSources = cSources + , C.cxxSources = cxxSources + , C.asmSources = asmSources + , C.cmmSources = cmmSources + , C.jsSources = jsSources + , C.includeDirs = includeDirs + , C.includes = includes + , C.installIncludes = installIncludes + , C.autogenIncludes = autogenIncludes + , C.extraLibDirs = extraLibDirs + , C.extraLibDirsStatic = extraLibDirsStatic + , C.frameworks = frameworks + , C.extraFrameworkDirs = frameworkDirs + , C.cppOptions = cppOptions + , C.ccOptions = ccOptions + , C.cxxOptions = cxxOptions + , C.jsppOptions = jsppOptions + , C.ldOptions = ldOptions + , C.asmOptions = asmOptions + , C.cmmOptions = cmmOptions + , C.hsc2hsOptions = hsc2hsOptions + , C.options = C.PerCompilerFlavor ghcOptions ghcjsOptions + , C.profOptions = C.PerCompilerFlavor profOptions profjsOptions + , C.sharedOptions = C.PerCompilerFlavor sharedOptions sharedjsOptions + , C.profSharedOptions = C.PerCompilerFlavor profSharedOptions profSharedjsOptions + , C.extraLibs = extraLibraries + , C.extraLibsStatic = extraLibrariesStatic + , C.extraGHCiLibs = extraGHCiLibraries + , C.extraBundledLibs = extraBundledLibraries + , C.extraLibFlavours = extraLibraryFlavours + , C.extraDynLibFlavours = extraDynamicFlavours + , C.pkgconfigDepends = pkgconfig + , C.customFieldsBI = custom + } + where + since' = since ctx + genExtensions = Gen.list (Range.linear 0 3) genExtension + tokens = Gen.list (Range.linear 0 2) genToken + +-- | Fields with an @x-@ prefix. The names are unique. A value can have +-- more than one line. A field name contains only ASCII letters, digits, +-- hyphens, and underscores. Cabal-syntax changes field names to lower case. +genCustomFields :: Gen [(String, String)] +genCustomFields = do + names <- nub <$> Gen.list (Range.linear 0 2) (("x-" ++) <$> Gen.string (Range.linear 1 10) + (Gen.frequency [(10, Gen.lower), (2, Gen.digit), (1, Gen.element ("-_" :: String))])) + traverse (\name -> (,) name <$> value) names + where + -- Cabal-syntax ignores empty lines and indentation in these values. + value = concatWith '\n' <$> Gen.list (Range.linear 1 4) genLine + +-- Components + +type Tree a = C.CondTree C.ConfVar a + +-- | A condition tree. Each node gets its data from the given generator. +-- The flag tells if the node is the top node. +genTree :: Context -> (Bool -> C.BuildInfo -> Gen a) -> Gen (Tree a) +genTree ctx make = go True (2 :: Int) + where + go top depth = do + value <- genBuildInfo ctx >>= make top + children <- if depth == 0 then pure [] else Gen.list (Range.linear 0 2) (branch (depth - 1)) + pure (C.CondNode value children) + branch depth = C.CondBranch <$> genCondition ctx <*> go False depth <*> Gen.maybe (go False depth) + +genCondition :: Context -> Gen (C.Condition C.ConfVar) +genCondition ctx = Gen.recursive Gen.choice leaves + [ Gen.subterm (genCondition ctx) negation + , Gen.subterm2 (genCondition ctx) (genCondition ctx) C.CAnd + , Gen.subterm2 (genCondition ctx) (genCondition ctx) C.COr + ] + where + -- The printer writes two negations as one "!!" token, which Cabal-syntax + -- rejects. + negation c@(C.CNot _) = c + negation c = C.CNot c + leaves = + [ C.Lit <$> Gen.bool + , C.Var . C.OS <$> Gen.frequency + [(4, Gen.element C.knownOSs), (1, C.OtherOS . ("other" ++) <$> lowerWord)] + , C.Var . C.Arch <$> Gen.frequency + [(4, Gen.element C.knownArches), (1, C.OtherArch . ("other" ++) <$> lowerWord)] + , C.Var <$> (C.Impl <$> genCompiler <*> genConditionRange ctx) + ] ++ [C.Var . C.PackageFlag <$> Gen.element (flagNames ctx) | not (null (flagNames ctx))] + +genCompiler :: Gen C.CompilerFlavor +genCompiler = Gen.frequency + [ (4, Gen.element C.knownCompilerFlavors) + , (1, C.OtherCompiler . ("other" ++) <$> lowerWord) + ] + +genLibrary :: Context -> C.LibraryName -> Bool -> C.BuildInfo -> Gen C.Library +genLibrary ctx name _ bi = do + exposed <- genModules + reexported <- Gen.list (Range.linear 0 2) genReexport + signatures <- since ctx C.CabalSpecV2_0 genModules + -- Only a sub-library has a visibility field. + visibility <- case name of + C.LSubLibName _ | contextSpec ctx >= C.CabalSpecV3_0 -> + Gen.element [C.LibraryVisibilityPrivate, C.LibraryVisibilityPublic] + C.LSubLibName _ -> pure C.LibraryVisibilityPrivate + C.LMainLibName -> pure C.LibraryVisibilityPublic + isExposed <- Gen.bool + pure C.emptyLibrary + { C.libName = name, C.exposedModules = exposed, C.reexportedModules = reexported + , C.signatures = signatures, C.libExposed = isExposed, C.libVisibility = visibility + , C.libBuildInfo = bi } + where + genReexport = C.ModuleReexport + <$> Gen.maybe (Gen.choice [genOtherPackage ctx, pure (packageName ctx)]) + <*> genModuleName <*> genModuleName + +genExecutable :: Context -> C.UnqualComponentName -> Bool -> C.BuildInfo -> Gen C.Executable +genExecutable ctx name _ bi = do + mainIs <- Gen.frequency [(1, pure ""), (4, genRelativePath)] + scope <- if contextSpec ctx >= C.CabalSpecV2_0 + then Gen.element [C.ExecutablePublic, C.ExecutablePrivate] + else pure C.ExecutablePublic + pure C.emptyExecutable + { C.exeName = name, C.modulePath = C.unsafeMakeSymbolicPath mainIs + , C.exeScope = scope, C.buildInfo = bi } + +genForeignLibrary :: C.UnqualComponentName -> Bool -> C.BuildInfo -> Gen C.ForeignLib +genForeignLibrary name _ bi = do + kind <- Gen.element C.knownForeignLibTypes + options <- Gen.element [[], [C.ForeignLibStandalone]] + versionInfo <- Gen.maybe (C.mkLibVersionInfo <$> ((,,) <$> small <*> small <*> small)) + versionLinux <- Gen.maybe genVersion + modDefFiles <- genRelativePaths + pure C.emptyForeignLib + { C.foreignLibName = name, C.foreignLibType = kind, C.foreignLibOptions = options + , C.foreignLibVersionInfo = versionInfo, C.foreignLibVersionLinux = versionLinux + , C.foreignLibModDefFile = modDefFiles, C.foreignLibBuildInfo = bi } + where + small = Gen.int (Range.linear 0 100) + +-- | A test suite. The top node always has an interface. A branch node can +-- have an interface or the value that Cabal-syntax gives to a branch +-- without a type field. Cabal-syntax does not keep the name in the test +-- suite value. +genTestSuite :: Context -> Bool -> C.BuildInfo -> Gen C.TestSuite +genTestSuite ctx top bi = do + interface <- Gen.frequency + [ (if top then 0 else 2, pure (C.TestSuiteUnsupported (C.TestTypeUnknown "" C.nullVersion))) + , (2, C.TestSuiteExeV10 (C.mkVersion [1, 0]) . C.unsafeMakeSymbolicPath <$> genRelativePath) + , (1, C.TestSuiteLibV09 (C.mkVersion [0, 9]) <$> genModuleName) + ] + generators <- since ctx C.CabalSpecV3_8 (Gen.list (Range.linear 0 2) genToken) + pure C.emptyTestSuite + { C.testInterface = interface, C.testBuildInfo = bi, C.testCodeGenerators = generators } + +genBenchmark :: Bool -> C.BuildInfo -> Gen C.Benchmark +genBenchmark top bi = do + interface <- Gen.frequency + [ (if top then 0 else 2, pure (C.BenchmarkUnsupported (C.BenchmarkTypeUnknown "" C.nullVersion))) + , (2, C.BenchmarkExeV10 (C.mkVersion [1, 0]) . C.unsafeMakeSymbolicPath <$> genRelativePath) + ] + pure C.emptyBenchmark { C.benchmarkInterface = interface, C.benchmarkBuildInfo = bi } + +-- | Unique component names for one kind of component. +genComponentNames :: Int -> Gen [C.UnqualComponentName] +genComponentNames count = map C.mkUnqualComponentName . nub <$> Gen.list (Range.linear 0 count) genName + +-- Package + +genLicense :: C.CabalSpecVersion -> Gen (Either SPDX.License L.License) +genLicense version + | version >= C.CabalSpecV2_2 = Left <$> Gen.frequency + [ (1, pure SPDX.NONE) + , (4, SPDX.License <$> expression (2 :: Int)) + ] + | otherwise = Right <$> Gen.frequency + [ (4, Gen.element L.knownLicenses) + , (1, L.GPL . Just <$> genVersion) + , (1, L.UnknownLicense . ("Unknown" ++) <$> Gen.string (Range.linear 1 6) Gen.alphaNum) + ] + where + list = SPDX.cabalSpecVersionToSPDXListVersion version + -- The printer writes an operand with the same operator without + -- parentheses, and the parser groups the operators to the right. + expression depth = foldr1 SPDX.EOr <$> Gen.list (Range.linear 1 3) (conjunction depth) + -- A disjunction in parentheses occurs only as an operand of a conjunction. + conjunction depth = Gen.choice + [ simple + , foldr1 SPDX.EAnd <$> Gen.list (Range.linear 2 3) (term depth) + ] + term depth + | depth == 0 = simple + | otherwise = Gen.frequency + [ (4, simple) + , (1, foldr1 SPDX.EOr <$> Gen.list (Range.linear 2 3) (conjunction (depth - 1))) + ] + simple = SPDX.ELicense <$> simpleLicense <*> Gen.frequency + [(4, pure Nothing), (1, Just <$> Gen.element (SPDX.licenseExceptionIdList list))] + simpleLicense = Gen.frequency + [ (6, SPDX.ELicenseId <$> Gen.element (SPDX.licenseIdList list)) + , (1, SPDX.ELicenseIdPlus <$> Gen.element (SPDX.licenseIdList list)) + , (1, SPDX.ELicenseRef <$> (SPDX.mkLicenseRef' <$> Gen.maybe genToken <*> genToken)) + ] + +genSourceRepo :: Gen C.SourceRepo +genSourceRepo = do + kind <- Gen.frequency + [(4, Gen.element [C.RepoHead, C.RepoThis]), (1, C.RepoKindUnknown . ("other" ++) <$> lowerWord)] + kindOfRepo <- Gen.maybe (Gen.frequency + [ (4, C.KnownRepoType <$> Gen.element C.knownRepoTypes) + , (1, C.OtherRepoType . ("other" ++) <$> lowerWord) + ]) + location <- Gen.maybe (Gen.frequency [(4, ("https://example.com/" ++) <$> genName), (1, genLine)]) + repoModule <- Gen.maybe genToken + branch <- Gen.maybe genToken + tag <- Gen.maybe genToken + subdir <- Gen.maybe genPath + pure (C.emptySourceRepo kind) + { C.repoType = kindOfRepo, C.repoLocation = location, C.repoModule = repoModule + , C.repoBranch = branch, C.repoTag = tag, C.repoSubdir = subdir } + +-- | A build type and a custom-setup section. +-- +-- * The custom-setup section starts in format version 1.24. +-- * Without a build-type field, the build type is Custom before format +-- version 2.2. From format version 2.2, the build type is Custom if a +-- custom-setup section is present, and Simple otherwise. +-- * From format version 1.24, a Custom build type needs a custom-setup +-- section. +-- * The Hooks build type starts in format version 3.14 and needs a +-- custom-setup section. +-- * The Make build type stops in format version 3.18. +genSetup :: Context -> Gen (Maybe C.BuildType, Maybe C.SetupBuildInfo) +genSetup ctx = do + buildType <- Gen.maybe (Gen.element types) + let effective = fromMaybe (if v >= C.CabalSpecV2_2 then C.Simple else C.Custom) buildType + required = (effective == C.Custom && v >= C.CabalSpecV1_24) || effective == C.Hooks + present <- if required then pure True else if v >= C.CabalSpecV1_24 then Gen.bool else pure False + setup <- if present + then Just . (`C.SetupBuildInfo` False) <$> Gen.list (Range.linear 0 3) (genDependency ctx) + else pure Nothing + -- A custom-setup section changes the default build type from format + -- version 2.2, so the value must be explicit. + let explicit = case buildType of + Nothing | present && v >= C.CabalSpecV2_2 -> Just C.Custom + _ -> buildType + pure (explicit, setup) + where + v = contextSpec ctx + types = [C.Simple, C.Configure, C.Custom] + ++ [C.Make | v < C.CabalSpecV3_18] ++ [C.Hooks | v >= C.CabalSpecV3_14] + +genFlag :: C.CabalSpecVersion -> C.FlagName -> Gen C.PackageFlag +genFlag version name = C.MkPackageFlag name <$> genFreeText version <*> Gen.bool <*> Gen.bool + +-- | A flag name. Cabal-syntax changes flag names to lower case. +genFlagName :: Gen C.FlagName +genFlagName = C.mkFlagName <$> Gen.filter (\n -> take 1 n /= "-") (Gen.string (Range.linear 1 8) + (Gen.frequency [(10, Gen.lower), (2, Gen.digit), (1, Gen.element ("-_" :: String))])) + +genPackage :: Gen C.GenericPackageDescription +genPackage = do + version <- Gen.enumBounded + name <- C.mkPackageName <$> genName + flags <- nub <$> Gen.list (Range.linear 0 3) genFlagName + subLibraryNames <- filter ((/= name) . C.unqualComponentNameToPackageName) <$> genComponentNames 2 + let ctx = Context version name subLibraryNames flags + packageVersion <- genVersion + flagDeclarations <- traverse (genFlag version) flags + license <- genLicense version + licenseFiles <- genRelativePaths + copyright <- genShortText + maintainer <- genShortText + author <- genShortText + stability <- genShortText + homepage <- genShortText + packageUrl <- genShortText + bugReports <- genShortText + synopsis <- genShortText + category <- genShortText + description <- genFreeText version + testedWith <- Gen.list (Range.linear 0 2) ((,) <$> genCompiler <*> genRange ctx) + (buildType, setup) <- genSetup ctx + repositories <- Gen.list (Range.linear 0 2) genSourceRepo + custom <- genCustomFields + extraSources <- genRelativePaths + extraDocs <- genRelativePaths + extraTemporary <- genRelativePaths + extraFiles <- since ctx C.CabalSpecV3_14 genRelativePaths + dataFiles <- genRelativePaths + dataDir <- Gen.frequency [(3, pure C.sameDirectory), (1, C.unsafeMakeSymbolicPath <$> genPath)] + library <- Gen.maybe (genTree ctx (genLibrary ctx C.LMainLibName)) + libraries <- traverse (\n -> (,) n <$> genTree ctx (genLibrary ctx (C.LSubLibName n))) subLibraryNames + exeNames <- genComponentNames 2 + executables <- traverse (\n -> (,) n <$> genTree ctx (genExecutable ctx n)) exeNames + foreignNames <- genComponentNames 1 + foreignLibraries <- traverse (\n -> (,) n <$> genTree ctx (genForeignLibrary n)) foreignNames + testNames <- genComponentNames 2 + tests <- traverse (\n -> (,) n <$> genTree ctx (genTestSuite ctx)) testNames + benchNames <- genComponentNames 1 + benchmarks <- traverse (\n -> (,) n <$> genTree ctx genBenchmark) benchNames + let pd = C.emptyPackageDescription + { C.specVersion = version + , C.package = C.PackageIdentifier name packageVersion + , C.licenseRaw = license + , C.licenseFiles = licenseFiles + , C.copyright = copyright + , C.maintainer = maintainer + , C.author = author + , C.stability = stability + , C.homepage = homepage + , C.pkgUrl = packageUrl + , C.bugReports = bugReports + , C.synopsis = synopsis + , C.category = category + , C.description = C.toShortText description + , C.testedWith = testedWith + , C.buildTypeRaw = buildType + , C.setupBuildInfo = setup + , C.sourceRepos = repositories + , C.customFieldsPD = custom + , C.extraSrcFiles = extraSources + , C.extraDocFiles = extraDocs + , C.extraTmpFiles = extraTemporary + , C.extraFiles = extraFiles + , C.dataFiles = dataFiles + , C.dataDir = dataDir + } + pure C.emptyGenericPackageDescription + { C.packageDescription = pd + , C.genPackageFlags = flagDeclarations + , C.condLibrary = library + , C.condSubLibraries = libraries + , C.condExecutables = executables + , C.condForeignLibs = foreignLibraries + , C.condTestSuites = tests + , C.condBenchmarks = benchmarks + } diff --git a/test/fixtures/aihc-hackage.cabal b/test/fixtures/aihc-hackage.cabal new file mode 100644 --- /dev/null +++ b/test/fixtures/aihc-hackage.cabal @@ -0,0 +1,67 @@ +cabal-version: 3.8 +name: aihc-hackage +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: + Aihc.Hackage.Cabal + Aihc.Hackage.Cache + Aihc.Hackage.Cpp + Aihc.Hackage.Download + Aihc.Hackage.Headers + Aihc.Hackage.Index + Aihc.Hackage.IndexCache + Aihc.Hackage.Preprocessor + Aihc.Hackage.Release + Aihc.Hackage.Types + Aihc.Hackage.Util + + hs-source-dirs: src + build-depends: + Cabal >=3.14 && <3.17, + Cabal-syntax >=3.14 && <3.17, + base >=4.16 && <5, + bytestring >=0.10.8 && <0.13, + containers >=0.5 && <0.9, + directory >=1.2.3 && <1.5, + filepath >=1.3.0.1 && <1.6, + http-client >=0.5 && <0.8, + http-client-tls >=0.2 && <0.4, + http-types >=0.9 && <0.13, + tar >=0.5 && <0.7, + text >=1.2.3 && <2.2, + time >=1.9 && <1.15, + zlib >=0.5.4 && <0.8, + + ghc-options: -Wall + default-language: GHC2021 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + Cabal-syntax >=3.14 && <3.17, + aihc-cpp >=2.0 && <2.1, + aihc-hackage, + base >=4.16 && <5, + bytestring, + containers, + directory, + filepath, + hedgehog, + tar, + tasty, + tasty-hedgehog, + tasty-hunit, + text, + zlib, + + ghc-options: + -Wall + -threaded + -rtsopts + "-with-rtsopts=-N -M10G" + + default-language: GHC2021 diff --git a/test/fixtures/aihc-haddock.cabal b/test/fixtures/aihc-haddock.cabal new file mode 100644 --- /dev/null +++ b/test/fixtures/aihc-haddock.cabal @@ -0,0 +1,78 @@ +cabal-version: 3.8 +name: aihc-haddock +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: + Aihc.Haddock.Build + Aihc.Haddock.Cli + Aihc.Haddock.Comment + Aihc.Haddock.Compare + Aihc.Haddock.Hoogle + Aihc.Haddock.Markup + Aihc.Haddock.Model + Aihc.Haddock.Package + Aihc.Haddock.Reference.Hoogle + Aihc.Haddock.Reference.Json + Aihc.Haddock.Render + Aihc.Haddock.Store + + hs-source-dirs: src + build-depends: + Cabal-syntax >=3.14 && <3.17, + aeson >=2.0 && <2.3, + aeson-pretty, + aihc-hackage, + aihc-package-plan, + aihc-parser, + base >=4.16 && <5, + bytestring >=0.10.8 && <0.13, + containers >=0.5 && <0.9, + directory >=1.2.3 && <1.5, + filepath >=1.3.0.1 && <1.6, + optparse-applicative >=0.16 && <0.19, + prettyprinter, + text >=2.1.4 && <2.2, + transformers, + + ghc-options: -Wall + default-language: GHC2021 + +executable aihc-haddock + main-is: Main.hs + hs-source-dirs: app + build-depends: + aihc-haddock, + base >=4.16 && <5, + + ghc-options: -Wall + default-language: GHC2021 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Test.Haddock.Fixtures + Test.Haddock.Units + + build-depends: + aihc-hackage, + aihc-haddock, + base >=4.16 && <5, + bytestring, + directory, + filepath, + tasty, + tasty-hedgehog, + tasty-hunit, + text, + + ghc-options: + -Wall + -threaded + -rtsopts + "-with-rtsopts=-N -M10G" + + default-language: GHC2021 diff --git a/test/fixtures/aihc-package-plan.cabal b/test/fixtures/aihc-package-plan.cabal new file mode 100644 --- /dev/null +++ b/test/fixtures/aihc-package-plan.cabal @@ -0,0 +1,60 @@ +cabal-version: 3.8 +name: aihc-package-plan +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: + Aihc.PackagePlan + Aihc.PackagePlan.Diagnostic + Aihc.PackagePlan.Lock + Aihc.PackagePlan.Solver + Aihc.PackagePlan.Source + + hs-source-dirs: src + build-depends: + Cabal-syntax >=3.14 && <3.17, + aeson >=2.0 && <2.3, + aihc-cpp, + aihc-hackage, + aihc-parser, + base >=4.16 && <5, + bytestring >=0.10.8 && <0.13, + containers >=0.5 && <0.9, + cryptohash-sha256 >=0.11 && <0.12, + directory >=1.2.3 && <1.5, + filepath >=1.3.0.1 && <1.6, + text >=2.1.4 && <2.2, + time >=1.9 && <1.15, + transformers, + + default-extensions: OverloadedStrings + ghc-options: -Wall + default-language: GHC2021 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + Cabal-syntax >=3.14 && <3.17, + aihc-hackage, + aihc-package-plan, + base >=4.16 && <5, + bytestring, + containers, + directory, + filepath, + hedgehog, + tar, + tasty, + tasty-hedgehog, + tasty-hunit, + + ghc-options: + -Wall + -threaded + -rtsopts + -with-rtsopts=-N + + default-language: GHC2021