{-# LANGUAGE FlexibleContexts #-}

-- | A simple parser for human-readable range strings, designed for CLI programs.
--
-- By default, ranges are separated by commas and span endpoints by a hyphen:
--
-- >>> parseRanges "-5,8-10,13-15,20-" :: Either ParseError (Ranges Integer)
-- Right (Ranges [ubi 5,8 +=+ 10,13 +=+ 15,lbi 20])
--
-- The @*@ wildcard produces an infinite range:
--
-- >>> parseRanges "*" :: Either ParseError (Ranges Integer)
-- Right (Ranges [inf])
--
-- Use 'customParseRanges' to change the separator characters:
--
-- >>> let args = defaultArgs { unionSeparator = ";", rangeSeparator = ".." }
-- >>> customParseRanges args "1..5;10" :: Either ParseError (Ranges Integer)
-- Right (Ranges [1 +=+ 5,SingletonRange 10])
--
-- __Known limitations:__
--
-- * Only non-negative integer literals are recognised. The input @\"-5\"@ is parsed
--   as @UpperBoundRange 5@ (an upper-bounded range), not @SingletonRange (-5)@.
--   For negative values, use 'customParseRanges' with a different 'rangeSeparator',
--   or pre-process the input string.
--
-- * Unrecognised input is silently consumed as an empty set rather than producing
--   a parse error. For example, @parseRanges \"abc\"@ returns @Right mempty@. This is a
--   consequence of using 'Text.Parsec.sepBy' internally and is by design for
--   CLI use where partial input is common.
--
-- For more complex parsing (e.g. @.cabal@ or @package.json@ files), parse version
-- strings with Parsec or Alex\/Happy and convert the results into 'Range' values directly,
-- then call 'mergeRanges'.
module Data.Range.Parser
   ( -- * Parsing
     parseRanges
   , customParseRanges
     -- * Configuration
   , RangeParserArgs(..)
   , defaultArgs
     -- * Lower-level parser
   , ranges
     -- * Re-exports
     -- | 'ParseError' is re-exported from "Text.Parsec" for convenience, so
     -- callers do not need to import Parsec directly just to match on parse failures.
   , ParseError
   ) where

-- $setup
-- >>> import Data.Ranges
-- >>> import Data.Range.Parser

import Text.Parsec
import Text.Parsec.String

import Data.Ranges

-- | Configuration for the range parser. All three fields are plain strings, so
-- multi-character separators (e.g. @\"..\"@) are supported.
data RangeParserArgs = Args
   { RangeParserArgs -> String
unionSeparator :: String -- ^ Separates multiple ranges in a union. Default: @\",\"@.
   , RangeParserArgs -> String
rangeSeparator :: String -- ^ Separates the two endpoints of a span. Default: @\"-\"@.
   , RangeParserArgs -> String
wildcardSymbol :: String -- ^ Symbol for an infinite range. Default: @\"*\"@.
   }
   deriving(Int -> RangeParserArgs -> ShowS
[RangeParserArgs] -> ShowS
RangeParserArgs -> String
(Int -> RangeParserArgs -> ShowS)
-> (RangeParserArgs -> String)
-> ([RangeParserArgs] -> ShowS)
-> Show RangeParserArgs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RangeParserArgs -> ShowS
showsPrec :: Int -> RangeParserArgs -> ShowS
$cshow :: RangeParserArgs -> String
show :: RangeParserArgs -> String
$cshowList :: [RangeParserArgs] -> ShowS
showList :: [RangeParserArgs] -> ShowS
Show)

-- | The default parser configuration: comma-separated ranges, hyphen-separated
-- endpoints, and @*@ as the wildcard. Modify individual fields with record syntax:
--
-- >>> defaultArgs { unionSeparator = ";", rangeSeparator = ".." }
-- Args {unionSeparator = ";", rangeSeparator = "..", wildcardSymbol = "*"}
defaultArgs :: RangeParserArgs
defaultArgs :: RangeParserArgs
defaultArgs = Args
   { unionSeparator :: String
unionSeparator = String
","
   , rangeSeparator :: String
rangeSeparator = String
"-"
   , wildcardSymbol :: String
wildcardSymbol = String
"*"
   }

-- | Parses a range string using the default separators (@,@ and @-@). Returns
-- either a 'ParseError' or a canonicalised 'Ranges' value ready for membership
-- testing and set operations.
--
-- The 'Read' instance of @a@ is used to parse individual numeric literals, so
-- the type must have a well-behaved 'Read'. Exotic types with unusual 'Read'
-- instances may not parse correctly.
--
-- See the module documentation for known limitations around negative numbers
-- and unrecognised input.
parseRanges :: (Read a, Ord a) => String -> Either ParseError (Ranges a)
parseRanges :: forall a. (Read a, Ord a) => String -> Either ParseError (Ranges a)
parseRanges = ([Range a] -> Ranges a)
-> Either ParseError [Range a] -> Either ParseError (Ranges a)
forall a b. (a -> b) -> Either ParseError a -> Either ParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Range a] -> Ranges a
forall a. Ord a => [Range a] -> Ranges a
mergeRanges (Either ParseError [Range a] -> Either ParseError (Ranges a))
-> (String -> Either ParseError [Range a])
-> String
-> Either ParseError (Ranges a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec String () [Range a]
-> String -> String -> Either ParseError [Range a]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (RangeParserArgs -> Parsec String () [Range a]
forall a. Read a => RangeParserArgs -> Parser [Range a]
ranges RangeParserArgs
defaultArgs) String
"(range parser)"

-- | Like 'parseRanges' but with caller-supplied separator configuration.
-- Use this when the default @,@ and @-@ characters conflict with your input format.
--
-- >>> let args = defaultArgs { unionSeparator = ";", rangeSeparator = ".." }
-- >>> customParseRanges args "1..5;10" :: Either ParseError (Ranges Integer)
-- Right (Ranges [1 +=+ 5,SingletonRange 10])
customParseRanges :: (Read a, Ord a) => RangeParserArgs -> String -> Either ParseError (Ranges a)
customParseRanges :: forall a.
(Read a, Ord a) =>
RangeParserArgs -> String -> Either ParseError (Ranges a)
customParseRanges RangeParserArgs
args = ([Range a] -> Ranges a)
-> Either ParseError [Range a] -> Either ParseError (Ranges a)
forall a b. (a -> b) -> Either ParseError a -> Either ParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Range a] -> Ranges a
forall a. Ord a => [Range a] -> Ranges a
mergeRanges (Either ParseError [Range a] -> Either ParseError (Ranges a))
-> (String -> Either ParseError [Range a])
-> String
-> Either ParseError (Ranges a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec String () [Range a]
-> String -> String -> Either ParseError [Range a]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (RangeParserArgs -> Parsec String () [Range a]
forall a. Read a => RangeParserArgs -> Parser [Range a]
ranges RangeParserArgs
args) String
"(range parser)"

string_ :: Stream s m Char => String -> ParsecT s u m ()
string_ :: forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m ()
string_ String
x = String -> ParsecT s u m String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
x ParsecT s u m String -> ParsecT s u m () -> ParsecT s u m ()
forall a b. ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ParsecT s u m ()
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Returns a Parsec 'Parser' for a list of ranges using the given configuration.
-- Use this when embedding range parsing into a larger Parsec grammar; for
-- standalone parsing prefer 'parseRanges' or 'customParseRanges'.
--
-- The returned list is unmerged — call 'mergeRanges' on the result to produce
-- a canonical 'Ranges' value.
ranges :: (Read a) => RangeParserArgs -> Parser [Range a]
ranges :: forall a. Read a => RangeParserArgs -> Parser [Range a]
ranges RangeParserArgs
args = Parser (Range a)
forall a. Read a => Parser (Range a)
range Parser (Range a)
-> ParsecT String () Identity String
-> ParsecT String () Identity [Range a]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string (String -> ParsecT String () Identity String)
-> String -> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ RangeParserArgs -> String
unionSeparator RangeParserArgs
args)
   where
      range :: (Read a) => Parser (Range a)
      range :: forall a. Read a => Parser (Range a)
range = [ParsecT String () Identity (Range a)]
-> ParsecT String () Identity (Range a)
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice
         [ ParsecT String () Identity (Range a)
forall a. Read a => Parser (Range a)
infiniteRange
         , ParsecT String () Identity (Range a)
forall a. Read a => Parser (Range a)
spanRange
         , ParsecT String () Identity (Range a)
forall a. Read a => Parser (Range a)
singletonRange
         ]

      infiniteRange :: (Read a) => Parser (Range a)
      infiniteRange :: forall a. Read a => Parser (Range a)
infiniteRange = do
         String -> ParsecT String () Identity ()
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m ()
string_ (String -> ParsecT String () Identity ())
-> String -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ RangeParserArgs -> String
wildcardSymbol RangeParserArgs
args
         Range a -> ParsecT String () Identity (Range a)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Range a
forall a. Range a
InfiniteRange

      spanRange :: (Read a) => Parser (Range a)
      spanRange :: forall a. Read a => Parser (Range a)
spanRange = ParsecT String () Identity (Range a)
-> ParsecT String () Identity (Range a)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () Identity (Range a)
 -> ParsecT String () Identity (Range a))
