Commit 6f0399ed authored by Rob Henderson's avatar Rob Henderson Committed by GitHub
Browse files

Merge pull request #4211 from robjhen/issue-3502

Preliminary refactoring in preparation for issue #3502
parents c6928316 1b5e83d1
......@@ -44,6 +44,7 @@ module Distribution.Compat.ReadP
munch, -- :: (Char -> Bool) -> ReadP String
munch1, -- :: (Char -> Bool) -> ReadP String
skipSpaces, -- :: ReadP ()
skipSpaces1,-- :: ReadP ()
choice, -- :: [ReadP a] -> ReadP a
count, -- :: Int -> ReadP a -> ReadP [a]
between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
......@@ -297,6 +298,11 @@ skipSpaces =
skip (c:s) | isSpace c = do _ <- get; skip s
skip _ = do return ()
skipSpaces1 :: ReadP r ()
-- ^ Like 'skipSpaces' but succeeds only if there is at least one
-- whitespace character to skip.
skipSpaces1 = satisfy isSpace >> skipSpaces
count :: Int -> ReadP r a -> ReadP r [a]
-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of
-- results is returned.
......
......@@ -93,6 +93,8 @@ module Distribution.PackageDescription (
Flag(..), emptyFlag,
FlagName, mkFlagName, unFlagName,
FlagAssignment,
showFlagValue,
dispFlagAssignment, parseFlagAssignment,
CondTree(..), ConfVar(..), Condition(..),
cNot, cAnd, cOr,
......
......@@ -36,6 +36,7 @@ module Distribution.ParseUtils (
field, simpleField, listField, listFieldWithSep, spaceListField,
commaListField, commaListFieldWithSep, commaNewLineListField,
optsField, liftField, boolField, parseQuoted, parseMaybeQuoted, indentWith,
readPToMaybe,
UnrecFieldParser, warnUnrec, ignoreUnrec,
) where
......@@ -697,3 +698,7 @@ parseMaybeQuoted p = parseQuoted p <++ p
parseFreeText :: ReadP.ReadP s String
parseFreeText = ReadP.munch (const True)
readPToMaybe :: ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str
, all isSpace s ]
......@@ -55,6 +55,7 @@ import Distribution.Verbosity
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ( (+++), (<++) )
import Distribution.ParseUtils ( readPToMaybe )
import Control.Monad ( msum )
import Data.List ( stripPrefix, groupBy, partition )
......@@ -207,10 +208,6 @@ readUserBuildTarget targetstr =
parseHaskellString :: Parse.ReadP r String
parseHaskellString = Parse.readS_to_P reads
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
, all isSpace s ]
data UserBuildTargetProblem
= UserBuildTargetUnrecognised String
deriving Show
......
......@@ -82,6 +82,7 @@ import Distribution.Compiler
import Distribution.ReadE
import Distribution.Text
import qualified Distribution.Compat.ReadP as Parse
import Distribution.ParseUtils (readPToMaybe)
import qualified Text.PrettyPrint as Disp
import Distribution.ModuleName
import Distribution.Package
......@@ -2187,10 +2188,6 @@ optionNumJobs get set =
-- * Other Utils
-- ------------------------------------------------------------
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
, all isSpace s ]
-- | Arguments to pass to a @configure@ script, e.g. generated by
-- @autoconf@.
configureArgs :: Bool -> ConfigFlags -> [String]
......
......@@ -15,6 +15,7 @@ module Distribution.Text (
Text(..),
defaultStyle,
display,
flatStyle,
simpleParse,
stdParse,
) where
......@@ -31,16 +32,29 @@ class Text a where
disp :: a -> Disp.Doc
parse :: Parse.ReadP r a
-- | The default rendering style used in Cabal for console output.
-- | The default rendering style used in Cabal for console
-- output. It has a fixed page width and adds line breaks
-- automatically.
defaultStyle :: Disp.Style
defaultStyle = Disp.Style { Disp.mode = Disp.PageMode
, Disp.lineLength = 79
, Disp.ribbonsPerLine = 1.0
}
-- | Pretty-prints with the default style.
display :: Text a => a -> String
display = Disp.renderStyle defaultStyle . disp
-- | A style for rendering all on one line.
flatStyle :: Disp.Style
flatStyle = Disp.Style { Disp.mode = Disp.LeftMode
, Disp.lineLength = err "lineLength"
, Disp.ribbonsPerLine = err "ribbonsPerLine"
}
where
err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++
"This should never happen and indicates a bug in Cabal.")
simpleParse :: Text a => String -> Maybe a
simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str
, all isSpace s ] of
......
......@@ -9,12 +9,19 @@ module Distribution.Types.GenericPackageDescription (
mkFlagName,
unFlagName,
FlagAssignment,
showFlagValue,
dispFlagAssignment,
parseFlagAssignment,
ConfVar(..),
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
import Distribution.Utils.Generic (lowercase)
import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ((+++))
import Distribution.Types.PackageDescription
......@@ -110,6 +117,35 @@ instance Binary FlagName
--
type FlagAssignment = [(FlagName, Bool)]
-- | String representation of a flag-value pair.
showFlagValue :: (FlagName, Bool) -> String
showFlagValue (f, True) = '+' : unFlagName f
showFlagValue (f, False) = '-' : unFlagName f
-- | Pretty-prints a flag assignment.
dispFlagAssignment :: FlagAssignment -> Disp.Doc
dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue)
-- | Parses a flag assignment.
parseFlagAssignment :: Parse.ReadP r FlagAssignment
parseFlagAssignment = Parse.sepBy1 parseFlagValue Parse.skipSpaces1
where
parseFlagValue =
(do Parse.optional (Parse.char '+')
f <- parseFlagName
return (f, True))
+++ (do _ <- Parse.char '-'
f <- parseFlagName
return (f, False))
parseFlagName = liftM (mkFlagName . lowercase) ident
ident :: Parse.ReadP r String
ident = Parse.munch1 identChar >>= \s -> check s >> return s
where
identChar c = isAlphaNum c || c == '_' || c == '-'
check ('-':_) = Parse.pfail
check _ = return ()
-- | A @ConfVar@ represents the variable type used.
data ConfVar = OS OS
| Arch Arch
......
......@@ -74,7 +74,7 @@ import Data.Function
import Data.List
( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy )
import Data.Maybe
( listToMaybe, maybeToList )
( maybeToList )
import Data.Ord
( comparing )
import GHC.Generics (Generic)
......@@ -97,6 +97,8 @@ import Control.Applicative (Alternative(..))
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP
( (+++), (<++) )
import Distribution.ParseUtils
( readPToMaybe )
import Data.Char
( isSpace, isAlphaNum )
import System.FilePath as FilePath
......@@ -399,10 +401,6 @@ parseUserBuildTarget targetstr =
parseHaskellString :: Parse.ReadP r String
parseHaskellString = Parse.readS_to_P reads
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
, all isSpace s ]
-- | Syntax error when trying to parse a 'UserBuildTarget'.
data UserBuildTargetProblem
= UserBuildTargetUnrecognised String
......
......@@ -150,7 +150,7 @@ import Distribution.Types.Dependency
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription, GenericPackageDescription(..), Flag(..)
, unFlagName, FlagAssignment )
, FlagAssignment, showFlagValue )
import Distribution.PackageDescription.Configuration
( finalizePD )
import Distribution.ParseUtils
......@@ -695,15 +695,10 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
in confPkgFlags cpkg \\ defaultAssignment
showStanzas :: [OptionalStanza] -> String
showStanzas = concatMap ((' ' :) . showStanza)
showStanza TestStanzas = "*test"
showStanza BenchStanzas = "*bench"
showStanzas = concatMap ((" *" ++) . showStanza)
showFlagAssignment :: FlagAssignment -> String
showFlagAssignment = concatMap ((' ' :) . showFlagValue)
showFlagValue (f, True) = '+' : showFlagName f
showFlagValue (f, False) = '-' : showFlagName f
showFlagName = unFlagName
change (OnlyInLeft pkgid) = display pkgid ++ " removed"
change (InBoth pkgid pkgid') = display pkgid ++ " -> "
......
......@@ -35,7 +35,7 @@ import Distribution.Package
import Distribution.System
( Platform, OS(Windows), buildOS )
import Distribution.PackageDescription
( unFlagName, FlagAssignment )
( FlagAssignment, showFlagValue )
import Distribution.Simple.Compiler
( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
, ProfDetailLevel(..), showProfDetailLevel )
......@@ -262,10 +262,7 @@ renderPackageHashInputs PackageHashInputs{
| value == def = Nothing
| otherwise = entry key format value
showFlagAssignment = unwords . map showEntry . sortBy (compare `on` fst)
where
showEntry (fname, False) = '-' : unFlagName fname
showEntry (fname, True) = '+' : unFlagName fname
showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst)
-----------------------------------------------
-- The specific choice of hash implementation
......
......@@ -34,7 +34,8 @@ import Distribution.Solver.Types.ConstraintSource
import Distribution.Package
import Distribution.Types.Dependency
import Distribution.PackageDescription
( SourceRepo(..), RepoKind(..) )
( SourceRepo(..), RepoKind(..)
, dispFlagAssignment, parseFlagAssignment )
import Distribution.PackageDescription.Parse
( sourceRepoFieldDescrs )
import Distribution.Simple.Compiler
......@@ -53,8 +54,6 @@ import Distribution.Simple.Program
( programName, knownPrograms )
import Distribution.Simple.Program.Db
( ProgramDb, defaultProgramDb )
import Distribution.Client.Targets
( dispFlagAssignment, parseFlagAssignment )
import Distribution.Simple.Utils
( lowercase )
import Distribution.Utils.NubList
......
......@@ -77,8 +77,7 @@ import Distribution.Solver.Types.OptionalStanza
import Distribution.Package
hiding (InstalledPackageId, installedPackageId)
import qualified Distribution.PackageDescription as PD
import Distribution.PackageDescription (FlagAssignment)
import Distribution.PackageDescription (FlagAssignment, showFlagValue)
import Distribution.Simple.Setup (HaddockFlags)
import qualified Distribution.Simple.Setup as Setup
import Distribution.Simple.Command (commandShowOptions)
......@@ -570,12 +569,8 @@ printPlan verbosity
= " (" ++ intercalate ", " [ showComponentTarget (packageId elab) t | t <- elabBuildTargets elab ]
++ ")"
-- TODO: [code cleanup] this should be a proper function in a proper place
showFlagAssignment :: FlagAssignment -> String
showFlagAssignment = concatMap ((' ' :) . showFlagValue)
showFlagValue (f, True) = '+' : showFlagName f
showFlagValue (f, False) = '-' : showFlagName f
showFlagName = PD.unFlagName
showConfigureFlags elab =
let fullConfigureFlags
......
......@@ -93,7 +93,7 @@ import Distribution.Simple.Setup
, Flag(..), toFlag, flagToMaybe, flagToList
, BooleanFlag(..), optionVerbosity
, boolOpt, boolOpt', trueArg, falseArg
, readPToMaybe, optionNumJobs )
, optionNumJobs )
import Distribution.Simple.InstallDirs
( PathTemplate, InstallDirs(dynlibdir, sysconfdir)
, toPathTemplate, fromPathTemplate )
......@@ -111,6 +111,8 @@ import Distribution.ReadE
( ReadE(..), readP_to_E, succeedReadE )
import qualified Distribution.Compat.ReadP as Parse
( ReadP, char, munch1, pfail, (+++) )
import Distribution.ParseUtils
( readPToMaybe )
import Distribution.Verbosity
( Verbosity, lessVerbose, normal )
import Distribution.Simple.Utils
......
......@@ -45,8 +45,6 @@ module Distribution.Client.Targets (
userConstraintPackageName,
readUserConstraint,
userToPackageConstraint,
dispFlagAssignment,
parseFlagAssignment,
) where
......@@ -79,7 +77,8 @@ import Distribution.Client.GlobalFlags
( RepoContext(..) )
import Distribution.PackageDescription
( GenericPackageDescription, mkFlagName, unFlagName, FlagAssignment )
( GenericPackageDescription, FlagAssignment
, dispFlagAssignment, parseFlagAssignment )
import Distribution.PackageDescription.Parse
( readPackageDescription, parsePackageDescription, ParseResult(..) )
import Distribution.Version
......@@ -102,6 +101,8 @@ import Control.Monad (mapM)
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP
( (+++), (<++) )
import Distribution.ParseUtils
( readPToMaybe )
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint
( (<+>) )
......@@ -301,10 +302,6 @@ readUserTarget targetstr =
v | v == nullVersion -> Dependency (packageName p) anyVersion
| otherwise -> Dependency (packageName p) (thisVersion v)
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
, all isSpace s ]
reportUserTargetProblems :: [UserTargetProblem] -> IO ()
reportUserTargetProblems problems = do
......@@ -758,57 +755,24 @@ instance Text UserConstraint where
disp (UserConstraintStanzas pkgname stanzas) = disp pkgname
<+> dispStanzas stanzas
where
dispStanzas = Disp.hsep . map dispStanza
dispStanza TestStanzas = Disp.text "test"
dispStanza BenchStanzas = Disp.text "bench"
dispStanzas = Disp.hsep . map (Disp.text . showStanza)
parse = parse >>= parseConstraint
where
parseConstraint pkgname =
((parse >>= return . UserConstraintVersion pkgname)
+++ (do skipSpaces1
+++ (do Parse.skipSpaces1
_ <- Parse.string "installed"
return (UserConstraintInstalled pkgname))
+++ (do skipSpaces1
+++ (do Parse.skipSpaces1
_ <- Parse.string "source"
return (UserConstraintSource pkgname))
+++ (do skipSpaces1
+++ (do Parse.skipSpaces1
_ <- Parse.string "test"
return (UserConstraintStanzas pkgname [TestStanzas]))
+++ (do skipSpaces1
+++ (do Parse.skipSpaces1
_ <- Parse.string "bench"
return (UserConstraintStanzas pkgname [BenchStanzas])))
<++ (do skipSpaces1
<++ (do Parse.skipSpaces1
flags <- parseFlagAssignment
return (UserConstraintFlags pkgname flags))
--TODO: [code cleanup] move these somewhere else
dispFlagAssignment :: FlagAssignment -> Disp.Doc
dispFlagAssignment = Disp.hsep . map dispFlagValue
where
dispFlagValue (f, True) = Disp.char '+' <<>> dispFlagName f
dispFlagValue (f, False) = Disp.char '-' <<>> dispFlagName f
dispFlagName = Disp.text . unFlagName
parseFlagAssignment :: Parse.ReadP r FlagAssignment
parseFlagAssignment = Parse.sepBy1 parseFlagValue skipSpaces1
where
parseFlagValue =
(do Parse.optional (Parse.char '+')
f <- parseFlagName
return (f, True))
+++ (do _ <- Parse.char '-'
f <- parseFlagName
return (f, False))
parseFlagName = liftM (mkFlagName . lowercase) ident
ident :: Parse.ReadP r String
ident = Parse.munch1 identChar >>= \s -> check s >> return s
where
identChar c = isAlphaNum c || c == '_' || c == '-'
check ('-':_) = Parse.pfail
check _ = return ()
skipSpaces1 :: Parse.ReadP r ()
skipSpaces1 = Parse.satisfy isSpace >> Parse.skipSpaces
......@@ -71,10 +71,6 @@ type QSN = SN QPN
newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool }
deriving (Eq, Ord, Show)
unStanza :: OptionalStanza -> String
unStanza TestStanzas = "test"
unStanza BenchStanzas = "bench"
showQFNBool :: QFN -> Bool -> String
showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b
......@@ -82,15 +78,14 @@ showQSNBool :: QSN -> Bool -> String
showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b
showFBool :: FN qpn -> Bool -> String
showFBool (FN _ f) True = "+" ++ unFlag f
showFBool (FN _ f) False = "-" ++ unFlag f
showFBool (FN _ f) v = showFlagValue (f, v)
showSBool :: SN qpn -> Bool -> String
showSBool (SN _ s) True = "*" ++ unStanza s
showSBool (SN _ s) False = "!" ++ unStanza s
showSBool (SN _ s) True = "*" ++ showStanza s
showSBool (SN _ s) False = "!" ++ showStanza s
showQFN :: QFN -> String
showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f
showQSN :: QSN -> String
showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f
showQSN (SN pi f) = showPI pi ++ ":" ++ showStanza f
......@@ -2,6 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Distribution.Solver.Types.OptionalStanza
( OptionalStanza(..)
, showStanza
, enableStanzas
) where
......@@ -17,6 +18,11 @@ data OptionalStanza
| BenchStanzas
deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable)
-- | String representation of an OptionalStanza.
showStanza :: OptionalStanza -> String
showStanza TestStanzas = "test"
showStanza BenchStanzas = "bench"
-- | Convert a list of 'OptionalStanza' into the corresponding
-- 'ComponentRequestedSpec' which records what components are enabled.
enableStanzas :: [OptionalStanza] -> ComponentRequestedSpec
......
......@@ -44,6 +44,3 @@ showPackageConstraint (PackageConstraintFlags pn fs) =
showFlag f False = "-" ++ unFlagName f
showPackageConstraint (PackageConstraintStanzas pn ss) =
"stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss)
where
showStanza TestStanzas = "test"
showStanza BenchStanzas = "bench"
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment