From 80c19b42b7419c4caa21e7b3d1cf5a99430fdd54 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 17 Aug 2017 02:31:55 +0300 Subject: [PATCH] Introduce FIeldGrammar. This commit reworks how GenericPackageDescription is parsed from `[Field Position]` and pretty-printed to `Doc`. This also fixes few issues: - Fix #4697: `cabal format` doesn't output custom-setup stanza (nor foreign-lib stanzas) - Fix #4719: `parse . pretty . parse = parse` for all Hackage cabal files. - `parser-hackage-tests roundtrip` is the test program. The handling of `license-file` and `license-files` is changed. Now they behave the same. --- Cabal/Cabal.cabal | 22 +- Cabal/Distribution/Compat/Map/Strict.hs | 5 + Cabal/Distribution/Compat/Parsec.hs | 4 + Cabal/Distribution/Compat/ReadP.hs | 21 +- Cabal/Distribution/Compiler.hs | 23 +- Cabal/Distribution/FieldGrammar.hs | 86 +++ Cabal/Distribution/FieldGrammar/Class.hs | 149 +++++ Cabal/Distribution/FieldGrammar/Parsec.hs | 260 ++++++++ Cabal/Distribution/FieldGrammar/Pretty.hs | 70 ++ Cabal/Distribution/License.hs | 34 +- Cabal/Distribution/ModuleName.hs | 15 +- Cabal/Distribution/PackageDescription.hs | 2 +- .../PackageDescription/FieldGrammar.hs | 505 ++++++++++++++ .../Distribution/PackageDescription/Parse.hs | 2 +- .../Distribution/PackageDescription/Parsec.hs | 396 +++++------ .../PackageDescription/Parsec/FieldDescr.hs | 620 ------------------ .../PackageDescription/PrettyPrint.hs | 372 ++++------- .../PackageDescription/{Parsec => }/Quirks.hs | 2 +- Cabal/Distribution/ParseUtils.hs | 6 +- Cabal/Distribution/Parsec/Class.hs | 405 +----------- .../Distribution/Parsec/{Types => }/Common.hs | 4 +- Cabal/Distribution/Parsec/ConfVar.hs | 20 +- .../Distribution/Parsec/{Types => }/Field.hs | 11 +- Cabal/Distribution/Parsec/Lexer.hs | 2 +- Cabal/Distribution/Parsec/LexerMonad.hs | 13 +- Cabal/Distribution/Parsec/Newtypes.hs | 236 +++++++ .../Parsec/{Types => }/ParseResult.hs | 13 +- Cabal/Distribution/Parsec/Parser.hs | 22 +- Cabal/Distribution/Parsec/Types/FieldDescr.hs | 238 ------- Cabal/Distribution/Pretty.hs | 5 +- Cabal/Distribution/ReadE.hs | 12 +- Cabal/Distribution/Simple.hs | 1 - Cabal/Distribution/Simple/Setup.hs | 51 +- Cabal/Distribution/System.hs | 63 +- Cabal/Distribution/Text.hs | 3 + Cabal/Distribution/Types/BenchmarkType.hs | 13 +- Cabal/Distribution/Types/BuildType.hs | 16 +- Cabal/Distribution/Types/ComponentId.hs | 12 +- Cabal/Distribution/Types/Dependency.hs | 11 +- Cabal/Distribution/Types/ExeDependency.hs | 29 +- Cabal/Distribution/Types/ExecutableScope.hs | 20 +- Cabal/Distribution/Types/ForeignLib.hs | 29 +- Cabal/Distribution/Types/ForeignLibOption.hs | 17 +- Cabal/Distribution/Types/ForeignLibType.hs | 21 +- .../Types/GenericPackageDescription.hs | 30 +- Cabal/Distribution/Types/IncludeRenaming.hs | 30 +- .../Distribution/Types/LegacyExeDependency.hs | 36 +- Cabal/Distribution/Types/Mixin.hs | 22 +- Cabal/Distribution/Types/Module.hs | 9 + Cabal/Distribution/Types/ModuleReexport.hs | 22 +- Cabal/Distribution/Types/ModuleRenaming.hs | 47 +- .../Distribution/Types/PackageDescription.hs | 1 + Cabal/Distribution/Types/PackageName.hs | 4 + .../Distribution/Types/PkgconfigDependency.hs | 24 +- Cabal/Distribution/Types/PkgconfigName.hs | 12 +- Cabal/Distribution/Types/SetupBuildInfo.hs | 15 +- Cabal/Distribution/Types/SourceRepo.hs | 23 +- Cabal/Distribution/Types/TestType.hs | 16 +- Cabal/Distribution/Types/UnitId.hs | 8 +- .../Distribution/Types/UnqualComponentName.hs | 12 +- Cabal/Distribution/Utils/Generic.hs | 6 +- Cabal/Distribution/Version.hs | 65 +- Cabal/Language/Haskell/Extension.hs | 13 +- Cabal/tests/CheckTests.hs | 12 +- Cabal/tests/ParserHackageTests.hs | 113 +++- Cabal/tests/ParserTests.hs | 58 +- .../ParserTests/regressions/Octree-0.5.format | 23 +- .../tests/ParserTests/regressions/elif.cabal | 20 + .../tests/ParserTests/regressions/elif.format | 18 + .../regressions/encoding-0.8.cabal | 29 +- .../regressions/encoding-0.8.format | 10 +- .../regressions/generics-sop.cabal | 128 ++++ .../regressions/generics-sop.format | 121 ++++ .../ParserTests/regressions/issue-774.format | 8 +- .../regressions/nothing-unicode.format | 12 +- .../tests/ParserTests/regressions/shake.cabal | 402 ++++++++++++ .../ParserTests/regressions/shake.format | 418 ++++++++++++ Cabal/tests/StructDiff.hs | 4 +- boot/Lexer.x | 2 +- cabal-testsuite/Test/Cabal/Prelude.hs | 2 +- stack.yaml | 2 +- 81 files changed, 3619 insertions(+), 2019 deletions(-) create mode 100644 Cabal/Distribution/FieldGrammar.hs create mode 100644 Cabal/Distribution/FieldGrammar/Class.hs create mode 100644 Cabal/Distribution/FieldGrammar/Parsec.hs create mode 100644 Cabal/Distribution/FieldGrammar/Pretty.hs create mode 100644 Cabal/Distribution/PackageDescription/FieldGrammar.hs delete mode 100644 Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs rename Cabal/Distribution/PackageDescription/{Parsec => }/Quirks.hs (99%) rename Cabal/Distribution/Parsec/{Types => }/Common.hs (97%) rename Cabal/Distribution/Parsec/{Types => }/Field.hs (93%) create mode 100644 Cabal/Distribution/Parsec/Newtypes.hs rename Cabal/Distribution/Parsec/{Types => }/ParseResult.hs (92%) delete mode 100644 Cabal/Distribution/Parsec/Types/FieldDescr.hs create mode 100644 Cabal/tests/ParserTests/regressions/elif.cabal create mode 100644 Cabal/tests/ParserTests/regressions/elif.format create mode 100644 Cabal/tests/ParserTests/regressions/generics-sop.cabal create mode 100644 Cabal/tests/ParserTests/regressions/generics-sop.format create mode 100644 Cabal/tests/ParserTests/regressions/shake.cabal create mode 100644 Cabal/tests/ParserTests/regressions/shake.format diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 210ceb17eec..f924753edba 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -33,9 +33,12 @@ extra-source-files: -- Do NOT edit this section manually; instead, run the script. -- BEGIN gen-extra-source-files tests/ParserTests/regressions/Octree-0.5.cabal + tests/ParserTests/regressions/elif.cabal tests/ParserTests/regressions/encoding-0.8.cabal + tests/ParserTests/regressions/generics-sop.cabal tests/ParserTests/regressions/issue-774.cabal tests/ParserTests/regressions/nothing-unicode.cabal + tests/ParserTests/regressions/shake.cabal tests/ParserTests/warnings/bom.cabal tests/ParserTests/warnings/bool.cabal tests/ParserTests/warnings/deprecatedfield.cabal @@ -274,18 +277,22 @@ library parsec >= 3.1.9 && <3.2 exposed-modules: Distribution.Compat.Parsec + Distribution.FieldGrammar + Distribution.FieldGrammar.Class + Distribution.FieldGrammar.Parsec + Distribution.FieldGrammar.Pretty + Distribution.PackageDescription.FieldGrammar Distribution.PackageDescription.Parsec - Distribution.PackageDescription.Parsec.FieldDescr - Distribution.PackageDescription.Parsec.Quirks + Distribution.PackageDescription.Quirks Distribution.Parsec.Class + Distribution.Parsec.Common Distribution.Parsec.ConfVar + Distribution.Parsec.Field Distribution.Parsec.Lexer Distribution.Parsec.LexerMonad + Distribution.Parsec.Newtypes + Distribution.Parsec.ParseResult Distribution.Parsec.Parser - Distribution.Parsec.Types.Common - Distribution.Parsec.Types.Field - Distribution.Parsec.Types.FieldDescr - Distribution.Parsec.Types.ParseResult -- Lens functionality exposed-modules: @@ -400,6 +407,7 @@ test-suite parser-tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: ParserTests.hs + build-depends: containers build-depends: base, bytestring, @@ -450,7 +458,7 @@ test-suite parser-hackage-tests if flag(parsec-struct-diff) build-depends: - generics-sop >= 0.2.5 && <0.3, + generics-sop >= 0.3.1.0 && <0.4, these >=0.7.1 && <0.8, singleton-bool >=0.1.1.0 && <0.2, keys diff --git a/Cabal/Distribution/Compat/Map/Strict.hs b/Cabal/Distribution/Compat/Map/Strict.hs index d7541c5a3bc..682377714b0 100644 --- a/Cabal/Distribution/Compat/Map/Strict.hs +++ b/Cabal/Distribution/Compat/Map/Strict.hs @@ -12,6 +12,7 @@ module Distribution.Compat.Map.Strict #ifdef HAVE_containers_050 #else , insertWith + , fromSet #endif ) where @@ -20,7 +21,11 @@ import Data.Map.Strict as X #else import Data.Map as X hiding (insertWith, insertWith') import qualified Data.Map +import qualified Data.Set insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWith = Data.Map.insertWith' + +fromSet :: (k -> a) -> Data.Set.Set k -> Map k a +fromSet f = Data.Map.fromDistinctAscList . Prelude.map (\k -> (k, f k)) . Data.Set.toList #endif diff --git a/Cabal/Distribution/Compat/Parsec.hs b/Cabal/Distribution/Compat/Parsec.hs index a8013cd2e16..d9d368b780e 100644 --- a/Cabal/Distribution/Compat/Parsec.hs +++ b/Cabal/Distribution/Compat/Parsec.hs @@ -25,6 +25,7 @@ module Distribution.Compat.Parsec ( P.satisfy, P.space, P.spaces, + skipSpaces1, P.string, munch, munch1, @@ -72,3 +73,6 @@ munch => (Char -> Bool) -> P.ParsecT s u m String munch = many . P.satisfy + +skipSpaces1 :: P.Stream s m Char => P.ParsecT s u m () +skipSpaces1 = P.skipMany1 P.space diff --git a/Cabal/Distribution/Compat/ReadP.hs b/Cabal/Distribution/Compat/ReadP.hs index b024c54a388..a9c79c891d9 100644 --- a/Cabal/Distribution/Compat/ReadP.hs +++ b/Cabal/Distribution/Compat/ReadP.hs @@ -67,17 +67,23 @@ module Distribution.Compat.ReadP -- * Running a parser ReadS, -- :: *; = String -> [(a,String)] readP_to_S, -- :: ReadP a -> ReadS a - readS_to_P -- :: ReadS a -> ReadP a + readS_to_P, -- :: ReadS a -> ReadP a + + -- ** Parsec + parsecToReadP, ) where import Prelude () import Distribution.Compat.Prelude hiding (many, get) +import Control.Applicative (liftA2) import qualified Distribution.Compat.MonadFail as Fail import Control.Monad( replicateM, (>=>) ) +import qualified Text.Parsec as P + infixr 5 +++, <++ -- --------------------------------------------------------------------------- @@ -414,3 +420,16 @@ readS_to_P :: ReadS a -> ReadP r a -- parser, and therefore a possible inefficiency. readS_to_P r = R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) + +-- --------------------------------------------------------------------------- +-- Converting from Parsec to ReadP +-- +-- | Convert @Parsec@ parser to 'ReadP'. +parsecToReadP + :: P.Parsec [Char] u a + -> u -- ^ initial user state + -> ReadP r a +parsecToReadP p u = R $ \k -> Look $ \s -> + case P.runParser (liftA2 (,) p P.getInput) u "" s of + Right (x, s') -> final (run (k x) s') + Left _ -> Fail diff --git a/Cabal/Distribution/Compiler.hs b/Cabal/Distribution/Compiler.hs index 4b5dcb7cbfb..b6a26754ec2 100644 --- a/Cabal/Distribution/Compiler.hs +++ b/Cabal/Distribution/Compiler.hs @@ -51,8 +51,11 @@ import Language.Haskell.Extension import Distribution.Version (Version, mkVersion', nullVersion) import qualified System.Info (compilerName, compilerVersion) +import Distribution.Parsec.Class (Parsec (..)) +import Distribution.Pretty (Pretty (..)) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P import qualified Text.PrettyPrint as Disp data CompilerFlavor = @@ -66,12 +69,20 @@ instance Binary CompilerFlavor knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] -instance Text CompilerFlavor where - disp (OtherCompiler name) = Disp.text name - disp (HaskellSuite name) = Disp.text name - disp NHC = Disp.text "nhc98" - disp other = Disp.text (lowercase (show other)) +instance Pretty CompilerFlavor where + pretty (OtherCompiler name) = Disp.text name + pretty (HaskellSuite name) = Disp.text name + pretty NHC = Disp.text "nhc98" + pretty other = Disp.text (lowercase (show other)) + +instance Parsec CompilerFlavor where + parsec = classifyCompilerFlavor <$> component + where + component = do + cs <- P.munch1 isAlphaNum + if all isDigit cs then fail "all digits compiler name" else return cs +instance Text CompilerFlavor where parse = do comp <- Parse.munch1 isAlphaNum when (all isDigit comp) Parse.pfail @@ -81,7 +92,7 @@ classifyCompilerFlavor :: String -> CompilerFlavor classifyCompilerFlavor s = fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap where - compilerMap = [ (display compiler, compiler) + compilerMap = [ (lowercase (display compiler), compiler) | compiler <- knownCompilerFlavors ] diff --git a/Cabal/Distribution/FieldGrammar.hs b/Cabal/Distribution/FieldGrammar.hs new file mode 100644 index 00000000000..08f2e5510a1 --- /dev/null +++ b/Cabal/Distribution/FieldGrammar.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | This module provides a way to specify a grammar of @.cabal@ -like files. +module Distribution.FieldGrammar ( + -- * Field grammar type + FieldGrammar (..), + uniqueField, + optionalField, + optionalFieldDef, + optionalFieldDefAla, + monoidalField, + deprecatedField', + -- * Concrete grammar implementations + ParsecFieldGrammar, + ParsecFieldGrammar', + parseFieldGrammar, + fieldGrammarKnownFieldList, + PrettyFieldGrammar, + PrettyFieldGrammar', + prettyFieldGrammar, + -- * Auxlilary + (^^^), + Section(..), + Fields, + partitionFields, + takeFields, + runFieldParser, + runFieldParser', + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.Map.Strict as Map + +import Distribution.FieldGrammar.Class +import Distribution.FieldGrammar.Parsec +import Distribution.FieldGrammar.Pretty +import Distribution.Parsec.Field +import Distribution.Utils.Generic (spanMaybe) + +type ParsecFieldGrammar' a = ParsecFieldGrammar a a +type PrettyFieldGrammar' a = PrettyFieldGrammar a a + +infixl 5 ^^^ + +-- | Reverse function application which binds tighter than '<$>' and '<*>'. +-- Useful for refining grammar specification. +-- +-- @ +-- \<*\> 'monoidalFieldAla' "extensions" (alaList' FSep MQuoted) oldExtensions +-- ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields." +-- @ +(^^^) :: a -> (a -> b) -> b +x ^^^ f = f x + +-- | Partitionin state +data PS ann = PS (Fields ann) [Section ann] [[Section ann]] + +-- | Partition field list into field map and groups of sections. +partitionFields :: [Field ann] -> (Fields ann, [[Section ann]]) +partitionFields = finalize . foldl' f (PS mempty mempty mempty) + where + finalize :: PS ann -> (Fields ann, [[Section ann]]) + finalize (PS fs s ss) + | null s = (fs, reverse ss) + | otherwise = (fs, reverse (reverse s : ss)) + + f :: PS ann -> Field ann -> PS ann + f (PS fs s ss) (Field (Name ann name) fss) = + PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss' + where + ss' | null s = ss + | otherwise = reverse s : ss + f (PS fs s ss) (Section name sargs sfields) = + PS fs (MkSection name sargs sfields : s) ss + +-- | Take all fields from the front. +takeFields :: [Field ann] -> (Fields ann, [Field ann]) +takeFields = finalize . spanMaybe match + where + finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest) + + match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs]) + match _ = Nothing diff --git a/Cabal/Distribution/FieldGrammar/Class.hs b/Cabal/Distribution/FieldGrammar/Class.hs new file mode 100644 index 00000000000..853fec2a2f9 --- /dev/null +++ b/Cabal/Distribution/FieldGrammar/Class.hs @@ -0,0 +1,149 @@ +module Distribution.FieldGrammar.Class ( + FieldGrammar (..), + uniqueField, + optionalField, + optionalFieldDef, + optionalFieldDefAla, + monoidalField, + deprecatedField', + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Data.Functor.Identity (Identity (..)) + +import Distribution.Compat.Newtype (Newtype) +import Distribution.Parsec.Class (Parsec) +import Distribution.Parsec.Field +import Distribution.Pretty (Pretty) + +-- | 'FieldGrammar' is parametrised by +-- +-- * @s@ which is a structure we are parsing. We need this to provide prettyprinter +-- functionality +-- +-- * @a@ type of the field. +-- +-- /Note:/ We'd like to have @forall s. Applicative (f s)@ context. +-- +class FieldGrammar g where + -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. + blurFieldGrammar :: ALens' a b -> g b c -> g a c + + -- | Field which should be defined, exactly once. + uniqueFieldAla + :: (Parsec b, Pretty b, Newtype b a) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'Newtype' pack + -> ALens' s a -- ^ lens into the field + -> g s a + + -- | Boolean field with a default value. + booleanFieldDef + :: FieldName -- ^ field name + -> ALens' s Bool -- ^ lens into the field + -> Bool -- ^ default + -> g s Bool + + -- | Optional field. + optionalFieldAla + :: (Parsec b, Pretty b, Newtype b a) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'pack' + -> ALens' s (Maybe a) -- ^ lens into the field + -> g s (Maybe a) + + -- | Monoidal field. + -- + -- Values are combined with 'mappend'. + -- + -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. + -- + monoidalFieldAla + :: (Parsec b, Pretty b, Monoid a, Newtype b a) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'pack' + -> ALens' s a -- ^ lens into the field + -> g s a + + -- | Parser matching all fields with a name starting with a prefix. + prefixedFields + :: FieldName -- ^ field name prefix + -> ALens' s [(String, String)] -- ^ lens into the field + -> g s [(String, String)] + + -- | Known field, which we don't parse, neither pretty print. + knownField :: FieldName -> g s () + + -- | Field which is parsed but not pretty printed. + hiddenField :: g s a -> g s a + + -- | Deprecated since + deprecatedSince + :: [Int] -- ^ version + -> String -- ^ deprecation message + -> g s a + -> g s a + + -- | Annotate field with since spec-version. + availableSince + :: [Int] -- ^ spec version + -> g s a + -> g s a + +-- | Field which can be defined at most once. +uniqueField + :: (FieldGrammar g, Parsec a, Pretty a) + => FieldName -- ^ field name + -> ALens' s a -- ^ lens into the field + -> g s a +uniqueField fn = uniqueFieldAla fn Identity + +-- | Field which can be defined at most once. +optionalField + :: (FieldGrammar g, Parsec a, Pretty a) + => FieldName -- ^ field name + -> ALens' s (Maybe a) -- ^ lens into the field + -> g s (Maybe a) +optionalField fn = optionalFieldAla fn Identity + +-- | Optional field with default value. +optionalFieldDef + :: (FieldGrammar g, Functor (g s), Parsec a, Pretty a, Eq a, Show a) + => FieldName -- ^ field name + -> LensLike' (Pretext (Maybe a) (Maybe a)) s a -- ^ @'Lens'' s a@: lens into the field + -> a -- ^ default value + -> g s a +optionalFieldDef fn = optionalFieldDefAla fn Identity + +-- | Optional field with default value. +optionalFieldDefAla + :: (FieldGrammar g, Functor (g s), Parsec b, Pretty b, Newtype b a, Eq a, Show a) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'Newtype' pack + -> LensLike' (Pretext (Maybe a) (Maybe a)) s a -- ^ @'Lens'' s a@: lens into the field + -> a -- ^ default value + -> g s a +optionalFieldDefAla fn pack l def = + fromMaybe def <$> optionalFieldAla fn pack (l . fromNon def) + +-- | Field which can be define multiple times, and the results are @mappend@ed. +monoidalField + :: (FieldGrammar g, Parsec a, Pretty a, Monoid a) + => FieldName -- ^ field name + -> ALens' s a -- ^ lens into the field + -> g s a +monoidalField fn = monoidalFieldAla fn Identity + +-- | Deprecated field. If found, warning is issued. +-- +-- /Note:/ also it's not pretty printed! +-- +deprecatedField' + :: FieldGrammar g + => String -- ^ deprecation message + -> g s a + -> g s a +deprecatedField' = deprecatedSince [] diff --git a/Cabal/Distribution/FieldGrammar/Parsec.hs b/Cabal/Distribution/FieldGrammar/Parsec.hs new file mode 100644 index 00000000000..1ca6c585fa4 --- /dev/null +++ b/Cabal/Distribution/FieldGrammar/Parsec.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides a 'FieldGrammarParser', one way to parse +-- @.cabal@ -like files. +-- +-- Fields can be specified multiple times in the .cabal files. The order of +-- such entries is important, but the mutual ordering of different fields is +-- not.Also conditional sections are considered after non-conditional data. +-- The example of this silent-commutation quirck is the fact that +-- +-- @ +-- buildable: True +-- if os(linux) +-- buildable: False +-- @ +-- +-- and +-- +-- @ +-- if os(linux) +-- buildable: False +-- buildable: True +-- @ +-- +-- behave the same! This is the limitation of 'GeneralPackageDescription' +-- structure. +-- +-- So we transform the list of fields @['Field' ann]@ into +-- a map of grouped ordinary fields and a list of lists of sections: +-- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@. +-- +-- We need list of list of sections, because we need to distinguish situations +-- where there are fields in between. For example +-- +-- @ +-- if flag(bytestring-lt-0_10_4) +-- build-depends: bytestring < 0.10.4 +-- +-- default-language: Haskell2020 +-- +-- else +-- build-depends: bytestring >= 0.10.4 +-- +-- @ +-- +-- is obviously invalid specification. +-- +-- We can parse 'Fields' like we parse @aeson@ objects, yet we use +-- slighly higher-level API, so we can process unspecified fields, +-- to report unknown fields and save custom @x-fields@. +-- +module Distribution.FieldGrammar.Parsec ( + ParsecFieldGrammar, + parseFieldGrammar, + fieldGrammarKnownFieldList, + -- * Auxiliary + Fields, + NamelessField (..), + Section (..), + runFieldParser, + runFieldParser', + ) where + +import qualified Data.ByteString as BS +import Data.List (dropWhileEnd) +import Data.Ord (comparing) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Distribution.Compat.Map.Strict as Map +import Distribution.Compat.Prelude +import Distribution.Compat.Newtype +import Distribution.Simple.Utils (fromUTF8BS) +import Prelude () +import qualified Text.Parsec as P +import qualified Text.Parsec.Error as P + +import Distribution.FieldGrammar.Class +import Distribution.Parsec.Class +import Distribution.Parsec.Common +import Distribution.Parsec.Field +import Distribution.Parsec.ParseResult + +------------------------------------------------------------------------------- +-- Auxiliary types +------------------------------------------------------------------------------- + +type Fields ann = Map FieldName [NamelessField ann] + +-- | Single field, without name, but with its annotation. +data NamelessField ann = MkNamelessField !ann [FieldLine ann] + deriving (Eq, Show, Functor) + +-- | The 'Section' constructor of 'Field'. +data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann] + deriving (Eq, Show, Functor) + +------------------------------------------------------------------------------- +-- ParsecFieldGrammar +------------------------------------------------------------------------------- + +data ParsecFieldGrammar s a = ParsecFG + { fieldGrammarKnownFields :: !(Set FieldName) + , fieldGrammarKnownPrefixes :: !(Set FieldName) + , fieldGrammarParser :: !(Fields Position -> ParseResult a) + } + deriving (Functor) + +parseFieldGrammar :: Fields Position -> ParsecFieldGrammar s a -> ParseResult a +parseFieldGrammar fields grammar = do + for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) -> + for_ nfields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name + -- TODO: fields allowed in this section + + -- parse + fieldGrammarParser grammar fields + + where + isUnknownField k _ = not $ + k `Set.member` fieldGrammarKnownFields grammar + || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) + +fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName] +fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields + +instance Applicative (ParsecFieldGrammar s) where + pure x = ParsecFG mempty mempty (\_ -> pure x) + {-# INLINE pure #-} + + ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG + (mappend f x) + (mappend f' x') + (\fields -> f'' fields <*> x'' fields) + {-# INLINE (<*>) #-} + +instance FieldGrammar ParsecFieldGrammar where + blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser + + uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser fields = case Map.lookup fn fields of + Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing:" + Just [] -> parseFatalFailure zeroPos $ show fn ++ " field foo" + Just [x] -> parseOne x + -- TODO: parse all + -- TODO: warn about duplicate fields? + Just xs-> parseOne (last xs) + + parseOne (MkNamelessField pos fls) = + unpack' _pack <$> runFieldParser pos parsec fls + + booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser + where + parser :: Fields Position -> ParseResult Bool + parser fields = case Map.lookup fn fields of + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne x + -- TODO: parse all + -- TODO: warn about duplicate optional fields? + Just xs -> parseOne (last xs) + + parseOne (MkNamelessField pos fls) = runFieldParser pos parsec fls + + optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser fields = case Map.lookup fn fields of + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne x + -- TODO: parse all! + Just xs -> parseOne (last xs) -- TODO: warn about duplicate optional fields? + + parseOne (MkNamelessField pos fls) + | null fls = pure Nothing + | otherwise = Just . (unpack' _pack) <$> runFieldParser pos parsec fls + + monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just xs -> foldMap (unpack' _pack) <$> traverse parseOne xs + + parseOne (MkNamelessField pos fls) = runFieldParser pos parsec fls + + prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (pure . parser) + where + parser :: Fields Position -> [(String, String)] + parser values = reorder $ concatMap convert $ filter match $ Map.toList values + + match (fn, _) = fnPfx `BS.isPrefixOf` fn + convert (fn, fields) = + -- TODO: warn about invalid UTF8 + [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls)) + | MkNamelessField pos fls <- fields + ] + -- hack: recover the order of prefixed fields + reorder = map snd . sortBy (comparing fst) + trim :: String -> String + trim = dropWhile isSpace . dropWhileEnd isSpace + + availableSince _ = id + + deprecatedSince (_ : _) _ grammar = grammar -- pass on non-empty version + deprecatedSince _ msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' values = do + let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList deprecatedFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTDeprecatedField $ + "The field " <> show name <> " is deprecated. " ++ msg + + parser values + + knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ -> pure ()) + + hiddenField = id + +------------------------------------------------------------------------------- +-- Parsec +------------------------------------------------------------------------------- + +runFieldParser' :: Position -> FieldParser a -> String -> ParseResult a +runFieldParser' (Position row col) p str = case P.runParser p' [] "" str of + Right (pok, ws) -> do + -- TODO: map pos + traverse_ (\(PWarning t pos w) -> parseWarning pos t w) ws + pure pok + Left err -> do + let ppos = P.errorPos err + -- Positions start from 1:1, not 0:0 + let epos = Position (row - 1 + P.sourceLine ppos) (col - 1 + P.sourceColumn ppos) + let msg = P.showErrorMessages + "or" "unknown parse error" "expecting" "unexpected" "end of input" + (P.errorMessages err) + + parseFatalFailure epos $ msg ++ ": " ++ show str + where + p' = (,) <$ P.spaces <*> p <* P.spaces <* P.eof <*> P.getState + +runFieldParser :: Position -> FieldParser a -> [FieldLine Position] -> ParseResult a +runFieldParser pp p ls = runFieldParser' pos p =<< fieldlinesToString pos ls + where + -- TODO: make per line lookup + pos = case ls of + [] -> pp + (FieldLine pos' _ : _) -> pos' + +fieldlinesToBS :: [FieldLine ann] -> BS.ByteString +fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) + +-- TODO: Take position from FieldLine +-- TODO: Take field name +fieldlinesToString :: Position -> [FieldLine ann] -> ParseResult String +fieldlinesToString pos fls = + let str = intercalate "\n" . map (\(FieldLine _ bs') -> fromUTF8BS bs') $ fls + in if '\xfffd' `elem` str + then str <$ parseWarning pos PWTUTF "Invalid UTF8 encoding" + else pure str diff --git a/Cabal/Distribution/FieldGrammar/Pretty.hs b/Cabal/Distribution/FieldGrammar/Pretty.hs new file mode 100644 index 00000000000..865ba108684 --- /dev/null +++ b/Cabal/Distribution/FieldGrammar/Pretty.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.FieldGrammar.Pretty ( + PrettyFieldGrammar, + prettyFieldGrammar, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Newtype +import Distribution.Compat.Prelude +import Distribution.Pretty (Pretty (..)) +import Distribution.Simple.Utils (fromUTF8BS) +import Prelude () +import Text.PrettyPrint (Doc) +import qualified Text.PrettyPrint as PP + +import Distribution.FieldGrammar.Class +import Distribution.ParseUtils (ppField) + +newtype PrettyFieldGrammar s a = PrettyFG + { fieldGrammarPretty :: s -> Doc + } + deriving (Functor) + +instance Applicative (PrettyFieldGrammar s) where + pure _ = PrettyFG (\_ -> mempty) + PrettyFG f <*> PrettyFG x = PrettyFG (\s -> f s PP.$$ x s) + +-- | We can use 'PrettyFieldGrammar' to pp print the @s@. +prettyFieldGrammar :: PrettyFieldGrammar s a -> s -> Doc +prettyFieldGrammar = fieldGrammarPretty + +instance FieldGrammar PrettyFieldGrammar where + blurFieldGrammar f (PrettyFG pp) = PrettyFG (pp . aview f) + + uniqueFieldAla fn _pack l = PrettyFG $ \s -> + ppField (fromUTF8BS fn) (pretty (pack' _pack (aview l s))) + + booleanFieldDef fn l def = PrettyFG pp + where + pp s + | b == def = mempty + | otherwise = ppField (fromUTF8BS fn) (PP.text (show b)) + where + b = aview l s + + optionalFieldAla fn _pack l = PrettyFG pp + where + pp s = case aview l s of + Nothing -> mempty + Just a -> ppField (fromUTF8BS fn) (pretty (pack' _pack a)) + + monoidalFieldAla fn _pack l = PrettyFG pp + where + pp s = ppField (fromUTF8BS fn) (pretty (pack' _pack (aview l s))) + + prefixedFields _fnPfx l = PrettyFG (pp . aview l) + where + pp xs = PP.vcat + -- always print the field, even its Doc is empty + -- i.e. don't use ppField + [ PP.text n <<>> PP.colon PP.<+> (PP.vcat $ map PP.text $ lines s) + | (n, s) <- xs + -- fnPfx `isPrefixOf` n + ] + + knownField _ = pure () + deprecatedSince [] _ _ = PrettyFG (\_ -> mempty) + deprecatedSince _ _ x = x + availableSince _ = id + hiddenField _ = PrettyFG (\_ -> mempty) diff --git a/Cabal/Distribution/License.hs b/Cabal/Distribution/License.hs index 783b6a79b16..c40c605405e 100644 --- a/Cabal/Distribution/License.hs +++ b/Cabal/Distribution/License.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | @@ -47,14 +47,17 @@ module Distribution.License ( knownLicenses, ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Version +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp +import Distribution.Version + +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp -- | Indicates the license under which a package's source code is released. -- Versions of the licenses not listed here will be rejected by Hackage and @@ -146,6 +149,27 @@ instance Pretty License where pretty (UnknownLicense other) = Disp.text other pretty other = Disp.text (show other) +instance Parsec License where + parsec = do + name <- P.munch1 isAlphaNum + version <- P.optionMaybe (P.char '-' *> parsec) + return $! case (name, version :: Maybe Version) of + ("GPL", _ ) -> GPL version + ("LGPL", _ ) -> LGPL version + ("AGPL", _ ) -> AGPL version + ("BSD2", Nothing) -> BSD2 + ("BSD3", Nothing) -> BSD3 + ("BSD4", Nothing) -> BSD4 + ("ISC", Nothing) -> ISC + ("MIT", Nothing) -> MIT + ("MPL", Just version') -> MPL version' + ("Apache", _ ) -> Apache version + ("PublicDomain", Nothing) -> PublicDomain + ("AllRightsReserved", Nothing) -> AllRightsReserved + ("OtherLicense", Nothing) -> OtherLicense + _ -> UnknownLicense $ name ++ + maybe "" (('-':) . display) version + instance Text License where parse = do name <- Parse.munch1 (\c -> isAlphaNum c && c /= '-') diff --git a/Cabal/Distribution/ModuleName.hs b/Cabal/Distribution/ModuleName.hs index abdba5db461..2e5ae5d9daf 100644 --- a/Cabal/Distribution/ModuleName.hs +++ b/Cabal/Distribution/ModuleName.hs @@ -28,12 +28,15 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.ShortText +import System.FilePath ( pathSeparator ) + import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp -import System.FilePath ( pathSeparator ) -- | A valid Haskell module name. -- @@ -49,6 +52,14 @@ instance Pretty ModuleName where pretty (ModuleName ms) = Disp.hcat (intersperse (Disp.char '.') (map Disp.text $ stlToStrings ms)) +instance Parsec ModuleName where + parsec = fromComponents <$> P.sepBy1 component (P.char '.') + where + component = do + c <- P.satisfy isUpper + cs <- P.munch validModuleChar + return (c:cs) + instance Text ModuleName where parse = do ms <- Parse.sepBy1 component (Parse.char '.') diff --git a/Cabal/Distribution/PackageDescription.hs b/Cabal/Distribution/PackageDescription.hs index 46a1d7c6862..78933140d0f 100644 --- a/Cabal/Distribution/PackageDescription.hs +++ b/Cabal/Distribution/PackageDescription.hs @@ -96,7 +96,7 @@ module Distribution.PackageDescription ( FlagName, mkFlagName, unFlagName, FlagAssignment, showFlagValue, - dispFlagAssignment, parseFlagAssignment, + dispFlagAssignment, parseFlagAssignment, parsecFlagAssignment, CondTree(..), ConfVar(..), Condition(..), cNot, cAnd, cOr, diff --git a/Cabal/Distribution/PackageDescription/FieldGrammar.hs b/Cabal/Distribution/PackageDescription/FieldGrammar.hs new file mode 100644 index 00000000000..33daf5d6dbd --- /dev/null +++ b/Cabal/Distribution/PackageDescription/FieldGrammar.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | 'GenericPackageDescription' Field descriptions +module Distribution.PackageDescription.FieldGrammar ( + -- * Package description + packageDescriptionFieldGrammar, + -- * Library + libraryFieldGrammar, + -- * Foreign library + foreignLibFieldGrammar, + -- * Executable + executableFieldGrammar, + -- * Test suite + TestSuiteStanza (..), + testSuiteFieldGrammar, + validateTestSuite, + unvalidateTestSuite, + -- ** Lenses + testStanzaTestType, + testStanzaMainIs, + testStanzaTestModule, + testStanzaBuildInfo, + -- * Benchmark + BenchmarkStanza (..), + benchmarkFieldGrammar, + validateBenchmark, + unvalidateBenchmark, + -- ** Lenses + benchmarkStanzaBenchmarkType, + benchmarkStanzaMainIs, + benchmarkStanzaBenchmarkModule, + benchmarkStanzaBuildInfo, + -- * Flag + flagFieldGrammar, + -- * Source repository + sourceRepoFieldGrammar, + -- * Setup build info + setupBInfoFieldGrammar, + -- * Component build info + buildInfoFieldGrammar, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compiler (CompilerFlavor (..)) +import Distribution.FieldGrammar +import Distribution.License (License (..)) +import Distribution.ModuleName (ModuleName) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec.Common +import Distribution.Parsec.Newtypes +import Distribution.Parsec.ParseResult +import Distribution.Text (display) +import Distribution.Types.ForeignLib +import Distribution.Types.ForeignLibType +import Distribution.Types.UnqualComponentName +import Distribution.Version (anyVersion) + +import qualified Distribution.Types.Lens as L + +------------------------------------------------------------------------------- +-- PackageDescription +------------------------------------------------------------------------------- + +packageDescriptionFieldGrammar + :: (FieldGrammar g, Applicative (g PackageDescription), Applicative (g PackageIdentifier)) + => g PackageDescription PackageDescription +packageDescriptionFieldGrammar = PackageDescription + <$> blurFieldGrammar L.package packageIdentifierGrammar + <*> optionalFieldDef "license" L.license UnspecifiedLicense + <*> licenseFilesGrammar + <*> optionalFieldDefAla "copyright" FreeText L.copyright "" + <*> optionalFieldDefAla "maintainer" FreeText L.maintainer "" + <*> optionalFieldDefAla "author" FreeText L.author "" + <*> optionalFieldDefAla "stability" FreeText L.stability "" + <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith + <*> optionalFieldDefAla "homepage" FreeText L.homepage "" + <*> optionalFieldDefAla "package-url" FreeText L.pkgUrl "" + <*> optionalFieldDefAla "bug-reports" FreeText L.bugReports "" + <*> pure [] -- source-repos are stanza + <*> optionalFieldDefAla "synopsis" FreeText L.synopsis "" + <*> optionalFieldDefAla "description" FreeText L.description "" + <*> optionalFieldDefAla "category" FreeText L.category "" + <*> prefixedFields "x-" L.customFieldsPD + <*> pure [] -- build-depends + <*> optionalFieldDefAla "cabal-version" SpecVersion L.specVersionRaw (Right anyVersion) + <*> optionalField "build-type" L.buildType + <*> pure Nothing -- custom-setup + -- components + <*> pure Nothing -- lib + <*> pure [] -- sub libs + <*> pure [] -- executables + <*> pure [] -- foreign libs + <*> pure [] -- test suites + <*> pure [] -- benchmarks + -- * Files + <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles + <*> optionalFieldDefAla "data-dir" FilePathNT L.dataDir "" + <*> monoidalFieldAla "extra-source-files" (alaList' VCat FilePathNT) L.extraSrcFiles + <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles + <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles + where + packageIdentifierGrammar = PackageIdentifier + <$> uniqueField "name" L.pkgName + <*> uniqueField "version" L.pkgVersion + + licenseFilesGrammar = (++) + -- TODO: neither field is deprecated + -- should we pretty print license-file if there's single license file + -- and license-files when more + <$> monoidalFieldAla "license-file" (alaList' FSep FilePathNT) L.licenseFiles + <*> monoidalFieldAla "license-files" (alaList' FSep FilePathNT) L.licenseFiles + ^^^ hiddenField + +------------------------------------------------------------------------------- +-- Library +------------------------------------------------------------------------------- + +libraryFieldGrammar + :: (FieldGrammar g, Applicative (g Library), Applicative (g BuildInfo)) + => Maybe UnqualComponentName -> g Library Library +libraryFieldGrammar n = Library n + <$> monoidalFieldAla "exposed-modules" (alaList' VCat MQuoted) L.exposedModules + <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules + <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures + <*> booleanFieldDef "exposed" L.libExposed True + <*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar +{-# SPECIALIZE libraryFieldGrammar :: Maybe UnqualComponentName -> ParsecFieldGrammar' Library #-} +{-# SPECIALIZE libraryFieldGrammar :: Maybe UnqualComponentName -> PrettyFieldGrammar' Library #-} + +------------------------------------------------------------------------------- +-- Foreign library +------------------------------------------------------------------------------- + +foreignLibFieldGrammar + :: (FieldGrammar g, Applicative (g ForeignLib), Applicative (g BuildInfo)) + => UnqualComponentName -> g ForeignLib ForeignLib +foreignLibFieldGrammar n = ForeignLib n + <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown + <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions + <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar + <*> optionalField "lib-version-info" L.foreignLibVersionInfo + <*> optionalField "lib-version-linux" L.foreignLibVersionLinux + <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile +{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-} +{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-} + +------------------------------------------------------------------------------- +-- Executable +------------------------------------------------------------------------------- + +executableFieldGrammar + :: (FieldGrammar g, Applicative (g Executable), Applicative (g BuildInfo)) + => UnqualComponentName -> g Executable Executable +executableFieldGrammar n = Executable n + -- main-is is optional as conditional blocks don't have it + <$> optionalFieldDefAla "main-is" FilePathNT L.modulePath "" + <*> monoidalField "scope" L.exeScope + <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar +{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-} +{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-} + +------------------------------------------------------------------------------- +-- TestSuite +------------------------------------------------------------------------------- + +-- | An intermediate type just used for parsing the test-suite stanza. +-- After validation it is converted into the proper 'TestSuite' type. +data TestSuiteStanza = TestSuiteStanza + { _testStanzaTestType :: Maybe TestType + , _testStanzaMainIs :: Maybe FilePath + , _testStanzaTestModule :: Maybe ModuleName + , _testStanzaBuildInfo :: BuildInfo + } + +testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) +testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s)) +{-# INLINE testStanzaTestType #-} + +testStanzaMainIs :: Lens' TestSuiteStanza (Maybe FilePath) +testStanzaMainIs f s = fmap (\x -> s { _testStanzaMainIs = x }) (f (_testStanzaMainIs s)) +{-# INLINE testStanzaMainIs #-} + +testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName) +testStanzaTestModule f s = fmap (\x -> s { _testStanzaTestModule = x }) (f (_testStanzaTestModule s)) +{-# INLINE testStanzaTestModule #-} + +testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo +testStanzaBuildInfo f s = fmap (\x -> s { _testStanzaBuildInfo = x }) (f (_testStanzaBuildInfo s)) +{-# INLINE testStanzaBuildInfo #-} + +testSuiteFieldGrammar + :: (FieldGrammar g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo)) + => g TestSuiteStanza TestSuiteStanza +testSuiteFieldGrammar = TestSuiteStanza + <$> optionalField "type" testStanzaTestType + <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs + <*> optionalField "test-module" testStanzaTestModule + <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar + +validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite +validateTestSuite pos stanza = case _testStanzaTestType stanza of + Nothing -> return $ + emptyTestSuite { testBuildInfo = _testStanzaBuildInfo stanza } + + Just tt@(TestTypeUnknown _ _) -> + pure emptyTestSuite + { testInterface = TestSuiteUnsupported tt + , testBuildInfo = _testStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownTestTypes -> + pure emptyTestSuite + { testInterface = TestSuiteUnsupported tt + , testBuildInfo = _testStanzaBuildInfo stanza + } + + Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of + Nothing -> do + parseFailure pos (missingField "main-is" tt) + pure emptyTestSuite + Just file -> do + when (isJust (_testStanzaTestModule stanza)) $ + parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) + pure emptyTestSuite + { testInterface = TestSuiteExeV10 ver file + , testBuildInfo = _testStanzaBuildInfo stanza + } + + Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of + Nothing -> do + parseFailure pos (missingField "test-module" tt) + pure emptyTestSuite + Just module_ -> do + when (isJust (_testStanzaMainIs stanza)) $ + parseWarning pos PWTExtraMainIs (extraField "main-is" tt) + pure emptyTestSuite + { testInterface = TestSuiteLibV09 ver module_ + , testBuildInfo = _testStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " test suite type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' test suite type." + +unvalidateTestSuite :: TestSuite -> TestSuiteStanza +unvalidateTestSuite t = TestSuiteStanza + { _testStanzaTestType = ty + , _testStanzaMainIs = ma + , _testStanzaTestModule = mo + , _testStanzaBuildInfo = testBuildInfo t + } + where + (ty, ma, mo) = case testInterface t of + TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing) + TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu) + _ -> (Nothing, Nothing, Nothing) + +------------------------------------------------------------------------------- +-- Benchmark +------------------------------------------------------------------------------- + +-- | An intermediate type just used for parsing the benchmark stanza. +-- After validation it is converted into the proper 'Benchmark' type. +data BenchmarkStanza = BenchmarkStanza + { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType + , _benchmarkStanzaMainIs :: Maybe FilePath + , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName + , _benchmarkStanzaBuildInfo :: BuildInfo + } + +benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) +benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s)) +{-# INLINE benchmarkStanzaBenchmarkType #-} + +benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe FilePath) +benchmarkStanzaMainIs f s = fmap (\x -> s { _benchmarkStanzaMainIs = x }) (f (_benchmarkStanzaMainIs s)) +{-# INLINE benchmarkStanzaMainIs #-} + +benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName) +benchmarkStanzaBenchmarkModule f s = fmap (\x -> s { _benchmarkStanzaBenchmarkModule = x }) (f (_benchmarkStanzaBenchmarkModule s)) +{-# INLINE benchmarkStanzaBenchmarkModule #-} + +benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo +benchmarkStanzaBuildInfo f s = fmap (\x -> s { _benchmarkStanzaBuildInfo = x }) (f (_benchmarkStanzaBuildInfo s)) +{-# INLINE benchmarkStanzaBuildInfo #-} + +benchmarkFieldGrammar + :: (FieldGrammar g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo)) + => g BenchmarkStanza BenchmarkStanza +benchmarkFieldGrammar = BenchmarkStanza + <$> optionalField "type" benchmarkStanzaBenchmarkType + <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs + <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule + <*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar + +validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark +validateBenchmark pos stanza = case _benchmarkStanzaBenchmarkType stanza of + Nothing -> pure emptyBenchmark + { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza } + + Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark + { benchmarkInterface = BenchmarkUnsupported tt + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark + { benchmarkInterface = BenchmarkUnsupported tt + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + + Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of + Nothing -> do + parseFailure pos (missingField "main-is" tt) + pure emptyBenchmark + Just file -> do + when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $ + parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) + pure emptyBenchmark + { benchmarkInterface = BenchmarkExeV10 ver file + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " benchmark type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' benchmark type." + +unvalidateBenchmark :: Benchmark -> BenchmarkStanza +unvalidateBenchmark b = BenchmarkStanza + { _benchmarkStanzaBenchmarkType = ty + , _benchmarkStanzaMainIs = ma + , _benchmarkStanzaBenchmarkModule = mo + , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b + } + where + (ty, ma, mo) = case benchmarkInterface b of + BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing) + BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing) + _ -> (Nothing, Nothing, Nothing) + +------------------------------------------------------------------------------- +-- Build info +------------------------------------------------------------------------------- + +buildInfoFieldGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo BuildInfo +buildInfoFieldGrammar = BuildInfo + <$> booleanFieldDef "buildable" L.buildable True + <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools + ^^^ deprecatedSince [2,0] "Please use 'build-tool-depends' field" + <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends + ^^^ availableSince [2,0] + <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions + <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions + <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions + <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends + <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks + <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs + <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources + <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources + <*> hsSourceDirsGrammar + <*> monoidalFieldAla "other-modules" (alaList' VCat MQuoted) L.otherModules + <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules + <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage + <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages + <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions + <*> monoidalFieldAla "other-extensions" (alaList' FSep MQuoted) L.otherExtensions + <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions + ^^^ deprecatedSince [1,12] "Please use 'default-extensions' or 'other-extensions' fields." + <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs + <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs + <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs + <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs + <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes + <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes + <*> optionsFieldGrammar + <*> profOptionsFieldGrammar + <*> sharedOptionsFieldGrammar + <*> pure [] -- static-options ??? + <*> prefixedFields "x-" L.customFieldsBI + <*> monoidalFieldAla "build-depends" (alaList CommaVCat) L.targetBuildDepends + <*> monoidalFieldAla "mixins" (alaList CommaVCat) L.mixins +{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-} +{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-} + +hsSourceDirsGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo [FilePath] +hsSourceDirsGrammar = (++) + <$> monoidalFieldAla "hs-source-dirs" (alaList' FSep FilePathNT) L.hsSourceDirs + <*> monoidalFieldAla "hs-source-dir" (alaList' FSep FilePathNT) L.hsSourceDirs + ^^^ deprecatedField' "Please use 'hs-source-dirs'" + +optionsFieldGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo [(CompilerFlavor, [String])] +optionsFieldGrammar = combine + <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) + <*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS) + <*> monoidalFieldAla "jhc-options" (alaList' NoCommaFSep Token') (extract JHC) + -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept + -- around for backwards compatibility. + <* knownField "hugs-options" + <* knownField "nhc98-options" + where + extract :: CompilerFlavor -> ALens' BuildInfo [String] + extract flavor = L.options . lookupLens flavor + + combine ghc ghcjs jhs = + f GHC ghc ++ f GHCJS ghcjs ++ f JHC jhs + where + f _flavor [] = [] + f flavor opts = [(flavor, opts)] + +profOptionsFieldGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo [(CompilerFlavor, [String])] +profOptionsFieldGrammar = combine + <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) + <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) + where + extract :: CompilerFlavor -> ALens' BuildInfo [String] + extract flavor = L.profOptions . lookupLens flavor + + combine ghc ghcjs = f GHC ghc ++ f GHCJS ghcjs + where + f _flavor [] = [] + f flavor opts = [(flavor, opts)] + +sharedOptionsFieldGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo [(CompilerFlavor, [String])] +sharedOptionsFieldGrammar = combine + <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) + <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) + where + extract :: CompilerFlavor -> ALens' BuildInfo [String] + extract flavor = L.sharedOptions . lookupLens flavor + + combine ghc ghcjs = f GHC ghc ++ f GHCJS ghcjs + where + f _flavor [] = [] + f flavor opts = [(flavor, opts)] + +lookupLens :: (Functor f, Ord k) => k -> LensLike' f [(k, [v])] [v] +lookupLens k f kvs = str kvs <$> f (gtr kvs) + where + gtr = fromMaybe [] . lookup k + + str [] v = [(k, v)] + str (x@(k',_):xs) v + | k == k' = (k, v) : xs + | otherwise = x : str xs v + +------------------------------------------------------------------------------- +-- Flag +------------------------------------------------------------------------------- + +flagFieldGrammar + :: (FieldGrammar g, Applicative (g Flag)) + => FlagName -> g Flag Flag +flagFieldGrammar name = MkFlag name + <$> optionalFieldDefAla "description" FreeText L.flagDescription "" + <*> booleanFieldDef "default" L.flagDefault True + <*> booleanFieldDef "manual" L.flagManual False +{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' Flag #-} +{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' Flag #-} + +------------------------------------------------------------------------------- +-- SourceRepo +------------------------------------------------------------------------------- + +sourceRepoFieldGrammar + :: (FieldGrammar g, Applicative (g SourceRepo)) + => RepoKind -> g SourceRepo SourceRepo +sourceRepoFieldGrammar kind = SourceRepo kind + <$> optionalField "type" L.repoType + <*> optionalFieldAla "location" FreeText L.repoLocation + <*> optionalFieldAla "module" Token L.repoModule + <*> optionalFieldAla "branch" Token L.repoBranch + <*> optionalFieldAla "tag" Token L.repoTag + <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir +{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-} +{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind ->PrettyFieldGrammar' SourceRepo #-} + +------------------------------------------------------------------------------- +-- SetupBuildInfo +------------------------------------------------------------------------------- + +setupBInfoFieldGrammar + :: (FieldGrammar g, Functor (g SetupBuildInfo)) + => Bool -> g SetupBuildInfo SetupBuildInfo +setupBInfoFieldGrammar def = flip SetupBuildInfo def + <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends +{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} +{-# SPECIALIZE setupBInfoFieldGrammar :: Bool ->PrettyFieldGrammar' SetupBuildInfo #-} diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index d8217cb2392..b0e316cff5c 100644 --- a/Cabal/Distribution/PackageDescription/Parse.hs +++ b/Cabal/Distribution/PackageDescription/Parse.hs @@ -118,7 +118,7 @@ pkgDescrFieldDescrs = (\pkg -> case licenseFiles pkg of [_] -> [] xs -> xs) - (\ls pkg -> pkg{licenseFiles=ls}) + (\ls pkg -> pkg{licenseFiles=licenseFiles pkg ++ ls}) , simpleField "copyright" showFreeText parseFreeText copyright (\val pkg -> pkg{copyright=val}) diff --git a/Cabal/Distribution/PackageDescription/Parsec.hs b/Cabal/Distribution/PackageDescription/Parsec.hs index b35b918c407..b01a772c69c 100644 --- a/Cabal/Distribution/PackageDescription/Parsec.hs +++ b/Cabal/Distribution/PackageDescription/Parsec.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.Parsec @@ -26,44 +26,38 @@ module Distribution.PackageDescription.Parsec ( runParseResult, -- ** Supplementary build information - -- readHookedBuildInfo, - -- parseHookedBuildInfo, + readHookedBuildInfo, + parseHookedBuildInfo, ) where -import Prelude () -import Distribution.Compat.Prelude -import qualified Data.ByteString as BS -import Data.List (partition) -import qualified Data.Map as Map -import qualified Distribution.Compat.SnocList as SnocList +import Distribution.Compat.Prelude +import Prelude () + +import qualified Data.ByteString as BS +import Data.List (partition) +import qualified Distribution.Compat.Map.Strict as Map +import Distribution.FieldGrammar import Distribution.PackageDescription -import Distribution.PackageDescription.Parsec.FieldDescr -import Distribution.PackageDescription.Parsec.Quirks (patchQuirks) -import Distribution.Parsec.Class (parsec) -import Distribution.Parsec.ConfVar - (parseConditionConfVar) -import Distribution.Parsec.LexerMonad - (LexWarning, toPWarning) +import Distribution.PackageDescription.FieldGrammar +import Distribution.PackageDescription.Quirks (patchQuirks) +import Distribution.Parsec.Class (parsec) +import Distribution.Parsec.Common +import Distribution.Parsec.ConfVar (parseConditionConfVar) +import Distribution.Parsec.Field (FieldName, getName) +import Distribution.Parsec.LexerMonad (LexWarning, toPWarning) import Distribution.Parsec.Parser -import Distribution.Parsec.Types.Common -import Distribution.Parsec.Types.Field (getName) -import Distribution.Parsec.Types.FieldDescr -import Distribution.Parsec.Types.ParseResult -import Distribution.Simple.Utils - (die', fromUTF8BS, warn) -import Distribution.Text (display) -import Distribution.Types.ForeignLib +import Distribution.Parsec.ParseResult +import Distribution.Simple.Utils (die', fromUTF8BS, warn) +import Distribution.Text (display) import Distribution.Types.CondTree +import Distribution.Types.ForeignLib import Distribution.Types.UnqualComponentName (UnqualComponentName, mkUnqualComponentName) -import Distribution.Verbosity (Verbosity) +import Distribution.Utils.Generic (breakMaybe, unfoldrM) +import Distribution.Verbosity (Verbosity) import Distribution.Version - (LowerBound (..), Version, asVersionIntervals, mkVersion, - orLaterVersion) -import System.Directory - (doesFileExist) -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P + (LowerBound (..), Version, asVersionIntervals, mkVersion, orLaterVersion) +import System.Directory (doesFileExist) import Distribution.Compat.Lens import qualified Distribution.Types.GenericPackageDescription.Lens as L @@ -106,7 +100,6 @@ readGenericPackageDescription = readAndParseFile parseGenericPackageDescription -- In Cabal 1.2 the syntax for package descriptions was changed to a format -- with sections and possibly indented property descriptions. -- --- TODO: add lex warnings parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription parseGenericPackageDescription bs = case readFields' bs' of Right (fs, lexWarnings) -> do @@ -125,44 +118,9 @@ parseGenericPackageDescriptionMaybe = where trdOf3 (_, _, x) = x -runFieldParser :: FieldParser a -> [FieldLine Position] -> ParseResult a -runFieldParser p ls = runFieldParser' pos p =<< fieldlinesToString pos ls - where - -- TODO: make per line lookup - pos = case ls of - [] -> Position 0 0 - (FieldLine pos' _ : _) -> pos' - fieldlinesToBS :: [FieldLine ann] -> BS.ByteString fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) --- TODO: Take position from FieldLine --- TODO: Take field name -fieldlinesToString :: Position -> [FieldLine ann] -> ParseResult String -fieldlinesToString pos fls = - let str = intercalate "\n" . map (\(FieldLine _ bs') -> fromUTF8BS bs') $ fls - in if '\xfffd' `elem` str - then str <$ parseWarning pos PWTUTF "Invalid UTF8 encoding" - else pure str - -runFieldParser' :: Position -> FieldParser a -> String -> ParseResult a -runFieldParser' (Position row col) p str = case P.runParser p' [] "" str of - Right (pok, ws) -> do - -- TODO: map pos - traverse_ (\(PWarning t pos w) -> parseWarning pos t w) ws - pure pok - Left err -> do - let ppos = P.errorPos err - -- Positions start from 1:1, not 0:0 - let epos = Position (row - 1 + P.sourceLine ppos) (col - 1 + P.sourceColumn ppos) - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - - parseFatalFailure epos $ msg ++ ": " ++ show str - where - p' = (,) <$ P.spaces <*> p <* P.spaces <* P.eof <*> P.getState - -- Note [Accumulating parser] -- -- This parser has two "states": @@ -173,37 +131,18 @@ parseGenericPackageDescription' -> [Field Position] -> ParseResult GenericPackageDescription parseGenericPackageDescription' lexWarnings fs = do - parseWarnings' (fmap toPWarning lexWarnings) + parseWarnings (fmap toPWarning lexWarnings) let (syntax, fs') = sectionizeFields fs - gpd <- goFields emptyGpd fs' - -- Various post checks - maybeWarnCabalVersion syntax (packageDescription gpd) - -- TODO: this does nothing - -- checkForUndefinedFlags gpd - -- TODO: do other validations - return gpd - where - -- First fields - goFields - :: GenericPackageDescription - -> [Field Position] - -> ParseResult GenericPackageDescription - goFields gpd [] = pure gpd - goFields gpd (Field (Name pos name) fieldLines : fields) = - case Map.lookup name pdFieldParsers of - -- TODO: can be more elegant - Nothing -> fieldlinesToString pos fieldLines >>= \value -> case storeXFieldsPD name value (packageDescription gpd) of - Nothing -> do - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - goFields gpd fields - Just pd -> - goFields (gpd { packageDescription = pd }) fields - Just parser -> do - pd <- runFieldParser (parser $ packageDescription gpd) fieldLines - let gpd' = gpd { packageDescription = pd } - goFields gpd' fields - goFields gpd fields@(Section _ _ _ : _) = goSections gpd fields + + -- PackageDescription + let (fields, sectionFields) = takeFields fs' + pd <- parseFieldGrammar fields packageDescriptionFieldGrammar + maybeWarnCabalVersion syntax pd + -- Sections + let gpd = emptyGpd & L.packageDescription .~ pd + goSections gpd sectionFields + where -- Sections goSections :: GenericPackageDescription @@ -220,10 +159,6 @@ parseGenericPackageDescription' lexWarnings fs = do emptyGpd :: GenericPackageDescription emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] [] - pdFieldParsers :: Map FieldName (PackageDescription -> FieldParser PackageDescription) - pdFieldParsers = Map.fromList $ - map (\x -> (fieldName x, fieldParser x)) pkgDescrFieldDescrs - parseSection :: GenericPackageDescription -> Name Position @@ -232,60 +167,54 @@ parseGenericPackageDescription' lexWarnings fs = do -> ParseResult GenericPackageDescription parseSection gpd (Name pos name) args fields | name == "library" && null args = do + lib <- parseCondTree (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields -- TODO: check that library is defined once - l <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields - let gpd' = gpd { condLibrary = Just l } - pure gpd' + pure $ gpd & L.condLibrary ?~ lib -- Sublibraries | name == "library" = do + -- TODO: check cabal-version name' <- parseUnqualComponentName pos args - lib <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields + lib <- parseCondTree (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields -- TODO check duplicate name here? - let gpd' = gpd { condSubLibraries = condSubLibraries gpd ++ [(name', lib)] } - pure gpd' + pure $ gpd & L.condSubLibraries %~ snoc (name', lib) | name == "foreign-library" = do name' <- parseUnqualComponentName pos args - flib <- parseCondTree foreignLibFieldDescrs storeXFieldsForeignLib (targetBuildDepends . foreignLibBuildInfo) emptyForeignLib fields + flib <- parseCondTree (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields -- TODO check duplicate name here? - let gpd' = gpd { condForeignLibs = condForeignLibs gpd ++ [(name', flib)] } - pure gpd' + pure $ gpd & L.condForeignLibs %~ snoc (name', flib) | name == "executable" = do name' <- parseUnqualComponentName pos args -- Note: we don't parse the "executable" field here, hence the tail hack. Duncan 2010 - exe <- parseCondTree (tail executableFieldDescrs) storeXFieldsExe (targetBuildDepends . buildInfo) emptyExecutable fields + exe <- parseCondTree (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields -- TODO check duplicate name here? - let gpd' = gpd { condExecutables = condExecutables gpd ++ [(name', exe)] } - pure gpd' + pure $ gpd & L.condExecutables %~ snoc (name', exe) | name == "test-suite" = do name' <- parseUnqualComponentName pos args - testStanza <- parseCondTree testSuiteFieldDescrs storeXFieldsTest (targetBuildDepends . testStanzaBuildInfo) emptyTestStanza fields + testStanza <- parseCondTree testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields testSuite <- traverse (validateTestSuite pos) testStanza -- TODO check duplicate name here? - let gpd' = gpd { condTestSuites = condTestSuites gpd ++ [(name', testSuite)] } - pure gpd' + pure $ gpd & L.condTestSuites %~ snoc (name', testSuite) | name == "benchmark" = do name' <- parseUnqualComponentName pos args - benchStanza <- parseCondTree benchmarkFieldDescrs storeXFieldsBenchmark (targetBuildDepends . benchmarkStanzaBuildInfo) emptyBenchmarkStanza fields + benchStanza <- parseCondTree benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields bench <- traverse (validateBenchmark pos) benchStanza -- TODO check duplicate name here? - let gpd' = gpd { condBenchmarks = condBenchmarks gpd ++ [(name', bench)] } - pure gpd' + pure $ gpd & L.condBenchmarks %~ snoc (name', bench) | name == "flag" = do name' <- parseName pos args name'' <- runFieldParser' pos parsec name' `recoverWith` mkFlagName "" - flag <- parseFields flagFieldDescrs warnUnrec (emptyFlag name'') fields + flag <- parseFields fields (flagFieldGrammar name'') -- Check default flag - let gpd' = gpd { genPackageFlags = genPackageFlags gpd ++ [flag] } - pure gpd' + pure $ gpd & L.genPackageFlags %~ snoc flag | name == "custom-setup" && null args = do - sbi <- parseFields setupBInfoFieldDescrs warnUnrec mempty fields + sbi <- parseFields fields (setupBInfoFieldGrammar False) pure $ gpd & L.packageDescription . L.setupBuildInfo ?~ sbi | name == "source-repository" = do @@ -293,13 +222,13 @@ parseGenericPackageDescription' lexWarnings fs = do [SecArgName spos secName] -> runFieldParser' spos parsec (fromUTF8BS secName) `recoverWith` RepoHead [] -> do - parseFailure pos $ "'source-repository' needs one argument" + parseFailure pos "'source-repository' requires exactly one argument" pure RepoHead _ -> do parseFailure pos $ "Invalid source-repository kind " ++ show args pure RepoHead - sr <- parseFields sourceRepoFieldDescrs warnUnrec (emptySourceRepo kind) fields + sr <- parseFields fields (sourceRepoFieldGrammar kind) pure $ gpd & L.packageDescription . L.sourceRepos %~ snoc sr | otherwise = do @@ -350,110 +279,71 @@ parseName pos args = case args of parseUnqualComponentName :: Position -> [SectionArg Position] -> ParseResult UnqualComponentName parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args - --- | Parse a non-recursive list of fields, given a list of field descriptions, --- a structure to accumulate the parsed fields, and a function --- that can decide what to do with fields which don't match any --- of the field descriptions. +-- | Parse a non-recursive list of fields. parseFields - :: forall a. - [FieldDescr a] -- ^ descriptions of fields we know how to parse - -> UnknownFieldParser a -- ^ possibly do something with unrecognized fields - -> a -- ^ accumulator - -> [Field Position] -- ^ fields to be parsed + :: [Field Position] -- ^ fields to be parsed + -> ParsecFieldGrammar' a -> ParseResult a -parseFields descrs _unknown = foldM go - where - go :: a -> Field Position -> ParseResult a - go x (Section (Name pos name) _ _) = do - -- Even we occur a subsection, we can continue parsing - parseFailure pos $ "invalid subsection " ++ show name - return x - go x (Field (Name pos name) fieldLines) = - case Map.lookup name fieldParsers of - Nothing -> do - -- TODO: use 'unknown' - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - return x - Just parser -> - runFieldParser (parser x) fieldLines - - fieldParsers :: Map FieldName (a -> FieldParser a) - fieldParsers = Map.fromList $ - map (\x -> (fieldName x, fieldParser x)) descrs - -type C c a = CondBranch ConfVar c a +parseFields fields grammar = do + let (fs0, ss) = partitionFields fields + traverse_ (traverse_ warnInvalidSubsection) ss + parseFieldGrammar fs0 grammar + +warnInvalidSubsection :: Section Position -> ParseResult () +warnInvalidSubsection (MkSection (Name pos name) _ _) = + void (parseFailure pos $ "invalid subsection " ++ show name) parseCondTree - :: forall a c. - [FieldDescr a] -- ^ Field descriptions - -> UnknownFieldParser a -- ^ How to parse unknown fields - -> (a -> c) -- ^ Condition extractor - -> a -- ^ Initial value - -> [Field Position] -- ^ Fields to parse + :: forall a c. ParsecFieldGrammar' a -- ^ grammar + -> (a -> c) -- ^ condition extractor + -> [Field Position] -> ParseResult (CondTree ConfVar c a) -parseCondTree descs unknown cond ini = impl +parseCondTree grammar cond = go where - impl :: [Field Position] -> ParseResult (CondTree ConfVar c a) - impl fields = do - (x, xs) <- goFields (ini, mempty) fields - return $ CondNode x (cond x) (SnocList.runSnocList xs) - - goFields - :: (a, SnocList.SnocList (C c a)) - -> [Field Position] - -> ParseResult (a, SnocList.SnocList (C c a)) - goFields xss [] = return xss - - goFields xxs (Section (Name _pos name) tes con : fields) | name == "if" = do - tes' <- parseConditionConfVar tes - con' <- impl con - -- Jump to 'else' state - goElse tes' con' xxs fields - - goFields xxs (Section (Name pos name) _ _ : fields) = do - -- Even we occur a subsection, we can continue parsing - -- http://hackage.haskell.org/package/constraints-0.1/constraints.cabal + go fields = do + let (fs, ss) = partitionFields fields + x <- parseFieldGrammar fs grammar + branches <- concat <$> traverse parseIfs ss + return (CondNode x (cond x) branches) -- TODO: branches + + parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar c a] + parseIfs [] = return [] + parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do + test' <- parseConditionConfVar test + fields' <- go fields + -- TODO: else + (elseFields, sections') <- parseElseIfs sections + return (CondBranch test' fields' elseFields : sections') + parseIfs (MkSection (Name pos name) _ _ : sections) = do parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name - goFields xxs fields - - goFields (x, xs) (Field (Name pos name) fieldLines : fields) = - case Map.lookup name fieldParsers of - Nothing -> fieldlinesToString pos fieldLines >>= \value -> case unknown name value x of - Nothing -> do - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - goFields (x, xs) fields - Just x' -> do - goFields (x', xs) fields - Just parser -> do - x' <- runFieldParser (parser x) fieldLines - goFields (x', xs) fields - - -- Try to parse else branch - goElse - :: Condition ConfVar - -> CondTree ConfVar c a - -> (a, SnocList.SnocList (C c a)) - -> [Field Position] - -> ParseResult (a, SnocList.SnocList (C c a)) - goElse tes con (x, xs) (Section (Name pos name) secArgs alt : fields) | name == "else" = do - when (not . null $ secArgs) $ do - parseFailure pos $ "`else` section has section arguments " ++ show secArgs - alt' <- case alt of - [] -> pure Nothing - _ -> Just <$> impl alt - let ieb = (CondBranch tes con alt') - goFields (x, SnocList.snoc xs ieb) fields - goElse tes con (x, xs) fields = do - let ieb = (CondBranch tes con Nothing) - goFields (x, SnocList.snoc xs ieb) fields - - fieldParsers :: Map FieldName (a -> FieldParser a) - fieldParsers = Map.fromList $ - map (\x -> (fieldName x, fieldParser x)) descs + parseIfs sections + + parseElseIfs + :: [Section Position] + -> ParseResult (Maybe (CondTree ConfVar c a), [CondBranch ConfVar c a]) + parseElseIfs [] = return (Nothing, []) + parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do + unless (null args) $ + parseFailure pos $ "`else` section has section arguments " ++ show args + elseFields <- go fields + sections' <- parseIfs sections + return (Just elseFields, sections') +{- + parseElseIfs (MkSection (Name _ name) test fields : sections) | name == "elif" = do + -- TODO: check cabal-version + test' <- parseConditionConfVar test + fields' <- go fields + (elseFields, sections') <- parseElseIfs sections + -- we parse an empty 'Fields', to get empty value for a node + a <- parseFieldGrammar mempty grammar + return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections') +-} + parseElseIfs sections = (,) Nothing <$> parseIfs sections {- Note [Accumulating parser] +Note: Outdated a bit + In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a -> FieldParser a)@. The weird value is used because we accumulate structure of @a@ by folding over the fields. There are various reasons for that: @@ -476,6 +366,8 @@ with new AST, this all need to be rewritten. -- Old syntax ------------------------------------------------------------------------------- +-- TODO: move to own module + -- | "Sectionize" an old-style Cabal file. A sectionized file has: -- -- * all global fields at the beginning, followed by @@ -537,4 +429,70 @@ data Syntax = OldSyntax | NewSyntax deriving (Eq, Show) libFieldNames :: [FieldName] -libFieldNames = map fieldName libFieldDescrs +libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar Nothing) + +------------------------------------------------------------------------------- +-- Suplementary build information +------------------------------------------------------------------------------- + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = readAndParseFile parseHookedBuildInfo + +parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo +parseHookedBuildInfo bs = case readFields' bs' of + Right (fs, lexWarnings) -> do + when patched $ + parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" + parseHookedBuildInfo' lexWarnings fs + -- TODO: better marshalling of errors + Left perr -> parseFatalFailure zeroPos (show perr) + where + (patched, bs') = patchQuirks bs + +parseHookedBuildInfo' + :: [LexWarning] + -> [Field Position] + -> ParseResult HookedBuildInfo +parseHookedBuildInfo' lexWarnings fs = do + parseWarnings (fmap toPWarning lexWarnings) + (mLibFields, exes) <- stanzas fs + mLib <- parseLib mLibFields + biExes <- traverse parseExe exes + return (mLib, biExes) + where + parseLib :: Fields Position -> ParseResult (Maybe BuildInfo) + parseLib fields + | Map.null fields = pure Nothing + | otherwise = Just <$> parseFieldGrammar fields buildInfoFieldGrammar + + parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo) + parseExe (n, fields) = do + bi <- parseFieldGrammar fields buildInfoFieldGrammar + pure (n, bi) + + stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)]) + stanzas fields = do + let (hdr0, exes0) = breakMaybe isExecutableField fields + hdr <- toFields hdr0 + exes <- unfoldrM (traverse toExe) exes0 + pure (hdr, exes) + + toFields :: [Field Position] -> ParseResult (Fields Position) + toFields fields = do + let (fields', ss) = partitionFields fields + traverse_ (traverse_ warnInvalidSubsection) ss + pure fields' + + toExe + :: ([FieldLine Position], [Field Position]) + -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position])) + toExe (fss, fields) = do + name <- runFieldParser zeroPos parsec fss + let (hdr0, rest) = breakMaybe isExecutableField fields + hdr <- toFields hdr0 + pure ((name, hdr), rest) + + isExecutableField (Field (Name _ name) fss) + | name == "executable" = Just fss + | otherwise = Nothing + isExecutableField _ = Nothing diff --git a/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs b/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs deleted file mode 100644 index 0d0de524a30..00000000000 --- a/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs +++ /dev/null @@ -1,620 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | 'GenericPackageDescription' Field descriptions -module Distribution.PackageDescription.Parsec.FieldDescr ( - -- * Package description - pkgDescrFieldDescrs, - storeXFieldsPD, - -- * Library - libFieldDescrs, - storeXFieldsLib, - -- * Foreign library - foreignLibFieldDescrs, - storeXFieldsForeignLib, - -- * Executable - executableFieldDescrs, - storeXFieldsExe, - -- * Test suite - TestSuiteStanza (..), - emptyTestStanza, - testSuiteFieldDescrs, - storeXFieldsTest, - validateTestSuite, - -- * Benchmark - BenchmarkStanza (..), - emptyBenchmarkStanza, - benchmarkFieldDescrs, - storeXFieldsBenchmark, - validateBenchmark, - -- * Flag - flagFieldDescrs, - -- * Source repository - sourceRepoFieldDescrs, - -- * Setup build info - setupBInfoFieldDescrs, - ) where - -import qualified Data.ByteString as BS -import Data.List (dropWhileEnd) -import qualified Distribution.Compat.Parsec as Parsec -import Distribution.Compat.Prelude -import Distribution.Compiler (CompilerFlavor (..)) -import Distribution.ModuleName (ModuleName) -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Parsec.Class -import Distribution.Parsec.Types.Common -import Distribution.Parsec.Types.FieldDescr -import Distribution.Parsec.Types.ParseResult -import Distribution.ParseUtils (showTestedWith) -import Distribution.Pretty -import Distribution.Simple.Utils (fromUTF8BS) -import Distribution.Text (disp, display) -import Distribution.Types.ForeignLib -import Prelude () -import Text.PrettyPrint (vcat) - -------------------------------------------------------------------------------- --- common FieldParsers -------------------------------------------------------------------------------- - --- | This is /almost/ @'many' 'Distribution.Compat.Parsec.anyChar'@, but it --- --- * trims whitespace from ends of the lines, --- --- * converts lines with only single dot into empty line. --- -freeTextFieldParser :: FieldParser String -freeTextFieldParser = dropDotLines <$ Parsec.spaces <*> many Parsec.anyChar - where - -- Example package with dot lines - -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal - dropDotLines "." = "." - dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x - dotToEmpty x | trim' x == "." = "" - dotToEmpty x = trim x - - trim' = dropWhileEnd (`elem` (" \t" :: String)) - -------------------------------------------------------------------------------- --- PackageDescription -------------------------------------------------------------------------------- - --- TODO: other-files isn't used in any cabal file on Hackage. -pkgDescrFieldDescrs :: [FieldDescr PackageDescription] -pkgDescrFieldDescrs = - [ simpleField "name" - disp parsec - packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) - , simpleField "version" - disp parsec - packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) - , simpleField "cabal-version" - (either disp disp) (Left <$> parsec <|> Right <$> parsec) - specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) - , simpleField "build-type" - (maybe mempty disp) (Just <$> parsec) - buildType (\t pkg -> pkg{buildType=t}) - , simpleField "license" - disp (parsecMaybeQuoted parsec) - license (\l pkg -> pkg{license=l}) - , simpleField "license-file" - showFilePath parsecFilePath - (\pkg -> case licenseFiles pkg of - [x] -> x - _ -> "") - (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]}) - -- We have both 'license-file' and 'license-files' fields. - -- Rather than declaring license-file to be deprecated, we will continue - -- to allow both. The 'license-file' will continue to only allow single - -- tokens, while 'license-files' allows multiple. On pretty-printing, we - -- will use 'license-file' if there's just one, and use 'license-files' - -- otherwise. - , listField "license-files" - showFilePath parsecFilePath - (\pkg -> case licenseFiles pkg of - [_] -> [] - xs -> xs) - (\ls pkg -> pkg{licenseFiles=ls}) - , simpleField "copyright" - showFreeText freeTextFieldParser - copyright (\val pkg -> pkg{copyright=val}) - , simpleField "maintainer" - showFreeText freeTextFieldParser - maintainer (\val pkg -> pkg{maintainer=val}) - , simpleField "stability" - showFreeText freeTextFieldParser - stability (\val pkg -> pkg{stability=val}) - , simpleField "homepage" - showFreeText freeTextFieldParser - homepage (\val pkg -> pkg{homepage=val}) - , simpleField "package-url" - showFreeText freeTextFieldParser - pkgUrl (\val pkg -> pkg{pkgUrl=val}) - , simpleField "bug-reports" - showFreeText freeTextFieldParser - bugReports (\val pkg -> pkg{bugReports=val}) - , simpleField "synopsis" - showFreeText freeTextFieldParser - synopsis (\val pkg -> pkg{synopsis=val}) - , simpleField "description" - showFreeText freeTextFieldParser - description (\val pkg -> pkg{description=val}) - , simpleField "category" - showFreeText freeTextFieldParser - category (\val pkg -> pkg{category=val}) - , simpleField "author" - showFreeText freeTextFieldParser - author (\val pkg -> pkg{author=val}) - , listField "tested-with" - showTestedWith parsecTestedWith - testedWith (\val pkg -> pkg{testedWith=val}) - , listFieldWithSep vcat "data-files" - showFilePath parsecFilePath - dataFiles (\val pkg -> pkg{dataFiles=val}) - , simpleField "data-dir" - showFilePath parsecFilePath - dataDir (\val pkg -> pkg{dataDir=val}) - , listFieldWithSep vcat "extra-source-files" - showFilePath parsecFilePath - extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) - , listFieldWithSep vcat "extra-tmp-files" - showFilePath parsecFilePath - extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) - , listFieldWithSep vcat "extra-doc-files" - showFilePath parsecFilePath - extraDocFiles (\val pkg -> pkg{extraDocFiles=val}) - ] - --- | Store any fields beginning with "x-" in the customFields field of --- a PackageDescription. All other fields will generate a warning. -storeXFieldsPD :: UnknownFieldParser PackageDescription -storeXFieldsPD f val pkg | beginsWithX f = - Just pkg { customFieldsPD = customFieldsPD pkg ++ [(fromUTF8BS f, trim val)] } -storeXFieldsPD _ _ _ = Nothing - -------------------------------------------------------------------------------- --- Library -------------------------------------------------------------------------------- - -libFieldDescrs :: [FieldDescr Library] -libFieldDescrs = - [ listFieldWithSep vcat "exposed-modules" disp (parsecMaybeQuoted parsec) - exposedModules (\mods lib -> lib{exposedModules=mods}) - , commaListFieldWithSep vcat "reexported-modules" disp parsec - reexportedModules (\mods lib -> lib{reexportedModules=mods}) - - , listFieldWithSep vcat "signatures" disp (parsecMaybeQuoted parsec) - signatures (\mods lib -> lib{signatures=mods}) - - , boolField "exposed" - libExposed (\val lib -> lib{libExposed=val}) - ] ++ map biToLib binfoFieldDescrs - where - biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) - -storeXFieldsLib :: UnknownFieldParser Library -storeXFieldsLib f val l@Library { libBuildInfo = bi } | beginsWithX f = - Just $ l {libBuildInfo = - bi{ customFieldsBI = customFieldsBI bi ++ [(fromUTF8BS f, trim val)]}} -storeXFieldsLib _ _ _ = Nothing - -------------------------------------------------------------------------------- --- Foreign library -------------------------------------------------------------------------------- - -foreignLibFieldDescrs :: [FieldDescr ForeignLib] -foreignLibFieldDescrs = - [ simpleField "type" - disp parsec - foreignLibType (\x flib -> flib { foreignLibType = x }) - , listField "options" - disp parsec - foreignLibOptions (\x flib -> flib { foreignLibOptions = x }) - , simpleField "lib-version-info" - (maybe mempty disp) (Just <$> parsec) - foreignLibVersionInfo (\x flib -> flib { foreignLibVersionInfo = x }) - , simpleField "lib-version-linux" - (maybe mempty disp) (Just <$> parsec) - foreignLibVersionLinux (\x flib -> flib { foreignLibVersionLinux = x }) - , listField "mod-def-file" - showFilePath parsecFilePath - foreignLibModDefFile (\x flib -> flib { foreignLibModDefFile = x }) - ] ++ map biToFLib binfoFieldDescrs - where - biToFLib = liftField foreignLibBuildInfo (\bi flib -> flib{foreignLibBuildInfo=bi}) - -storeXFieldsForeignLib :: UnknownFieldParser ForeignLib -storeXFieldsForeignLib f val l@ForeignLib { foreignLibBuildInfo = bi } | beginsWithX f = - Just $ l {foreignLibBuildInfo = - bi{ customFieldsBI = customFieldsBI bi ++ [(fromUTF8BS f, trim val)]}} -storeXFieldsForeignLib _ _ _ = Nothing - -------------------------------------------------------------------------------- --- Executable -------------------------------------------------------------------------------- - -executableFieldDescrs :: [FieldDescr Executable] -executableFieldDescrs = - [ -- note ordering: configuration must come first, for - -- showPackageDescription. - simpleField "executable" - disp parsec - exeName (\xs exe -> exe{exeName=xs}) - , simpleField "main-is" - showFilePath parsecFilePath - modulePath (\xs exe -> exe{modulePath=xs}) - - , simpleField "scope" - disp parsec - exeScope (\sc exe -> exe{exeScope=sc}) - ] - ++ map biToExe binfoFieldDescrs - where - biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) - -storeXFieldsExe :: UnknownFieldParser Executable -storeXFieldsExe f val e@Executable { buildInfo = bi } | beginsWithX f = - Just $ e {buildInfo = bi{ customFieldsBI = (fromUTF8BS f, trim val) : customFieldsBI bi}} -storeXFieldsExe _ _ _ = Nothing - -------------------------------------------------------------------------------- --- TestSuite -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the test-suite stanza. --- After validation it is converted into the proper 'TestSuite' type. -data TestSuiteStanza = TestSuiteStanza - { testStanzaTestType :: Maybe TestType - , testStanzaMainIs :: Maybe FilePath - , testStanzaTestModule :: Maybe ModuleName - , testStanzaBuildInfo :: BuildInfo - } - -emptyTestStanza :: TestSuiteStanza -emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty - -testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] -testSuiteFieldDescrs = - [ simpleField "type" - (maybe mempty disp) (Just <$> parsec) - testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) - , simpleField "main-is" - (maybe mempty showFilePath) (Just <$> parsecFilePath) - testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) - , simpleField "test-module" - (maybe mempty disp) (Just <$> parsecMaybeQuoted parsec) - testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) - ] - ++ map biToTest binfoFieldDescrs - where - biToTest = liftField - testStanzaBuildInfo - (\bi suite -> suite { testStanzaBuildInfo = bi }) - -storeXFieldsTest :: UnknownFieldParser TestSuiteStanza -storeXFieldsTest f val t@TestSuiteStanza { testStanzaBuildInfo = bi } - | beginsWithX f = - Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (fromUTF8BS f,val):customFieldsBI bi}} -storeXFieldsTest _ _ _ = Nothing - -validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite -validateTestSuite pos stanza = case testStanzaTestType stanza of - Nothing -> return $ - emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } - - Just tt@(TestTypeUnknown _ _) -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = testStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownTestTypes -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = testStanzaBuildInfo stanza - } - - Just tt@(TestTypeExe ver) -> case testStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyTestSuite - Just file -> do - when (isJust (testStanzaTestModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) - pure emptyTestSuite - { testInterface = TestSuiteExeV10 ver file - , testBuildInfo = testStanzaBuildInfo stanza - } - - Just tt@(TestTypeLib ver) -> case testStanzaTestModule stanza of - Nothing -> do - parseFailure pos (missingField "test-module" tt) - pure emptyTestSuite - Just module_ -> do - when (isJust (testStanzaMainIs stanza)) $ - parseWarning pos PWTExtraMainIs (extraField "main-is" tt) - pure emptyTestSuite - { testInterface = TestSuiteLibV09 ver module_ - , testBuildInfo = testStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ display tt ++ " test suite type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ display tt ++ "' test suite type." - -------------------------------------------------------------------------------- --- Benchmark -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the benchmark stanza. --- After validation it is converted into the proper 'Benchmark' type. -data BenchmarkStanza = BenchmarkStanza - { benchmarkStanzaBenchmarkType :: Maybe BenchmarkType - , benchmarkStanzaMainIs :: Maybe FilePath - , benchmarkStanzaBenchmarkModule :: Maybe ModuleName - , benchmarkStanzaBuildInfo :: BuildInfo - } - -emptyBenchmarkStanza :: BenchmarkStanza -emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty - -benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza] -benchmarkFieldDescrs = - [ simpleField "type" - (maybe mempty disp) (Just <$> parsec) - benchmarkStanzaBenchmarkType - (\x suite -> suite { benchmarkStanzaBenchmarkType = x }) - , simpleField "main-is" - (maybe mempty showFilePath) (Just <$> parsecFilePath) - benchmarkStanzaMainIs - (\x suite -> suite { benchmarkStanzaMainIs = x }) - ] - ++ map biToBenchmark binfoFieldDescrs - where - biToBenchmark = liftField benchmarkStanzaBuildInfo - (\bi suite -> suite { benchmarkStanzaBuildInfo = bi }) - -storeXFieldsBenchmark :: UnknownFieldParser BenchmarkStanza -storeXFieldsBenchmark f val t@BenchmarkStanza { benchmarkStanzaBuildInfo = bi } | beginsWithX f = - Just $ t {benchmarkStanzaBuildInfo = - bi{ customFieldsBI = (fromUTF8BS f, trim val):customFieldsBI bi}} -storeXFieldsBenchmark _ _ _ = Nothing - -validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark -validateBenchmark pos stanza = case benchmarkStanzaBenchmarkType stanza of - Nothing -> pure emptyBenchmark - { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } - - Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza - } - - Just tt@(BenchmarkTypeExe ver) -> case benchmarkStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyBenchmark - Just file -> do - when (isJust (benchmarkStanzaBenchmarkModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) - pure emptyBenchmark - { benchmarkInterface = BenchmarkExeV10 ver file - , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ display tt ++ " benchmark type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ display tt ++ "' benchmark type." - -------------------------------------------------------------------------------- --- BuildInfo -------------------------------------------------------------------------------- - -binfoFieldDescrs :: [FieldDescr BuildInfo] -binfoFieldDescrs = - [ boolField "buildable" - buildable (\val binfo -> binfo{buildable=val}) - , commaListField "build-tools" - disp parsec - buildTools (\xs binfo -> binfo{buildTools=xs}) - , commaListField "build-tool-depends" - disp parsec - buildToolDepends (\xs binfo -> binfo{buildToolDepends=xs}) - , commaListFieldWithSep vcat "build-depends" - disp parsec - targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs}) - , commaListFieldWithSep vcat "mixins" - disp parsec - mixins (\xs binfo -> binfo{mixins=xs}) - , spaceListField "cpp-options" - showToken parsecToken' - cppOptions (\val binfo -> binfo{cppOptions=val}) - , spaceListField "cc-options" - showToken parsecToken' - ccOptions (\val binfo -> binfo{ccOptions=val}) - , spaceListField "ld-options" - showToken parsecToken' - ldOptions (\val binfo -> binfo{ldOptions=val}) - , commaListField "pkgconfig-depends" - disp parsec - pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) - , listField "frameworks" - showToken parsecToken - frameworks (\val binfo -> binfo{frameworks=val}) - , listField "extra-framework-dirs" - showToken parsecFilePath - extraFrameworkDirs (\val binfo -> binfo{extraFrameworkDirs=val}) - , listFieldWithSep vcat "c-sources" - showFilePath parsecFilePath - cSources (\paths binfo -> binfo{cSources=paths}) - , listFieldWithSep vcat "js-sources" - showFilePath parsecFilePath - jsSources (\paths binfo -> binfo{jsSources=paths}) - , simpleField "default-language" - (maybe mempty disp) (Parsec.optionMaybe $ parsecMaybeQuoted parsec) - defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) - , listField "other-languages" - disp (parsecMaybeQuoted parsec) - otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) - , listField "default-extensions" - disp (parsecMaybeQuoted parsec) - defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) - , listField "other-extensions" - disp (parsecMaybeQuoted parsec) - otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) - , listField "extensions" - -- TODO: this is deprecated field, isn't it? - disp (parsecMaybeQuoted parsec) - oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) - , listFieldWithSep vcat "extra-libraries" - showToken parsecToken - extraLibs (\xs binfo -> binfo{extraLibs=xs}) - , listFieldWithSep vcat "extra-ghci-libraries" - showToken parsecToken - extraGHCiLibs (\xs binfo -> binfo{extraGHCiLibs=xs}) - , listField "extra-lib-dirs" - showFilePath parsecFilePath - extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) - , listFieldWithSep vcat "includes" - showFilePath parsecFilePath - includes (\paths binfo -> binfo{includes=paths}) - , listFieldWithSep vcat "install-includes" - showFilePath parsecFilePath - installIncludes (\paths binfo -> binfo{installIncludes=paths}) - , listField "include-dirs" - showFilePath parsecFilePath - includeDirs (\paths binfo -> binfo{includeDirs=paths}) - , listField "hs-source-dirs" - showFilePath parsecFilePath - hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) - , deprecatedField "hs-source-dirs" $ listField "hs-source-dir" - showFilePath parsecFilePath - (const []) (\paths binfo -> binfo{hsSourceDirs=paths}) - , listFieldWithSep vcat "other-modules" - disp (parsecMaybeQuoted parsec) - otherModules (\val binfo -> binfo{otherModules=val}) - , listFieldWithSep vcat "autogen-modules" - disp (parsecMaybeQuoted parsec) - autogenModules (\val binfo -> binfo{autogenModules=val}) - , optsField "ghc-prof-options" GHC - profOptions (\val binfo -> binfo{profOptions=val}) - , optsField "ghcjs-prof-options" GHCJS - profOptions (\val binfo -> binfo{profOptions=val}) - , optsField "ghc-shared-options" GHC - sharedOptions (\val binfo -> binfo{sharedOptions=val}) - , optsField "ghcjs-shared-options" GHCJS - sharedOptions (\val binfo -> binfo{sharedOptions=val}) - , optsField "ghc-options" GHC - options (\path binfo -> binfo{options=path}) - , optsField "ghcjs-options" GHCJS - options (\path binfo -> binfo{options=path}) - , optsField "jhc-options" JHC - options (\path binfo -> binfo{options=path}) - -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept - -- around for backwards compatibility. - -- - -- TODO: deprecate? - , optsField "hugs-options" Hugs - options (const id) - , optsField "nhc98-options" NHC - options (const id) - ] - -{- -storeXFieldsBI :: UnknownFieldParser BuildInfo ---storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi } -storeXFieldsBI _ _ = Nothing --} - -------------------------------------------------------------------------------- --- Flag -------------------------------------------------------------------------------- - -flagFieldDescrs :: [FieldDescr Flag] -flagFieldDescrs = - [ simpleField "description" - showFreeText freeTextFieldParser - flagDescription (\val fl -> fl{ flagDescription = val }) - , boolField "default" - flagDefault (\val fl -> fl{ flagDefault = val }) - , boolField "manual" - flagManual (\val fl -> fl{ flagManual = val }) - ] - -------------------------------------------------------------------------------- --- SourceRepo -------------------------------------------------------------------------------- - -sourceRepoFieldDescrs :: [FieldDescr SourceRepo] -sourceRepoFieldDescrs = - [ simpleField "type" - (maybe mempty disp) (Just <$> parsec) - repoType (\val repo -> repo { repoType = val }) - , simpleField "location" - (maybe mempty showFreeText) (Just <$> freeTextFieldParser) - repoLocation (\val repo -> repo { repoLocation = val }) - , simpleField "module" - (maybe mempty showToken) (Just <$> parsecToken) - repoModule (\val repo -> repo { repoModule = val }) - , simpleField "branch" - (maybe mempty showToken) (Just <$> parsecToken) - repoBranch (\val repo -> repo { repoBranch = val }) - , simpleField "tag" - (maybe mempty showToken) (Just <$> parsecToken) - repoTag (\val repo -> repo { repoTag = val }) - , simpleField "subdir" - (maybe mempty showFilePath) (Just <$> parsecFilePath) - repoSubdir (\val repo -> repo { repoSubdir = val }) - ] - -------------------------------------------------------------------------------- --- SetupBuildInfo -------------------------------------------------------------------------------- - -setupBInfoFieldDescrs :: [FieldDescr SetupBuildInfo] -setupBInfoFieldDescrs = - [ commaListFieldWithSep vcat "setup-depends" - disp parsec - setupDepends (\xs binfo -> binfo{setupDepends=xs}) - ] - - -------------------------------------------------------------------------------- --- Utilities -------------------------------------------------------------------------------- - --- | Predicate to test field names beginning with "x-" -beginsWithX :: FieldName -> Bool -beginsWithX bs = BS.take 2 bs == "x-" - --- | Mark the field as deprecated. -deprecatedField - :: FieldName -- ^ alternative field - -> FieldDescr a - -> FieldDescr a -deprecatedField newFieldName fd = FieldDescr - { fieldName = oldFieldName - , fieldPretty = const mempty -- we don't print deprecated field - , fieldParser = \x -> do - parsecWarning PWTDeprecatedField $ - "The field " <> show oldFieldName <> - " is deprecated, please use " <> show newFieldName - fieldParser fd x - } - where - oldFieldName = fieldName fd - --- Used to trim x-fields -trim :: String -> String -trim = dropWhile isSpace . dropWhileEnd isSpace diff --git a/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/Cabal/Distribution/PackageDescription/PrettyPrint.hs index 8ca6610165a..f14bd0644c9 100644 --- a/Cabal/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal/Distribution/PackageDescription/PrettyPrint.hs @@ -30,27 +30,30 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.Types.Dependency -import Distribution.Types.ForeignLib +import Distribution.Types.ForeignLib (ForeignLib (foreignLibName)) import Distribution.Types.UnqualComponentName import Distribution.Types.CondTree import Distribution.PackageDescription import Distribution.Simple.Utils import Distribution.ParseUtils -import Distribution.PackageDescription.Parse import Distribution.Text -import Distribution.ModuleName + +import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) +import Distribution.PackageDescription.FieldGrammar + (packageDescriptionFieldGrammar, buildInfoFieldGrammar, + flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar, + benchmarkFieldGrammar, testSuiteFieldGrammar, + setupBInfoFieldGrammar, sourceRepoFieldGrammar, executableFieldGrammar) + +import qualified Distribution.PackageDescription.FieldGrammar as FG import Text.PrettyPrint - (hsep, space, parens, char, nest, isEmpty, ($$), (<+>), - colon, text, vcat, ($+$), Doc, render) + (hsep, space, parens, char, nest, ($$), (<+>), + text, vcat, ($+$), Doc, render) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 --- | Recompile with false for regression testing -simplifiedPrinting :: Bool -simplifiedPrinting = False - -- | Writes a .cabal file from a generic package description writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> NoCallStackIO () writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) @@ -62,159 +65,113 @@ showGenericPackageDescription = render . ppGenericPackageDescription ppGenericPackageDescription :: GenericPackageDescription -> Doc ppGenericPackageDescription gpd = ppPackageDescription (packageDescription gpd) + $+$ ppSetupBInfo (setupBuildInfo (packageDescription gpd)) $+$ ppGenPackageFlags (genPackageFlags gpd) $+$ ppCondLibrary (condLibrary gpd) $+$ ppCondSubLibraries (condSubLibraries gpd) + $+$ ppCondForeignLibs (condForeignLibs gpd) $+$ ppCondExecutables (condExecutables gpd) $+$ ppCondTestSuites (condTestSuites gpd) $+$ ppCondBenchmarks (condBenchmarks gpd) ppPackageDescription :: PackageDescription -> Doc -ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd - $+$ ppCustomFields (customFieldsPD pd) - $+$ ppSourceRepos (sourceRepos pd) +ppPackageDescription pd = + prettyFieldGrammar packageDescriptionFieldGrammar pd + $+$ ppSourceRepos (sourceRepos pd) ppSourceRepos :: [SourceRepo] -> Doc ppSourceRepos [] = mempty ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl ppSourceRepo :: SourceRepo -> Doc -ppSourceRepo repo = - emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$ - (nest indentWith (ppFields sourceRepoFieldDescrs' repo)) - where - sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"] - --- TODO: this is a temporary hack. Ideally, fields containing default values --- would be filtered out when the @FieldDescr a@ list is generated. -ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc -ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x +ppSourceRepo repo = + emptyLine $ text "source-repository" <+> disp kind $+$ + nest indentWith (prettyFieldGrammar (sourceRepoFieldGrammar kind) repo) where - nondefault (FieldDescr name getter _) = - maybe True (render (getter x) /=) (lookup name removable) - -binfoDefaults :: [(String, String)] -binfoDefaults = [("buildable", "True")] - -libDefaults :: [(String, String)] -libDefaults = ("exposed", "True") : binfoDefaults - -flagDefaults :: [(String, String)] -flagDefaults = [("default", "True"), ("manual", "False")] - -ppDiffFields :: [FieldDescr a] -> a -> a -> Doc -ppDiffFields fields x y = - vcat [ ppField name (getter x) - | FieldDescr name getter _ <- fields - , render (getter x) /= render (getter y) - ] + kind = repoKind repo -ppCustomFields :: [(String,String)] -> Doc -ppCustomFields flds = vcat [ppCustomField f | f <- flds] - -ppCustomField :: (String,String) -> Doc -ppCustomField (name,val) = text name <<>> colon <+> showFreeText val +ppSetupBInfo :: Maybe SetupBuildInfo -> Doc +ppSetupBInfo Nothing = mempty +ppSetupBInfo (Just sbi) + | defaultSetupDepends sbi = mempty + | otherwise = + emptyLine $ text "custom-setup" $+$ + nest indentWith (prettyFieldGrammar (setupBInfoFieldGrammar False) sbi) ppGenPackageFlags :: [Flag] -> Doc -ppGenPackageFlags flds = vcat [ppFlag f | f <- flds] +ppGenPackageFlags flds = vcat [ppFlag f | f <- flds] ppFlag :: Flag -> Doc -ppFlag flag@(MkFlag name _ _ _) = - emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields +ppFlag flag@(MkFlag name _ _ _) = + emptyLine $ text "flag" <+> ppFlagName name $+$ + nest indentWith (prettyFieldGrammar (flagFieldGrammar name) flag) + +ppCondTree2 :: PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> Doc +ppCondTree2 grammar = go where - fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag + -- TODO: recognise elif opportunities + go (CondNode it _ ifs) = + prettyFieldGrammar grammar it + $+$ vcat (map ppIf ifs) + + ppIf (CondBranch c thenTree Nothing) +-- | isEmpty thenDoc = mempty + | otherwise = ppIfCondition c $$ nest indentWith thenDoc + where + thenDoc = go thenTree + + ppIf (CondBranch c thenTree (Just elseTree)) = + case (False, False) of + -- case (isEmpty thenDoc, isEmpty elseDoc) of + (True, True) -> mempty + (False, True) -> ppIfCondition c $$ nest indentWith thenDoc + (True, False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc + (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc) + $+$ (text "else" $$ nest indentWith elseDoc) + where + thenDoc = go thenTree + elseDoc = go elseTree ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc ppCondLibrary Nothing = mempty ppCondLibrary (Just condTree) = - emptyLine $ text "library" - $+$ nest indentWith (ppCondTree condTree Nothing ppLib) + emptyLine $ text "library" $+$ + nest indentWith (ppCondTree2 (libraryFieldGrammar Nothing) condTree) + ppCondSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> Doc -ppCondSubLibraries libs = - vcat [emptyLine $ (text "library " <+> disp n) - $+$ nest indentWith (ppCondTree condTree Nothing ppLib)| (n,condTree) <- libs] +ppCondSubLibraries libs = vcat + [ emptyLine $ (text "library" <+> disp n) $+$ + nest indentWith (ppCondTree2 (libraryFieldGrammar $ Just n) condTree) + | (n, condTree) <- libs + ] -ppLib :: Library -> Maybe Library -> Doc -ppLib lib Nothing = ppFieldsFiltered libDefaults libFieldDescrs lib - $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) -ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib - $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) +ppCondForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> Doc +ppCondForeignLibs flibs = vcat + [ emptyLine $ (text "library" <+> disp n) $+$ + nest indentWith (ppCondTree2 (foreignLibFieldGrammar n) condTree) + | (n, condTree) <- flibs + ] ppCondExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> Doc -ppCondExecutables exes = - vcat [emptyLine $ (text "executable " <+> disp n) - $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] - where - ppExe (Executable _ modulePath' exeScope' buildInfo') Nothing = - (if modulePath' == "" then mempty else text "main-is:" <+> text modulePath') - $+$ if exeScope' == mempty then mempty else text "scope:" <+> disp exeScope' - $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo' - $+$ ppCustomFields (customFieldsBI buildInfo') - ppExe (Executable _ modulePath' exeScope' buildInfo') - (Just (Executable _ modulePath2 exeScope2 buildInfo2)) = - (if modulePath' == "" || modulePath' == modulePath2 - then mempty else text "main-is:" <+> text modulePath') - $+$ if exeScope' == exeScope2 then mempty else text "scope:" <+> disp exeScope' - $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 - $+$ ppCustomFields (customFieldsBI buildInfo') +ppCondExecutables exes = vcat + [ emptyLine $ (text "executable" <+> disp n) $+$ + nest indentWith (ppCondTree2 (executableFieldGrammar n) condTree) + | (n, condTree) <- exes + ] ppCondTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> Doc -ppCondTestSuites suites = - emptyLine $ vcat [ (text "test-suite " <+> disp n) - $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) - | (n,condTree) <- suites] - where - ppTestSuite testsuite Nothing = - maybe mempty (\t -> text "type:" <+> disp t) - maybeTestType - $+$ maybe mempty (\f -> text "main-is:" <+> text f) - (testSuiteMainIs testsuite) - $+$ maybe mempty (\m -> text "test-module:" <+> disp m) - (testSuiteModule testsuite) - $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite) - $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite)) - where - maybeTestType | testInterface testsuite == mempty = Nothing - | otherwise = Just (testType testsuite) - - ppTestSuite test' (Just test2) = - ppDiffFields binfoFieldDescrs - (testBuildInfo test') (testBuildInfo test2) - $+$ ppCustomFields (customFieldsBI (testBuildInfo test')) - - testSuiteMainIs test = case testInterface test of - TestSuiteExeV10 _ f -> Just f - _ -> Nothing - - testSuiteModule test = case testInterface test of - TestSuiteLibV09 _ m -> Just m - _ -> Nothing +ppCondTestSuites suites = vcat + [ emptyLine $ (text "test-suite" <+> disp n) $+$ + nest indentWith (ppCondTree2 testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree)) + | (n, condTree) <- suites + ] ppCondBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> Doc -ppCondBenchmarks suites = - emptyLine $ vcat [ (text "benchmark " <+> disp n) - $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark) - | (n,condTree) <- suites] - where - ppBenchmark benchmark Nothing = - maybe mempty (\t -> text "type:" <+> disp t) - maybeBenchmarkType - $+$ maybe mempty (\f -> text "main-is:" <+> text f) - (benchmarkMainIs benchmark) - $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark) - $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark)) - where - maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing - | otherwise = Just (benchmarkType benchmark) - - ppBenchmark bench' (Just bench2) = - ppDiffFields binfoFieldDescrs - (benchmarkBuildInfo bench') (benchmarkBuildInfo bench2) - $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo bench')) - - benchmarkMainIs benchmark = case benchmarkInterface benchmark of - BenchmarkExeV10 _ f -> Just f - _ -> Nothing +ppCondBenchmarks suites = vcat + [ emptyLine $ (text "benchmark" <+> disp n) $+$ + nest indentWith (ppCondTree2 benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree)) + | (n, condTree) <- suites + ] ppCondition :: Condition ConfVar -> Doc ppCondition (Var x) = ppConfVar x @@ -233,46 +190,9 @@ ppConfVar (Impl c v) = text "impl" <<>> parens (disp c <+> d ppFlagName :: FlagName -> Doc ppFlagName = text . unFlagName -ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc -ppCondTree ct@(CondNode it _ ifs) mbIt ppIt = - let res = (vcat $ map ppIf ifs) - $+$ ppIt it mbIt - in if isJust mbIt && isEmpty res - then ppCondTree ct Nothing ppIt - else res - where - -- TODO: this ends up printing trailing spaces when combined with nest. - ppIf (CondBranch c thenTree (Just elseTree)) = ppIfElse it ppIt c thenTree elseTree - ppIf (CondBranch c thenTree Nothing) = ppIf' it ppIt c thenTree - ppIfCondition :: (Condition ConfVar) -> Doc ppIfCondition c = (emptyLine $ text "if" <+> ppCondition c) -ppIf' :: a -> (a -> Maybe a -> Doc) - -> Condition ConfVar - -> CondTree ConfVar [Dependency] a - -> Doc -ppIf' it ppIt c thenTree = - if isEmpty thenDoc - then mempty - else ppIfCondition c $$ nest indentWith thenDoc - where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt - -ppIfElse :: a -> (a -> Maybe a -> Doc) - -> Condition ConfVar - -> CondTree ConfVar [Dependency] a - -> CondTree ConfVar [Dependency] a - -> Doc -ppIfElse it ppIt c thenTree elseTree = - case (isEmpty thenDoc, isEmpty elseDoc) of - (True, True) -> mempty - (False, True) -> ppIfCondition c $$ nest indentWith thenDoc - (True, False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc - (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc) - $+$ (text "else" $$ nest indentWith elseDoc) - where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt - elseDoc = ppCondTree elseTree (if simplifiedPrinting then (Just it) else Nothing) ppIt - emptyLine :: Doc -> Doc emptyLine d = text "" $+$ d @@ -285,88 +205,29 @@ writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription -- | @since 2.0.0.2 showPackageDescription :: PackageDescription -> String -showPackageDescription pkg = render $ - ppPackageDescription pkg - $+$ ppMaybeLibrary (library pkg) - $+$ ppSubLibraries (subLibraries pkg) - $+$ ppForeignLibs (foreignLibs pkg) - $+$ ppExecutables (executables pkg) - $+$ ppTestSuites (testSuites pkg) - $+$ ppBenchmarks (benchmarks pkg) - -ppMaybeLibrary :: Maybe Library -> Doc -ppMaybeLibrary Nothing = mempty -ppMaybeLibrary (Just lib) = - emptyLine $ text "library" - $+$ nest indentWith (ppFields libFieldDescrs lib) - -ppSubLibraries :: [Library] -> Doc -ppSubLibraries libs = vcat [ - emptyLine $ text "library" <+> disp libname - $+$ nest indentWith (ppFields libFieldDescrs lib) - | lib@Library{ libName = Just libname } <- libs ] - -ppForeignLibs :: [ForeignLib] -> Doc -ppForeignLibs flibs = vcat [ - emptyLine $ text "foreign library" <+> disp flibname - $+$ nest indentWith (ppFields foreignLibFieldDescrs flib) - | flib@ForeignLib{ foreignLibName = flibname } <- flibs ] - -ppExecutables :: [Executable] -> Doc -ppExecutables exes = vcat [ - emptyLine $ text "executable" <+> disp (exeName exe) - $+$ nest indentWith (ppFields executableFieldDescrs exe) - | exe <- exes ] - -ppTestSuites :: [TestSuite] -> Doc -ppTestSuites tests = vcat [ - emptyLine $ text "test-suite" <+> disp (testName test) - $+$ nest indentWith (ppFields testSuiteFieldDescrs test_stanza) - | test <- tests - , let test_stanza - = TestSuiteStanza { - testStanzaTestType = Just (testSuiteInterfaceToTestType (testInterface test)), - testStanzaMainIs = testSuiteInterfaceToMaybeMainIs (testInterface test), - testStanzaTestModule = testSuiteInterfaceToMaybeModule (testInterface test), - testStanzaBuildInfo = testBuildInfo test - } - ] - -testSuiteInterfaceToTestType :: TestSuiteInterface -> TestType -testSuiteInterfaceToTestType (TestSuiteExeV10 ver _) = TestTypeExe ver -testSuiteInterfaceToTestType (TestSuiteLibV09 ver _) = TestTypeLib ver -testSuiteInterfaceToTestType (TestSuiteUnsupported ty) = ty - -testSuiteInterfaceToMaybeMainIs :: TestSuiteInterface -> Maybe FilePath -testSuiteInterfaceToMaybeMainIs (TestSuiteExeV10 _ fp) = Just fp -testSuiteInterfaceToMaybeMainIs TestSuiteLibV09{} = Nothing -testSuiteInterfaceToMaybeMainIs TestSuiteUnsupported{} = Nothing - -testSuiteInterfaceToMaybeModule :: TestSuiteInterface -> Maybe ModuleName -testSuiteInterfaceToMaybeModule (TestSuiteLibV09 _ mod_name) = Just mod_name -testSuiteInterfaceToMaybeModule TestSuiteExeV10{} = Nothing -testSuiteInterfaceToMaybeModule TestSuiteUnsupported{} = Nothing - -ppBenchmarks :: [Benchmark] -> Doc -ppBenchmarks benchs = vcat [ - emptyLine $ text "benchmark" <+> disp (benchmarkName bench) - $+$ nest indentWith (ppFields benchmarkFieldDescrs bench_stanza) - | bench <- benchs - , let bench_stanza = BenchmarkStanza { - benchmarkStanzaBenchmarkType = Just (benchmarkInterfaceToBenchmarkType (benchmarkInterface bench)), - benchmarkStanzaMainIs = benchmarkInterfaceToMaybeMainIs (benchmarkInterface bench), - benchmarkStanzaBenchmarkModule = Nothing, - benchmarkStanzaBuildInfo = benchmarkBuildInfo bench - }] - -benchmarkInterfaceToBenchmarkType :: BenchmarkInterface -> BenchmarkType -benchmarkInterfaceToBenchmarkType (BenchmarkExeV10 ver _) = BenchmarkTypeExe ver -benchmarkInterfaceToBenchmarkType (BenchmarkUnsupported ty) = ty - -benchmarkInterfaceToMaybeMainIs :: BenchmarkInterface -> Maybe FilePath -benchmarkInterfaceToMaybeMainIs (BenchmarkExeV10 _ fp) = Just fp -benchmarkInterfaceToMaybeMainIs BenchmarkUnsupported{} = Nothing +showPackageDescription = showGenericPackageDescription . pdToGpd + +pdToGpd :: PackageDescription -> GenericPackageDescription +pdToGpd pd = GenericPackageDescription + { packageDescription = pd + , genPackageFlags = [] + , condLibrary = mkCondTree <$> library pd + , condSubLibraries = mkCondTreeL <$> subLibraries pd + , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd + , condExecutables = mkCondTree' exeName <$> executables pd + , condTestSuites = mkCondTree' testName <$> testSuites pd + , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd + } + where + -- We set CondTree's [Dependency] to an empty list, as it + -- is not pretty printed anyway. + mkCondTree x = CondNode x [] [] + mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libName l), CondNode l [] []) + mkCondTree' + :: (a -> UnqualComponentName) + -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + mkCondTree' f x = (f x, CondNode x [] []) -- | @since 2.0.0.2 writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> NoCallStackIO () @@ -376,13 +237,10 @@ writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack -- | @since 2.0.0.2 showHookedBuildInfo :: HookedBuildInfo -> String showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ - (case mb_lib_bi of - Nothing -> mempty - Just bi -> ppBuildInfo bi) - $$ vcat [ space - $$ (text "executable:" <+> disp name) - $$ ppBuildInfo bi - | (name, bi) <- ex_bis ] - where - ppBuildInfo bi = ppFields binfoFieldDescrs bi - $$ ppCustomFields (customFieldsBI bi) + maybe mempty (prettyFieldGrammar buildInfoFieldGrammar) mb_lib_bi + $$ vcat + [ space + $$ (text "executable:" <+> disp name) + $$ prettyFieldGrammar buildInfoFieldGrammar bi + | (name, bi) <- ex_bis + ] diff --git a/Cabal/Distribution/PackageDescription/Parsec/Quirks.hs b/Cabal/Distribution/PackageDescription/Quirks.hs similarity index 99% rename from Cabal/Distribution/PackageDescription/Parsec/Quirks.hs rename to Cabal/Distribution/PackageDescription/Quirks.hs index c1634c4b56f..0a7e28cbfe8 100644 --- a/Cabal/Distribution/PackageDescription/Parsec/Quirks.hs +++ b/Cabal/Distribution/PackageDescription/Quirks.hs @@ -3,7 +3,7 @@ -- | -- -- @since 2.2.0.0 -module Distribution.PackageDescription.Parsec.Quirks (patchQuirks) where +module Distribution.PackageDescription.Quirks (patchQuirks) where import Prelude () import Distribution.Compat.Prelude diff --git a/Cabal/Distribution/ParseUtils.hs b/Cabal/Distribution/ParseUtils.hs index f4b4c1fcfeb..081d07fa3f8 100644 --- a/Cabal/Distribution/ParseUtils.hs +++ b/Cabal/Distribution/ParseUtils.hs @@ -51,6 +51,8 @@ import Distribution.ModuleName import qualified Distribution.Compat.MonadFail as Fail import Distribution.Compat.ReadP as ReadP hiding (get) import Distribution.ReadE +import Distribution.Compat.Newtype +import Distribution.Parsec.Newtypes (TestedWith (..)) import Distribution.Text import Distribution.Utils.Generic import Distribution.Pretty @@ -704,8 +706,8 @@ readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str , all isSpace s ] ------------------------------------------------------------------------------- --- Temporary: move to Distribution.Parsec.Newtypes +-- Internal ------------------------------------------------------------------------------- showTestedWith :: (CompilerFlavor, VersionRange) -> Doc -showTestedWith (compiler, vr) = text (show compiler) <+> pretty vr +showTestedWith = pretty . pack' TestedWith diff --git a/Cabal/Distribution/Parsec/Class.hs b/Cabal/Distribution/Parsec/Class.hs index 6c7c32d1c95..eeeb6fc2592 100644 --- a/Cabal/Distribution/Parsec/Class.hs +++ b/Cabal/Distribution/Parsec/Class.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes, FlexibleContexts #-} module Distribution.Parsec.Class ( Parsec(..), + ParsecParser, simpleParsec, -- * Warnings parsecWarning, + PWarnType (..), -- * Utilities - parsecTestedWith, parsecToken, parsecToken', parsecFilePath, @@ -13,57 +14,18 @@ module Distribution.Parsec.Class ( parsecMaybeQuoted, parsecCommaList, parsecOptCommaList, + parsecStandard, + parsecUnqualComponentName, ) where -import Data.Functor.Identity (Identity) -import qualified Distribution.Compat.Parsec as P +import Data.Functor.Identity (Identity (..)) +import qualified Distribution.Compat.Parsec as P import Distribution.Compat.Prelude -import Distribution.Parsec.Types.Common (PWarnType (..), PWarning (..), Position (..)) -import Distribution.Utils.Generic (lowercase) +import Distribution.Parsec.Common (PWarnType (..), PWarning (..), Position (..)) import Prelude () -import qualified Text.Parsec as Parsec -import qualified Text.Parsec.Language as Parsec -import qualified Text.Parsec.Token as Parsec - --- Instances - -import Data.Functor.Identity (Identity (..)) -import Distribution.Compiler - (CompilerFlavor (..), classifyCompilerFlavor) -import Distribution.License (License (..)) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.System - (Arch (..), ClassificationStrictness (..), OS (..), classifyArch, classifyOS) -import Distribution.Text (display) -import Distribution.Types.BenchmarkType (BenchmarkType (..)) -import Distribution.Types.BuildType (BuildType (..)) -import Distribution.Types.Dependency (Dependency (..)) -import Distribution.Types.ExecutableScope -import Distribution.Types.ExeDependency (ExeDependency (..)) -import Distribution.Types.ForeignLib (LibVersionInfo, mkLibVersionInfo) -import Distribution.Types.ForeignLibOption (ForeignLibOption (..)) -import Distribution.Types.ForeignLibType (ForeignLibType (..)) -import Distribution.Types.GenericPackageDescription (FlagName, mkFlagName) -import Distribution.Types.IncludeRenaming -import Distribution.Types.LegacyExeDependency (LegacyExeDependency (..)) -import Distribution.Types.Mixin -import Distribution.Types.ModuleReexport (ModuleReexport (..)) -import Distribution.Types.ModuleRenaming -import Distribution.Types.PackageName (PackageName, mkPackageName) -import Distribution.Types.PkgconfigDependency (PkgconfigDependency (..)) -import Distribution.Types.PkgconfigName (PkgconfigName, mkPkgconfigName) -import Distribution.Types.SourceRepo - (RepoKind, RepoType, classifyRepoKind, classifyRepoType) -import Distribution.Types.TestType (TestType (..)) -import Distribution.Types.UnqualComponentName - (UnqualComponentName, mkUnqualComponentName) -import Distribution.Version - (Version, VersionRange (..), anyVersion, earlierVersion, intersectVersionRanges, - laterVersion, majorBoundVersion, mkVersion, noVersion, normaliseVersionRange, - orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges, withinVersion) -import Language.Haskell.Extension - (Extension, Language, classifyExtension, classifyLanguage) +import qualified Text.Parsec as Parsec +import qualified Text.Parsec.Language as Parsec +import qualified Text.Parsec.Token as Parsec ------------------------------------------------------------------------------- -- Class @@ -74,12 +36,14 @@ import Language.Haskell.Extension -- TODO: implementation details: should be careful about consuming trailing whitespace? -- Should we always consume it? class Parsec a where - parsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a + parsec :: ParsecParser a -- | 'parsec' /could/ consume trailing spaces, this function /must/ consume. - lexemeParsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a + lexemeParsec :: ParsecParser a lexemeParsec = parsec <* P.spaces +type ParsecParser a = forall s. P.Stream s Identity Char => P.Parsec s [PWarning] a + -- | Parse a 'String' with 'lexemeParsec'. simpleParsec :: Parsec a => String -> Maybe a simpleParsec @@ -107,335 +71,23 @@ instance Parsec Bool where caseWarning = "Boolean values are case sensitive, use 'True' or 'False'." -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - --- TODO: use lexemeParsec - --- TODO avoid String -parsecUnqualComponentName :: P.Stream s Identity Char => P.Parsec s [PWarning] String -parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-') - where - component :: P.Stream s Identity Char => P.Parsec s [PWarning] String - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs - then fail "all digits in portion of unqualified component name" - else return cs - -instance Parsec UnqualComponentName where - parsec = mkUnqualComponentName <$> parsecUnqualComponentName - -instance Parsec PackageName where - parsec = mkPackageName <$> parsecUnqualComponentName - -instance Parsec PkgconfigName where - parsec = mkPkgconfigName <$> P.munch1 (\c -> isAlphaNum c || c `elem` "+-._") - -instance Parsec ModuleName where - parsec = ModuleName.fromComponents <$> P.sepBy1 component (P.char '.') - where - component = do - c <- P.satisfy isUpper - cs <- P.munch validModuleChar - return (c:cs) - - validModuleChar :: Char -> Bool - validModuleChar c = isAlphaNum c || c == '_' || c == '\'' - -instance Parsec FlagName where - parsec = mkFlagName . lowercase <$> parsec' - where - parsec' = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlphaNum c || c == '_') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') - -instance Parsec Dependency where - parsec = do - name <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (Dependency name ver) - -instance Parsec ExeDependency where - parsec = do - name <- lexemeParsec - _ <- P.char ':' - exe <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (ExeDependency name exe ver) - -instance Parsec LegacyExeDependency where - parsec = do - name <- parsecMaybeQuoted nameP - P.spaces - verRange <- parsecMaybeQuoted parsec <|> pure anyVersion - pure $ LegacyExeDependency name verRange - where - nameP = intercalate "-" <$> P.sepBy1 component (P.char '-') - component = do - cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then fail "invalid component" else return cs - -instance Parsec PkgconfigDependency where - parsec = do - name <- parsec - P.spaces - verRange <- parsec <|> pure anyVersion - pure $ PkgconfigDependency name verRange - -instance Parsec Version where - parsec = mkVersion <$> - P.sepBy1 P.integral (P.char '.') - <* tags - where - tags = do - ts <- P.optionMaybe $ some $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - Nothing -> pure () - -- TODO: make this warning severe - Just _ -> parsecWarning PWTVersionTag "version with tags" - --- TODO: this is not good parsec code --- use lexer, also see D.P.ConfVar -instance Parsec VersionRange where - parsec = normaliseVersionRange <$> expr - where - expr = do P.spaces - t <- term - P.spaces - (do _ <- P.string "||" - P.spaces - e <- expr - return (unionVersionRanges t e) - <|> - return t) - term = do f <- factor - P.spaces - (do _ <- P.string "&&" - P.spaces - t <- term - return (intersectVersionRanges f t) - <|> - return f) - factor = P.choice - $ parens expr - : parseAnyVersion - : parseNoVersion - : parseWildcardRange - : map parseRangeOp rangeOps - parseAnyVersion = P.string "-any" >> return anyVersion - parseNoVersion = P.string "-none" >> return noVersion - - parseWildcardRange = P.try $ do - _ <- P.string "==" - P.spaces - branch <- some (P.integral <* P.char '.') - _ <- P.char '*' - return (withinVersion (mkVersion branch)) - - parens p = P.between - (P.char '(' >> P.spaces) - (P.char ')' >> P.spaces) - (do a <- p - P.spaces - return (VersionRangeParens a)) - - -- TODO: make those non back-tracking - parseRangeOp (s,f) = P.try (P.string s *> P.spaces *> fmap f parsec) - rangeOps = [ ("<", earlierVersion), - ("<=", orEarlierVersion), - (">", laterVersion), - (">=", orLaterVersion), - ("^>=", majorBoundVersion), - ("==", thisVersion) ] - -instance Parsec LibVersionInfo where - parsec = do - c <- P.integral - (r, a) <- P.option (0,0) $ do - _ <- P.char ':' - r <- P.integral - a <- P.option 0 $ do - _ <- P.char ':' - P.integral - return (r,a) - return $ mkLibVersionInfo (c,r,a) - -instance Parsec Language where - parsec = classifyLanguage <$> P.munch1 isAlphaNum - -instance Parsec Extension where - parsec = classifyExtension <$> P.munch1 isAlphaNum - -instance Parsec RepoType where - parsec = classifyRepoType <$> P.munch1 isIdent - -instance Parsec RepoKind where - parsec = classifyRepoKind <$> P.munch1 isIdent - -instance Parsec License where - parsec = do - name <- P.munch1 isAlphaNum - version <- P.optionMaybe (P.char '-' *> parsec) - return $! case (name, version :: Maybe Version) of - ("GPL", _ ) -> GPL version - ("LGPL", _ ) -> LGPL version - ("AGPL", _ ) -> AGPL version - ("BSD2", Nothing) -> BSD2 - ("BSD3", Nothing) -> BSD3 - ("BSD4", Nothing) -> BSD4 - ("ISC", Nothing) -> ISC - ("MIT", Nothing) -> MIT - ("MPL", Just version') -> MPL version' - ("Apache", _ ) -> Apache version - ("PublicDomain", Nothing) -> PublicDomain - ("AllRightsReserved", Nothing) -> AllRightsReserved - ("OtherLicense", Nothing) -> OtherLicense - _ -> UnknownLicense $ name ++ - maybe "" (('-':) . display) version - -instance Parsec BuildType where - parsec = do - name <- P.munch1 isAlphaNum - return $ case name of - "Simple" -> Simple - "Configure" -> Configure - "Custom" -> Custom - "Make" -> Make - _ -> UnknownBuildType name - -instance Parsec TestType where - parsec = stdParse $ \ver name -> case name of - "exitcode-stdio" -> TestTypeExe ver - "detailed" -> TestTypeLib ver - _ -> TestTypeUnknown name ver - -instance Parsec BenchmarkType where - parsec = stdParse $ \ver name -> case name of - "exitcode-stdio" -> BenchmarkTypeExe ver - _ -> BenchmarkTypeUnknown name ver - -instance Parsec ForeignLibType where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - return $ case name of - "native-shared" -> ForeignLibNativeShared - "native-static" -> ForeignLibNativeStatic - _ -> ForeignLibTypeUnknown - -instance Parsec ForeignLibOption where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - case name of - "standalone" -> return ForeignLibStandalone - _ -> fail "unrecognized foreign-library option" - -instance Parsec OS where - parsec = classifyOS Compat <$> parsecIdent - -instance Parsec Arch where - parsec = classifyArch Strict <$> parsecIdent - -instance Parsec CompilerFlavor where - parsec = classifyCompilerFlavor <$> component - where - component :: P.Stream s Identity Char => P.Parsec s [PWarning] String - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digits compiler name" else return cs - -instance Parsec ModuleReexport where - parsec = do - mpkgname <- P.optionMaybe (P.try $ parsec <* P.char ':') - origname <- parsec - newname <- P.option origname $ P.try $ do - P.spaces - _ <- P.string "as" - P.spaces - parsec - return (ModuleReexport mpkgname origname newname) - -instance Parsec ModuleRenaming where - -- NB: try not necessary as the first token is obvious - parsec = P.choice [ parseRename, parseHiding, return DefaultRenaming ] - where - parseRename = do - rns <- P.between (P.char '(') (P.char ')') parseList - P.spaces - return (ModuleRenaming rns) - parseHiding = do - _ <- P.string "hiding" - P.spaces - hides <- P.between (P.char '(') (P.char ')') - (P.sepBy parsec (P.char ',' >> P.spaces)) - return (HidingRenaming hides) - parseList = - P.sepBy parseEntry (P.char ',' >> P.spaces) - parseEntry = do - orig <- parsec - P.spaces - P.option (orig, orig) $ do - _ <- P.string "as" - P.spaces - new <- parsec - P.spaces - return (orig, new) - -instance Parsec IncludeRenaming where - parsec = do - prov_rn <- parsec - req_rn <- P.option defaultRenaming $ P.try $ do - P.spaces - _ <- P.string "requires" - P.spaces - parsec - return (IncludeRenaming prov_rn req_rn) - -instance Parsec Mixin where - parsec = do - mod_name <- parsec - P.spaces - incl <- parsec - return (Mixin mod_name incl) - -instance Parsec ExecutableScope where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - return $ case name of - "public" -> ExecutablePublic - "private" -> ExecutablePrivate - _ -> ExecutableScopeUnknown - -------------------------------------------------------------------------------- --- Utilities -------------------------------------------------------------------------------- - -isIdent :: Char -> Bool -isIdent c = isAlphaNum c || c == '_' || c == '-' - -parsecTestedWith :: P.Stream s Identity Char => P.Parsec s [PWarning] (CompilerFlavor, VersionRange) -parsecTestedWith = do - name <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (name, ver) - +-- | @[^ ,]@ parsecToken :: P.Stream s Identity Char => P.Parsec s [PWarning] String parsecToken = parsecHaskellString <|> (P.munch1 (\x -> not (isSpace x) && x /= ',') P. "identifier" ) +-- | @[^ ]@ parsecToken' :: P.Stream s Identity Char => P.Parsec s [PWarning] String parsecToken' = parsecHaskellString <|> (P.munch1 (not . isSpace) P. "token") -parsecFilePath :: P.Stream s Identity Char => P.Parsec s [PWarning] String +parsecFilePath :: P.Stream s Identity Char => P.Parsec s [PWarning] FilePath parsecFilePath = parsecToken -- | Parse a benchmark/test-suite types. -stdParse - :: P.Stream s Identity Char - => (Version -> String -> a) +parsecStandard + :: (Parsec ver, P.Stream s Identity Char) + => (ver -> String -> a) -> P.Parsec s [PWarning] a -stdParse f = do - -- TODO: this backtracks +parsecStandard f = do cs <- some $ P.try (component <* P.char '-') ver <- parsec let name = map toLower (intercalate "-" cs) @@ -461,7 +113,6 @@ parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) where comma = P.char ',' *> P.spaces - -- | Content isn't unquoted parsecQuoted :: P.Stream s Identity Char @@ -493,8 +144,12 @@ parsecHaskellString = Parsec.stringLiteral $ Parsec.makeTokenParser Parsec.empty where opl = P.oneOf ":!#$%&*+./<=>?@\\^|-~" -parsecIdent :: P.Stream s Identity Char => P.Parsec s [PWarning] String -parsecIdent = (:) <$> firstChar <*> rest +parsecUnqualComponentName :: P.Stream s Identity Char => P.Parsec s [PWarning] String +parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-') where - firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + component :: P.Stream s Identity Char => P.Parsec s [PWarning] String + component = do + cs <- P.munch1 isAlphaNum + if all isDigit cs + then fail "all digits in portion of unqualified component name" + else return cs diff --git a/Cabal/Distribution/Parsec/Types/Common.hs b/Cabal/Distribution/Parsec/Common.hs similarity index 97% rename from Cabal/Distribution/Parsec/Types/Common.hs rename to Cabal/Distribution/Parsec/Common.hs index f6523bc9124..972b1e18e49 100644 --- a/Cabal/Distribution/Parsec/Types/Common.hs +++ b/Cabal/Distribution/Parsec/Common.hs @@ -1,5 +1,5 @@ -- | Module containing small types -module Distribution.Parsec.Types.Common ( +module Distribution.Parsec.Common ( -- * Diagnostics PError (..), showPError, @@ -76,7 +76,7 @@ type FieldParser = Parsec.Parsec String [PWarning] -- :: * -> * data Position = Position {-# UNPACK #-} !Int -- row {-# UNPACK #-} !Int -- column - deriving (Eq, Show) + deriving (Eq, Ord, Show) -- | Shift position by n columns to the right. incPos :: Int -> Position -> Position diff --git a/Cabal/Distribution/Parsec/ConfVar.hs b/Cabal/Distribution/Parsec/ConfVar.hs index 8263f16be0e..723ecc1ef62 100644 --- a/Cabal/Distribution/Parsec/ConfVar.hs +++ b/Cabal/Distribution/Parsec/ConfVar.hs @@ -1,22 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} module Distribution.Parsec.ConfVar (parseConditionConfVar) where -import Prelude () -import Distribution.Compat.Prelude import Distribution.Compat.Parsec (integral) +import Distribution.Compat.Prelude import Distribution.Parsec.Class (Parsec (..)) -import Distribution.Parsec.Types.Common -import Distribution.Parsec.Types.Field (SectionArg (..)) -import Distribution.Parsec.Types.ParseResult +import Distribution.Parsec.Common +import Distribution.Parsec.Field (SectionArg (..)) +import Distribution.Parsec.ParseResult import Distribution.Simple.Utils (fromUTF8BS) import Distribution.Types.Condition -import Distribution.Types.GenericPackageDescription - (ConfVar (..)) +import Distribution.Types.GenericPackageDescription (ConfVar (..)) import Distribution.Version - (anyVersion, earlierVersion, intersectVersionRanges, - laterVersion, majorBoundVersion, mkVersion, noVersion, - orEarlierVersion, orLaterVersion, thisVersion, - unionVersionRanges, withinVersion) + (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, + majorBoundVersion, mkVersion, noVersion, orEarlierVersion, orLaterVersion, + thisVersion, unionVersionRanges, withinVersion) +import Prelude () import qualified Text.Parsec as P import qualified Text.Parsec.Error as P diff --git a/Cabal/Distribution/Parsec/Types/Field.hs b/Cabal/Distribution/Parsec/Field.hs similarity index 93% rename from Cabal/Distribution/Parsec/Types/Field.hs rename to Cabal/Distribution/Parsec/Field.hs index 6385ce18c75..91447c10d9e 100644 --- a/Cabal/Distribution/Parsec/Types/Field.hs +++ b/Cabal/Distribution/Parsec/Field.hs @@ -2,7 +2,7 @@ -- | Cabal-like file AST types: 'Field', 'Section' etc -- -- These types are parametrized by an annotation. -module Distribution.Parsec.Types.Field ( +module Distribution.Parsec.Field ( -- * Cabal file Field (..), fieldName, @@ -12,6 +12,7 @@ module Distribution.Parsec.Types.Field ( SectionArg (..), sectionArgAnn, -- * Name + FieldName, Name (..), mkName, getName, @@ -77,16 +78,18 @@ sectionArgAnn (SecArgOther ann _) = ann -- Name ------------------------------------------------------------------------------- +type FieldName = ByteString + -- | A field name. -- -- /Invariant/: 'ByteString' is lower-case ASCII. -data Name ann = Name !ann !ByteString +data Name ann = Name !ann !FieldName deriving (Eq, Show, Functor) -mkName :: ann -> ByteString -> Name ann +mkName :: ann -> FieldName -> Name ann mkName ann bs = Name ann (B.map Char.toLower bs) -getName :: Name ann -> ByteString +getName :: Name ann -> FieldName getName (Name _ bs) = bs nameAnn :: Name ann -> ann diff --git a/Cabal/Distribution/Parsec/Lexer.hs b/Cabal/Distribution/Parsec/Lexer.hs index 0b645667f81..720d084c06e 100644 --- a/Cabal/Distribution/Parsec/Lexer.hs +++ b/Cabal/Distribution/Parsec/Lexer.hs @@ -39,7 +39,7 @@ import qualified Prelude as Prelude import Distribution.Compat.Prelude import Distribution.Parsec.LexerMonad -import Distribution.Parsec.Types.Common (Position (..), incPos, retPos) +import Distribution.Parsec.Common (Position (..), incPos, retPos) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B.Char8 diff --git a/Cabal/Distribution/Parsec/LexerMonad.hs b/Cabal/Distribution/Parsec/LexerMonad.hs index f0b54e0de40..50fc93f8c4d 100644 --- a/Cabal/Distribution/Parsec/LexerMonad.hs +++ b/Cabal/Distribution/Parsec/LexerMonad.hs @@ -31,17 +31,16 @@ module Distribution.Parsec.LexerMonad ( ) where -import Prelude () +import qualified Data.ByteString as B import Distribution.Compat.Prelude -import qualified Data.ByteString as B -import Distribution.Parsec.Types.Common - (PWarnType (..), PWarning (..), Position (..)) +import Distribution.Parsec.Common (PWarnType (..), PWarning (..), Position (..)) +import Prelude () #ifdef CABAL_PARSEC_DEBUG -- testing only: -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V #endif -- simple state monad diff --git a/Cabal/Distribution/Parsec/Newtypes.hs b/Cabal/Distribution/Parsec/Newtypes.hs new file mode 100644 index 00000000000..3716afd005f --- /dev/null +++ b/Cabal/Distribution/Parsec/Newtypes.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". +module Distribution.Parsec.Newtypes ( + -- * List + alaList, + alaList', + -- ** Modifiers + CommaVCat (..), + CommaFSep (..), + VCat (..), + FSep (..), + NoCommaFSep (..), + -- ** Type + List, + -- * Version + SpecVersion (..), + TestedWith (..), + -- * Identifiers + Token (..), + Token' (..), + MQuoted (..), + FreeText (..), + FilePathNT (..), + ) where + +import Distribution.Compat.Newtype +import Distribution.Compat.Prelude +import Prelude () + +import Data.Functor.Identity (Identity (..)) +import Data.List (dropWhileEnd) +import qualified Distribution.Compat.Parsec as P +import Distribution.Compiler (CompilerFlavor) +import Distribution.Parsec.Class +import Distribution.Parsec.Common (PWarning) +import Distribution.Pretty +import Distribution.Version (Version, VersionRange, anyVersion) +import Text.PrettyPrint (Doc, comma, fsep, punctuate, vcat, (<+>)) + +-- | Vertical list with commas. Displayed with 'vcat' +data CommaVCat = CommaVCat + +-- | Paragraph fill list with commas. Displayed with 'fsep' +data CommaFSep = CommaFSep + +-- | Vertical list with optional commas. Displayed with 'vcat'. +data VCat = VCat + +-- | Paragraph fill list with optional commas. Displayed with 'fsep'. +data FSep = FSep + +-- | Paragraph fill list without commas. Displayed with 'fsep'. +data NoCommaFSep = NoCommaFSep + +-- | Proxy, internal to this module. +data P sep = P + +class Sep sep where + prettySep :: P sep -> [Doc] -> Doc + parseSep + :: P sep -> P.Stream s Identity Char + => P.Parsec s [PWarning] a + -> P.Parsec s [PWarning] [a] + +instance Sep CommaVCat where + prettySep _ = vcat . punctuate comma + parseSep _ = parsecCommaList +instance Sep CommaFSep where + prettySep _ = fsep . punctuate comma + parseSep _ = parsecCommaList +instance Sep VCat where + prettySep _ = vcat + parseSep _ = parsecOptCommaList +instance Sep FSep where + prettySep _ = fsep + parseSep _ = parsecOptCommaList +instance Sep NoCommaFSep where + prettySep _ = fsep + parseSep _ p = many (p <* P.spaces) + +-- | List separated with optional commas. Displayed with @sep@, arguments of +-- type @a@ are parsed and pretty-printed as @b@. +newtype List sep b a = List { getList :: [a] } + +-- | 'alaList' and 'alaList'' are simply 'List', with additional phantom +-- arguments to constraint the resulting type +-- +-- >>> :t alaList VCat +-- alaList VCat :: [a] -> List VCat (Identity a) a +-- +-- >>> :t alaList' FSep Token +-- alaList' FSep Token :: [String] -> List FSep Token String +-- +alaList :: sep -> [a] -> List sep (Identity a) a +alaList _ = List + +-- | More general version of 'alaList'. +alaList' :: sep -> (a -> b) -> [a] -> List sep b a +alaList' _ _ = List + +instance Newtype (List sep wrapper a) [a] where + pack = List + unpack = getList + +instance (Newtype b a, Sep sep, Parsec b) => Parsec (List sep b a) where + parsec = pack . map (unpack :: b -> a) <$> parseSep (P :: P sep) parsec + +instance (Newtype b a, Sep sep, Pretty b) => Pretty (List sep b a) where + pretty = prettySep (P :: P sep) . map (pretty . (pack :: a -> b)) . unpack + +-- | Haskell string or @[^ ,]+@ +newtype Token = Token { getToken :: String } + +instance Newtype Token String where + pack = Token + unpack = getToken + +instance Parsec Token where + parsec = pack <$> parsecToken + +instance Pretty Token where + pretty = showToken . unpack + +-- | Haskell string or @[^ ]+@ +newtype Token' = Token' { getToken' :: String } + +instance Newtype Token' String where + pack = Token' + unpack = getToken' + +instance Parsec Token' where + parsec = pack <$> parsecToken' + +instance Pretty Token' where + pretty = showToken . unpack + +-- | Either @"quoted"@ or @un-quoted@. +newtype MQuoted a = MQuoted { getMQuoted :: a } + +instance Newtype (MQuoted a) a where + pack = MQuoted + unpack = getMQuoted + +instance Parsec a => Parsec (MQuoted a) where + parsec = pack <$> parsecMaybeQuoted parsec + +instance Pretty a => Pretty (MQuoted a) where + pretty = pretty . unpack + +-- | Version range or just version +newtype SpecVersion = SpecVersion { getSpecVersion :: Either Version VersionRange } + +instance Newtype SpecVersion (Either Version VersionRange) where + pack = SpecVersion + unpack = getSpecVersion + +instance Parsec SpecVersion where + parsec = pack <$> parsecSpecVersion + where + parsecSpecVersion = Left <$> parsec <|> Right <$> parsec + +instance Pretty SpecVersion where + pretty = either pretty pretty . unpack + +-- | Version range or just version +newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) } + +instance Newtype TestedWith (CompilerFlavor, VersionRange) where + pack = TestedWith + unpack = getTestedWith + +instance Parsec TestedWith where + parsec = pack <$> parsecTestedWith + +instance Pretty TestedWith where + pretty x = case unpack x of + (compiler, vr) -> pretty compiler <+> pretty vr + +-- | This is /almost/ @'many' 'Distribution.Compat.P.anyChar'@, but it +-- +-- * trims whitespace from ends of the lines, +-- +-- * converts lines with only single dot into empty line. +-- +newtype FreeText = FreeText { getFreeText :: String } + +instance Newtype FreeText String where + pack = FreeText + unpack = getFreeText + +instance Parsec FreeText where + parsec = pack . dropDotLines <$ P.spaces <*> many P.anyChar + where + -- Example package with dot lines + -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal + dropDotLines "." = "." + dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x + dotToEmpty x | trim' x == "." = "" + dotToEmpty x = trim x + + trim' :: String -> String + trim' = dropWhileEnd (`elem` (" \t" :: String)) + + trim :: String -> String + trim = dropWhile isSpace . dropWhileEnd isSpace + +instance Pretty FreeText where + pretty = showFreeText . unpack + +-- | Filepath are parsed as 'Token'. +newtype FilePathNT = FilePathNT { getFilePathNT :: String } + +instance Newtype FilePathNT String where + pack = FilePathNT + unpack = getFilePathNT + +instance Parsec FilePathNT where + parsec = pack <$> parsecToken + +instance Pretty FilePathNT where + pretty = showFilePath . unpack + +------------------------------------------------------------------------------- +-- Internal +------------------------------------------------------------------------------- + +parsecTestedWith :: P.Stream s Identity Char => P.Parsec s [PWarning] (CompilerFlavor, VersionRange) +parsecTestedWith = do + name <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (name, ver) diff --git a/Cabal/Distribution/Parsec/Types/ParseResult.hs b/Cabal/Distribution/Parsec/ParseResult.hs similarity index 92% rename from Cabal/Distribution/Parsec/Types/ParseResult.hs rename to Cabal/Distribution/Parsec/ParseResult.hs index 3aea3ab0543..421d3d0019a 100644 --- a/Cabal/Distribution/Parsec/Types/ParseResult.hs +++ b/Cabal/Distribution/Parsec/ParseResult.hs @@ -2,19 +2,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} -- | A parse result type for parsers from AST to Haskell types. -module Distribution.Parsec.Types.ParseResult ( +module Distribution.Parsec.ParseResult ( ParseResult, runParseResult, recoverWith, parseWarning, + parseWarnings, parseFailure, parseFatalFailure, parseFatalFailure', - parseWarnings', ) where import Distribution.Compat.Prelude -import Distribution.Parsec.Types.Common +import Distribution.Parsec.Common (PError (..), PWarnType (..), PWarning (..), Position (..), zeroPos) import Prelude () @@ -96,12 +96,14 @@ recoverWith :: ParseResult a -> a -> ParseResult a recoverWith (PR pr) x = PR $ \ !s _failure success -> pr s (\ !s' -> success s' x) success +-- | Add a warning. This doesn't fail the parsing process. parseWarning :: Position -> PWarnType -> String -> ParseResult () parseWarning pos t msg = PR $ \(PRState warns errs) _failure success -> success (PRState (PWarning t pos msg : warns) errs) () -parseWarnings' :: [PWarning] -> ParseResult () -parseWarnings' newWarns = PR $ \(PRState warns errs) _failure success -> +-- | Add multiple warnings at once. +parseWarnings :: [PWarning] -> ParseResult () +parseWarnings newWarns = PR $ \(PRState warns errs) _failure success -> success (PRState (newWarns ++ warns) errs) () -- | Add an error, but not fail the parser yet. @@ -116,6 +118,7 @@ parseFatalFailure :: Position -> String -> ParseResult a parseFatalFailure pos msg = PR $ \(PRState warns errs) failure _success -> failure (PRState warns (PError pos msg : errs)) +-- | A 'mzero'. parseFatalFailure' :: ParseResult a parseFatalFailure' = PR pr where diff --git a/Cabal/Distribution/Parsec/Parser.hs b/Cabal/Distribution/Parsec/Parser.hs index 9b9db35405c..4696cae8b8b 100644 --- a/Cabal/Distribution/Parsec/Parser.hs +++ b/Cabal/Distribution/Parsec/Parser.hs @@ -27,25 +27,25 @@ module Distribution.Parsec.Parser ( #endif ) where -import Prelude () -import Distribution.Compat.Prelude -import Control.Monad (guard) -import qualified Data.ByteString.Char8 as B8 +import Control.Monad (guard) +import qualified Data.ByteString.Char8 as B8 import Data.Functor.Identity +import Distribution.Compat.Prelude +import Distribution.Parsec.Common +import Distribution.Parsec.Field import Distribution.Parsec.Lexer import Distribution.Parsec.LexerMonad (LexResult (..), LexState (..), LexWarning (..), unLex) -import Distribution.Parsec.Types.Common -import Distribution.Parsec.Types.Field -import Text.Parsec.Combinator hiding (eof, notFollowedBy) +import Prelude () +import Text.Parsec.Combinator hiding (eof, notFollowedBy) import Text.Parsec.Error import Text.Parsec.Pos -import Text.Parsec.Prim hiding (many, (<|>)) +import Text.Parsec.Prim hiding (many, (<|>)) #ifdef CABAL_PARSEC_DEBUG -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T #endif -- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream' diff --git a/Cabal/Distribution/Parsec/Types/FieldDescr.hs b/Cabal/Distribution/Parsec/Types/FieldDescr.hs deleted file mode 100644 index a68f56f361c..00000000000 --- a/Cabal/Distribution/Parsec/Types/FieldDescr.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Parsec.Types.FieldDescr --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- -module Distribution.Parsec.Types.FieldDescr ( - -- * Field name - FieldName, - -- * Field description - FieldDescr (..), - liftField, - simpleField, - boolField, - optsField, - listField, - listFieldWithSep, - commaListField, - commaListFieldWithSep, - spaceListField, - -- ** Pretty printing - ppFields, - ppField, - -- * Unknown fields - UnknownFieldParser, - warnUnrec, - ignoreUnrec, - ) where - -import Prelude () -import Distribution.Compat.Prelude hiding (get) -import qualified Data.ByteString as BS -import Data.Ord (comparing) -import qualified Distribution.Compat.Parsec as P -import Distribution.Compiler (CompilerFlavor) -import Distribution.Pretty -import Distribution.Parsec.Class -import Distribution.Parsec.Types.Common -import Text.PrettyPrint - (Doc, colon, comma, fsep, hsep, isEmpty, nest, punctuate, - text, vcat, ($+$), (<+>)) - -type FieldName = BS.ByteString - -------------------------------------------------------------------------------- --- Unrecoginsed fields -------------------------------------------------------------------------------- - --- | How to handle unknown fields. -type UnknownFieldParser a = FieldName -> String -> a -> Maybe a - --- | A default unrecognized field parser which simply returns Nothing, --- i.e. ignores all unrecognized fields, so warnings will be generated. -warnUnrec :: UnknownFieldParser a -warnUnrec _ _ _ = Nothing - --- | A default unrecognized field parser which silently (i.e. no --- warnings will be generated) ignores unrecognized fields, by --- returning the structure being built unmodified. -ignoreUnrec :: UnknownFieldParser a -ignoreUnrec _ _ = Just - -------------------------------------------------------------------------------- --- Field description -------------------------------------------------------------------------------- - -data FieldDescr a = FieldDescr - { fieldName :: FieldName - , fieldPretty :: a -> Doc - , fieldParser :: a -> FieldParser a - } - -liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b -liftField get set fd = FieldDescr - (fieldName fd) - (fieldPretty fd . get) - (\b -> flip set b <$> fieldParser fd (get b)) - -simpleField - :: FieldName -- ^ fieldname - -> (a -> Doc) -- ^ show - -> FieldParser a -- ^ parser - -> (b -> a) -- ^ getter - -> (a -> b -> b) -- ^ setter - -> FieldDescr b -simpleField name pp parse get set = FieldDescr - name - (pp . get) - (\a -> flip set a <$> parse) - -boolField - :: FieldName - -> (b -> Bool) - -> (Bool -> b -> b) - -> FieldDescr b -boolField name get set = liftField get set (FieldDescr name showF parseF) - where - showF = text . show - parseF _ = P.munch1 isAlpha >>= postprocess - postprocess str - | str == "True" = pure True - | str == "False" = pure False - | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True - | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False - | otherwise = fail $ "Not a boolena: " ++ str - where - lstr = map toLower str - caseWarning = - "The " ++ show name ++ " field is case sensitive, use 'True' or 'False'." - -optsField - :: FieldName - -> CompilerFlavor - -> (b -> [(CompilerFlavor,[String])]) - -> ([(CompilerFlavor,[String])] -> b -> b) - -> FieldDescr b -optsField name flavor get set = liftField - (fromMaybe [] . lookup flavor . get) - (\opts b -> set (reorder (update flavor opts (get b))) b) - $ field name showF (many $ parsecToken' <* P.munch isSpace) - where - update _ opts l | all null opts = l --empty opts as if no opts - update f opts [] = [(f,opts)] - update f opts ((f',opts'):rest) - | f == f' = (f, opts' ++ opts) : rest - | otherwise = (f',opts') : update f opts rest - reorder = sortBy (comparing fst) - showF = hsep . map text - -listField - :: FieldName - -> (a -> Doc) - -> FieldParser a - -> (b -> [a]) - -> ([a] -> b -> b) - -> FieldDescr b -listField = listFieldWithSep fsep - -listFieldWithSep - :: Separator - -> FieldName - -> (a -> Doc) - -> FieldParser a - -> (b -> [a]) - -> ([a] -> b -> b) - -> FieldDescr b -listFieldWithSep separator name showF parseF get set = - liftField get set' $ - field name showF' (parsecOptCommaList parseF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . map showF - - -commaListField - :: FieldName -> (a -> Doc) -> FieldParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListField = commaListFieldWithSep fsep - -commaListFieldWithSep - :: Separator -> FieldName -> (a -> Doc) -> FieldParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListFieldWithSep separator name showF parseF get set = - liftField get set' $ - field name showF' (parsecCommaList parseF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . punctuate comma . map showF - -spaceListField - :: FieldName -> (a -> Doc) -> FieldParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -spaceListField name showF parseF get set = liftField get set' $ - field name showF' (many $ parseF <* P.spaces) - where - set' xs b = set (get b ++ xs) b - showF' = fsep . map showF - --- Overriding field -field :: FieldName -> (a -> Doc) -> FieldParser a -> FieldDescr a -field name showF parseF = - FieldDescr name showF (const parseF) - -------------------------------------------------------------------------------- --- Pretty printing -------------------------------------------------------------------------------- - -ppFields :: [FieldDescr a] -> a -> Doc -ppFields fields x = - vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ] - -ppField :: FieldName -> Doc -> Doc -ppField name fielddoc - | isEmpty fielddoc = mempty - | name `elem` nestedFields = text namestr <<>> colon $+$ nest indentWith fielddoc - | otherwise = text namestr <<>> colon <+> fielddoc - where - namestr = show name -- TODO: do this - nestedFields :: [BS.ByteString] - nestedFields = - [ "description" - , "build-depends" - , "data-files" - , "extra-source-files" - , "extra-tmp-files" - , "exposed-modules" - , "c-sources" - , "js-sources" - , "extra-libraries" - , "includes" - , "install-includes" - , "other-modules" - , "depends" - ] - --- | Handle deprecated fields --- --- *TODO:* use Parsec -{- -deprecField :: Field Position -> Parsec (Field Position) -deprecField = undefined {- --} - - (Field (Name pos fld) val) = do - fld' <- case lookup fld deprecatedFields of - Nothing -> return fld - Just newName -> do - warning $ "The field " ++ show fld - ++ " is deprecated, please use " ++ show newName - return newName - return (Field (Name pos fld') val) -deprecField _ = cabalBug "'deprecField' called on a non-field" --} diff --git a/Cabal/Distribution/Pretty.hs b/Cabal/Distribution/Pretty.hs index 66e648c5b54..31467b188e8 100644 --- a/Cabal/Distribution/Pretty.hs +++ b/Cabal/Distribution/Pretty.hs @@ -60,11 +60,12 @@ flatStyle = PP.Style { PP.mode = PP.LeftMode type Separator = [PP.Doc] -> PP.Doc showFilePath :: FilePath -> PP.Doc -showFilePath "" = mempty -showFilePath x = showToken x +showFilePath = showToken showToken :: String -> PP.Doc showToken str + | "--" `isPrefixOf` str = PP.text (show str) + | ":" `isSuffixOf` str = PP.text (show str) | not (any dodgy str) && not (null str) = PP.text str | otherwise = PP.text (show str) where diff --git a/Cabal/Distribution/ReadE.hs b/Cabal/Distribution/ReadE.hs index de857a9633c..fbe1b0371e3 100644 --- a/Cabal/Distribution/ReadE.hs +++ b/Cabal/Distribution/ReadE.hs @@ -14,13 +14,15 @@ module Distribution.ReadE ( ReadE(..), succeedReadE, failReadE, -- * Projections parseReadE, readEOrFail, - readP_to_E + readP_to_E, + parsecToReadE, ) where import Prelude () import Distribution.Compat.Prelude import Distribution.Compat.ReadP +import qualified Distribution.Compat.Parsec as P -- | Parser with simple error reporting newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} @@ -45,9 +47,17 @@ parseReadE (ReadE p) = do readEOrFail :: ReadE a -> String -> a readEOrFail r = either error id . runReadE r +-- {-# DEPRECATED readP_to_E "Use parsecToReadE" #-} readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a readP_to_E err r = ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt , all isSpace s ] of [] -> Left (err txt) (p:_) -> Right p + +parsecToReadE :: (String -> ErrorMsg) -> P.Parsec String [w] a -> ReadE a +parsecToReadE err p = ReadE $ \txt -> + case P.runParser (p <* P.spaces <* P.eof) [] "" txt of + Right x -> Right x + Left _e -> Left (err txt) +-- TODO: use parsec error to make 'ErrorMsg'. diff --git a/Cabal/Distribution/Simple.hs b/Cabal/Distribution/Simple.hs index 3941f4dbbcc..31d2deaca84 100644 --- a/Cabal/Distribution/Simple.hs +++ b/Cabal/Distribution/Simple.hs @@ -106,7 +106,6 @@ import Distribution.Compat.GetShortPathName (getShortPathName) import Data.List (unionBy, (\\)) import Distribution.PackageDescription.Parsec -import Distribution.PackageDescription.Parse (readHookedBuildInfo) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs index ac714dd1f93..4f2fc40601d 100644 --- a/Cabal/Distribution/Simple/Setup.hs +++ b/Cabal/Distribution/Simple/Setup.hs @@ -81,7 +81,10 @@ import Distribution.Compat.Prelude hiding (get) import Distribution.Compiler import Distribution.ReadE import Distribution.Text +import Distribution.Parsec.Class +import Distribution.Pretty import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P import Distribution.ParseUtils (readPToMaybe) import qualified Text.PrettyPrint as Disp import Distribution.ModuleName @@ -492,12 +495,12 @@ configureCommand progDb = CommandUI } -- | Inverse to 'dispModSubstEntry'. -parseModSubstEntry :: Parse.ReadP r (ModuleName, Module) -parseModSubstEntry = - do k <- parse - _ <- Parse.char '=' - v <- parse - return (k, v) +parsecModSubstEntry :: ParsecParser (ModuleName, Module) +parsecModSubstEntry = do + k <- parsec + _ <- P.char '=' + v <- parsec + return (k, v) -- | Pretty-print a single entry of a module substitution. dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc @@ -673,7 +676,7 @@ configureOptions showOrParseArgs = "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) (reqArg "FLAGS" - (readP_to_E (\err -> "Invalid flag assignment: " ++ err) parseFlagAssignment) + (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) parsecFlagAssignment) (map showFlagValue')) ,option "" ["extra-include-dirs"] @@ -716,21 +719,21 @@ configureOptions showOrParseArgs = "A list of additional constraints on the dependencies." configConstraints (\v flags -> flags { configConstraints = v}) (reqArg "DEPENDENCY" - (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) (map display)) ,option "" ["dependency"] "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" configDependencies (\v flags -> flags { configDependencies = v}) (reqArg "NAME=CID" - (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency)) + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecDependency)) (map (\x -> display (fst x) ++ "=" ++ display (snd x)))) ,option "" ["instantiate-with"] "A mapping of signature names to concrete module instantiations." configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) (reqArg "NAME=MOD" - (readP_to_E ("Cannot parse module substitution: " ++) (fmap (:[]) parseModSubstEntry)) + (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry)) (map (Disp.renderStyle defaultStyle . dispModSubstEntry))) ,option "" ["tests"] @@ -803,11 +806,11 @@ showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] showProfDetailLevelFlag NoFlag = [] showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] -parseDependency :: Parse.ReadP r (PackageName, ComponentId) -parseDependency = do - x <- parse - _ <- Parse.char '=' - y <- parse +parsecDependency :: ParsecParser (PackageName, ComponentId) +parsecDependency = do + x <- parsec + _ <- P.char '=' + y <- parsec return (x, y) installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] @@ -1823,9 +1826,19 @@ data TestShowDetails = Never | Failures | Always | Streaming | Direct knownTestShowDetails :: [TestShowDetails] knownTestShowDetails = [minBound..maxBound] -instance Text TestShowDetails where - disp = Disp.text . lowercase . show +instance Pretty TestShowDetails where + pretty = Disp.text . lowercase . show + +instance Parsec TestShowDetails where + parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident + where + ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = [ (display x, x) + | x <- knownTestShowDetails ] +instance Text TestShowDetails where parse = maybe Parse.pfail return . classify =<< ident where ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') @@ -1912,10 +1925,10 @@ testCommand = CommandUI ++ "'direct': send results of test cases in real time; no log file.") testShowDetails (\v flags -> flags { testShowDetails = v }) (reqArg "FILTER" - (readP_to_E (\_ -> "--show-details flag expects one of " + (parsecToReadE (\_ -> "--show-details flag expects one of " ++ intercalate ", " (map display knownTestShowDetails)) - (fmap toFlag parse)) + (fmap toFlag parsec)) (flagToList . fmap display)) , option [] ["keep-tix-files"] "keep .tix files for HPC between test runs" diff --git a/Cabal/Distribution/System.hs b/Cabal/Distribution/System.hs index aa25624d7ef..ee436262ca7 100644 --- a/Cabal/Distribution/System.hs +++ b/Cabal/Distribution/System.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -42,12 +43,17 @@ module Distribution.System ( import Prelude () import Distribution.Compat.Prelude +import Control.Applicative (liftA2) import qualified System.Info (os, arch) +import Distribution.Utils.Generic (lowercase) +import Distribution.Parsec.Class +import Distribution.Pretty import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P import qualified Text.PrettyPrint as Disp -- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. @@ -118,10 +124,14 @@ osAliases Permissive Solaris = ["solaris2"] osAliases Compat Solaris = ["solaris2"] osAliases _ _ = [] -instance Text OS where - disp (OtherOS name) = Disp.text name - disp other = Disp.text (lowercase (show other)) +instance Pretty OS where + pretty (OtherOS name) = Disp.text name + pretty other = Disp.text (lowercase (show other)) + +instance Parsec OS where + parsec = classifyOS Compat <$> parsecIdent +instance Text OS where parse = fmap (classifyOS Compat) ident classifyOS :: ClassificationStrictness -> String -> OS @@ -179,10 +189,14 @@ archAliases _ Mips = ["mipsel", "mipseb"] archAliases _ Arm = ["armeb", "armel"] archAliases _ _ = [] -instance Text Arch where - disp (OtherArch name) = Disp.text name - disp other = Disp.text (lowercase (show other)) +instance Pretty Arch where + pretty (OtherArch name) = Disp.text name + pretty other = Disp.text (lowercase (show other)) +instance Parsec Arch where + parsec = classifyArch Strict <$> parsecIdent + +instance Text Arch where parse = fmap (classifyArch Strict) ident classifyArch :: ClassificationStrictness -> String -> Arch @@ -205,8 +219,24 @@ data Platform = Platform Arch OS instance Binary Platform +instance Pretty Platform where + pretty (Platform arch os) = pretty arch <<>> Disp.char '-' <<>> pretty os + +instance Parsec Platform where + parsec = do + arch <- parsecDashlessArch + _ <- P.char '-' + os <- parsec + return (Platform arch os) + where + parsecDashlessArch = classifyArch Strict <$> dashlessIdent + + dashlessIdent = liftA2 (:) firstChar rest + where + firstChar = P.satisfy isAlpha + rest = P.munch (\c -> isAlphaNum c || c == '_') + instance Text Platform where - disp (Platform arch os) = disp arch <<>> Disp.char '-' <<>> disp os -- TODO: there are ambigious platforms like: `arch-word-os` -- which could be parsed as -- * Platform "arch-word" "os" @@ -223,6 +253,11 @@ instance Text Platform where parseDashlessArch :: Parse.ReadP r Arch parseDashlessArch = fmap (classifyArch Strict) dashlessIdent + dashlessIdent :: Parse.ReadP r String + dashlessIdent = liftM2 (:) firstChar rest + where firstChar = Parse.satisfy isAlpha + rest = Parse.munch (\c -> isAlphaNum c || c == '_') + -- | The platform Cabal was compiled on. In most cases, -- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're -- targeting). @@ -236,13 +271,11 @@ ident = liftM2 (:) firstChar rest where firstChar = Parse.satisfy isAlpha rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-') -dashlessIdent :: Parse.ReadP r String -dashlessIdent = liftM2 (:) firstChar rest - where firstChar = Parse.satisfy isAlpha - rest = Parse.munch (\c -> isAlphaNum c || c == '_') - -lowercase :: String -> String -lowercase = map toLower +parsecIdent :: ParsecParser String +parsecIdent = (:) <$> firstChar <*> rest + where + firstChar = P.satisfy isAlpha + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') platformFromTriple :: String -> Maybe Platform platformFromTriple triple = diff --git a/Cabal/Distribution/Text.hs b/Cabal/Distribution/Text.hs index 2765c49eb3c..67346e682ba 100644 --- a/Cabal/Distribution/Text.hs +++ b/Cabal/Distribution/Text.hs @@ -26,6 +26,7 @@ import Distribution.Compat.Prelude import Data.Functor.Identity (Identity (..)) import Distribution.Pretty +import Distribution.Parsec.Class import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp @@ -39,6 +40,8 @@ class Text a where disp = pretty parse :: Parse.ReadP r a + default parse :: Parsec a => Parse.ReadP r a + parse = Parse.parsecToReadP parsec [] -- | Pretty-prints with the default style. display :: Text a => a -> String diff --git a/Cabal/Distribution/Types/BenchmarkType.hs b/Cabal/Distribution/Types/BenchmarkType.hs index 23c195d882a..90f5b0f0e67 100644 --- a/Cabal/Distribution/Types/BenchmarkType.hs +++ b/Cabal/Distribution/Types/BenchmarkType.hs @@ -1,19 +1,19 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.BenchmarkType ( BenchmarkType(..), knownBenchmarkTypes, ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.Text import Distribution.Version - -import Text.PrettyPrint as Disp +import Text.PrettyPrint (char, text) -- | The \"benchmark-type\" field in the benchmark stanza. -- @@ -32,6 +32,11 @@ instance Pretty BenchmarkType where pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver pretty (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver +instance Parsec BenchmarkType where + parsec = parsecStandard $ \ver name -> case name of + "exitcode-stdio" -> BenchmarkTypeExe ver + _ -> BenchmarkTypeUnknown name ver + instance Text BenchmarkType where parse = stdParse $ \ver name -> case name of "exitcode-stdio" -> BenchmarkTypeExe ver diff --git a/Cabal/Distribution/Types/BuildType.hs b/Cabal/Distribution/Types/BuildType.hs index 26e871e4260..2e3ded3f549 100644 --- a/Cabal/Distribution/Types/BuildType.hs +++ b/Cabal/Distribution/Types/BuildType.hs @@ -10,10 +10,12 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse -import Text.PrettyPrint as Disp +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp -- | The type of build system used by this package. data BuildType @@ -39,6 +41,16 @@ instance Pretty BuildType where pretty (UnknownBuildType other) = Disp.text other pretty other = Disp.text (show other) +instance Parsec BuildType where + parsec = do + name <- P.munch1 isAlphaNum + return $ case name of + "Simple" -> Simple + "Configure" -> Configure + "Custom" -> Custom + "Make" -> Make + _ -> UnknownBuildType name + instance Text BuildType where parse = do name <- Parse.munch1 isAlphaNum diff --git a/Cabal/Distribution/Types/ComponentId.hs b/Cabal/Distribution/Types/ComponentId.hs index d572f1224ab..19b0564cda5 100644 --- a/Cabal/Distribution/Types/ComponentId.hs +++ b/Cabal/Distribution/Types/ComponentId.hs @@ -11,7 +11,10 @@ import Distribution.Compat.Prelude import Distribution.Utils.ShortText import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P import Distribution.Text +import Distribution.Pretty +import Distribution.Parsec.Class import Text.PrettyPrint (text) @@ -56,9 +59,14 @@ instance IsString ComponentId where instance Binary ComponentId -instance Text ComponentId where - disp = text . unComponentId +instance Pretty ComponentId where + pretty = text . unComponentId + +instance Parsec ComponentId where + parsec = mkComponentId `fmap` P.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." +instance Text ComponentId where parse = mkComponentId `fmap` Parse.munch1 abi_char where abi_char c = isAlphaNum c || c `elem` "-_." diff --git a/Cabal/Distribution/Types/Dependency.hs b/Cabal/Distribution/Types/Dependency.hs index 5e6d826b1e1..ce05392ce73 100644 --- a/Cabal/Distribution/Types/Dependency.hs +++ b/Cabal/Distribution/Types/Dependency.hs @@ -17,9 +17,10 @@ import Distribution.Version ( VersionRange, thisVersion , simplifyVersionRange ) import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP + import Distribution.Text import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Types.PackageId import Distribution.Types.PackageName @@ -42,10 +43,16 @@ instance NFData Dependency where rnf = genericRnf instance Pretty Dependency where pretty (Dependency name ver) = pretty name <+> pretty ver +instance Parsec Dependency where + parsec = do + name <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (Dependency name ver) + instance Text Dependency where parse = do name <- parse Parse.skipSpaces - ver <- parse <++ return anyVersion + ver <- parse Parse.<++ return anyVersion Parse.skipSpaces return (Dependency name ver) diff --git a/Cabal/Distribution/Types/ExeDependency.hs b/Cabal/Distribution/Types/ExeDependency.hs index 3a19dba8a77..e75f12a3d86 100644 --- a/Cabal/Distribution/Types/ExeDependency.hs +++ b/Cabal/Distribution/Types/ExeDependency.hs @@ -1,24 +1,25 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ExeDependency ( ExeDependency(..) , qualifiedExeName ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.ComponentName -import Distribution.Types.UnqualComponentName -import Distribution.Types.PackageName -import Distribution.Version ( VersionRange, anyVersion ) - -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.Text +import Distribution.Types.ComponentName +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName +import Distribution.Version (VersionRange, anyVersion) -import Text.PrettyPrint ((<+>), text) +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint (text, (<+>)) -- | Describes a dependency on an executable from a package -- @@ -35,6 +36,14 @@ instance Pretty ExeDependency where pretty (ExeDependency name exe ver) = (pretty name <<>> text ":" <<>> pretty exe) <+> pretty ver +instance Parsec ExeDependency where + parsec = do + name <- lexemeParsec + _ <- P.char ':' + exe <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (ExeDependency name exe ver) + instance Text ExeDependency where parse = do name <- parse _ <- Parse.char ':' diff --git a/Cabal/Distribution/Types/ExecutableScope.hs b/Cabal/Distribution/Types/ExecutableScope.hs index b76eb95854e..4063507b5a4 100644 --- a/Cabal/Distribution/Types/ExecutableScope.hs +++ b/Cabal/Distribution/Types/ExecutableScope.hs @@ -9,10 +9,12 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse -import Text.PrettyPrint (text) +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp data ExecutableScope = ExecutableScopeUnknown | ExecutablePublic @@ -20,9 +22,17 @@ data ExecutableScope = ExecutableScopeUnknown deriving (Generic, Show, Read, Eq, Typeable, Data) instance Pretty ExecutableScope where - pretty ExecutablePublic = text "public" - pretty ExecutablePrivate = text "private" - pretty ExecutableScopeUnknown = text "unknown" + pretty ExecutablePublic = Disp.text "public" + pretty ExecutablePrivate = Disp.text "private" + pretty ExecutableScopeUnknown = Disp.text "unknown" + +instance Parsec ExecutableScope where + parsec = do + name <- P.munch1 (\c -> isAlphaNum c || c == '-') + return $ case name of + "public" -> ExecutablePublic + "private" -> ExecutablePrivate + _ -> ExecutableScopeUnknown instance Text ExecutableScope where parse = Parse.choice diff --git a/Cabal/Distribution/Types/ForeignLib.hs b/Cabal/Distribution/Types/ForeignLib.hs index 492c22b96cb..6787909085b 100644 --- a/Cabal/Distribution/Types/ForeignLib.hs +++ b/Cabal/Distribution/Types/ForeignLib.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ForeignLib( ForeignLib(..), @@ -16,23 +16,24 @@ module Distribution.Types.ForeignLib( libVersionMajor ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.ModuleName +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.System import Distribution.Text -import Distribution.Version -import qualified Distribution.Compat.ReadP as Parse - import Distribution.Types.BuildInfo -import Distribution.Types.ForeignLibType import Distribution.Types.ForeignLibOption +import Distribution.Types.ForeignLibType import Distribution.Types.UnqualComponentName +import Distribution.Version -import qualified Text.PrettyPrint as Disp -import qualified Text.Read as Read +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Text.Read as Read import qualified Distribution.Types.BuildInfo.Lens as L @@ -88,6 +89,18 @@ instance Pretty LibVersionInfo where pretty (LibVersionInfo c r a) = Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c,r,a] +instance Parsec LibVersionInfo where + parsec = do + c <- P.integral + (r, a) <- P.option (0,0) $ do + _ <- P.char ':' + r <- P.integral + a <- P.option 0 $ do + _ <- P.char ':' + P.integral + return (r,a) + return $ mkLibVersionInfo (c,r,a) + instance Text LibVersionInfo where parse = do c <- parseNat diff --git a/Cabal/Distribution/Types/ForeignLibOption.hs b/Cabal/Distribution/Types/ForeignLibOption.hs index 48596fb0e7b..dbf61a04963 100644 --- a/Cabal/Distribution/Types/ForeignLibOption.hs +++ b/Cabal/Distribution/Types/ForeignLibOption.hs @@ -8,11 +8,14 @@ module Distribution.Types.ForeignLibOption( import Prelude () import Distribution.Compat.Prelude -import Text.PrettyPrint -import qualified Distribution.Compat.ReadP as Parse import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + data ForeignLibOption = -- | Merge in all dependent libraries (i.e., use -- @ghc -shared -static@ rather than just record @@ -23,7 +26,14 @@ data ForeignLibOption = deriving (Generic, Show, Read, Eq, Typeable, Data) instance Pretty ForeignLibOption where - pretty ForeignLibStandalone = text "standalone" + pretty ForeignLibStandalone = Disp.text "standalone" + +instance Parsec ForeignLibOption where + parsec = do + name <- P.munch1 (\c -> isAlphaNum c || c == '-') + case name of + "standalone" -> return ForeignLibStandalone + _ -> fail "unrecognized foreign-library option" instance Text ForeignLibOption where parse = Parse.choice [ @@ -31,4 +41,3 @@ instance Text ForeignLibOption where ] instance Binary ForeignLibOption - diff --git a/Cabal/Distribution/Types/ForeignLibType.hs b/Cabal/Distribution/Types/ForeignLibType.hs index 39179541e62..e8ff20d3a6c 100644 --- a/Cabal/Distribution/Types/ForeignLibType.hs +++ b/Cabal/Distribution/Types/ForeignLibType.hs @@ -9,12 +9,15 @@ module Distribution.Types.ForeignLibType( import Prelude () import Distribution.Compat.Prelude +import Distribution.PackageDescription.Utils -import Text.PrettyPrint hiding ((<>)) import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text + +import qualified Distribution.Compat.Parsec as P import qualified Distribution.Compat.ReadP as Parse -import Distribution.PackageDescription.Utils +import qualified Text.PrettyPrint as Disp -- | What kind of foreign library is to be built? data ForeignLibType = @@ -28,9 +31,17 @@ data ForeignLibType = deriving (Generic, Show, Read, Eq, Typeable, Data) instance Pretty ForeignLibType where - pretty ForeignLibNativeShared = text "native-shared" - pretty ForeignLibNativeStatic = text "native-static" - pretty ForeignLibTypeUnknown = text "unknown" + pretty ForeignLibNativeShared = Disp.text "native-shared" + pretty ForeignLibNativeStatic = Disp.text "native-static" + pretty ForeignLibTypeUnknown = Disp.text "unknown" + +instance Parsec ForeignLibType where + parsec = do + name <- P.munch1 (\c -> isAlphaNum c || c == '-') + return $ case name of + "native-shared" -> ForeignLibNativeShared + "native-static" -> ForeignLibNativeStatic + _ -> ForeignLibTypeUnknown instance Text ForeignLibType where parse = Parse.choice [ diff --git a/Cabal/Distribution/Types/GenericPackageDescription.hs b/Cabal/Distribution/Types/GenericPackageDescription.hs index 6844fe19a5a..1547ade814e 100644 --- a/Cabal/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal/Distribution/Types/GenericPackageDescription.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} module Distribution.Types.GenericPackageDescription ( GenericPackageDescription(..), @@ -12,6 +13,7 @@ module Distribution.Types.GenericPackageDescription ( showFlagValue, dispFlagAssignment, parseFlagAssignment, + parsecFlagAssignment, ConfVar(..), ) where @@ -21,6 +23,7 @@ import Distribution.Utils.ShortText import Distribution.Utils.Generic (lowercase) import qualified Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P import Distribution.Compat.ReadP ((+++)) import Distribution.Types.PackageDescription @@ -38,6 +41,8 @@ import Distribution.Package import Distribution.Version import Distribution.Compiler import Distribution.System +import Distribution.Parsec.Class +import Distribution.Pretty import Distribution.Text -- --------------------------------------------------------------------------- @@ -117,8 +122,17 @@ unFlagName (FlagName s) = fromShortText s instance Binary FlagName +instance Pretty FlagName where + pretty = Disp.text . unFlagName + +instance Parsec FlagName where + parsec = mkFlagName . lowercase <$> parsec' + where + parsec' = (:) <$> lead <*> rest + lead = P.satisfy (\c -> isAlphaNum c || c == '_') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + instance Text FlagName where - disp = Disp.text . unFlagName -- Note: we don't check that FlagName doesn't have leading dash, -- cabal check will do that. parse = mkFlagName . lowercase <$> parse' @@ -143,6 +157,19 @@ showFlagValue (f, False) = '-' : unFlagName f dispFlagAssignment :: FlagAssignment -> Disp.Doc dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) +-- | Parses a flag assignment. +parsecFlagAssignment :: ParsecParser FlagAssignment +parsecFlagAssignment = P.sepBy1 (onFlag <|> offFlag) P.skipSpaces1 + where + onFlag = do + P.optional (P.char '+') + f <- parsec + return (f, True) + offFlag = do + _ <- P.char '-' + f <- parsec + return (f, False) + -- | Parses a flag assignment. parseFlagAssignment :: Parse.ReadP r FlagAssignment parseFlagAssignment = Parse.sepBy1 parseFlagValue Parse.skipSpaces1 @@ -154,6 +181,7 @@ parseFlagAssignment = Parse.sepBy1 parseFlagValue Parse.skipSpaces1 +++ (do _ <- Parse.char '-' f <- parse return (f, False)) +-- {-# DEPRECATED parseFlagAssignment "Use parsecFlagAssignment" #-} -- | A @ConfVar@ represents the variable type used. data ConfVar = OS OS diff --git a/Cabal/Distribution/Types/IncludeRenaming.hs b/Cabal/Distribution/Types/IncludeRenaming.hs index 93960265e16..cf295b240a3 100644 --- a/Cabal/Distribution/Types/IncludeRenaming.hs +++ b/Cabal/Distribution/Types/IncludeRenaming.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.IncludeRenaming ( IncludeRenaming(..), @@ -7,17 +7,19 @@ module Distribution.Types.IncludeRenaming ( isDefaultIncludeRenaming, ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.ModuleRenaming -import Distribution.Pretty -import Distribution.Text - -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<+>), text) -import Distribution.Compat.ReadP +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Parsec.Class +import Distribution.Pretty +import Distribution.Text +import Text.PrettyPrint (text, (<+>)) +import qualified Text.PrettyPrint as Disp -- --------------------------------------------------------------------------- -- Module renaming @@ -48,10 +50,20 @@ instance Pretty IncludeRenaming where then Disp.empty else text "requires" <+> pretty req_rn) +instance Parsec IncludeRenaming where + parsec = do + prov_rn <- parsec + req_rn <- P.option defaultRenaming $ P.try $ do + P.spaces + _ <- P.string "requires" + P.spaces + parsec + return (IncludeRenaming prov_rn req_rn) + instance Text IncludeRenaming where parse = do prov_rn <- parse - req_rn <- (string "requires" >> skipSpaces >> parse) <++ return defaultRenaming + req_rn <- (Parse.string "requires" >> Parse.skipSpaces >> parse) <++ return defaultRenaming -- Requirements don't really care if they're mentioned -- or not (since you can't thin a requirement.) But -- we have a little hack in Configure to combine diff --git a/Cabal/Distribution/Types/LegacyExeDependency.hs b/Cabal/Distribution/Types/LegacyExeDependency.hs index 84696cdbc23..298ef7a5cfe 100644 --- a/Cabal/Distribution/Types/LegacyExeDependency.hs +++ b/Cabal/Distribution/Types/LegacyExeDependency.hs @@ -1,22 +1,22 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.LegacyExeDependency ( LegacyExeDependency(..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Version ( VersionRange, anyVersion ) - -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP +import Distribution.Parsec.Class +import Distribution.ParseUtils (parseMaybeQuoted) import Distribution.Pretty import Distribution.Text +import Distribution.Version (VersionRange, anyVersion) -import Text.PrettyPrint ((<+>), text) - -import Distribution.ParseUtils (parseMaybeQuoted) +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint (text, (<+>)) -- | Describes a legacy `build-tools`-style dependency on an executable -- @@ -37,6 +37,18 @@ instance Pretty LegacyExeDependency where pretty (LegacyExeDependency name ver) = text name <+> pretty ver +instance Parsec LegacyExeDependency where + parsec = do + name <- parsecMaybeQuoted nameP + P.spaces + verRange <- parsecMaybeQuoted parsec <|> pure anyVersion + pure $ LegacyExeDependency name verRange + where + nameP = intercalate "-" <$> P.sepBy1 component (P.char '-') + component = do + cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then fail "invalid component" else return cs + instance Text LegacyExeDependency where parse = do name <- parseMaybeQuoted parseBuildToolName Parse.skipSpaces @@ -46,8 +58,8 @@ instance Text LegacyExeDependency where where -- like parsePackageName but accepts symbols in components parseBuildToolName :: Parse.ReadP r String - parseBuildToolName = do ns <- sepBy1 component (Parse.char '-') + parseBuildToolName = do ns <- Parse.sepBy1 component (Parse.char '-') return (intercalate "-" ns) where component = do - cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then pfail else return cs + cs <- Parse.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then Parse.pfail else return cs diff --git a/Cabal/Distribution/Types/Mixin.hs b/Cabal/Distribution/Types/Mixin.hs index 42367de4618..af886ec1647 100644 --- a/Cabal/Distribution/Types/Mixin.hs +++ b/Cabal/Distribution/Types/Mixin.hs @@ -1,20 +1,23 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.Mixin ( Mixin(..), ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Text.PrettyPrint ((<+>)) -import Distribution.Compat.ReadP + +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.Text - -import Distribution.Types.PackageName import Distribution.Types.IncludeRenaming +import Distribution.Types.PackageName + +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse data Mixin = Mixin { mixinPackageName :: PackageName , mixinIncludeRenaming :: IncludeRenaming } @@ -25,9 +28,16 @@ instance Binary Mixin instance Pretty Mixin where pretty (Mixin pkg_name incl) = pretty pkg_name <+> pretty incl +instance Parsec Mixin where + parsec = do + mod_name <- parsec + P.spaces + incl <- parsec + return (Mixin mod_name incl) + instance Text Mixin where parse = do pkg_name <- parse - skipSpaces + Parse.skipSpaces incl <- parse return (Mixin pkg_name incl) diff --git a/Cabal/Distribution/Types/Module.hs b/Cabal/Distribution/Types/Module.hs index 32c06513dbc..fa862a128a3 100644 --- a/Cabal/Distribution/Types/Module.hs +++ b/Cabal/Distribution/Types/Module.hs @@ -10,8 +10,10 @@ import Prelude () import Distribution.Compat.Prelude import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P import qualified Text.PrettyPrint as Disp import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text import Distribution.Types.UnitId import Distribution.ModuleName @@ -34,6 +36,13 @@ instance Pretty Module where pretty (Module uid mod_name) = pretty uid <<>> Disp.text ":" <<>> pretty mod_name +instance Parsec Module where + parsec = do + uid <- parsec + _ <- P.char ':' + mod_name <- parsec + return (Module uid mod_name) + instance Text Module where parse = do uid <- parse diff --git a/Cabal/Distribution/Types/ModuleReexport.hs b/Cabal/Distribution/Types/ModuleReexport.hs index 03984f9bb04..4170bd31adf 100644 --- a/Cabal/Distribution/Types/ModuleReexport.hs +++ b/Cabal/Distribution/Types/ModuleReexport.hs @@ -1,20 +1,23 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ModuleReexport ( ModuleReexport(..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import qualified Distribution.Compat.ReadP as Parse import Distribution.ModuleName +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.Text import Distribution.Types.PackageName -import Text.PrettyPrint as Disp +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint ((<+>)) +import qualified Text.PrettyPrint as Disp -- ----------------------------------------------------------------------------- -- Module re-exports @@ -36,6 +39,17 @@ instance Pretty ModuleReexport where then Disp.empty else Disp.text "as" <+> pretty newname +instance Parsec ModuleReexport where + parsec = do + mpkgname <- P.optionMaybe (P.try $ parsec <* P.char ':') + origname <- parsec + newname <- P.option origname $ P.try $ do + P.spaces + _ <- P.string "as" + P.spaces + parsec + return (ModuleReexport mpkgname origname newname) + instance Text ModuleReexport where parse = do mpkgname <- Parse.option Nothing $ do diff --git a/Cabal/Distribution/Types/ModuleRenaming.hs b/Cabal/Distribution/Types/ModuleRenaming.hs index abbc7bd5bc3..a4ed3cd2562 100644 --- a/Cabal/Distribution/Types/ModuleRenaming.hs +++ b/Cabal/Distribution/Types/ModuleRenaming.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ModuleRenaming ( ModuleRenaming(..), @@ -8,19 +8,20 @@ module Distribution.Types.ModuleRenaming ( isDefaultRenaming, ) where -import Prelude () import Distribution.Compat.Prelude hiding (empty) +import Prelude () -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((<++)) import Distribution.ModuleName +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.Text -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Text.PrettyPrint +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint (hsep, parens, punctuate, text, (<+>), comma) -- | Renaming applied to the modules provided by a package. -- The boolean indicates whether or not to also include all of the @@ -71,7 +72,7 @@ instance Binary ModuleRenaming where -- NB: parentheses are mandatory, because later we may extend this syntax -- to allow "hiding (A, B)" or other modifier words. instance Pretty ModuleRenaming where - pretty DefaultRenaming = empty + pretty DefaultRenaming = mempty pretty (HidingRenaming hides) = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides))) pretty (ModuleRenaming rns) @@ -80,6 +81,34 @@ instance Pretty ModuleRenaming where | orig == new = pretty orig | otherwise = pretty orig <+> text "as" <+> pretty new +instance Parsec ModuleRenaming where + -- NB: try not necessary as the first token is obvious + parsec = P.choice [ parseRename, parseHiding, return DefaultRenaming ] + where + parseRename = do + rns <- P.between (P.char '(') (P.char ')') parseList + P.spaces + return (ModuleRenaming rns) + parseHiding = do + _ <- P.string "hiding" + P.spaces + hides <- P.between (P.char '(') (P.char ')') + (P.sepBy parsec (P.char ',' >> P.spaces)) + return (HidingRenaming hides) + parseList = + P.sepBy parseEntry (P.char ',' >> P.spaces) + parseEntry = do + orig <- parsec + P.spaces + P.option (orig, orig) $ do + _ <- P.string "as" + P.spaces + new <- parsec + P.spaces + return (orig, new) + + + instance Text ModuleRenaming where parse = do fmap ModuleRenaming parseRns <++ parseHidingRenaming diff --git a/Cabal/Distribution/Types/PackageDescription.hs b/Cabal/Distribution/Types/PackageDescription.hs index 27007bacf41..080841fea69 100644 --- a/Cabal/Distribution/Types/PackageDescription.hs +++ b/Cabal/Distribution/Types/PackageDescription.hs @@ -137,6 +137,7 @@ data PackageDescription foreignLibs :: [ForeignLib], testSuites :: [TestSuite], benchmarks :: [Benchmark], + -- files dataFiles :: [FilePath], dataDir :: FilePath, extraSrcFiles :: [FilePath], diff --git a/Cabal/Distribution/Types/PackageName.hs b/Cabal/Distribution/Types/PackageName.hs index 0629b677e76..e7d527518f5 100644 --- a/Cabal/Distribution/Types/PackageName.hs +++ b/Cabal/Distribution/Types/PackageName.hs @@ -13,6 +13,7 @@ import qualified Text.PrettyPrint as Disp import Distribution.ParseUtils import Distribution.Text import Distribution.Pretty +import Distribution.Parsec.Class -- | A package name. -- @@ -51,6 +52,9 @@ instance Binary PackageName instance Pretty PackageName where pretty = Disp.text . unPackageName +instance Parsec PackageName where + parsec = mkPackageName <$> parsecUnqualComponentName + instance Text PackageName where parse = mkPackageName <$> parsePackageName diff --git a/Cabal/Distribution/Types/PkgconfigDependency.hs b/Cabal/Distribution/Types/PkgconfigDependency.hs index 06f5da7251c..204b92f5a14 100644 --- a/Cabal/Distribution/Types/PkgconfigDependency.hs +++ b/Cabal/Distribution/Types/PkgconfigDependency.hs @@ -1,21 +1,24 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.PkgconfigDependency ( PkgconfigDependency(..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Version (VersionRange, anyVersion) -import Distribution.Version ( VersionRange, anyVersion ) +import Distribution.Types.PkgconfigName -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.Text -import Distribution.Types.PkgconfigName -import Text.PrettyPrint ((<+>)) +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint ((<+>)) -- | Describes a dependency on a pkg-config library -- @@ -32,6 +35,13 @@ instance Pretty PkgconfigDependency where pretty (PkgconfigDependency name ver) = pretty name <+> pretty ver +instance Parsec PkgconfigDependency where + parsec = do + name <- parsec + P.spaces + verRange <- parsec <|> pure anyVersion + pure $ PkgconfigDependency name verRange + instance Text PkgconfigDependency where parse = do name <- parse Parse.skipSpaces diff --git a/Cabal/Distribution/Types/PkgconfigName.hs b/Cabal/Distribution/Types/PkgconfigName.hs index dce81ae16da..697a47f7089 100644 --- a/Cabal/Distribution/Types/PkgconfigName.hs +++ b/Cabal/Distribution/Types/PkgconfigName.hs @@ -9,11 +9,14 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.ShortText -import qualified Text.PrettyPrint as Disp -import Distribution.Compat.ReadP import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + -- | A pkg-config library name -- -- This is parsed as any valid argument to the pkg-config utility. @@ -53,9 +56,12 @@ instance Binary PkgconfigName instance Pretty PkgconfigName where pretty = Disp.text . unPkgconfigName +instance Parsec PkgconfigName where + parsec = mkPkgconfigName <$> P.munch1 (\c -> isAlphaNum c || c `elem` "+-._") + instance Text PkgconfigName where parse = mkPkgconfigName - <$> munch1 (\c -> isAlphaNum c || c `elem` "+-._") + <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-._") instance NFData PkgconfigName where rnf (PkgconfigName pkg) = rnf pkg diff --git a/Cabal/Distribution/Types/SetupBuildInfo.hs b/Cabal/Distribution/Types/SetupBuildInfo.hs index 3afc922b54b..7170e01ca22 100644 --- a/Cabal/Distribution/Types/SetupBuildInfo.hs +++ b/Cabal/Distribution/Types/SetupBuildInfo.hs @@ -17,9 +17,9 @@ import Distribution.Types.Dependency -- To keep things simple for tools that compile Setup.hs we limit the -- options authors can specify to just Haskell package dependencies. -data SetupBuildInfo = SetupBuildInfo { - setupDepends :: [Dependency], - defaultSetupDepends :: Bool +data SetupBuildInfo = SetupBuildInfo + { setupDepends :: [Dependency] + , defaultSetupDepends :: Bool -- ^ Is this a default 'custom-setup' section added by the cabal-install -- code (as opposed to user-provided)? This field is only used -- internally, and doesn't correspond to anything in the .cabal @@ -30,9 +30,10 @@ data SetupBuildInfo = SetupBuildInfo { instance Binary SetupBuildInfo instance Monoid SetupBuildInfo where - mempty = SetupBuildInfo [] False - mappend = (<>) + mempty = SetupBuildInfo [] False + mappend = (<>) instance Semigroup SetupBuildInfo where - a <> b = SetupBuildInfo (setupDepends a <> setupDepends b) - (defaultSetupDepends a || defaultSetupDepends b) + a <> b = SetupBuildInfo + (setupDepends a <> setupDepends b) + (defaultSetupDepends a || defaultSetupDepends b) diff --git a/Cabal/Distribution/Types/SourceRepo.hs b/Cabal/Distribution/Types/SourceRepo.hs index 73ee6215e58..2e04db05266 100644 --- a/Cabal/Distribution/Types/SourceRepo.hs +++ b/Cabal/Distribution/Types/SourceRepo.hs @@ -14,11 +14,15 @@ module Distribution.Types.SourceRepo ( import Prelude () import Distribution.Compat.Prelude -import qualified Distribution.Compat.ReadP as Parse +import Distribution.Utils.Generic (lowercase) + import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text -import Text.PrettyPrint as Disp +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp -- ------------------------------------------------------------ -- * Source repos @@ -138,6 +142,9 @@ instance Pretty RepoKind where pretty RepoThis = Disp.text "this" pretty (RepoKindUnknown other) = Disp.text other +instance Parsec RepoKind where + parsec = classifyRepoKind <$> P.munch1 isIdent + instance Text RepoKind where parse = fmap classifyRepoKind ident @@ -151,20 +158,22 @@ instance Pretty RepoType where pretty (OtherRepoType other) = Disp.text other pretty other = Disp.text (lowercase (show other)) +instance Parsec RepoType where + parsec = classifyRepoType <$> P.munch1 isIdent + instance Text RepoType where parse = fmap classifyRepoType ident classifyRepoType :: String -> RepoType classifyRepoType s = - fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap + fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap where repoTypeMap = [ (name, repoType') | repoType' <- knownRepoTypes , name <- display repoType' : repoTypeAliases repoType' ] ident :: Parse.ReadP r String -ident = Parse.munch1 (\c -> isAlphaNum c || c == '_' || c == '-') - -lowercase :: String -> String -lowercase = map toLower +ident = Parse.munch1 isIdent +isIdent :: Char -> Bool +isIdent c = isAlphaNum c || c == '_' || c == '-' diff --git a/Cabal/Distribution/Types/TestType.hs b/Cabal/Distribution/Types/TestType.hs index c8c87ce083b..e7abb8389e5 100644 --- a/Cabal/Distribution/Types/TestType.hs +++ b/Cabal/Distribution/Types/TestType.hs @@ -1,19 +1,19 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.TestType ( TestType(..), knownTestTypes, ) where -import Prelude () import Distribution.Compat.Prelude +import Distribution.Version +import Prelude () +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.Text -import Distribution.Version - -import Text.PrettyPrint as Disp +import Text.PrettyPrint (char, text) -- | The \"test-type\" field in the test suite stanza. -- @@ -33,6 +33,12 @@ instance Pretty TestType where pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver pretty (TestTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver +instance Parsec TestType where + parsec = parsecStandard $ \ver name -> case name of + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver + instance Text TestType where parse = stdParse $ \ver name -> case name of "exitcode-stdio" -> TestTypeExe ver diff --git a/Cabal/Distribution/Types/UnitId.hs b/Cabal/Distribution/Types/UnitId.hs index 6c29f55242b..33e987c03b1 100644 --- a/Cabal/Distribution/Types/UnitId.hs +++ b/Cabal/Distribution/Types/UnitId.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} module Distribution.Types.UnitId ( UnitId, unUnitId, mkUnitId @@ -18,7 +19,9 @@ import Distribution.Compat.Prelude import Distribution.Utils.ShortText import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text import Distribution.Types.ComponentId import Distribution.Types.PackageId @@ -79,6 +82,9 @@ instance Pretty UnitId where -- | The textual format for 'UnitId' coincides with the format -- GHC accepts for @-package-id@. -- +instance Parsec UnitId where + parsec = mkUnitId <$> P.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + instance Text UnitId where parse = mkUnitId <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") @@ -115,7 +121,7 @@ getHSLibraryName uid = "HS" ++ display uid -- that a 'UnitId' identified this way is definite; i.e., it has no -- unfilled holes. newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty, Text) + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Parsec, Pretty, Text) -- | Unsafely create a 'DefUnitId' from a 'UnitId'. Your responsibility -- is to ensure that the 'DefUnitId' invariant holds. diff --git a/Cabal/Distribution/Types/UnqualComponentName.hs b/Cabal/Distribution/Types/UnqualComponentName.hs index 287b588f355..bf2e1e91775 100644 --- a/Cabal/Distribution/Types/UnqualComponentName.hs +++ b/Cabal/Distribution/Types/UnqualComponentName.hs @@ -1,18 +1,19 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.UnqualComponentName ( UnqualComponentName, unUnqualComponentName, mkUnqualComponentName , packageNameToUnqualComponentName, unqualComponentNameToPackageName ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.ShortText +import Prelude () +import Distribution.Parsec.Class +import Distribution.ParseUtils (parsePackageName) import Distribution.Pretty import Distribution.Text -import Distribution.ParseUtils (parsePackageName) import Distribution.Types.PackageName -- | An unqualified component name, for any kind of component. @@ -54,6 +55,9 @@ instance Binary UnqualComponentName instance Pretty UnqualComponentName where pretty = showToken . unUnqualComponentName +instance Parsec UnqualComponentName where + parsec = mkUnqualComponentName <$> parsecUnqualComponentName + instance Text UnqualComponentName where parse = mkUnqualComponentName <$> parsePackageName diff --git a/Cabal/Distribution/Utils/Generic.hs b/Cabal/Distribution/Utils/Generic.hs index 1fa362de05e..322d528fec8 100644 --- a/Cabal/Distribution/Utils/Generic.hs +++ b/Cabal/Distribution/Utils/Generic.hs @@ -351,10 +351,10 @@ unintersperse mark = unfoldr unintersperse1 where -- | Like 'break', but with 'Maybe' predicate -- --- >>> breakM (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"] --- (["foo","bar"],Just (1,["quu"])) +-- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"] +-- (["foo","bar"],Just (1,["2","quu"])) -- --- >>> breakM (readMaybe :: String -> Maybe Int) ["foo", "bar"] +-- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar"] -- (["foo","bar"],Nothing) -- -- @since 2.2 diff --git a/Cabal/Distribution/Version.hs b/Cabal/Distribution/Version.hs index 49225fa7dc3..8e81238458e 100644 --- a/Cabal/Distribution/Version.hs +++ b/Cabal/Distribution/Version.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -86,9 +87,11 @@ import qualified Data.Version as Base import Data.Bits (shiftL, shiftR, (.|.), (.&.)) import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP hiding (get) +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP hiding (get, many) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<+>)) @@ -163,6 +166,14 @@ instance Pretty Version where = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int $ versionNumbers ver)) +instance Parsec Version where + parsec = mkVersion <$> P.sepBy1 P.integral (P.char '.') <* tags + where + tags = do + ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) + case ts of + [] -> pure () + (_ : _) -> parsecWarning PWTVersionTag "version with tags" instance Text Version where parse = do @@ -1019,6 +1030,58 @@ instance Pretty VersionRange where punct p p' | p < p' = Disp.parens | otherwise = id +instance Parsec VersionRange where + parsec = normaliseVersionRange <$> expr + where + expr = do P.spaces + t <- term + P.spaces + (do _ <- P.string "||" + P.spaces + e <- expr + return (unionVersionRanges t e) + <|> + return t) + term = do f <- factor + P.spaces + (do _ <- P.string "&&" + P.spaces + t <- term + return (intersectVersionRanges f t) + <|> + return f) + factor = P.choice + $ parens expr + : parseAnyVersion + : parseNoVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = P.string "-any" >> return anyVersion + parseNoVersion = P.string "-none" >> return noVersion + + parseWildcardRange = P.try $ do + _ <- P.string "==" + P.spaces + branch <- some (P.integral <* P.char '.') + _ <- P.char '*' + return (withinVersion (mkVersion branch)) + + parens p = P.between + (P.char '(' >> P.spaces) + (P.char ')' >> P.spaces) + (do a <- p + P.spaces + return (VersionRangeParens a)) + + -- TODO: make those non back-tracking + parseRangeOp (s,f) = P.try (P.string s *> P.spaces *> fmap f parsec) + rangeOps = [ ("<", earlierVersion), + ("<=", orEarlierVersion), + (">", laterVersion), + (">=", orLaterVersion), + ("^>=", majorBoundVersion), + ("==", thisVersion) ] + instance Text VersionRange where parse = normaliseVersionRange <$> expr where diff --git a/Cabal/Language/Haskell/Extension.hs b/Cabal/Language/Haskell/Extension.hs index 1062aca8d56..0603b2740fa 100644 --- a/Cabal/Language/Haskell/Extension.hs +++ b/Cabal/Language/Haskell/Extension.hs @@ -27,12 +27,15 @@ module Language.Haskell.Extension ( import Prelude () import Distribution.Compat.Prelude +import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) + +import Distribution.Parsec.Class import Distribution.Pretty import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp -import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) -- ------------------------------------------------------------ -- * Language @@ -66,6 +69,9 @@ instance Pretty Language where pretty (UnknownLanguage other) = Disp.text other pretty other = Disp.text (show other) +instance Parsec Language where + parsec = classifyLanguage <$> P.munch1 isAlphaNum + instance Text Language where parse = do lang <- Parse.munch1 isAlphaNum @@ -818,6 +824,9 @@ instance Pretty Extension where pretty (EnableExtension ke) = Disp.text (show ke) pretty (DisableExtension ke) = Disp.text ("No" ++ show ke) +instance Parsec Extension where + parsec = classifyExtension <$> P.munch1 isAlphaNum + instance Text Extension where parse = do extension <- Parse.munch1 isAlphaNum diff --git a/Cabal/tests/CheckTests.hs b/Cabal/tests/CheckTests.hs index 7151666057c..0d06aad0e36 100644 --- a/Cabal/tests/CheckTests.hs +++ b/Cabal/tests/CheckTests.hs @@ -5,14 +5,14 @@ module Main import Test.Tasty import Test.Tasty.Golden.Advanced (goldenTest) +import Data.Algorithm.Diff (Diff (..), getGroupedDiff) +import Distribution.PackageDescription.Check (checkPackage) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) -import Distribution.PackageDescription.Check (checkPackage) -import Distribution.Parsec.Types.ParseResult (runParseResult) -import Distribution.Utils.Generic (toUTF8BS, fromUTF8BS) -import System.FilePath ((), replaceExtension) -import Data.Algorithm.Diff (Diff (..), getGroupedDiff) +import Distribution.Parsec.ParseResult (runParseResult) +import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) +import System.FilePath (replaceExtension, ()) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 tests :: TestTree diff --git a/Cabal/tests/ParserHackageTests.hs b/Cabal/tests/ParserHackageTests.hs index 68b24f4cea1..ba342459dd9 100644 --- a/Cabal/tests/ParserHackageTests.hs +++ b/Cabal/tests/ParserHackageTests.hs @@ -1,24 +1,25 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} module Main where import Prelude () import Prelude.Compat -import Control.Monad (when, unless) -import Data.Foldable - (for_, traverse_) -import Data.List (isPrefixOf, isSuffixOf) -import Data.Maybe (mapMaybe) -import Data.Monoid (Sum (..)) -import Distribution.Simple.Utils (fromUTF8LBS, ignoreBOM) -import System.Directory - (getAppUserDataDirectory) -import System.Environment (getArgs) -import System.Exit (exitFailure) -import System.FilePath (()) - -import Data.Orphans () +import Control.Monad (unless, when) +import Data.Foldable (for_, traverse_) +import Data.List (isPrefixOf, isSuffixOf, sort) +import Data.Maybe (mapMaybe) +import Data.Monoid (Sum (..)) +import Data.String (fromString) +import Distribution.License (License (..)) +import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) +import Distribution.Simple.Utils (fromUTF8LBS, ignoreBOM, toUTF8BS) +import System.Directory (getAppUserDataDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.FilePath (()) + +import Data.Orphans () import qualified Codec.Archive.Tar as Tar import qualified Data.ByteString as B @@ -27,18 +28,21 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.Map as Map import qualified Distribution.PackageDescription.Parse as ReadP import qualified Distribution.PackageDescription.Parsec as Parsec +import qualified Distribution.Parsec.Common as Parsec import qualified Distribution.Parsec.Parser as Parsec -import qualified Distribution.Parsec.Types.Common as Parsec import qualified Distribution.ParseUtils as ReadP import Distribution.Compat.Lens -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.Executable.Lens as L +import qualified Distribution.Types.GenericPackageDescription.Lens as L +import qualified Distribution.Types.Library.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Distribution.Types.SourceRepo.Lens as L #ifdef HAS_STRUCT_DIFF -import DiffInstances () -import StructDiff +import DiffInstances () +import StructDiff #endif parseIndex :: Monoid a => (FilePath -> BSL.ByteString -> IO a) -> IO a @@ -102,15 +106,28 @@ compareTest pfx fpath bsl traverse_ (putStrLn . Parsec.showPError fpath) errors parsec <- maybe (print readp >> exitFailure) return parsec' + let patchLocation (Just "") = Nothing + patchLocation x = x + -- Old parser is broken for many descriptions, and other free text fields let readp0 = readp & L.packageDescription . L.description .~ "" & L.packageDescription . L.synopsis .~ "" & L.packageDescription . L.maintainer .~ "" + -- ReadP parses @location:@ as @repoLocation = Just ""@ + & L.packageDescription . L.sourceRepos . traverse . L.repoLocation %~ patchLocation + & L.condExecutables . traverse . _2 . traverse . L.exeName .~ fromString "" + -- custom fields: no order + & L.buildInfos . L.customFieldsBI %~ sort let parsec0 = parsec & L.packageDescription . L.description .~ "" & L.packageDescription . L.synopsis .~ "" & L.packageDescription . L.maintainer .~ "" + -- ReadP doesn't (always) parse sublibrary or executable names + & L.condSubLibraries . traverse . _2 . traverse . L.libName .~ Nothing + & L.condExecutables . traverse . _2 . traverse . L.exeName .~ fromString "" + -- custom fields: no order. TODO: see if we can preserve it. + & L.buildInfos . L.customFieldsBI %~ sort -- hs-source-dirs ".", old parser broken -- See e.g. http://hackage.haskell.org/package/hledger-ui-0.27/hledger-ui.cabal executable @@ -166,6 +183,54 @@ parseParsecTest _ fpath bsl = do traverse_ (putStrLn . Parsec.showPError fpath) errors exitFailure +roundtripTest :: String -> FilePath -> BSL.ByteString -> IO (Sum Int) +roundtripTest pfx fpath _ | not (pfx `isPrefixOf` fpath) = return (Sum 0) +roundtripTest _ fpath bsl = do + let bs = bslToStrict bsl + x0 <- parse "1st" bs + let bs' = showGenericPackageDescription x0 + y0 <- parse "2nd" (toUTF8BS bs') + + -- unspecified license + let y1 = if x0 ^. L.packageDescription . L.license == UnspecifiedLicense + && y0 ^. L.packageDescription . L.license == UnknownLicense "UnspecifiedLicense" + then y0 & L.packageDescription . L.license .~ UnspecifiedLicense + else y0 + + -- license-files: "" + let stripEmpty = filter (/="") + let x1 = x0 & L.packageDescription . L.licenseFiles %~ stripEmpty + let y2 = y1 & L.packageDescription . L.licenseFiles %~ stripEmpty + + let y = y2 & L.packageDescription . L.description .~ "" + let x = x1 & L.packageDescription . L.description .~ "" + + unless (x == y || fpath == "ixset/1.0.4/ixset.cabal") $ do + putStrLn fpath +#if HAS_STRUCT_DIFF + prettyResultIO $ diff x y +#else + putStrLn "<<<<<<" + print x + putStrLn "======" + print y + putStrLn ">>>>>>" + +#endif + putStrLn bs' + exitFailure + + return (Sum 1) + where + parse phase c = do + let (_, errs, x') = Parsec.runParseResult $ Parsec.parseGenericPackageDescription c + case x' of + Just gpd | null errs -> pure gpd + _ -> do + putStrLn $ fpath ++ " " ++ phase + traverse_ print errs + B.putStr c + fail "parse error" main :: IO () main = do args <- getArgs @@ -178,6 +243,12 @@ main = do ["parse-parsec", pfx] -> do Sum n <- parseIndex (parseParsecTest pfx) putStrLn $ show n ++ " files processed" + ["roundtrip"] -> do + Sum n <- parseIndex (roundtripTest "") + putStrLn $ show n ++ " files processed" + ["roundtrip", pfx] -> do + Sum n <- parseIndex (roundtripTest pfx) + putStrLn $ show n ++ " files processed" [pfx] -> defaultMain pfx _ -> defaultMain "" where diff --git a/Cabal/tests/ParserTests.hs b/Cabal/tests/ParserTests.hs index b277bc0f26f..2a79efefdfd 100644 --- a/Cabal/tests/ParserTests.hs +++ b/Cabal/tests/ParserTests.hs @@ -3,21 +3,27 @@ module Main ) where import Test.Tasty -import Test.Tasty.HUnit import Test.Tasty.Golden.Advanced (goldenTest) +import Test.Tasty.HUnit -import Data.Maybe (isJust) -import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Data.Algorithm.Diff (Diff (..), getGroupedDiff) +import Data.Maybe (isJust) +import Distribution.License (License (..)) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) -import Distribution.Parsec.Types.Common (PWarnType (..), PWarning (..)) -import Distribution.Parsec.Types.ParseResult (runParseResult) -import Distribution.Utils.Generic (toUTF8BS, fromUTF8BS) -import System.FilePath ((), replaceExtension) -import Data.Algorithm.Diff (Diff (..), getGroupedDiff) +import Distribution.Parsec.Common (PWarnType (..), PWarning (..)) +import Distribution.Parsec.ParseResult (runParseResult) +import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) +import System.FilePath (replaceExtension, ()) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 +import Distribution.Compat.Lens +import qualified Distribution.Types.GenericPackageDescription.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L + tests :: TestTree tests = testGroup "parsec tests" [ warningTests @@ -50,6 +56,7 @@ warningTests = testGroup "warnings triggered" warningTest :: PWarnType -> FilePath -> TestTree warningTest wt fp = testCase (show wt) $ do contents <- BS.readFile $ "tests" "ParserTests" "warnings" fp + let res = parseGenericPackageDescription contents let (warns, errs, x) = runParseResult res @@ -71,10 +78,19 @@ regressionTests = testGroup "regressions" , regressionTest "Octree-0.5.cabal" , regressionTest "nothing-unicode.cabal" , regressionTest "issue-774.cabal" + , regressionTest "generics-sop.cabal" + , regressionTest "elif.cabal" + , regressionTest "shake.cabal" ] regressionTest :: FilePath -> TestTree -regressionTest fp = cabalGoldenTest fp correct $ do +regressionTest fp = testGroup fp + [ formatGoldenTest fp + , formatRoundTripTest fp + ] + +formatGoldenTest :: FilePath -> TestTree +formatGoldenTest fp = cabalGoldenTest "format" correct $ do contents <- BS.readFile input let res = parseGenericPackageDescription contents let (_, errs, x) = runParseResult res @@ -88,6 +104,28 @@ regressionTest fp = cabalGoldenTest fp correct $ do input = "tests" "ParserTests" "regressions" fp correct = replaceExtension input "format" +formatRoundTripTest :: FilePath -> TestTree +formatRoundTripTest fp = testCase "roundtrip" $ do + contents <- BS.readFile input + x <- parse contents + let contents' = showGenericPackageDescription x + y <- parse (toUTF8BS contents') + let y' = if x ^. L.packageDescription . L.license == UnspecifiedLicense + && y ^. L.packageDescription . L.license == UnknownLicense "UnspecifiedLicense" + then y & L.packageDescription . L.license .~ UnspecifiedLicense + else y + assertEqual "re-parsed doesn't match" x y' + where + parse :: BS.ByteString -> IO GenericPackageDescription + parse c = do + let (_, errs, x') = runParseResult $ parseGenericPackageDescription c + case x' of + Just gpd | null errs -> return gpd + _ -> do + assertFailure $ unlines (map show errs) + fail "failure" + input = "tests" "ParserTests" "regressions" fp + ------------------------------------------------------------------------------- -- Main ------------------------------------------------------------------------------- diff --git a/Cabal/tests/ParserTests/regressions/Octree-0.5.format b/Cabal/tests/ParserTests/regressions/Octree-0.5.format index b6c496f3851..61d1ccedee0 100644 --- a/Cabal/tests/ParserTests/regressions/Octree-0.5.format +++ b/Cabal/tests/ParserTests/regressions/Octree-0.5.format @@ -1,12 +1,12 @@ name: Octree version: 0.5 -cabal-version: >=1.8 -build-type: Simple license: BSD3 license-file: LICENSE copyright: Copyright by Michal J. Gajda '2012 maintainer: mjgajda@googlemail.com +author: Michal J. Gajda stability: beta +tested-with: ghc ==7.0.4 ghc ==7.4.1 ghc ==7.4.2 ghc ==7.6.0 homepage: https://github.com/mgajda/octree package-url: http://hackage.haskell.org/package/octree bug-reports: mailto:mjgajda@googlemail.com @@ -14,8 +14,8 @@ synopsis: Simple unbalanced Octree for storing data about 3D points description: Octree data structure is relatively shallow data structure for space partitioning. category: Data -author: Michal J. Gajda -tested-with: GHC ==7.0.4 GHC ==7.4.1 GHC ==7.4.2 GHC ==7.6.0 +cabal-version: >=1.8 +build-type: Simple source-repository head type: git @@ -24,27 +24,28 @@ source-repository head library exposed-modules: Data.Octree + other-modules: + Data.Octree.Internal + extensions: ScopedTypeVariables build-depends: base >=4.0 && <4.7, AC-Vector >=2.3.0, QuickCheck >=2.4.0 - extensions: ScopedTypeVariables - other-modules: - Data.Octree.Internal -test-suite test_Octree +test-suite test_Octree type: exitcode-stdio-1.0 main-is: tests/test_Octree.hs build-depends: base >=4.0 && <4.7, AC-Vector >=2.3.0, QuickCheck >=2.4.0 -test-suite readme + +test-suite readme type: exitcode-stdio-1.0 main-is: README.lhs + ghc-options: -pgmL markdown-unlit build-depends: base >=4.0 && <4.7, AC-Vector >=2.3.0, QuickCheck >=2.4.0, - markdown-unlit -any - ghc-options: -pgmL markdown-unlit + markdown-unlit -any \ No newline at end of file diff --git a/Cabal/tests/ParserTests/regressions/elif.cabal b/Cabal/tests/ParserTests/regressions/elif.cabal new file mode 100644 index 00000000000..2d760681842 --- /dev/null +++ b/Cabal/tests/ParserTests/regressions/elif.cabal @@ -0,0 +1,20 @@ +name: elif +version: 0 +synopsis: The elif demo +build-type: Simple +cabal-version: >=1.10 + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +library + default-language: Haskell2010 + exposed-modules: ElseIf + + if os(linux) + build-depends: unix + elif os(windows) + build-depends: Win32 + else + buildable: False diff --git a/Cabal/tests/ParserTests/regressions/elif.format b/Cabal/tests/ParserTests/regressions/elif.format new file mode 100644 index 00000000000..9f53ec5634c --- /dev/null +++ b/Cabal/tests/ParserTests/regressions/elif.format @@ -0,0 +1,18 @@ +name: elif +version: 0 +synopsis: The elif demo +cabal-version: >=1.10 +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: + ElseIf + default-language: Haskell2010 + + if os(linux) + build-depends: + unix -any \ No newline at end of file diff --git a/Cabal/tests/ParserTests/regressions/encoding-0.8.cabal b/Cabal/tests/ParserTests/regressions/encoding-0.8.cabal index 47c23a78007..6139c31e368 100644 --- a/Cabal/tests/ParserTests/regressions/encoding-0.8.cabal +++ b/Cabal/tests/ParserTests/regressions/encoding-0.8.cabal @@ -1,12 +1,17 @@ -Name: encoding -Version: 0.8 - -custom-setup -  setup-depends: - base < 5, -    ghc-prim - -Library - build-depends: base - Exposed-Modules: - Data.Encoding +Name: encoding +Version: 0.8 + +custom-setup +  setup-depends: + base < 5, +    ghc-prim + +Library + -- version range round trip is not perfect + build-depends: base (> 4.4 || == 4.4) + + Exposed-Modules: + Data.Encoding + + -- options with spaces + GHC-Options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N1 -A64m" diff --git a/Cabal/tests/ParserTests/regressions/encoding-0.8.format b/Cabal/tests/ParserTests/regressions/encoding-0.8.format index b44ad59c425..fcaeaa5b539 100644 --- a/Cabal/tests/ParserTests/regressions/encoding-0.8.format +++ b/Cabal/tests/ParserTests/regressions/encoding-0.8.format @@ -1,11 +1,13 @@ name: encoding version: 0.8 -cabal-version: -any -license: UnspecifiedLicense + +custom-setup + setup-depends: base <5, + ghc-prim -any library exposed-modules: Data.Encoding + ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N1 -A64m" build-depends: - base -any - + base >=4.4 \ No newline at end of file diff --git a/Cabal/tests/ParserTests/regressions/generics-sop.cabal b/Cabal/tests/ParserTests/regressions/generics-sop.cabal new file mode 100644 index 00000000000..e8932980912 --- /dev/null +++ b/Cabal/tests/ParserTests/regressions/generics-sop.cabal @@ -0,0 +1,128 @@ +name: generics-sop +version: 0.3.1.0 +synopsis: Generic Programming using True Sums of Products +description: + A library to support the definition of generic functions. + Datatypes are viewed in a uniform, structured way: + the choice between constructors is represented using an n-ary + sum, and the arguments of each constructor are represented using + an n-ary product. + . + The module "Generics.SOP" is the main module of this library and contains + more detailed documentation. + . + Examples of using this library are provided by the following + packages: + . + * @@ basic examples, + . + * @@ generic pretty printing, + . + * @@ generically computed lenses, + . + * @@ generic JSON conversions. + . + A detailed description of the ideas behind this library is provided by + the paper: + . + * Edsko de Vries and Andres Löh. + . + Workshop on Generic Programming (WGP) 2014. + . +license: BSD3 +license-file: LICENSE +author: Edsko de Vries , Andres Löh +maintainer: andres@well-typed.com +category: Generics +build-type: Custom +cabal-version: >=1.10 +extra-source-files: CHANGELOG.md +tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.3.* + +custom-setup + setup-depends: + base, + Cabal, + cabal-doctest >= 1.0.2 && <1.1 + +source-repository head + type: git + location: https://github.com/well-typed/generics-sop + +library + exposed-modules: Generics.SOP + Generics.SOP.GGP + Generics.SOP.TH + Generics.SOP.Dict + Generics.SOP.Type.Metadata + -- exposed via Generics.SOP: + Generics.SOP.BasicFunctors + Generics.SOP.Classes + Generics.SOP.Constraint + Generics.SOP.Instances + Generics.SOP.Metadata + Generics.SOP.NP + Generics.SOP.NS + Generics.SOP.Universe + Generics.SOP.Sing + build-depends: base >= 4.7 && < 5, + template-haskell >= 2.8 && < 2.13, + ghc-prim >= 0.3 && < 0.6, + deepseq >= 1.3 && < 1.5 + if !impl (ghc >= 7.8) + build-depends: tagged >= 0.7 && < 0.9 + if !impl (ghc >= 8.0) + build-depends: transformers-compat >= 0.3 && < 0.6, + transformers >= 0.3 && < 0.6 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + default-extensions: CPP + ScopedTypeVariables + TypeFamilies + RankNTypes + TypeOperators + GADTs + ConstraintKinds + MultiParamTypeClasses + TypeSynonymInstances + FlexibleInstances + FlexibleContexts + DeriveFunctor + DeriveFoldable + DeriveTraversable + DefaultSignatures + KindSignatures + DataKinds + FunctionalDependencies + if impl (ghc >= 7.8) + default-extensions: AutoDeriveTypeable + other-extensions: OverloadedStrings + PolyKinds + UndecidableInstances + TemplateHaskell + DeriveGeneric + StandaloneDeriving + if impl (ghc < 7.10) + other-extensions: OverlappingInstances + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + x-doctest-options: --preserve-it + hs-source-dirs: test + default-language: Haskell2010 + build-depends: base, + doctest >= 0.13 && <0.14 + ghc-options: -Wall -threaded + +test-suite generics-sop-examples + type: exitcode-stdio-1.0 + main-is: Example.hs + other-modules: HTransExample + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: base >= 4.6 && < 5, + generics-sop diff --git a/Cabal/tests/ParserTests/regressions/generics-sop.format b/Cabal/tests/ParserTests/regressions/generics-sop.format new file mode 100644 index 00000000000..509101b988b --- /dev/null +++ b/Cabal/tests/ParserTests/regressions/generics-sop.format @@ -0,0 +1,121 @@ +name: generics-sop +version: 0.3.1.0 +license: BSD3 +license-file: LICENSE +maintainer: andres@well-typed.com +author: Edsko de Vries , Andres Löh +tested-with: ghc ==7.8.4 ghc ==7.10.3 ghc ==8.0.1 ghc ==8.0.2 + ghc ==8.2.1 ghc ==8.3.* +synopsis: Generic Programming using True Sums of Products +description: + A library to support the definition of generic functions. + Datatypes are viewed in a uniform, structured way: + the choice between constructors is represented using an n-ary + sum, and the arguments of each constructor are represented using + an n-ary product. + . + The module "Generics.SOP" is the main module of this library and contains + more detailed documentation. + . + Examples of using this library are provided by the following + packages: + . + * @@ basic examples, + . + * @@ generic pretty printing, + . + * @@ generically computed lenses, + . + * @@ generic JSON conversions. + . + A detailed description of the ideas behind this library is provided by + the paper: + . + * Edsko de Vries and Andres Löh. + . + Workshop on Generic Programming (WGP) 2014. + . +category: Generics +cabal-version: >=1.10 +build-type: Custom +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/well-typed/generics-sop + +custom-setup + setup-depends: base -any, + Cabal -any, + cabal-doctest >=1.0.2 && <1.1 + +library + exposed-modules: + Generics.SOP + Generics.SOP.GGP + Generics.SOP.TH + Generics.SOP.Dict + Generics.SOP.Type.Metadata + Generics.SOP.BasicFunctors + Generics.SOP.Classes + Generics.SOP.Constraint + Generics.SOP.Instances + Generics.SOP.Metadata + Generics.SOP.NP + Generics.SOP.NS + Generics.SOP.Universe + Generics.SOP.Sing + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: CPP ScopedTypeVariables TypeFamilies RankNTypes + TypeOperators GADTs ConstraintKinds MultiParamTypeClasses + TypeSynonymInstances FlexibleInstances FlexibleContexts + DeriveFunctor DeriveFoldable DeriveTraversable DefaultSignatures + KindSignatures DataKinds FunctionalDependencies + other-extensions: OverloadedStrings PolyKinds UndecidableInstances + TemplateHaskell DeriveGeneric StandaloneDeriving + ghc-options: -Wall + build-depends: + base >=4.7 && <5, + template-haskell >=2.8 && <2.13, + ghc-prim >=0.3 && <0.6, + deepseq >=1.3 && <1.5 + + if !impl(ghc >=7.8) + build-depends: + tagged >=0.7 && <0.9 + + if !impl(ghc >=8.0) + build-depends: + transformers-compat >=0.3 && <0.6, + transformers >=0.3 && <0.6 + + if impl(ghc >=7.8) + default-extensions: AutoDeriveTypeable + + if impl(ghc <7.10) + other-extensions: OverlappingInstances + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -threaded + x-doctest-options: --preserve-it + build-depends: + base -any, + doctest >=0.13 && <0.14 + +test-suite generics-sop-examples + type: exitcode-stdio-1.0 + main-is: Example.hs + hs-source-dirs: test + other-modules: + HTransExample + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.6 && <5, + generics-sop -any \ No newline at end of file diff --git a/Cabal/tests/ParserTests/regressions/issue-774.format b/Cabal/tests/ParserTests/regressions/issue-774.format index e1b063f3e74..1e37c9c5f86 100644 --- a/Cabal/tests/ParserTests/regressions/issue-774.format +++ b/Cabal/tests/ParserTests/regressions/issue-774.format @@ -1,8 +1,5 @@ name: issue version: 744 -cabal-version: >=1.10 -build-type: Simple -license: UnspecifiedLicense synopsis: Package description parser interprets curly braces in the description field description: Here is some C code: @@ -12,9 +9,10 @@ description: > } . What does it look like? +cabal-version: >=1.10 +build-type: Simple library exposed-modules: Issue - default-language: Haskell2010 - + default-language: Haskell2010 \ No newline at end of file diff --git a/Cabal/tests/ParserTests/regressions/nothing-unicode.format b/Cabal/tests/ParserTests/regressions/nothing-unicode.format index fa158642e26..ca6e6618cd6 100644 --- a/Cabal/tests/ParserTests/regressions/nothing-unicode.format +++ b/Cabal/tests/ParserTests/regressions/nothing-unicode.format @@ -1,10 +1,9 @@ name: 無 version: 0 -cabal-version: >=1.10 -build-type: Simple -license: UnspecifiedLicense synopsis: The canonical non-package 無 x-無: 無 +cabal-version: >=1.10 +build-type: Simple source-repository head type: git @@ -15,10 +14,9 @@ flag 無 無 library - - if !flag(無) - buildable: False exposed-modules: Ω default-language: Haskell2010 - + + if !flag(無) + buildable: False \ No newline at end of file diff --git a/Cabal/tests/ParserTests/regressions/shake.cabal b/Cabal/tests/ParserTests/regressions/shake.cabal new file mode 100644 index 00000000000..6bffd2c4953 --- /dev/null +++ b/Cabal/tests/ParserTests/regressions/shake.cabal @@ -0,0 +1,402 @@ +cabal-version: >= 1.18 +build-type: Simple +name: shake +version: 0.15.11 +license: BSD3 +license-file: LICENSE +category: Development, Shake +author: Neil Mitchell +maintainer: Neil Mitchell +copyright: Neil Mitchell 2011-2017 +synopsis: Build system library, like Make, but more accurate dependencies. +description: + Shake is a Haskell library for writing build systems - designed as a + replacement for @make@. See "Development.Shake" for an introduction, + including an example. Further examples are included in the Cabal tarball, + under the @Examples@ directory. The homepage contains links to a user + manual, an academic paper and further information: + + . + To use Shake the user writes a Haskell program + that imports "Development.Shake", defines some build rules, and calls + the 'Development.Shake.shakeArgs' function. Thanks to do notation and infix + operators, a simple Shake build system + is not too dissimilar from a simple Makefile. However, as build systems + get more complex, Shake is able to take advantage of the excellent + abstraction facilities offered by Haskell and easily support much larger + projects. The Shake library provides all the standard features available in other + build systems, including automatic parallelism and minimal rebuilds. + Shake also provides more accurate dependency tracking, including seamless + support for generated files, and dependencies on system information + (e.g. compiler version). +homepage: http://shakebuild.com +bug-reports: https://github.com/ndmitchell/shake/issues +tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +extra-doc-files: + CHANGES.txt + README.md +extra-source-files: + src/Test/C/constants.c + src/Test/C/constants.h + src/Test/C/main.c + src/Test/MakeTutor/Makefile + src/Test/MakeTutor/hellofunc.c + src/Test/MakeTutor/hellomake.c + src/Test/MakeTutor/hellomake.h + src/Test/Tar/list.txt + src/Test/Ninja/*.ninja + src/Test/Ninja/subdir/*.ninja + src/Test/Ninja/*.output + src/Test/Progress/*.prog + src/Test/Tup/hello.c + src/Test/Tup/root.cfg + src/Test/Tup/newmath/root.cfg + src/Test/Tup/newmath/square.c + src/Test/Tup/newmath/square.h + src/Paths.hs + docs/Manual.md + docs/shake-progress.png + +data-files: + html/viz.js + html/profile.html + html/progress.html + html/shake.js + docs/manual/build.bat + docs/manual/Build.hs + docs/manual/build.sh + docs/manual/constants.c + docs/manual/constants.h + docs/manual/main.c + +source-repository head + type: git + location: https://github.com/ndmitchell/shake.git + +flag portable + default: False + manual: True + description: Obtain FileTime using portable functions + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: + base >= 4.5, + directory, + hashable >= 1.1.2.3, + binary, + filepath, + process >= 1.1, + unordered-containers >= 0.2.1, + bytestring, + utf8-string >= 0.3, + time, + random, + js-jquery, + js-flot, + transformers >= 0.2, + extra >= 1.4.8, + deepseq >= 1.1 + + if flag(portable) + cpp-options: -DPORTABLE + if impl(ghc < 7.6) + build-depends: old-time + else + if !os(windows) + build-depends: unix >= 2.5.1 + if !os(windows) + build-depends: unix + + exposed-modules: + Development.Shake + Development.Shake.Classes + Development.Shake.Command + Development.Shake.Config + Development.Shake.FilePath + Development.Shake.Forward + Development.Shake.Rule + Development.Shake.Util + + other-modules: + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Core + Development.Shake.CmdOption + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePattern + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + + +executable shake + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -main-is Run.main + main-is: Run.hs + ghc-options: -rtsopts + -- GHC bug 7646 means -threaded causes errors + if impl(ghc >= 7.8) + ghc-options: -threaded "-with-rtsopts=-I0 -qg -qb" + build-depends: + base == 4.*, + directory, + hashable >= 1.1.2.3, + binary, + filepath, + process >= 1.1, + unordered-containers >= 0.2.1, + bytestring, + utf8-string >= 0.3, + time, + random, + js-jquery, + js-flot, + transformers >= 0.2, + extra >= 1.4.8, + deepseq >= 1.1, + primitive + + if flag(portable) + cpp-options: -DPORTABLE + if impl(ghc < 7.6) + build-depends: old-time + else + if !os(windows) + build-depends: unix >= 2.5.1 + if !os(windows) + build-depends: unix + + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + + +test-suite shake-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: src + + ghc-options: -main-is Test.main -rtsopts + if impl(ghc >= 7.6) + -- space leak introduced by -O1 in 7.4, see #445 + ghc-options: -with-rtsopts=-K1K + if impl(ghc >= 7.8) + -- GHC bug 7646 (fixed in 7.8) means -threaded causes errors + ghc-options: -threaded + + build-depends: + base == 4.*, + directory, + hashable >= 1.1.2.3, + binary, + filepath, + process >= 1.1, + unordered-containers >= 0.2.1, + bytestring, + utf8-string >= 0.3, + time, + random, + js-jquery, + js-flot, + transformers >= 0.2, + deepseq >= 1.1, + extra >= 1.4.8, + QuickCheck >= 2.0 + + if flag(portable) + cpp-options: -DPORTABLE + if impl(ghc < 7.6) + build-depends: old-time + else + if !os(windows) + build-depends: unix >= 2.5.1 + if !os(windows) + build-depends: unix + + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Config + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Util + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + Test.Assume + Test.Basic + Test.Benchmark + Test.C + Test.Cache + Test.Command + Test.Config + Test.Digest + Test.Directory + Test.Docs + Test.Errors + Test.FileLock + Test.FilePath + Test.FilePattern + Test.Files + Test.Forward + Test.Journal + Test.Lint + Test.Live + Test.Makefile + Test.Manual + Test.Match + Test.Monad + Test.Ninja + Test.Oracle + Test.OrderOnly + Test.Parallel + Test.Pool + Test.Progress + Test.Random + Test.Resources + Test.Self + Test.Tar + Test.Tup + Test.Type + Test.Unicode + Test.Util + Test.Verbosity + Test.Version diff --git a/Cabal/tests/ParserTests/regressions/shake.format b/Cabal/tests/ParserTests/regressions/shake.format new file mode 100644 index 00000000000..31336998156 --- /dev/null +++ b/Cabal/tests/ParserTests/regressions/shake.format @@ -0,0 +1,418 @@ +name: shake +version: 0.15.11 +license: BSD3 +license-file: LICENSE +copyright: Neil Mitchell 2011-2017 +maintainer: Neil Mitchell +author: Neil Mitchell +tested-with: ghc ==8.0.1 ghc ==7.10.3 ghc ==7.8.4 ghc ==7.6.3 + ghc ==7.4.2 +homepage: http://shakebuild.com +bug-reports: https://github.com/ndmitchell/shake/issues +synopsis: Build system library, like Make, but more accurate dependencies. +description: + Shake is a Haskell library for writing build systems - designed as a + replacement for @make@. See "Development.Shake" for an introduction, + including an example. Further examples are included in the Cabal tarball, + under the @Examples@ directory. The homepage contains links to a user + manual, an academic paper and further information: + + . + To use Shake the user writes a Haskell program + that imports "Development.Shake", defines some build rules, and calls + the 'Development.Shake.shakeArgs' function. Thanks to do notation and infix + operators, a simple Shake build system + is not too dissimilar from a simple Makefile. However, as build systems + get more complex, Shake is able to take advantage of the excellent + abstraction facilities offered by Haskell and easily support much larger + projects. The Shake library provides all the standard features available in other + build systems, including automatic parallelism and minimal rebuilds. + Shake also provides more accurate dependency tracking, including seamless + support for generated files, and dependencies on system information + (e.g. compiler version). +category: Development, Shake +cabal-version: >=1.18 +build-type: Simple +data-files: + html/viz.js + html/profile.html + html/progress.html + html/shake.js + docs/manual/build.bat + docs/manual/Build.hs + docs/manual/build.sh + docs/manual/constants.c + docs/manual/constants.h + docs/manual/main.c +extra-source-files: + src/Test/C/constants.c + src/Test/C/constants.h + src/Test/C/main.c + src/Test/MakeTutor/Makefile + src/Test/MakeTutor/hellofunc.c + src/Test/MakeTutor/hellomake.c + src/Test/MakeTutor/hellomake.h + src/Test/Tar/list.txt + src/Test/Ninja/*.ninja + src/Test/Ninja/subdir/*.ninja + src/Test/Ninja/*.output + src/Test/Progress/*.prog + src/Test/Tup/hello.c + src/Test/Tup/root.cfg + src/Test/Tup/newmath/root.cfg + src/Test/Tup/newmath/square.c + src/Test/Tup/newmath/square.h + src/Paths.hs + docs/Manual.md + docs/shake-progress.png +extra-doc-files: CHANGES.txt + README.md + +source-repository head + type: git + location: https://github.com/ndmitchell/shake.git + +flag portable + description: + Obtain FileTime using portable functions + default: False + manual: True + +library + exposed-modules: + Development.Shake + Development.Shake.Classes + Development.Shake.Command + Development.Shake.Config + Development.Shake.FilePath + Development.Shake.Forward + Development.Shake.Rule + Development.Shake.Util + hs-source-dirs: src + other-modules: + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Core + Development.Shake.CmdOption + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePattern + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + default-language: Haskell2010 + build-depends: + base >=4.5, + directory -any, + hashable >=1.1.2.3, + binary -any, + filepath -any, + process >=1.1, + unordered-containers >=0.2.1, + bytestring -any, + utf8-string >=0.3, + time -any, + random -any, + js-jquery -any, + js-flot -any, + transformers >=0.2, + extra >=1.4.8, + deepseq >=1.1 + + if flag(portable) + cpp-options: -DPORTABLE + + if impl(ghc <7.6) + build-depends: + old-time -any + else + + if !os(windows) + build-depends: + unix >=2.5.1 + + if !os(windows) + build-depends: + unix -any + +executable shake + main-is: Run.hs + scope: unknown + hs-source-dirs: src + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + default-language: Haskell2010 + ghc-options: -main-is Run.main -rtsopts + build-depends: + base ==4.*, + directory -any, + hashable >=1.1.2.3, + binary -any, + filepath -any, + process >=1.1, + unordered-containers >=0.2.1, + bytestring -any, + utf8-string >=0.3, + time -any, + random -any, + js-jquery -any, + js-flot -any, + transformers >=0.2, + extra >=1.4.8, + deepseq >=1.1, + primitive -any + + if impl(ghc >=7.8) + scope: unknown + ghc-options: -threaded "-with-rtsopts=-I0 -qg -qb" + + if flag(portable) + scope: unknown + cpp-options: -DPORTABLE + + if impl(ghc <7.6) + scope: unknown + build-depends: + old-time -any + else + scope: unknown + + if !os(windows) + scope: unknown + build-depends: + unix >=2.5.1 + + if !os(windows) + scope: unknown + build-depends: + unix -any + +test-suite shake-test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: src + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Config + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Util + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + Test.Assume + Test.Basic + Test.Benchmark + Test.C + Test.Cache + Test.Command + Test.Config + Test.Digest + Test.Directory + Test.Docs + Test.Errors + Test.FileLock + Test.FilePath + Test.FilePattern + Test.Files + Test.Forward + Test.Journal + Test.Lint + Test.Live + Test.Makefile + Test.Manual + Test.Match + Test.Monad + Test.Ninja + Test.Oracle + Test.OrderOnly + Test.Parallel + Test.Pool + Test.Progress + Test.Random + Test.Resources + Test.Self + Test.Tar + Test.Tup + Test.Type + Test.Unicode + Test.Util + Test.Verbosity + Test.Version + default-language: Haskell2010 + ghc-options: -main-is Test.main -rtsopts + build-depends: + base ==4.*, + directory -any, + hashable >=1.1.2.3, + binary -any, + filepath -any, + process >=1.1, + unordered-containers >=0.2.1, + bytestring -any, + utf8-string >=0.3, + time -any, + random -any, + js-jquery -any, + js-flot -any, + transformers >=0.2, + deepseq >=1.1, + extra >=1.4.8, + QuickCheck >=2.0 + + if impl(ghc >=7.6) + ghc-options: -with-rtsopts=-K1K + + if impl(ghc >=7.8) + ghc-options: -threaded + + if flag(portable) + cpp-options: -DPORTABLE + + if impl(ghc <7.6) + build-depends: + old-time -any + else + + if !os(windows) + build-depends: + unix >=2.5.1 + + if !os(windows) + build-depends: + unix -any \ No newline at end of file diff --git a/Cabal/tests/StructDiff.hs b/Cabal/tests/StructDiff.hs index 688deadbefa..c2d3a699c6b 100644 --- a/Cabal/tests/StructDiff.hs +++ b/Cabal/tests/StructDiff.hs @@ -37,7 +37,7 @@ import Data.Monoid (Monoid (..), (<>)) import Data.Singletons.Bool (SBool (..), SBoolI (..), eqToRefl) import Data.These (These (..)) import Data.Type.Equality -import Generics.SOP +import Generics.SOP hiding (fieldName) -- | Because @'Data.Proxy.Proxy' :: 'Data.Proxy.Proxy' a@ is so long. data P a = P @@ -141,9 +141,7 @@ instance (Ord k, Show k, Diff v, Show v) => Diff (Map k v) where diff = alignDif constructorNameOf :: NP ConstructorInfo xss -> NS f xss -> ConstructorName constructorNameOf (c :* _) (Z _) = constructorName c constructorNameOf (_ :* cs) (S xs) = constructorNameOf cs xs -#if __GLASGOW_HASKELL__ < 800 constructorNameOf _ _ = error "Should never happen" -#endif -- | This is a little lie. fieldNames :: ConstructorInfo xs -> NP (K FieldName) xs diff --git a/boot/Lexer.x b/boot/Lexer.x index 9584591eb96..9c6738d1d5c 100644 --- a/boot/Lexer.x +++ b/boot/Lexer.x @@ -36,7 +36,7 @@ import qualified Prelude as Prelude import Distribution.Compat.Prelude import Distribution.Parsec.LexerMonad -import Distribution.Parsec.Types.Common (Position (..), incPos, retPos) +import Distribution.Parsec.Common (Position (..), incPos, retPos) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B.Char8 diff --git a/cabal-testsuite/Test/Cabal/Prelude.hs b/cabal-testsuite/Test/Cabal/Prelude.hs index c9be22983e9..c12a0996e55 100644 --- a/cabal-testsuite/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/Test/Cabal/Prelude.hs @@ -35,7 +35,7 @@ import Distribution.Package import Distribution.Types.UnqualComponentName import Distribution.Types.LocalBuildInfo import Distribution.PackageDescription -import Distribution.PackageDescription.Parse +import Distribution.PackageDescription.Parsec import Distribution.Compat.Stack diff --git a/stack.yaml b/stack.yaml index bcaa817ebf7..aaa3a70c9aa 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-9.0 +resolver: nightly-2017-09-01 packages: - Cabal/ - cabal-install/