-> ParsecT String () Identity (Range a)
-> ParsecT String () Identity (Range a)
forall a b. (a -> b) -> a -> b
$ do
         first <- Parser (Maybe a)
forall a. Read a => Parser (Maybe a)
readSection
         string_ $ rangeSeparator args
         second <- readSection
         case (first, second) of
            (Just a
x, Just a
y)  -> Range a -> ParsecT String () Identity (Range a)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Range a -> ParsecT String () Identity (Range a))
-> Range a -> ParsecT String () Identity (Range a)
forall a b. (a -> b) -> a -> b
$ Bound a -> Bound a -> Range a
forall a. Bound a -> Bound a -> Range a
SpanRange (a -> BoundType -> Bound a
forall a. a -> BoundType -> Bound a
Bound a
x BoundType
Inclusive) (a -> BoundType -> Bound a
forall a. a -> BoundType -> Bound a
Bound a
y BoundType
Inclusive)
            (Just a
x, Maybe a
_)       -> Range a -> ParsecT String () Identity (Range a)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Range a -> ParsecT String () Identity (Range a))
-> Range a -> ParsecT String () Identity (Range a)
forall a b. (a -> b) -> a -> b
$ Bound a -> Range a
forall a. Bound a -> Range a
LowerBoundRange (a -> BoundType -> Bound a
forall a. a -> BoundType -> Bound a
Bound a
x BoundType
Inclusive)
            (Maybe a
_, Just a
y)       -> Range a -> ParsecT String () Identity (Range a)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Range a -> ParsecT String () Identity (Range a))
-> Range a -> ParsecT String () Identity (Range a)
forall a b. (a -> b) -> a -> b
$ Bound a -> Range a
forall a. Bound a -> Range a
UpperBoundRange (a -> BoundType -> Bound a
forall a. a -> BoundType -> Bound a
Bound a
y BoundType
Inclusive)
            (Maybe a, Maybe a)
