Migrate Text instances to Pretty/Parsec (part 4)

Distribution/Client/UploadLog.hs

@@ -28,6 +28,10 @@ import Distribution.Package
          ( PackageId, PackageName, packageName, PackageIdentifier(..))
 import Distribution.Text
          ( Text(..), simpleParse )
+import Distribution.Pretty (Pretty(..))
+-- import Distribution.Parsec.Class (Parsec(..))
+-- import qualified Distribution.Parsec.Class as P
+-- import qualified Distribution.Compat.CharParsing as P
 import Distribution.ParseUtils ( parseMaybeQuoted )
 import qualified Distribution.Compat.ReadP as Parse
 import qualified Text.PrettyPrint          as Disp
@@ -50,6 +54,7 @@ import Data.List
 data Entry = Entry UTCTime UserName PackageIdentifier
   deriving (Eq, Ord, Show)
 
+-- TODO: remove this instance for Cabal 3.0
 instance Text Entry where
   disp (Entry time user pkgid) =
         Disp.text (formatTime defaultTimeLocale "%c" time)
@@ -65,6 +70,28 @@ instance Text Entry where
     let pkgid = PackageIdentifier pkg ver
     return (Entry (zonedTimeToUTC time) user pkgid)
 
+instance Pretty Entry where
+  pretty (Entry time user pkgid) =
+        Disp.text (formatTime defaultTimeLocale "%c" time)
+    <+> pretty user <+> pretty pkgid
+
+{- TODO
+
+instance Parsec Entry where
+  parse = do
+    -- parseDateTimeFmt parses "%a %b %e %H:%M:%S %Z %Y",
+    time <- parseDateTimeFmt
+    P.skipSpaces1
+    user <- parsec
+    P.skipSpaces1
+    pkg  <- parseMaybeQuoted parse
+    P.skipSpaces
+    ver  <- parsec
+    let pkgid = PackageIdentifier pkg ver
+    return (Entry (zonedTimeToUTC time) user pkgid)
+
+-}
+
 -- | Returns a list of log entries, however some packages have been uploaded
 -- more than once, so each entry is paired with any older entries for the same
 -- package.

Distribution/Server/Features/BuildReports/BuildReports.hs

@@ -23,6 +23,11 @@ import Distribution.Server.Features.BuildReports.BuildReport
 
 import Distribution.Package (PackageId)
 import Distribution.Text (Text(..), display)
+import Distribution.Pretty (Pretty(..))
+import Distribution.Parsec.Class (Parsec(..))
+import qualified Distribution.Parsec.Class as P
+import qualified Distribution.Compat.Parsing as P
+import qualified Distribution.Compat.CharParsing as P
 
 import Distribution.Server.Framework.MemSize
 import Distribution.Server.Framework.Instances
@@ -34,22 +39,41 @@ import Data.Serialize (Serialize)
 import Data.SafeCopy
 import Data.Typeable (Typeable)
 import Control.Applicative ((<$>))
+import qualified Data.List as L
+import qualified Data.Char as Char
 
 import qualified Distribution.Server.Util.Parse as Parse
 import qualified Text.PrettyPrint          as Disp
 import Text.StringTemplate (ToSElem(..))
 
 
 newtype BuildReportId = BuildReportId Int
-  deriving (Eq, Ord, Typeable, Show, MemSize)
+  deriving (Eq, Ord, Typeable, Show, MemSize, Pretty)
 
 incrementReportId :: BuildReportId -> BuildReportId
 incrementReportId (BuildReportId n) = BuildReportId (n+1)
 
+-- TODO: remove this instance for Cabal 3.0
 instance Text BuildReportId where
   disp (BuildReportId n) = Disp.int n
   parse = BuildReportId <$> Parse.int
 
+-- TODO: factor out common code
+instance Parsec BuildReportId where
+  -- parse a non-negative integer. No redundant leading zeros allowed.
+  -- (this is effectively a relabeled versionDigitParser)
+  parsec = (P.some d >>= (fmap BuildReportId . toNumber)) P.<?> "BuildReportId (natural number without redunant leading zeroes)"
+    where
+      toNumber :: P.CabalParsing m => [Int] -> m Int
+      toNumber [0]   = return 0
+      toNumber (0:_) = P.unexpected "BuildReportId with redundant leading zero"
+      -- TODO: Add sanity check this doesn't overflow
+      toNumber xs    = return $ L.foldl' (\a b -> a * 10 + b) 0 xs
+
+      d :: P.CharParsing m => m Int
+      d = f <$> P.satisfyRange '0' '9'
+      f c = Char.ord c - Char.ord '0'
+
 newtype BuildLog = BuildLog BlobStorage.BlobId
   deriving (Eq, Typeable, Show, MemSize)
 

Distribution/Server/Framework/Instances.hs

