Commit 4e874a45 authored by Duncan Coutts's avatar Duncan Coutts

Shrink the size of the ParseUtils module

Really it should be eleminated entirely.
parent 9a5b46ce
......@@ -38,7 +38,8 @@ import Distribution.Compat.ReadP as ReadP
import Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor)
import Distribution.ParseUtils
( FieldDescr(..), simpleField, listField, liftField, field
, parseFilePathQ, parseTokenQ, showPWarning, ParseResult(..) )
, parseFilePathQ, parseTokenQ
, ParseResult(..), showPWarning, locatedErrorMsg )
import Distribution.Simple.Compiler (PackageDB(..))
import Distribution.Simple.InstallDirs
( InstallDirs(..), PathTemplate, toPathTemplate, fromPathTemplate )
......@@ -54,7 +55,7 @@ import Distribution.System
import Distribution.Client.Types
( RemoteRepo(..), Repo(..), Username(..), Password(..) )
import Distribution.Client.ParseUtils
import Distribution.Client.ParseUtils (showFields, parseBasicStanza)
import Distribution.Client.Utils (readFileIfExists)
import Distribution.Simple.Utils (notice, warn)
......@@ -170,25 +171,30 @@ defaultRemoteRepo = RemoteRepo name uri
--
loadConfig :: Verbosity -> FilePath -> IO SavedConfig
loadConfig verbosity configFile =
do defaultConf <- defaultSavedConfig
minp <- readFileIfExists configFile
case minp of
Nothing -> do notice verbosity $ "Config file " ++ configFile ++ " not found."
notice verbosity $ "Writing default configuration to " ++ configFile
writeDefaultConfigFile configFile defaultConf
return defaultConf
Just inp -> case parseBasicStanza configFieldDescrs defaultConf' inp of
ParseOk ws conf ->
do when (not $ null ws) $ warn verbosity $
unlines (map (showPWarning configFile) ws)
return conf
ParseFailed err ->
do warn verbosity $ "Error parsing config file "
++ configFile ++ ": " ++ showPError err
warn verbosity $ "Using default configuration."
return defaultConf
where defaultConf' = defaultConf { configRemoteRepos = [] }
loadConfig verbosity configFile = do
defaultConf <- defaultSavedConfig
minp <- readFileIfExists configFile
case minp of
Nothing -> do
notice verbosity $ "Config file " ++ configFile ++ " not found."
notice verbosity $ "Writing default configuration to " ++ configFile
writeDefaultConfigFile configFile defaultConf
return defaultConf
Just inp -> case parseBasicStanza configFieldDescrs defaultConf' inp of
ParseOk ws conf -> do
when (not $ null ws) $ warn verbosity $
unlines (map (showPWarning configFile) ws)
return conf
ParseFailed err -> do
let (line, msg) = locatedErrorMsg err
warn verbosity $
"Error parsing config file " ++ configFile
++ maybe "" (\n -> ":" ++ show n) line ++ ": " ++ show msg
warn verbosity $ "Using default configuration."
return defaultConf
where defaultConf' = defaultConf { configRemoteRepos = [] }
writeDefaultConfigFile :: FilePath -> SavedConfig -> IO ()
writeDefaultConfigFile file cfg =
......
module Distribution.Client.ParseUtils where
module Distribution.Client.ParseUtils (
parseBasicStanza,
showFields,
) where
import Distribution.Compat.ReadP
( ReadP, readP_to_S, pfail, get, look, choice, (+++) )
import Distribution.Package (PackageIdentifier(..), Dependency(..))
import Distribution.ParseUtils
( Field(..), FieldDescr(..), ParseResult(..), PError
, field, liftField, readFields
, warning, lineNo, locatedErrorMsg)
import Distribution.Text
( Text(parse) )
import Distribution.Version (Version(..), VersionRange(..))
import Control.Monad (foldM, liftM)
import Data.Char (isSpace, toLower)
( Field(..), FieldDescr(..), ParseResult(..)
, readFields, warning, lineNo )
import Control.Monad (foldM)
import Data.Maybe (listToMaybe)
import Text.PrettyPrint.HughesPJ (Doc, render, vcat, text, (<>), (<+>))
showPError :: PError -> String
showPError err = let (ml,msg) = locatedErrorMsg err
in maybe "" (\l -> "On line " ++ show l ++ ": ") ml ++ msg
readPToMaybe :: ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str, all isSpace s ]
ignoreWarnings :: ParseResult a -> ParseResult a
ignoreWarnings (ParseOk _ x) = ParseOk [] x
ignoreWarnings r = r
import Text.PrettyPrint.HughesPJ (render, vcat, text, (<>), (<+>))
parseBasicStanza :: [FieldDescr a] -> a -> String -> ParseResult a
parseBasicStanza fields empty inp =
......@@ -51,32 +32,6 @@ setField _ x s =
lookupFieldDescr :: [FieldDescr a] -> String -> Maybe (FieldDescr a)
lookupFieldDescr fs n = listToMaybe [f | f@(FieldDescr name _ _) <- fs, name == n]
boolField :: String -> (a -> Bool) -> (Bool -> a -> a) -> FieldDescr a
boolField name g s = liftField g s $ field name showBool readBool
where
showBool :: Bool -> Doc
showBool True = text "true"
showBool False = text "false"
readBool :: ReadP r Bool
readBool = choice [ stringNoCase "true" >> return True
, stringNoCase "false" >> return False
, stringNoCase "yes" >> return True
, stringNoCase "no" >> return False]
showFields :: [FieldDescr a] -> a -> String
showFields fs x = render $ vcat [ text name <> text ":" <+> g x | FieldDescr name g _ <- fs]
stringNoCase :: String -> ReadP r String
stringNoCase this = look >>= scan this
where
scan [] _ = return this
scan (x:xs) (y:ys) | toLower x == toLower y = get >> scan xs ys
scan _ _ = pfail
parseDependencyOrPackageId :: ReadP r Dependency
parseDependencyOrPackageId = parse +++ liftM pkgToDep parse
where pkgToDep p = case pkgVersion p of
Version [] _ -> Dependency (pkgName p) AnyVersion
version -> Dependency (pkgName p) (ThisVersion version)
showFields fields x = render $ vcat [ text name <> text ":" <+> getter x
| FieldDescr name getter _ <- fields ]
......@@ -25,39 +25,35 @@ module Distribution.Client.Setup
, parsePackageArgs
) where
import Distribution.Simple.Program (defaultProgramConfiguration)
import Distribution.Client.Types
( Username(..), Password(..) )
import Distribution.Simple.Program
( defaultProgramConfiguration )
import Distribution.Simple.Command
import qualified Distribution.Simple.Setup as Cabal
(GlobalFlags(..), {-emptyGlobalFlags,-} globalCommand,
ConfigFlags(..), {-emptyConfigFlags,-} configureCommand,
{- CopyFlags(..), emptyCopyFlags, copyCommand,
InstallFlags(..), emptyInstallFlags, installCommand,
HaddockFlags(..), emptyHaddockFlags, haddockCommand,
HscolourFlags(..), emptyHscolourFlags, hscolourCommand,
BuildFlags(..), emptyBuildFlags, buildCommand,
CleanFlags(..), emptyCleanFlags, cleanCommand,
PFEFlags(..), emptyPFEFlags, programaticaCommand,
MakefileFlags(..), emptyMakefileFlags, makefileCommand,
RegisterFlags(..), emptyRegisterFlags, registerCommand, unregisterCommand,
SDistFlags(..), emptySDistFlags, sdistCommand,
testCommand-})
( GlobalFlags(..), globalCommand
, ConfigFlags(..), configureCommand )
import Distribution.Simple.Setup
( Flag(..), toFlag, flagToList, trueArg, optionVerbosity )
import Distribution.Version
( Version(Version) )
( Version(Version), VersionRange(..) )
import Distribution.Package
( Dependency )
( PackageIdentifier, packageName, packageVersion, Dependency(..) )
import Distribution.Text
( Text(parse), display )
import Distribution.ReadE
( readP_to_E )
import Distribution.Verbosity (Verbosity, normal)
import Distribution.Compat.ReadP
( ReadP, readP_to_S, (+++) )
import Distribution.Verbosity
( Verbosity, normal )
import Distribution.Client.Types
( Username(..), Password(..) )
import Distribution.Client.ParseUtils (readPToMaybe, parseDependencyOrPackageId)
import Data.Char (isSpace)
import Data.Maybe (listToMaybe)
import Data.Monoid (Monoid(..))
import Control.Monad (liftM)
import Data.Monoid (Monoid(..))
globalCommand :: CommandUI Cabal.GlobalFlags
globalCommand = Cabal.globalCommand {
......@@ -364,3 +360,14 @@ parsePackageArgs = parsePkgArgs []
case readPToMaybe parseDependencyOrPackageId arg of
Just dep -> parsePkgArgs (dep:ds) args
Nothing -> Left ("Failed to parse package dependency: " ++ show arg)
readPToMaybe :: ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str, all isSpace s ]
parseDependencyOrPackageId :: ReadP r Dependency
parseDependencyOrPackageId = parse +++ liftM pkgidToDependency parse
where
pkgidToDependency :: PackageIdentifier -> Dependency
pkgidToDependency p = case packageVersion p of
Version [] _ -> Dependency (packageName p) AnyVersion
version -> Dependency (packageName p) (ThisVersion version)
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