_                 -> String -> ParsecT String () Identity (Range a)
forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail (String
"Range should have a number on one end: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RangeParserArgs -> String
rangeSeparator RangeParserArgs
args)

      singletonRange :: (Read a) => Parser (Range a)
      singletonRange :: forall a. Read a => Parser (Range a)
singletonRange = (String -> Range a)
-> ParsecT String () Identity String
-> ParsecT String () Identity (Range a)
forall a b.
(a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Range a
forall a. a -> Range a
SingletonRange (a -> Range a) -> (String -> a) -> String -> Range a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. Read a => String -> a
read) (ParsecT String () Identity String
 -> ParsecT String () Identity (Range a))
-> ParsecT String () Identity String
-> ParsecT String () Identity (Range a)
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

readSection :: (Read a) => Parser (Maybe a)
readSection :: forall a. Read a => Parser (Maybe a)
readSection = (Maybe String -> Maybe a)
-> ParsecT String () Identity (Maybe String)
-> ParsecT String () Identity (Maybe a)
forall a b.
(a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> a) -> Maybe String -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> a
forall a. Read a => String -> a
read) (ParsecT String () Identity (Maybe String)
 -> ParsecT String () Identity (Maybe a))
-> ParsecT String () Identity (Maybe String)
-> ParsecT String () Identity (Maybe a)
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity String
-> ParsecT String () Identity (Maybe String)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)