Commit efff91c0 authored by Oleg Grenrus's avatar Oleg Grenrus

Separate modifiers by space in TotalIndexState

parent 30da456b
{-# 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
......
......@@ -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
......
......@@ -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 "_-."
......@@ -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
......
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