Commit 86ac8140 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Add Text class for displaying and parsing values

This is intended to replace all these showFoo read/parseFoo functions
we have all over the place. It's like the Read/Show classes but uses
a half decent parser and pretty printer:
class Text a where
  disp  :: a -> Doc
  parse :: ReadP a
This patch just adds the class and an instance for Bool, replacing
the parseBool function used in a few places. More to follow...
parent da8cdc05
......@@ -79,6 +79,7 @@ Library
Distribution.Simple.UserHooks,
Distribution.Simple.Utils,
Distribution.System,
Distribution.Text,
Distribution.Verbosity,
Distribution.Version,
Distribution.Compat.ReadP,
......
......@@ -64,6 +64,8 @@ import Data.List (nub, unfoldr, partition, (\\))
import Control.Monad (liftM, foldM, when)
import System.Directory (doesFileExist)
import Distribution.Text
( Text(disp, parse) )
import Text.PrettyPrint.HughesPJ
import Distribution.Compat.ReadP hiding (get)
......@@ -202,7 +204,7 @@ storeXFieldsExe _ _ = Nothing
binfoFieldDescrs :: [FieldDescr BuildInfo]
binfoFieldDescrs =
[ simpleField "buildable"
(text . show) parseBool
disp parse
buildable (\val binfo -> binfo{buildable=val})
, commaListField "build-tools"
showDependency parseBuildTool
......@@ -277,7 +279,7 @@ flagFieldDescrs =
showFreeText (munch (const True))
flagDescription (\val fl -> fl{ flagDescription = val })
, simpleField "default"
(text . show) parseBool
disp parse
flagDefault (\val fl -> fl{ flagDefault = val })
]
......@@ -657,8 +659,8 @@ parseField :: [FieldDescr a] -- ^ list of parseable fields
-> (a,[(Int,String)]) -- ^ accumulated result and warnings
-> Field -- ^ the field to be parsed
-> ParseResult (a, [(Int,String)])
parseField ((FieldDescr name _ parse):fields) unrec (a, us) (F line f val)
| name == f = parse line val a >>= \a' -> return (a',us)
parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val)
| name == f = parser line val a >>= \a' -> return (a',us)
| otherwise = parseField fields unrec (a,us) (F line f val)
parseField [] unrec (a,us) (F l f val) = return $
case unrec (f,val) a of -- no fields matched, see if the 'unrec'
......
......@@ -55,7 +55,7 @@ module Distribution.ParseUtils (
parseSepList, parseCommaList, parseOptCommaList,
showFilePath, showToken, showTestedWith, showFreeText,
field, simpleField, listField, commaListField, optsField, liftField,
parseReadS, parseReadSQ, parseQuoted, parseBool,
parseReadS, parseReadSQ, parseQuoted,
UnrecFieldParser, warnUnrec, ignoreUnrec,
) where
......@@ -502,10 +502,6 @@ parseFilePathQ = parseTokenQ
parseReadS :: Read a => ReadP r a
parseReadS = readS_to_P reads
parseBool :: ReadP r Bool
parseBool = choice [ (string "true" <++ string "True") >> return True
, (string "false" <++ string "False") >> return False ]
parseBuildTool :: ReadP r Dependency
parseBuildTool = do name <- parseBuildToolNameQ
skipSpaces
......
......@@ -83,6 +83,8 @@ import Data.List (sortBy)
import Data.Maybe
import Data.Monoid
import qualified Distribution.GetOpt as GetOpt
import Distribution.Text
( Text(parse) )
import Distribution.ParseUtils
import Distribution.ReadE
import Text.PrettyPrint.HughesPJ ( punctuate, cat, comma, text, empty)
......@@ -272,7 +274,7 @@ viewAsFieldDescr (OptionField n dd) = FieldDescr n get set
ChoiceOpt{} -> case getChoiceByLongFlag optDescr val of
Just f -> return (f a)
_ -> syntaxError line val
BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parseBool val
BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val
OptArg _ _ _ _readE _ _ -> -- The behaviour in this case is not clear, and it has no use so far,
-- so we avoid future surprises by not implementing it.
error "Command.optionToFieldDescr: feature not implemented"
......
module Distribution.Text (
Text(..),
display,
simpleParse,
) where
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
import qualified Data.Char as Char (isSpace)
class Text a where
disp :: a -> Disp.Doc
parse :: Parse.ReadP r a
display :: Text a => a -> String
display = Disp.render . disp
simpleParse :: Text a => String -> Maybe a
simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str
, all Char.isSpace s ] of
[] -> Nothing
(p:_) -> Just p
-- -----------------------------------------------------------------------------
-- Instances for types from the base package
instance Text Bool where
disp = Disp.text . show
parse = Parse.choice [ (Parse.string "true" Parse.<++
Parse.string "True") >> return True
, (Parse.string "false" Parse.<++
Parse.string "False") >> return False ]
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