Use Pretty/Parsec in Init (remote Text Category instance)

Author: phadej

cabal-install/Distribution/Client/Init/FileCreators.hs

@@ -65,8 +65,6 @@ import Distribution.Client.Init.Types
 import Distribution.CabalSpecVersion
 import Distribution.Compat.Newtype
   ( Newtype )
-import Distribution.Deprecated.Text
-  ( display, Text(..) )
 import Distribution.Fields.Field
   ( FieldName )
 import Distribution.License
@@ -166,8 +164,8 @@ writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc
     , ""
     , "* First version. Released on an unsuspecting world."
     ]
-  pname = maybe "" display $ flagToMaybe $ packageName flags
-  pver = maybe "" display $ flagToMaybe $ version flags
+  pname = maybe "" prettyShow $ flagToMaybe $ packageName flags
+  pver = maybe "" prettyShow $ flagToMaybe $ version flags
 
 -- | Creates and writes the initialized .cabal file.
 --
@@ -177,7 +175,7 @@ writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do
   message flags "Error: no package name provided."
   return False
 writeCabalFile flags@(InitFlags{packageName = Flag p}) = do
-  let cabalFileName = display p ++ ".cabal"
+  let cabalFileName = prettyShow p ++ ".cabal"
   message flags $ "Generating " ++ cabalFileName ++ "..."
   writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)
   return True
@@ -415,7 +413,7 @@ generateCabalFile fileName c =
            ["A copyright notice."]
            True
 
-  , fieldS "category"      (either id display `fmap` category c)
+  , fieldS "category"      (either id prettyShow `fmap` category c)
            []
            True
 
@@ -500,13 +498,13 @@ generateCabalFile fileName c =
 
    -- | Construct a 'PrettyField' from a field that can be automatically
    --   converted to a 'Doc' via 'display'.
-   field :: Text t
+   field :: Pretty t
          => FieldName
          -> Flag t
          -> [String]
          -> Bool
          -> Maybe (PrettyField FieldAnnotation)
-   field fieldName fieldContentsFlag = fieldS fieldName (display <$> fieldContentsFlag)
+   field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag)
 
    -- | Construct a 'PrettyField' from a 'String' field.
    fieldS :: FieldName   -- ^ Name of the field
@@ -596,7 +594,7 @@ generateCabalFile fileName c =
      ++
      generateBuildInfo ExecBuild c
      where
-       exeName = text (maybe "" display . flagToMaybe $ packageName c)
+       exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c)
 
    libraryStanza :: PrettyField FieldAnnotation
    libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes
@@ -633,7 +631,7 @@ generateCabalFile fileName c =
      ]
      where
        testSuiteName =
-         text (maybe "" ((++"-test") . display) . flagToMaybe $ packageName c)
+         text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c)
 
 -- | Annotations for cabal file PrettyField.
 data FieldAnnotation = FieldAnnotation

cabal-install/Distribution/Client/Init/Prompt.hs

@@ -26,17 +26,15 @@ module Distribution.Client.Init.Prompt (
 import Prelude ()
 import Distribution.Client.Compat.Prelude hiding (empty)
 
-import Distribution.Deprecated.ReadP (readP_to_E)
-
 import Control.Monad
   ( mapM_ )
 
 import Distribution.Client.Init.Types
   ( InitFlags(..) )
-import Distribution.Deprecated.Text
-  ( display, Text(..) )
-import Distribution.ReadE
-  ( runReadE )
+import Distribution.Parsec
+  ( Parsec, simpleParsec )
+import Distribution.Pretty
+  ( Pretty, prettyShow )
 import Distribution.Simple.Setup
   ( Flag(..) )
 
@@ -69,10 +67,8 @@ promptYesNo =
 
 -- | Create a prompt with optional default value that returns a value
 --   of some Text instance.
-prompt :: Text t => String -> Maybe t -> IO t
-prompt = promptDefault'
-           (either (const Nothing) Just . runReadE (readP_to_E id parse))
-           display
+prompt :: (Parsec t, Pretty t) => String -> Maybe t -> IO t
+prompt = promptDefault' simpleParsec prettyShow
 
 -- | Create a prompt with an optional default value.
 promptDefault' :: (String -> Maybe t)       -- ^ parser
@@ -99,11 +95,11 @@ mkDefPrompt pr def = pr ++ "?" ++ defStr def
 
 -- | Create a prompt from a list of items, where no selected items is
 --   valid and will be represented as a return value of 'Nothing'.
-promptListOptional :: (Text t, Eq t)
+promptListOptional :: (Pretty t, Eq t)
                    => String            -- ^ prompt
                    -> [t]               -- ^ choices
                    -> IO (Maybe (Either String t))
-promptListOptional pr choices = promptListOptional' pr choices display
+promptListOptional pr choices = promptListOptional' pr choices prettyShow
 
 promptListOptional' :: Eq t
                    => String            -- ^ prompt

cabal-install/Distribution/Client/Init/Types.hs

@@ -15,10 +15,12 @@
 -----------------------------------------------------------------------------
 module Distribution.Client.Init.Types where
 
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
 import Distribution.Simple.Setup (Flag(..), toFlag )
 
 import Distribution.Types.Dependency as P
-import Distribution.Compat.Semigroup
 import Distribution.Version
 import Distribution.Verbosity
 import qualified Distribution.Package as P
@@ -28,10 +30,10 @@ import Distribution.CabalSpecVersion
 import Language.Haskell.Extension ( Language(..), Extension )
 
 import qualified Text.PrettyPrint as Disp
-import qualified Distribution.Deprecated.ReadP as Parse
-import Distribution.Deprecated.Text
-
-import GHC.Generics ( Generic )
+import qualified Distribution.Compat.CharParsing as P
+import qualified Data.Map as Map
+import Distribution.Pretty (Pretty (..))
+import Distribution.Parsec (Parsec (..))
 
 -- | InitFlags is really just a simple type to represent certain
 --   portions of a .cabal file.  Rather than have a flag for EVERY
@@ -129,6 +131,14 @@ data Category
     | Web
     deriving (Read, Show, Eq, Ord, Bounded, Enum)
 
-instance Text Category where
-  disp  = Disp.text . show
-  parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -- TODO: eradicateNoParse
+instance Pretty Category where
+  pretty = Disp.text . show
+
+instance Parsec Category where
+  parsec = do
+    name <- P.munch1 isAlpha
+    case Map.lookup name names of
+      Just cat -> pure cat
+      _        -> P.unexpected $ "Category: " ++ name
+    where
+      names = Map.fromList [ (show cat, cat) | cat <- [ minBound .. maxBound ] ]