Commit baf78ca2 authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Move ReadP out of Cabal (to cabal-install)

- Distribution.Compat.ReadP to Distribution.Deprecated.ReadP
- Distribution.Text to Distribution.Deprecated.Text
- all Text instances needed by cabal-install to Deprecated.Text too
- Distribution.ParseUtils to Distribution.Deprecated.ParseUtils
- Remove deprecated Distribution.PrettyUtils
- new Distribution.Text with

    display = prettyShow
    simpleParse = simpleParsec

  to not break too much stuff (Custom Setup.hs)
- parseInstalledPackageInfo type signature changed to use
  `base` types

This removes around 2k lines from Cabal the library.
git diff --stat shows less, as files are moved (git is smart).
Even so, total 300 lines removal at this point.
parent 547791ce
......@@ -231,7 +231,6 @@ library
Distribution.Compat.Internal.TempFile
Distribution.Compat.Newtype
Distribution.Compat.Prelude.Internal
Distribution.Compat.ReadP
Distribution.Compat.Semigroup
Distribution.Compat.Stack
Distribution.Compat.Time
......@@ -251,8 +250,6 @@ library
Distribution.PackageDescription.Configuration
Distribution.PackageDescription.PrettyPrint
Distribution.PackageDescription.Utils
Distribution.ParseUtils
Distribution.PrettyUtils
Distribution.ReadE
Distribution.Simple
Distribution.Simple.Bench
......@@ -492,7 +489,6 @@ test-suite unit-tests
Test.Laws
Test.QuickCheck.Utils
UnitTests.Distribution.Compat.CreatePipe
UnitTests.Distribution.Compat.ReadP
UnitTests.Distribution.Compat.Time
UnitTests.Distribution.Compat.Graph
UnitTests.Distribution.Simple.Glob
......
......@@ -29,8 +29,6 @@ module Distribution.Backpack (
OpenModuleSubst,
dispOpenModuleSubst,
dispOpenModuleSubstEntry,
parseOpenModuleSubst,
parseOpenModuleSubstEntry,
parsecOpenModuleSubst,
parsecOpenModuleSubstEntry,
openModuleSubstFreeHoles,
......@@ -41,18 +39,15 @@ module Distribution.Backpack (
) where
import Distribution.Compat.Prelude hiding (mod)
import Distribution.Compat.ReadP ((<++))
import Distribution.Parsec.Class
import Distribution.Pretty
import Prelude ()
import Text.PrettyPrint (hcat)
import qualified Distribution.Compat.CharParsing as P
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
import Distribution.ModuleName
import Distribution.Text
import Distribution.Types.ComponentId
import Distribution.Types.Module
import Distribution.Types.UnitId
......@@ -134,15 +129,6 @@ instance Parsec OpenUnitId where
parsecOpenModuleSubst
return (IndefFullUnitId cid insts)
instance Text OpenUnitId where
parse = parseOpenUnitId <++ fmap DefiniteUnitId parse
where
parseOpenUnitId = do
cid <- parse
insts <- Parse.between (Parse.char '[') (Parse.char ']')
parseOpenModuleSubst
return (IndefFullUnitId cid insts)
-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.
openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName
openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts
......@@ -211,20 +197,6 @@ instance Parsec OpenModule where
_ <- P.char '>'
return (OpenModuleVar mod_name)
instance Text OpenModule where
parse = parseModuleVar <++ parseOpenModule
where
parseOpenModule = do
uid <- parse
_ <- Parse.char ':'
mod_name <- parse
return (OpenModule uid mod_name)
parseModuleVar = do
_ <- Parse.char '<'
mod_name <- parse
_ <- Parse.char '>'
return (OpenModuleVar mod_name)
-- | Get the set of holes ('ModuleVar') embedded in a 'Module'.
openModuleFreeHoles :: OpenModule -> Set ModuleName
openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name
......@@ -249,21 +221,7 @@ dispOpenModuleSubst subst
-- | Pretty-print a single entry of a module substitution.
dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc
dispOpenModuleSubstEntry (k, v) = disp k <<>> Disp.char '=' <<>> disp v
-- | Inverse to 'dispModSubst'.
parseOpenModuleSubst :: Parse.ReadP r OpenModuleSubst
parseOpenModuleSubst = fmap Map.fromList
. flip Parse.sepBy (Parse.char ',')
$ parseOpenModuleSubstEntry
-- | Inverse to 'dispModSubstEntry'.
parseOpenModuleSubstEntry :: Parse.ReadP r (ModuleName, OpenModule)
parseOpenModuleSubstEntry =
do k <- parse
_ <- Parse.char '='
v <- parse
return (k, v)
dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v
-- | Inverse to 'dispModSubst'.
--
......@@ -307,5 +265,5 @@ hashModuleSubst subst
| Map.null subst = Nothing
| otherwise =
Just . hashToBase62 $
concat [ display mod_name ++ "=" ++ display m ++ "\n"
concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n"
| (mod_name, m) <- Map.toList subst]
......@@ -60,7 +60,6 @@ import Data.Char
import Data.Text (Text, unpack)
import qualified Text.Parsec as Parsec
import qualified Distribution.Compat.ReadP as ReadP
import Distribution.Compat.Parsing
......@@ -310,13 +309,6 @@ instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where
anyChar = Parsec.anyChar
string = Parsec.string
instance t ~ Char => CharParsing (ReadP.Parser r t) where
satisfy = ReadP.satisfy
char = ReadP.char
notChar c = ReadP.satisfy (/= c)
anyChar = ReadP.get
string = ReadP.string
-------------------------------------------------------------------------------
-- Our additions
-------------------------------------------------------------------------------
......
......@@ -59,7 +59,6 @@ import Control.Monad.Trans.Identity (IdentityT (..))
import Data.Foldable (asum)
import qualified Text.Parsec as Parsec
import qualified Distribution.Compat.ReadP as ReadP
-- | @choice ps@ tries to apply the parsers in the list @ps@ in order,
-- until one of them succeeds. Returns the value of the succeeding
......@@ -389,15 +388,3 @@ instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where
unexpected = Parsec.unexpected
eof = Parsec.eof
notFollowedBy = Parsec.notFollowedBy
instance t ~ Char => Parsing (ReadP.Parser r t) where
try = id
(<?>) = const
skipMany = ReadP.skipMany
skipSome = ReadP.skipMany1
unexpected = const ReadP.pfail
eof = ReadP.eof
-- TODO: we would like to have <++ here
notFollowedBy p = ((Just <$> p) ReadP.+++ pure Nothing)
>>= maybe (pure ()) (unexpected . show)
......@@ -30,7 +30,6 @@ module Distribution.Compiler (
buildCompilerId,
buildCompilerFlavor,
defaultCompilerFlavor,
parseCompilerFlavorCompat,
classifyCompilerFlavor,
knownCompilerFlavors,
......@@ -52,9 +51,7 @@ 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 Distribution.Pretty (Pretty (..), prettyShow)
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
......@@ -85,44 +82,13 @@ instance Parsec CompilerFlavor where
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
return (classifyCompilerFlavor comp)
classifyCompilerFlavor :: String -> CompilerFlavor
classifyCompilerFlavor s =
fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap
where
compilerMap = [ (lowercase (display compiler), compiler)
compilerMap = [ (lowercase (prettyShow compiler), compiler)
| compiler <- knownCompilerFlavors ]
--TODO: In some future release, remove 'parseCompilerFlavorCompat' and use
-- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'.
-- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser.
--
-- It is compatible in the sense that it accepts only the same strings,
-- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'.
-- The point of this is that we do not allow extra valid values that would
-- upset older Cabal versions that had a stricter parser however we cope with
-- new values more gracefully so that we'll be able to introduce new value in
-- future without breaking things so much.
--
parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor
parseCompilerFlavorCompat = do
comp <- Parse.munch1 isAlphaNum
when (all isDigit comp) Parse.pfail
case lookup comp compilerMap of
Just compiler -> return compiler
Nothing -> return (OtherCompiler comp)
where
compilerMap = [ (show compiler, compiler)
| compiler <- knownCompilerFlavors
, compiler /= YHC ]
buildCompilerFlavor :: CompilerFlavor
buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName
......@@ -165,12 +131,6 @@ instance Parsec CompilerId where
version <- (P.char '-' >> parsec) <|> return nullVersion
return (CompilerId flavour version)
instance Text CompilerId where
parse = do
flavour <- parse
version <- (Parse.char '-' >> parse) Parse.<++ return nullVersion
return (CompilerId flavour version)
lowercase :: String -> String
lowercase = map toLower
......@@ -207,12 +167,13 @@ data AbiTag
instance Binary AbiTag
instance Text AbiTag where
disp NoAbiTag = Disp.empty
disp (AbiTag tag) = Disp.text tag
instance Pretty AbiTag where
pretty NoAbiTag = Disp.empty
pretty (AbiTag tag) = Disp.text tag
parse = do
tag <- Parse.munch (\c -> isAlphaNum c || c == '_')
instance Parsec AbiTag where
parsec = do
tag <- P.munch (\c -> isAlphaNum c || c == '_')
if null tag then return NoAbiTag else return (AbiTag tag)
abiTagString :: AbiTag -> String
......
......@@ -7,14 +7,13 @@ module Distribution.FieldGrammar.Pretty (
import Distribution.Compat.Lens
import Distribution.Compat.Newtype
import Distribution.Compat.Prelude
import Distribution.Pretty (Pretty (..))
import Distribution.Pretty (Pretty (..), indentWith)
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
......@@ -77,3 +76,30 @@ instance FieldGrammar PrettyFieldGrammar where
deprecatedSince _ _ x = x
availableSince _ _ = id
hiddenField _ = PrettyFG (\_ -> mempty)
ppField :: String -> Doc -> Doc
ppField name fielddoc
| PP.isEmpty fielddoc = mempty
| name `elem` nestedFields = PP.text name <<>> PP.colon PP.$+$ PP.nest indentWith fielddoc
| otherwise = PP.text name <<>> PP.colon PP.<+> fielddoc
where
nestedFields =
[ "description"
, "build-depends"
, "data-files"
, "extra-source-files"
, "extra-tmp-files"
, "exposed-modules"
, "asm-sources"
, "cmm-sources"
, "c-sources"
, "js-sources"
, "extra-libraries"
, "includes"
, "install-includes"
, "other-modules"
, "autogen-modules"
, "depends"
]
......@@ -33,7 +33,6 @@ module Distribution.InstalledPackageInfo (
requiredSignatures,
ExposedModule(..),
AbiDependency(..),
ParseResult(..), PError(..), PWarning,
emptyInstalledPackageInfo,
parseInstalledPackageInfo,
showInstalledPackageInfo,
......@@ -52,7 +51,6 @@ import Distribution.FieldGrammar
import Distribution.FieldGrammar.FieldDescrs
import Distribution.ModuleName
import Distribution.Package hiding (installedPackageId, installedUnitId)
import Distribution.ParseUtils
import Distribution.Types.ComponentName
import Distribution.Types.LibraryName
import Distribution.Utils.Generic (toUTF8BS)
......@@ -61,8 +59,6 @@ import qualified Data.Map as Map
import qualified Distribution.Parsec.Common as P
import qualified Distribution.Parsec.Parser as P
import qualified Distribution.Parsec.ParseResult as P
import qualified Text.Parsec.Error as Parsec
import qualified Text.Parsec.Pos as Parsec
import qualified Text.PrettyPrint as Disp
import Distribution.Types.InstalledPackageInfo
......@@ -111,15 +107,20 @@ sourceComponentName ipi =
-- -----------------------------------------------------------------------------
-- Parsing
parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo
-- | Return either errors, or IPI with list of warnings
--
-- /Note:/ errors array /may/ be empty, but the parse is still failed (it's a bug though)
parseInstalledPackageInfo
:: String
-> Either [String] ([String], InstalledPackageInfo)
parseInstalledPackageInfo s = case P.readFields (toUTF8BS s) of
Left err -> ParseFailed (NoParse (show err) $ Parsec.sourceLine $ Parsec.errorPos err)
Left err -> Left [show err]
Right fs -> case partitionFields fs of
(fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of
(ws, Right x) -> ParseOk ws' x where
ws' = map (PWarning . P.showPWarning "") ws
(_, Left (_, errs)) -> ParseFailed (NoParse errs' 0) where
errs' = intercalate "; " $ map (\(P.PError _ msg) -> msg) errs
(ws, Right x) -> Right (ws', x) where
ws' = map (P.showPWarning "") ws
(_, Left (_, errs)) -> Left errs' where
errs' = map (P.showPError "") errs
-- -----------------------------------------------------------------------------
-- Pretty-printing
......@@ -149,3 +150,8 @@ showSimpleInstalledPackageInfoField fn =
fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar fn
where
myStyle = Disp.style { Disp.mode = Disp.LeftMode }
ppField :: String -> Disp.Doc -> Disp.Doc
ppField name fielddoc
| Disp.isEmpty fielddoc = mempty
| otherwise = Disp.text name <<>> Disp.colon Disp.<+> fielddoc
......@@ -54,12 +54,10 @@ import Prelude ()
import Distribution.Parsec.Class
import Distribution.Pretty
import Distribution.Text
import Distribution.Version
import qualified Distribution.Compat.CharParsing as P
import qualified Data.Map.Strict as Map
import qualified Distribution.Compat.ReadP as Parse
import qualified Distribution.SPDX as SPDX
import qualified Text.PrettyPrint as Disp
......@@ -244,32 +242,11 @@ instance Parsec License where
("AllRightsReserved", Nothing) -> AllRightsReserved
("OtherLicense", Nothing) -> OtherLicense
_ -> UnknownLicense $ name ++
maybe "" (('-':) . display) version
instance Text License where
parse = do
name <- Parse.munch1 (\c -> isAlphaNum c && c /= '-')
version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse)
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
maybe "" (('-':) . prettyShow) version
dispOptVersion :: Maybe Version -> Disp.Doc
dispOptVersion Nothing = Disp.empty
dispOptVersion (Just v) = dispVersion v
dispVersion :: Version -> Disp.Doc
dispVersion v = Disp.char '-' <<>> disp v
dispVersion v = Disp.char '-' <<>> pretty v
......@@ -78,7 +78,7 @@ import Distribution.Simple.Utils
import Distribution.License
import Distribution.Version
import Distribution.Text
import Distribution.Pretty
import System.Environment (getArgs, getProgName)
import System.Exit
......@@ -114,9 +114,9 @@ defaultMainHelper args =
printErrors errs = do
putStr (intercalate "\n" errs)
exitWith (ExitFailure 1)
printNumericVersion = putStrLn $ display cabalVersion
printNumericVersion = putStrLn $ prettyShow cabalVersion
printVersion = putStrLn $ "Cabal library version "
++ display cabalVersion
++ prettyShow cabalVersion
progs = defaultProgramDb
commands =
......
......@@ -32,10 +32,8 @@ import System.FilePath ( pathSeparator )
import Distribution.Pretty
import Distribution.Parsec.Class
import Distribution.Text
import qualified Distribution.Compat.CharParsing as P
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
-- | A valid Haskell module name.
......@@ -60,17 +58,6 @@ instance Parsec ModuleName where
cs <- P.munch validModuleChar
return (c:cs)
instance Text ModuleName where
parse = do
ms <- Parse.sepBy1 component (Parse.char '.')
return (ModuleName $ stlFromStrings ms)
where
component = do
c <- Parse.satisfy isUpper
cs <- Parse.munch validModuleChar
return (c:cs)
validModuleChar :: Char -> Bool
validModuleChar c = isAlphaNum c || c == '_' || c == '\''
......
......@@ -99,7 +99,7 @@ module Distribution.PackageDescription (
FlagAssignment, mkFlagAssignment, unFlagAssignment,
nullFlagAssignment, showFlagValue,
diffFlagAssignment, lookupFlagAssignment, insertFlagAssignment,
dispFlagAssignment, parseFlagAssignment, parsecFlagAssignment,
dispFlagAssignment, parsecFlagAssignment,
findDuplicateFlagAssignments,
CondTree(..), ConfVar(..), Condition(..),
cNot, cAnd, cOr,
......
......@@ -36,7 +36,6 @@ import Distribution.Types.CondTree
import Distribution.PackageDescription
import Distribution.Simple.Utils
import Distribution.ParseUtils
import Distribution.Pretty
import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar)
......
......@@ -38,7 +38,6 @@ import Prelude ()
import qualified Distribution.Compat.CharParsing as P
import qualified Distribution.Compat.MonadFail as Fail
import qualified Distribution.Compat.ReadP as ReadP
import qualified Text.Parsec as Parsec
-------------------------------------------------------------------------------
......@@ -63,10 +62,6 @@ class (P.CharParsing m, MonadPlus m) => CabalParsing m where
askCabalSpecVersion :: m CabalSpecVersion
instance t ~ Char => CabalParsing (ReadP.Parser r t) where
parsecWarning _ _ = pure ()
askCabalSpecVersion = pure cabalSpecLatest
-- | 'parsec' /could/ consume trailing spaces, this function /will/ consume.
lexemeParsec :: (CabalParsing m, Parsec a) => m a
lexemeParsec = parsec <* P.spaces
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.PrettyUtils
-- Copyright : (c) The University of Glasgow 2004
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Utilities for pretty printing.
{-# OPTIONS_HADDOCK hide #-}
module Distribution.PrettyUtils {-# DEPRECATED "Use Distribution.Pretty. This module will be removed in Cabal-3.0 (est. Mar 2019)." #-} (
Separator,
-- * Internal
showFilePath,
showToken,
showTestedWith,
showFreeText,
indentWith,
) where
import Distribution.Pretty
import Distribution.ParseUtils
......@@ -13,15 +13,13 @@ module Distribution.ReadE (
-- * ReadE
ReadE(..), succeedReadE, failReadE,
-- * Projections
parseReadE, readEOrFail,
readP_to_E,
readEOrFail,
parsecToReadE,
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.ReadP
import Distribution.Parsec.Class
import Distribution.Parsec.FieldLineStream
......@@ -40,22 +38,9 @@ succeedReadE f = ReadE (Right . f)
failReadE :: ErrorMsg -> ReadE a
failReadE = ReadE . const . Left
parseReadE :: ReadE a -> ReadP r a
parseReadE (ReadE p) = do
txt <- look
either fail return (p txt)
readEOrFail :: ReadE a -> String -> a
readEOrFail r = either error id . runReadE r
-- {-# DEPRECATED readP_to_E "Use parsecToReadE. This symbol will be removed in Cabal-3.0 (est. Mar 2019)." #-}
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) -> ParsecParser a -> ReadE a
parsecToReadE err p = ReadE $ \txt ->
case runParsecParser p "<parsecToReadE>" (fieldLineStreamFromString txt) of
......
......@@ -92,7 +92,7 @@ import Distribution.Verbosity
import Language.Haskell.Extension
import Distribution.Version
import Distribution.License
import Distribution.Text
import Distribution.Pretty
-- Base
import System.Environment (getArgs, getProgName)
......@@ -168,9 +168,9 @@ defaultMainHelper hooks args = topHandler $
printErrors errs = do
putStr (intercalate "\n" errs)
exitWith (ExitFailure 1)
printNumericVersion = putStrLn $ display cabalVersion
printNumericVersion = putStrLn $ prettyShow cabalVersion
printVersion = putStrLn $ "Cabal library version "
++ display cabalVersion
++ prettyShow cabalVersion
progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb
commands =
......@@ -497,7 +497,7 @@ sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_)
sanityCheckHookedBuildInfo pkg_descr (_, hookExes)
| not (null nonExistant)
= die $ "The buildinfo contains info for an executable called '"
++ display (head nonExistant) ++ "' but the package does not have a "
++ prettyShow (head nonExistant) ++ "' but the package does not have a "
++ "executable with that name."
where
pkgExeNames = nub (map exeName (executables pkg_descr))
......
......@@ -56,7 +56,7 @@ module Distribution.Simple.Command (
option, multiOption,
-- ** Liftings & Projections
liftOption, viewAsFieldDescr,
liftOption,
-- * Option Descriptions
OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder,
......@@ -72,14 +72,9 @@ import Prelude ()
import Distribution.Compat.Prelude hiding (get)