Merge pull request #6682 from phadej/space-comma-in-total-index-state

Separate modifiers by space in TotalIndexState

Cabal/Distribution/FieldGrammar/Described.hs

-{-# LANGUAGE DeriveFoldable      #-}
-{-# LANGUAGE DeriveFunctor       #-}
-{-# LANGUAGE DeriveTraversable   #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Distribution.FieldGrammar.Described (
@@ -28,6 +25,7 @@ module Distribution.FieldGrammar.Described (
     reOptCommaList,
     -- * Character Sets
     csChar,
+    csAlpha,
     csAlphaNum,
     csUpper,
     csNotSpace,
@@ -126,6 +124,9 @@ reSpacedComma = RESpaces <> reComma <> RESpaces
 csChar :: Char -> CS.CharSet
 csChar = CS.singleton
 
+csAlpha :: CS.CharSet
+csAlpha = CS.alpha
+
 csAlphaNum :: CS.CharSet
 csAlphaNum = CS.alphanum
 

cabal-install/Distribution/Client/IndexUtils/IndexState.hs

@@ -22,13 +22,16 @@ import Distribution.Client.IndexUtils.Timestamp (Timestamp)
 import Distribution.Client.Types.RepoName       (RepoName (..))
 
 import Distribution.FieldGrammar.Described
-import Distribution.Parsec                 (Parsec (..))
+import Distribution.Parsec                 (Parsec (..), parsecLeadingCommaList)
 import Distribution.Pretty                 (Pretty (..))
 
 import qualified Data.Map.Strict                 as Map
 import qualified Distribution.Compat.CharParsing as P
 import qualified Text.PrettyPrint                as Disp
 
+-- $setup
+-- >>> import Distribution.Parsec
+
 -------------------------------------------------------------------------------
 -- Total index state
 -------------------------------------------------------------------------------
@@ -44,33 +47,41 @@ instance NFData TotalIndexState
 instance Pretty TotalIndexState where
     pretty (TIS IndexStateHead m)
         | not (Map.null m)
-        = Disp.hsep
-            [ pretty rn <<>> Disp.colon <<>> pretty idx
+        = Disp.hsep $ Disp.punctuate Disp.comma
+            [ pretty rn Disp.<+> pretty idx
             | (rn, idx) <- Map.toList m
             ]
     pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where
-        go doc (rn, idx) = doc Disp.<+> pretty rn <<>> Disp.colon <<>> pretty idx
+        go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx
 
+-- |
+--
+-- >>> simpleParsec "HEAD" :: Maybe TotalIndexState
+-- Just (TIS IndexStateHead (fromList []))
+--
+-- >>> simpleParsec "" :: Maybe TotalIndexState
+-- Just (TIS IndexStateHead (fromList []))
+--
+-- >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState
+-- Just (TIS IndexStateHead (fromList []))
+--
+-- >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState
+-- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName "hackage.haskell.org",IndexStateHead)]))
+--
+-- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState
+-- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))]))
+--
 instance Parsec TotalIndexState where
-    parsec = normalise . foldl' add headTotalIndexState <$> some (single0 <* P.spaces) where
-        -- hard to do without try
-        -- 2020-03-21T11:22:33Z looks like it begins with
-        -- repository name 2020-03-21T11
-        --
-        -- To make this easy, we could forbid repository names starting with digit
-        --
-        single0 = P.try single1 <|> TokTimestamp <$> parsec
-        single1 = do
-            token <- P.munch1 (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
-            single2 token <|> single3 token
-
-        single2 token = do
-            _   <- P.char ':'
-            idx <- parsec
-            return (TokRepo (RepoName token) idx)
-
-        single3 "HEAD" = return TokHead
-        single3 token  = P.unexpected ("Repository " ++ token ++ " without index state (after comma)")
+    parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaList single0 where
+        single0 = startsWithRepoName <|> TokTimestamp <$> parsec
+        startsWithRepoName = do
+            reponame <- parsec
+            -- the "HEAD" is technically a valid reponame...
+            if reponame == RepoName "HEAD"
+            then return TokHead
+            else do
+                P.spaces
+                TokRepo reponame <$> parsec
 
         add :: TotalIndexState -> Tok -> TotalIndexState
         add _           TokHead           = headTotalIndexState
@@ -78,8 +89,8 @@ instance Parsec TotalIndexState where
         add (TIS def m) (TokRepo rn idx)  = TIS def (Map.insert rn idx m)
 
 instance Described TotalIndexState where
-    describe _ = REMunch1 RESpaces1 $ REUnion
-        [ describe (Proxy :: Proxy RepoName) <> reChar ':' <> ris
+    describe _ = reCommaList $ REUnion
+        [ describe (Proxy :: Proxy RepoName) <> RESpaces1 <> ris
         , ris
         ]
       where

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

@@ -7,13 +7,16 @@ module Distribution.Client.Types.RepoName (
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
-import Distribution.FieldGrammar.Described (Described (..), csAlphaNum, reMunch1CS)
+import Distribution.FieldGrammar.Described (Described (..), Regex (..), csAlpha, csAlphaNum, reMunchCS)
 import Distribution.Parsec                 (Parsec (..))
 import Distribution.Pretty                 (Pretty (..))
 
 import qualified Distribution.Compat.CharParsing as P
 import qualified Text.PrettyPrint                as Disp
 
+-- $setup
+-- >>> import Distribution.Parsec
+
 -- | Repository name.
 --
 -- May be used as path segment.
@@ -31,9 +34,21 @@ instance NFData RepoName
 instance Pretty RepoName where
     pretty = Disp.text . unRepoName
 
+-- |
+--
+-- >>> simpleParsec "hackage.haskell.org" :: Maybe RepoName
+-- Just (RepoName "hackage.haskell.org")
+--
+-- >>> simpleParsec "0123" :: Maybe RepoName
+-- Nothing
+--
 instance Parsec RepoName where
-    parsec = RepoName <$>
-        P.munch1 (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
+    parsec = RepoName <$> parser where
+        parser = (:) <$> lead <*> rest
+        lead = P.satisfy (\c -> isAlpha    c || c == '_' || c == '-' || c == '.')
+        rest = P.munch   (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
 
 instance Described RepoName where
-    describe _ = reMunch1CS $ csAlphaNum <> fromString "_-."
+    describe _ = lead <> rest where
+        lead = RECharSet $ csAlpha    <> fromString "_-."
+        rest = reMunchCS $ csAlphaNum <> fromString "_-."

cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs

@@ -152,7 +152,11 @@ arbitraryFlag :: Gen a -> Gen (Flag a)
 arbitraryFlag = liftArbitrary
 
 instance Arbitrary RepoName where
-    arbitrary = RepoName <$> listOf1 (elements
+    arbitrary = RepoName <$> mk where
+      mk = (:) <$> lead <*> rest
+      lead = elements
+        [ c | c <- [ '\NUL' .. '\255' ], isAlpha c || c `elem` "_-."]
+      rest = listOf (elements
         [ c | c <- [ '\NUL' .. '\255' ], isAlphaNum c || c `elem` "_-."])
 
 instance Arbitrary ReportLevel where