Skip to content

Commit

Permalink
WIP
Browse files Browse the repository at this point in the history
- Parse custom-setup. Fixes haskell#4697
- Rename PPP to FieldGrammar. Flatten D.PackageDescription namespace
- Add booleanFieldDef, flagFieldGrammar
- Correct FreeText parsec
- WIP: FieldGrammar BuildInfo and Library
- More newtypes
- Unknown and deprecated fields
- NoCommaFSep
- extra-libraries
- Parse 'else'
- WIP
- More BuildInfo opts
- ReadP parses 'location:\n' as location = Just ""
- Known fields
- monoidalField
- ^^^ operator
- RFC: Add elif
- Make FieldGrammar into a type class
- Parse sublibraries with FieldGrammar
- Use prettyFieldGrammar for library sections
- executableFieldGrammar
- ForeignLib grammar
- PackageDescription grammar
- Remove unused imports
- shake regression
- Update extra-source-files
- TestSuite & Benchmark grammars
- Change readp license-files setter
- Add hiddenField
- Add GPD parse . pretty roundtrip tests. Fixes haskell#4719
- Roundtrip hackage tests
- Roundtrip fixes
- More pretty-printing fixes
- More pp fixes
  • Loading branch information
phadej committed Sep 3, 2017
1 parent 00a675d commit f6a842f
Show file tree
Hide file tree
Showing 77 changed files with 3,521 additions and 1,983 deletions.
22 changes: 15 additions & 7 deletions Cabal/Cabal.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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:
Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -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
Expand Down
4 changes: 4 additions & 0 deletions Cabal/Distribution/Compat/Parsec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@ module Distribution.Compat.Parsec (
P.satisfy,
P.space,
P.spaces,
skipSpaces1,
P.string,
munch,
munch1,
Expand Down Expand Up @@ -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
21 changes: 20 additions & 1 deletion Cabal/Distribution/Compat/ReadP.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 +++, <++

-- ---------------------------------------------------------------------------
Expand Down Expand Up @@ -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 "<parsecToReadP>" s of
Right (x, s') -> final (run (k x) s')
Left _ -> Fail
21 changes: 16 additions & 5 deletions Cabal/Distribution/Compiler.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand All @@ -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
Expand Down
141 changes: 141 additions & 0 deletions Cabal/Distribution/FieldGrammar.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,141 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module provides one way to specify 'FieldGrammar',
-- to parse lists of 'Field' and pretty print the structures.
--
-- 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 non important. (The only exception is @hs-source-dirs@ and
-- @hs-source-dir@, but it can be fixed with preprocessing).
--
-- 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 (
-- * Field grammar type
FieldGrammar (..),
uniqueField,
optionalField,
optionalFieldDef,
optionalFieldDefAla,
monoidalField,
deprecatedField',
-- * Concrete grammar implementations
ParsecFieldGrammar,
ParsecFieldGrammar',
parseFieldGrammar,
fieldGrammarKnownFieldList,
PrettyFieldGrammar,
PrettyFieldGrammar',
prettyFieldGrammar,
-- * Auxlilary
(^^^),
Section(..),
partitionFields,
takeFields,
) 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

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

spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a])
spanMaybe _ xs@[] = ([], xs)
spanMaybe p xs@(x:xs') = case p x of
Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs)
Nothing -> ([], xs)
Loading

0 comments on commit f6a842f

Please sign in to comment.