@@ -28,9 +28,12 @@ import Distribution.Types.PackageName
 import Distribution.Version
 import Distribution.Pretty (Pretty(pretty), prettyShow)
 import Distribution.Parsec.Class (Parsec(..), simpleParsec)
+import qualified Distribution.Compat.CharParsing as P
 
-import Data.Time (Day(..), DiffTime, UTCTime(..))
+import Data.Time (Day(..), DiffTime, UTCTime(..), fromGregorianValid)
 import Control.DeepSeq
+import qualified Data.Char as Char
+import Text.Read (readMaybe)
 
 import Data.Serialize as Serialize
 import Data.SafeCopy hiding (Version)
@@ -307,9 +310,54 @@ instance Text UTCTime where
 instance Pretty Day where
   pretty = PP.text . show
 
+instance Parsec Day where
+  parsec = do
+    -- imitate grammar of Read instance of 'Day' (i.e. "%Y-%m-%d")
+    yyyy <- P.integral
+    P.char '-'
+    mm <- replicateM 2 P.digit
+    P.char '-'
+    dd <- replicateM 2 P.digit
+    case fromGregorianValid yyyy (read mm) (read dd) of
+      Nothing -> fail "invalid Day"
+      Just day -> return day
+
 instance Pretty UTCTime where
   pretty  = PP.text . show
 
+
+instance Parsec UTCTime where
+  parsec = do
+      -- "%Y-%m-%d %H:%M:%S%Q%Z"
+      yyyy <- P.munch1 Char.isDigit
+      P.char '-'
+      mm <- digit2
+      P.char '-'
+      dd <- digit2
+
+      P.skipSpaces1
+
+      h <- digit2
+      P.char ':'
+      m <- digit2
+      P.char ':'
+      s <- digit2
+
+      mq <- optional (liftM2 (:) (P.char '.') (P.munch Char.isDigit))
+
+      P.spaces
+
+      -- TODO: more accurate timezone grammar
+      mtz <- optional (liftM2 (:) (P.satisfy (\c -> Char.isAsciiLower c || Char.isAsciiUpper c || c == '+' || c == '-'))
+                                  (P.munch (\c -> Char.isAsciiLower c || Char.isAsciiUpper c || Char.isDigit c)))
+
+      let tstr = concat [ yyyy, "-", mm, "-", dd, " ", h, ":", m, ":", s, maybe "" id mq, maybe "" (' ':) mtz ]
+
+      case readMaybe tstr of
+        Nothing -> fail "invalid UTCTime"
+        Just t  -> return t
+    where
+      digit2 = replicateM 2 P.digit
 -------------------
 -- Arbitrary instances
 --

Distribution/Server/Packages/Unpack.hs

@@ -35,6 +35,10 @@ import Distribution.Parsec.Common
          ( showPError, showPWarning )
 import Distribution.Text
          ( Text(..), display, simpleParse )
+import Distribution.Pretty (Pretty(..))
+-- import Distribution.Parsec.Class (Parsec(..))
+-- import qualified Distribution.Parsec.Class as P
+-- import qualified Distribution.Compat.CharParsing as P
 import Distribution.Server.Util.ParseSpecVer
 import qualified Distribution.SPDX as SPDX
 import qualified Distribution.License as License
@@ -101,11 +105,15 @@ unpackPackageRaw tarGzFile contents =
   where
     noTime = UTCTime (fromGregorian 1970 1 1) 0
 
+-- | Denotes a PackageId with extra version tags
+--
+-- See also 893de51faf7802db007eedba7d1471da95863c3b which introduced 'TaggedPackageId'
 data TaggedPackageId = TaggedPackageId {
         _taggedPkgName   :: PackageName,
         taggedPkgVersion :: Data.Version.Version
     }
 
+-- TODO: remove this instance for Cabal 3.0
 instance Text TaggedPackageId where
     disp (TaggedPackageId n v)
         | v == Data.Version.Version [] [] = disp n
@@ -116,6 +124,14 @@ instance Text TaggedPackageId where
         v <- (Parse.char '-' >> parse) Parse.<++ return (Data.Version.Version [] [])
         return (TaggedPackageId n v)
 
+instance Pretty TaggedPackageId where
+    pretty (TaggedPackageId n v)
+        | v == Data.Version.Version [] [] = pretty n
+        | otherwise = pretty n Disp.<> Disp.char '-' Disp.<> Disp.text (Data.Version.showVersion v)
+
+-- TODO: 'instance Parsec TaggedPackageId'
+-- see also 893de51faf7802db007eedba7d1471da95863c3b which introduced 'TaggedPackageId' for why this is tricky
+
 tarPackageChecks :: Bool -> UTCTime -> FilePath -> ByteString
                  -> UploadMonad (PackageIdentifier, TarIndex)
 tarPackageChecks lax now tarGzFile contents = do