{-# LANGUAGE CPP                        #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}

{-| Use this module to either:

    * match `Text` with light-weight backtracking patterns, or:

    * parse structured values from `Text`.

    Example usage:

>>> :set -XOverloadedStrings
>>> match ("can" <|> "cat") "cat"
["cat"]
>>> match ("can" <|> "cat") "dog"
[]
>>> match (decimal `sepBy` ",") "1,2,3"
[[1,2,3]]

    This pattern has unlimited backtracking, and will return as many solutions
    as possible:

>>> match (prefix (star anyChar)) "123"
["123","12","1",""]

    Use @do@ notation to structure more complex patterns:

>>> :{
let bit = ("0" *> pure False) <|> ("1" *> pure True) :: Pattern Bool;
    portableBitMap = do
        { "P1"
        ; width  <- spaces1 *> decimal
        ; height <- spaces1 *> decimal
        ; count width (count height (spaces1 *> bit))
        };
in  match (prefix portableBitMap) "P1\n2 2\n0 0\n1 0\n"
:}
[[[False,False],[True,False]]]

-}

module Turtle.Pattern (
    -- * Pattern
      Pattern
    , match

    -- * Primitive patterns
    , anyChar
    , eof

    -- * Character patterns
    , dot
    , satisfy
    , char
    , notChar
    , text
    , asciiCI
    , oneOf
    , noneOf
    , space
    , spaces
    , spaces1
    , tab
    , newline
    , crlf
    , upper
    , lower
    , alphaNum
    , letter
    , digit
    , hexDigit
    , octDigit

    -- * Numbers
    , decimal
    , signed

    -- * Combinators
    , prefix
    , suffix
    , has
    , begins
    , ends
    , contains
    , invert
    , once
    , star
    , plus
    , selfless
    , choice
    , count
    , lowerBounded
    , upperBounded
    , bounded
    , option
    , between
    , skip
    , within
    , fixed
    , sepBy
    , sepBy1

    -- * High-efficiency primitives
    , chars
    , chars1
    ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
import Data.Char
import Data.List (foldl')
import Data.Monoid
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Prelude -- Fix redundant import warnings

-- | A fully backtracking pattern that parses an @\'a\'@ from some `Text`
newtype Pattern a = Pattern { Pattern a -> StateT Text [] a
runPattern :: StateT Text [] a }
    deriving (a -> Pattern b -> Pattern a
(a -> b) -> Pattern a -> Pattern b
(forall a b. (a -> b) -> Pattern a -> Pattern b)
-> (forall a b. a -> Pattern b -> Pattern a) -> Functor Pattern
forall a b. a -> Pattern b -> Pattern a
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Pattern b -> Pattern a
$c<$ :: forall a b. a -> Pattern b -> Pattern a
fmap :: (a -> b) -> Pattern a -> Pattern b
$cfmap :: forall a b. (a -> b) -> Pattern a -> Pattern b
Functor, Functor Pattern
a -> Pattern a
Functor Pattern
-> (forall a. a -> Pattern a)
-> (forall a b. Pattern (a -> b) -> Pattern a -> Pattern b)
-> (forall a b c.
    (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c)
-> (forall a b. Pattern a -> Pattern b -> Pattern b)
-> (forall a b. Pattern a -> Pattern b -> Pattern a)
-> Applicative Pattern
Pattern a -> Pattern b -> Pattern b
Pattern a -> Pattern b -> Pattern a
Pattern (a -> b) -> Pattern a -> Pattern b
(a -> b -> c) -> Pattern a -> Pattern b -> Pattern c
forall a. a -> Pattern a
forall a b. Pattern a -> Pattern b -> Pattern a
forall a b. Pattern a -> Pattern b -> Pattern b
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall a b c. (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Pattern a -> Pattern b -> Pattern a
$c<* :: forall a b. Pattern a -> Pattern b -> Pattern a
*> :: Pattern a -> Pattern b -> Pattern b
$c*> :: forall a b. Pattern a -> Pattern b -> Pattern b
liftA2 :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c
$cliftA2 :: forall a b c. (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c
<*> :: Pattern (a -> b) -> Pattern a -> Pattern b
$c<*> :: forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
pure :: a -> Pattern a
$cpure :: forall a. a -> Pattern a
$cp1Applicative :: Functor Pattern
Applicative, Applicative Pattern
a -> Pattern a
Applicative Pattern
-> (forall a b. Pattern a -> (a -> Pattern b) -> Pattern b)
-> (forall a b. Pattern a -> Pattern b -> Pattern b)
-> (forall a. a -> Pattern a)
-> Monad Pattern
Pattern a -> (a -> Pattern b) -> Pattern b
Pattern a -> Pattern b -> Pattern b
forall a. a -> Pattern a
forall a b. Pattern a -> Pattern b -> Pattern b
forall a b. Pattern a -> (a -> Pattern b) -> Pattern b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Pattern a
$creturn :: forall a. a -> Pattern a
>> :: Pattern a -> Pattern b -> Pattern b
$c>> :: forall a b. Pattern a -> Pattern b -> Pattern b
>>= :: Pattern a -> (a -> Pattern b) -> Pattern b
$c>>= :: forall a b. Pattern a -> (a -> Pattern b) -> Pattern b
$cp1Monad :: Applicative Pattern
Monad, Applicative Pattern
Pattern a
Applicative Pattern
-> (forall a. Pattern a)
-> (forall a. Pattern a -> Pattern a -> Pattern a)
-> (forall a. Pattern a -> Pattern [a])
-> (forall a. Pattern a -> Pattern [a])
-> Alternative Pattern
Pattern a -> Pattern a -> Pattern a
Pattern a -> Pattern [a]
Pattern a -> Pattern [a]
forall a. Pattern a
forall a. Pattern a -> Pattern [a]
forall a. Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: Pattern a -> Pattern [a]
$cmany :: forall a. Pattern a -> Pattern [a]
some :: Pattern a -> Pattern [a]
$csome :: forall a. Pattern a -> Pattern [a]
<|> :: Pattern a -> Pattern a -> Pattern a
$c<|> :: forall a. Pattern a -> Pattern a -> Pattern a
empty :: Pattern a
$cempty :: forall a. Pattern a
$cp1Alternative :: Applicative Pattern
Alternative, Monad Pattern
Alternative Pattern
Pattern a
Alternative Pattern
-> Monad Pattern
-> (forall a. Pattern a)
-> (forall a. Pattern a -> Pattern a -> Pattern a)
-> MonadPlus Pattern
Pattern a -> Pattern a -> Pattern a
forall a. Pattern a
forall a. Pattern a -> Pattern a -> Pattern a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: Pattern a -> Pattern a -> Pattern a
$cmplus :: forall a. Pattern a -> Pattern a -> Pattern a
mzero :: Pattern a
$cmzero :: forall a. Pattern a
$cp2MonadPlus :: Monad Pattern
$cp1MonadPlus :: Alternative Pattern
MonadPlus)

#if __GLASGOW_HASKELL__ >= 804
instance Monoid a => Semigroup (Pattern a) where
  <> :: Pattern a -> Pattern a -> Pattern a
(<>) = Pattern a -> Pattern a -> Pattern a
forall a. Monoid a => a -> a -> a
mappend
#endif

instance Monoid a => Monoid (Pattern a) where
    mempty :: Pattern a
mempty  = a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
    mappend :: Pattern a -> Pattern a -> Pattern a
mappend = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend

-- | Pattern forms a semiring, this is the closest approximation
instance Monoid a => Num (Pattern a) where
    fromInteger :: Integer -> Pattern a
fromInteger Integer
n = StateT Text [] a -> Pattern a
forall a. StateT Text [] a -> Pattern a
Pattern ([a] -> StateT Text [] a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) a
forall a. Monoid a => a
mempty))
    + :: Pattern a -> Pattern a -> Pattern a
(+) = Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
    * :: Pattern a -> Pattern a -> Pattern a
(*) = Pattern a -> Pattern a -> Pattern a
forall a. Semigroup a => a -> a -> a
(<>)

instance (a ~ Text) => IsString (Pattern a) where
    fromString :: String -> Pattern a
fromString String
str = Text -> Pattern Text
text (String -> Text
Text.pack String
str)

{-| Match a `Pattern` against a `Text` input, returning all possible solutions

    The `Pattern` must match the entire `Text`
-}
match :: Pattern a -> Text -> [a]
match :: Pattern a -> Text -> [a]
match Pattern a
p = StateT Text [] a -> Text -> [a]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Pattern a -> StateT Text [] a
forall a. Pattern a -> StateT Text [] a
runPattern (Pattern a
p Pattern a -> Pattern () -> Pattern a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Pattern ()
eof))

{-| Match any character

>>> match anyChar "1"
"1"
>>> match anyChar ""
""
-}
anyChar :: Pattern Char
anyChar :: Pattern Char
anyChar = StateT Text [] Char -> Pattern Char
forall a. StateT Text [] a -> Pattern a
Pattern (do
    Just (Char
c, Text
cs) <- (Text -> Maybe (Char, Text))
-> StateT Text [] Text -> StateT Text [] (Maybe (Char, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe (Char, Text)
Text.uncons StateT Text [] Text
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Text -> StateT Text [] ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Text
cs
    Char -> StateT Text [] Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c )

{-| Matches the end of input

>>> match eof "1"
[]
>>> match eof ""
[()]
-}
eof :: Pattern ()
eof :: Pattern ()
eof = StateT Text [] () -> Pattern ()
forall a. StateT Text [] a -> Pattern a
Pattern (do
    Bool
True <- (Text -> Bool) -> StateT Text [] Text -> StateT Text [] Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Bool
Text.null StateT Text [] Text
forall (m :: * -> *) s. Monad m => StateT s m s
get
    () -> StateT Text [] ()
forall (m :: * -> *) a. Monad m => a -> m a
return () )

-- | Synonym for `anyChar`
dot :: Pattern Char
dot :: Pattern Char
dot = Pattern Char
anyChar

{-| Match any character that satisfies the given predicate

>>> match (satisfy (== '1')) "1"
"1"
>>> match (satisfy (== '2')) "1"
""
-}
satisfy :: (Char -> Bool) -> Pattern Char
satisfy :: (Char -> Bool) -> Pattern Char
satisfy Char -> Bool
predicate = do
    Char
c <- Pattern Char
anyChar
    Bool -> Pattern ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char -> Bool
predicate Char
c)
    Char -> Pattern Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c

{-| Match a specific character

>>> match (char '1') "1"
"1"
>>> match (char '2') "1"
""
-}
char :: Char -> Pattern Char
char :: Char -> Pattern Char
char Char
c = (Char -> Bool) -> Pattern Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)

{-| Match any character except the given one

>>> match (notChar '2') "1"
"1"
>>> match (notChar '1') "1"
""
-}
notChar :: Char -> Pattern Char
notChar :: Char -> Pattern Char
notChar Char
c = (Char -> Bool) -> Pattern Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c)

{-| Match a specific string

>>> match (text "123") "123"
["123"]

    You can also omit the `text` function if you enable the @OverloadedStrings@
    extension:

>>> match "123" "123"
["123"]
-}
text :: Text -> Pattern Text
text :: Text -> Pattern Text
text Text
before' = StateT Text [] Text -> Pattern Text
forall a. StateT Text [] a -> Pattern a
Pattern (do
    Text
txt <- StateT Text [] Text
forall (m :: * -> *) s. Monad m => StateT s m s
get
    let (Text
before, Text
after) = Int -> Text -> (Text, Text)
Text.splitAt (Text -> Int
Text.length Text
before') Text
txt
    Bool -> StateT Text [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
before Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
before')
    Text -> StateT Text [] ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Text
after
    Text -> StateT Text [] Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
before)

{-| Match a specific string in a case-insensitive way

    This only handles ASCII strings

>>> match (asciiCI "abc") "ABC"
["ABC"]
-}
asciiCI :: Text -> Pattern Text
asciiCI :: Text -> Pattern Text
asciiCI Text
before' = StateT Text [] Text -> Pattern Text
forall a. StateT Text [] a -> Pattern a
Pattern (do
    Text
txt <- StateT Text [] Text
forall (m :: * -> *) s. Monad m => StateT s m s
get
    let (Text
before, Text
after) = Int -> Text -> (Text, Text)
Text.splitAt (Text -> Int
Text.length Text
before') Text
txt
    Bool -> StateT Text [] ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Text
lowerChars Text
before Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
lowerChars Text
before')
    Text -> StateT Text [] ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Text
after
    Text -> StateT Text [] Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
before )
  where
    lowerChars :: Text -> Text
lowerChars = (Char -> Char) -> Text -> Text
Text.map Char -> Char
lowerChar
    lowerChar :: Char -> Char
lowerChar Char
c | Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Int -> Char
chr (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A')
                | Bool
otherwise            = Char
c

{-| Match any one of the given characters

>>> match (oneOf "1a") "1"
"1"
>>> match (oneOf "2a") "1"
""
-}
oneOf :: [Char] -> Pattern Char
oneOf :: String -> Pattern Char
oneOf String
cs = (Char -> Bool) -> Pattern Char
satisfy (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
cs)

{-| Match anything other than the given characters

>>> match (noneOf "2a") "1"
"1"
>>> match (noneOf "1a") "1"
""
-}
noneOf :: [Char] -> Pattern Char
noneOf :: String -> Pattern Char
noneOf String
cs = (Char -> Bool) -> Pattern Char
satisfy (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
cs)

{-| Match a whitespace character

>>> match space " "
" "
>>> match space "1"
""
-}
space :: Pattern Char
space :: Pattern Char
space = (Char -> Bool) -> Pattern Char
satisfy Char -> Bool
isSpace

{-| Match zero or more whitespace characters

>>> match spaces "  "
["  "]
>>> match spaces ""
[""]
-}
spaces :: Pattern Text
spaces :: Pattern Text
spaces = Pattern Char -> Pattern Text
star Pattern Char
space

{-| Match one or more whitespace characters

>>> match spaces1 "  "
["  "]
>>> match spaces1 ""
[]
-}
spaces1 :: Pattern Text
spaces1 :: Pattern Text
spaces1 = Pattern Char -> Pattern Text
plus Pattern Char
space

{-| Match the tab character (@\'\t\'@)

>>> match tab "\t"
"\t"
>>> match tab " "
""
-}
tab :: Pattern Char
tab :: Pattern Char
tab = Char -> Pattern Char
char Char
'\t'

{-| Match the newline character (@\'\n\'@)

>>> match newline "\n"
"\n"
>>> match newline " "
""
-}
newline :: Pattern Char
newline :: Pattern Char
newline = Char -> Pattern Char
char Char
'\n'

{-| Matches a carriage return (@\'\r\'@) followed by a newline (@\'\n\'@)

>>> match crlf "\r\n"
["\r\n"]
>>> match crlf "\n\r"
[]
-}
crlf :: Pattern Text
crlf :: Pattern Text
crlf = Text -> Pattern Text
text Text
"\r\n"

{-| Match an uppercase letter

>>> match upper "A"
"A"
>>> match upper "a"
""
-}
upper :: Pattern Char
upper :: Pattern Char
upper = (Char -> Bool) -> Pattern Char
satisfy Char -> Bool
isUpper

{-| Match a lowercase letter

>>> match lower "a"
"a"
>>> match lower "A"
""
-}
lower :: Pattern Char
lower :: Pattern Char
lower = (Char -> Bool) -> Pattern Char
satisfy Char -> Bool
isLower

{-| Match a letter or digit

>>> match alphaNum "1"
"1"
>>> match alphaNum "a"
"a"
>>> match alphaNum "A"
"A"
>>> match alphaNum "."
""
-}
alphaNum :: Pattern Char
alphaNum :: Pattern Char
alphaNum = (Char -> Bool) -> Pattern Char
satisfy Char -> Bool
isAlphaNum

{-| Match a letter

>>> match letter "A"
"A"
>>> match letter "a"
"a"
>>> match letter "1"
""
-}
letter :: Pattern Char
letter :: Pattern Char
letter = (Char -> Bool) -> Pattern Char
satisfy Char -> Bool
isLetter

{-| Match a digit

>>> match digit "1"
"1"
>>> match digit "a"
""
-}
digit :: Pattern Char
digit :: Pattern Char
digit = (Char -> Bool) -> Pattern Char
satisfy Char -> Bool
isDigit

{-| Match a hexadecimal digit

>>> match hexDigit "1"
"1"
>>> match hexDigit "A"
"A"
>>> match hexDigit "a"
"a"
>>> match hexDigit "g"
""
-}
hexDigit :: Pattern Char
hexDigit :: Pattern Char
hexDigit = (Char -> Bool) -> Pattern Char
satisfy Char -> Bool
isHexDigit

{-| Match an octal digit

>>> match octDigit "1"
"1"
>>> match octDigit "9"
""
-}
octDigit :: Pattern Char
octDigit :: Pattern Char
octDigit = (Char -> Bool) -> Pattern Char
satisfy Char -> Bool
isOctDigit

{-| Match an unsigned decimal number

>>> match decimal  "123"
[123]
>>> match decimal "-123"
[]
-}
decimal :: Num n => Pattern n
decimal :: Pattern n
decimal = do
    String
ds <- Pattern Char -> Pattern String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Pattern Char
digit
    n -> Pattern n
forall (m :: * -> *) a. Monad m => a -> m a
return ((n -> Char -> n) -> n -> String -> n
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' n -> Char -> n
forall a. Num a => a -> Char -> a
step n
0 String
ds)
  where
    step :: a -> Char -> a
step a
n Char
d = a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0')

{-| Transform a numeric parser to accept an optional leading @\'+\'@ or @\'-\'@
    sign

>>> match (signed decimal) "+123"
[123]
>>> match (signed decimal) "-123"
[-123]
>>> match (signed decimal)  "123"
[123]
-}
signed :: Num a => Pattern a -> Pattern a
signed :: Pattern a -> Pattern a
signed Pattern a
p = do
    a -> a
sign <- (Char -> Pattern Char
char Char
'+' Pattern Char -> Pattern (a -> a) -> Pattern (a -> a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> a) -> Pattern (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id) Pattern (a -> a) -> Pattern (a -> a) -> Pattern (a -> a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Pattern Char
char Char
'-' Pattern Char -> Pattern (a -> a) -> Pattern (a -> a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> a) -> Pattern (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. Num a => a -> a
negate) Pattern (a -> a) -> Pattern (a -> a) -> Pattern (a -> a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((a -> a) -> Pattern (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id)
    (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
sign Pattern a
p

{-| @(`invert` p)@ succeeds if @p@ fails and fails if @p@ succeeds

>>> match (invert "A") "A"
[]
>>> match (invert "A") "B"
[()]
>>> match (invert "A") "AA"
[()]
-}
invert :: Pattern a -> Pattern ()
invert :: Pattern a -> Pattern ()
invert Pattern a
p = StateT Text [] () -> Pattern ()
forall a. StateT Text [] a -> Pattern a
Pattern ((Text -> [((), Text)]) -> StateT Text [] ()
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT Text -> [((), Text)]
f)
  where
    f :: Text -> [((), Text)]
f Text
str = case Pattern a -> Text -> [a]
forall a. Pattern a -> Text -> [a]
match Pattern a
p Text
str of
        [] -> [((), Text
"")]
        [a]
_  -> []

{-| Match a `Char`, but return `Text`

>>> match (once (char '1')) "1"
["1"]
>>> match (once (char '1')) ""
[]
-}
once :: Pattern Char -> Pattern Text
once :: Pattern Char -> Pattern Text
once Pattern Char
p = (Char -> Text) -> Pattern Char -> Pattern Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Text
Text.singleton Pattern Char
p

{-| Use this to match the prefix of a string

>>> match         "A"  "ABC"
[]
>>> match (prefix "A") "ABC"
["A"]
-}
prefix :: Pattern a -> Pattern a
prefix :: Pattern a -> Pattern a
prefix Pattern a
p = Pattern a
p Pattern a -> Pattern Text -> Pattern a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Pattern Text
chars

{-| Use this to match the suffix of a string

>>> match         "C"  "ABC"
[]
>>> match (suffix "C") "ABC"
["C"]
-}
suffix :: Pattern a -> Pattern a
suffix :: Pattern a -> Pattern a
suffix Pattern a
p = Pattern Text
chars Pattern Text -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Pattern a
p

{-| Use this to match the interior of a string

>>> match      "B"  "ABC"
[]
>>> match (has "B") "ABC"
["B"]
-}
has :: Pattern a -> Pattern a
has :: Pattern a -> Pattern a
has Pattern a
p = Pattern Text
chars Pattern Text -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Pattern a
p Pattern a -> Pattern Text -> Pattern a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Pattern Text
chars

{-| Match the entire string if it begins with the given pattern

    This returns the entire string, not just the matched prefix

>>> match (begins  "A"             ) "ABC"
["ABC"]
>>> match (begins ("A" *> pure "1")) "ABC"
["1BC"]
-}
begins :: Pattern Text -> Pattern Text
begins :: Pattern Text -> Pattern Text
begins Pattern Text
pattern = Pattern Text
pattern Pattern Text -> Pattern Text -> Pattern Text
forall a. Semigroup a => a -> a -> a
<> Pattern Text
chars

{-| Match the entire string if it ends with the given pattern

    This returns the entire string, not just the matched prefix

>>> match (ends  "C"             ) "ABC"
["ABC"]
>>> match (ends ("C" *> pure "1")) "ABC"
["AB1"]
-}
ends :: Pattern Text -> Pattern Text
ends :: Pattern Text -> Pattern Text
ends Pattern Text
pattern = Pattern Text
chars Pattern Text -> Pattern Text -> Pattern Text
forall a. Semigroup a => a -> a -> a
<> Pattern Text
pattern

{-| Match the entire string if it contains the given pattern

    This returns the entire string, not just the interior pattern

>>> match (contains  "B"             ) "ABC"
["ABC"]
>>> match (contains ("B" *> pure "1")) "ABC"
["A1C"]
-}
contains :: Pattern Text -> Pattern Text
contains :: Pattern Text -> Pattern Text
contains Pattern Text
pattern = Pattern Text
chars Pattern Text -> Pattern Text -> Pattern Text
forall a. Semigroup a => a -> a -> a
<> Pattern Text
pattern Pattern Text -> Pattern Text -> Pattern Text
forall a. Semigroup a => a -> a -> a
<> Pattern Text
chars

{-| Parse 0 or more occurrences of the given character

>>> match (star anyChar) "123"
["123"]
>>> match (star anyChar) ""
[""]

    See also: `chars`
-}
star :: Pattern Char -> Pattern Text
star :: Pattern Char -> Pattern Text
star Pattern Char
p = (String -> Text) -> Pattern String -> Pattern Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Text.pack (Pattern Char -> Pattern String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Pattern Char
p)

{-| Parse 1 or more occurrences of the given character

>>> match (plus digit) "123"
["123"]
>>> match (plus digit) ""
[]

    See also: `chars1`
-}
plus :: Pattern Char -> Pattern Text
plus :: Pattern Char -> Pattern Text
plus Pattern Char
p = (String -> Text) -> Pattern String -> Pattern Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Text.pack (Pattern Char -> Pattern String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Pattern Char
p)

{-| Patterns that match multiple times are greedy by default, meaning that they
    try to match as many times as possible.  The `selfless` combinator makes a
    pattern match as few times as possible

    This only changes the order in which solutions are returned, by prioritizing
    less greedy solutions

>>> match (prefix (selfless (some anyChar))) "123"
["1","12","123"]
>>> match (prefix           (some anyChar) ) "123"
["123","12","1"]
-}
selfless :: Pattern a -> Pattern a
selfless :: Pattern a -> Pattern a
selfless Pattern a
p = StateT Text [] a -> Pattern a
forall a. StateT Text [] a -> Pattern a
Pattern ((Text -> [(a, Text)]) -> StateT Text [] a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (\Text
s -> [(a, Text)] -> [(a, Text)]
forall a. [a] -> [a]
reverse (StateT Text [] a -> Text -> [(a, Text)]
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Pattern a -> StateT Text [] a
forall a. Pattern a -> StateT Text [] a
runPattern Pattern a
p) Text
s)))

{-| Apply the patterns in the list in order, until one of them succeeds

>>> match (choice ["cat", "dog", "egg"]) "egg"
["egg"]
>>> match (choice ["cat", "dog", "egg"]) "cat"
["cat"]
>>> match (choice ["cat", "dog", "egg"]) "fan"
[]
-}
choice :: [Pattern a] -> Pattern a
choice :: [Pattern a] -> Pattern a
choice = [Pattern a] -> Pattern a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum

{-| Apply the given pattern a fixed number of times, collecting the results

>>> match (count 3 anyChar) "123"
["123"]
>>> match (count 4 anyChar) "123"
[]
-}
count :: Int -> Pattern a -> Pattern [a]
count :: Int -> Pattern a -> Pattern [a]
count = Int -> Pattern a -> Pattern [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM

{-| Apply the given pattern at least the given number of times, collecting the
    results

>>> match (lowerBounded 5 dot) "123"
[]
>>> match (lowerBounded 2 dot) "123"
["123"]
-}
lowerBounded :: Int -> Pattern a -> Pattern [a]
lowerBounded :: Int -> Pattern a -> Pattern [a]
lowerBounded Int
n Pattern a
p = do
    [a]
ps1 <- Int -> Pattern a -> Pattern [a]
forall a. Int -> Pattern a -> Pattern [a]
count Int
n Pattern a
p
    [a]
ps2 <- Pattern a -> Pattern [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Pattern a
p
    [a] -> Pattern [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
ps1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ps2)

{-| Apply the given pattern 0 or more times, up to a given bound,
    collecting the results

>>> match (upperBounded 5 dot) "123"
["123"]
>>> match (upperBounded 2 dot) "123"
[]
>>> match ((,) <$> upperBounded 2 dot <*> chars) "123"
[("12","3"),("1","23")]
-}
upperBounded :: Int -> Pattern a -> Pattern [a]
upperBounded :: Int -> Pattern a -> Pattern [a]
upperBounded Int
n Pattern a
p
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Pattern [a]
forall a. Monoid a => a
mempty
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = (a -> [a]) -> Pattern a -> Pattern [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pattern a
p
    | Bool
otherwise = (:) (a -> [a] -> [a]) -> Pattern a -> Pattern ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
p Pattern ([a] -> [a]) -> Pattern [a] -> Pattern [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern [a] -> Pattern [a]
forall a. Monoid a => Pattern a -> Pattern a
option (Int -> Pattern a -> Pattern [a]
forall a. Int -> Pattern a -> Pattern [a]
upperBounded (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Pattern a
p)

{-| Apply the given pattern a number of times restricted by given
    lower and upper bounds, collecting the results

>>> match (bounded 2 5 "cat") "catcatcat"
[["cat","cat","cat"]]
>>> match (bounded 2 5 "cat") "cat"
[]
>>> match (bounded 2 5 "cat") "catcatcatcatcatcat"
[]

`bounded` could be implemented naively as follows:

> bounded m n p = do
>   x <- choice (map pure [m..n])
>   count x p

-}
bounded :: Int -> Int -> Pattern a -> Pattern [a]
bounded :: Int -> Int -> Pattern a -> Pattern [a]
bounded Int
m Int
n Pattern a
p
    | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = Int -> Pattern a -> Pattern [a]
forall a. Int -> Pattern a -> Pattern [a]
count Int
m Pattern a
p
    | Int
m  Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([a] -> [a] -> [a]) -> Pattern [a] -> Pattern ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Pattern a -> Pattern [a]
forall a. Int -> Pattern a -> Pattern [a]
count Int
m Pattern a
p Pattern ([a] -> [a]) -> Pattern [a] -> Pattern [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern [a] -> Pattern [a]
forall a. Monoid a => Pattern a -> Pattern a
option (Int -> Pattern a -> Pattern [a]
forall a. Int -> Pattern a -> Pattern [a]
upperBounded (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Pattern a
p)
    | Bool
otherwise = Pattern [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero

{-| Transform a parser to a succeed with an empty value instead of failing

    See also: `optional`

>>> match (option "1" <> "2") "12"
["12"]
>>> match (option "1" <> "2") "2"
["2"]
-}
option :: Monoid a => Pattern a -> Pattern a
option :: Pattern a -> Pattern a
option Pattern a
p = Pattern a
p Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Pattern a
forall a. Monoid a => a
mempty

{-| @(between open close p)@ matches @\'p\'@ in between @\'open\'@ and
    @\'close\'@

>>> match (between (char '(') (char ')') (star anyChar)) "(123)"
["123"]
>>> match (between (char '(') (char ')') (star anyChar)) "(123"
[]
-}
between :: Pattern a -> Pattern b -> Pattern c -> Pattern c
between :: Pattern a -> Pattern b -> Pattern c -> Pattern c
between Pattern a
open Pattern b
close Pattern c
p = Pattern a
open Pattern a -> Pattern c -> Pattern c
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Pattern c
p Pattern c -> Pattern b -> Pattern c
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Pattern b
close

{-| Discard the pattern's result

>>> match (skip anyChar) "1"
[()]
>>> match (skip anyChar) ""
[]
-}
skip :: Pattern a -> Pattern ()
skip :: Pattern a -> Pattern ()
skip = Pattern a -> Pattern ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void

{-| Restrict the pattern to consume no more than the given number of characters

>>> match (within 2 decimal) "12"
[12]
>>> match (within 2 decimal) "1"
[1]
>>> match (within 2 decimal) "123"
[]
-}
within :: Int -> Pattern a -> Pattern a
within :: Int -> Pattern a -> Pattern a
within Int
n Pattern a
p = StateT Text [] a -> Pattern a
forall a. StateT Text [] a -> Pattern a
Pattern (do
    Text
txt <- StateT Text [] Text
forall (m :: * -> *) s. Monad m => StateT s m s
get
    let (Text
before, Text
after) = Int -> Text -> (Text, Text)
Text.splitAt Int
n Text
txt
    Text -> StateT Text [] ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Text
before
    a
a <- Pattern a -> StateT Text [] a
forall a. Pattern a -> StateT Text [] a
runPattern Pattern a
p
    (Text -> Text) -> StateT Text [] ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
after)
    a -> StateT Text [] a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a )

{-| Require the pattern to consume exactly the given number of characters

>>> match (fixed 2 decimal) "12"
[12]
>>> match (fixed 2 decimal) "1"
[]
-}
fixed :: Int -> Pattern a -> Pattern a
fixed :: Int -> Pattern a -> Pattern a
fixed Int
n Pattern a
p = do
    Text
txt <- StateT Text [] Text -> Pattern Text
forall a. StateT Text [] a -> Pattern a
Pattern StateT Text [] Text
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Bool -> Pattern ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Int
Text.length Text
txt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n)
    Int -> Pattern a -> Pattern a
forall a. Int -> Pattern a -> Pattern a
within Int
n (Pattern a
p Pattern a -> Pattern () -> Pattern a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Pattern ()
eof)

{-| @p `sepBy` sep@ matches zero or more occurrences of @p@ separated by @sep@

>>> match (decimal `sepBy` char ',') "1,2,3"
[[1,2,3]]
>>> match (decimal `sepBy` char ',') ""
[[]]
-}
sepBy :: Pattern a -> Pattern b -> Pattern [a]
Pattern a
p sepBy :: Pattern a -> Pattern b -> Pattern [a]
`sepBy` Pattern b
sep = (Pattern a
p Pattern a -> Pattern b -> Pattern [a]
forall a b. Pattern a -> Pattern b -> Pattern [a]
`sepBy1` Pattern b
sep) Pattern [a] -> Pattern [a] -> Pattern [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Pattern [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

{-| @p `sepBy1` sep@ matches one or more occurrences of @p@ separated by @sep@

>>> match (decimal `sepBy1` ",") "1,2,3"
[[1,2,3]]
>>> match (decimal `sepBy1` ",") ""
[]
-}
sepBy1 :: Pattern a -> Pattern b -> Pattern [a]
Pattern a
p sepBy1 :: Pattern a -> Pattern b -> Pattern [a]
`sepBy1` Pattern b
sep = (:) (a -> [a] -> [a]) -> Pattern a -> Pattern ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
p Pattern ([a] -> [a]) -> Pattern [a] -> Pattern [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern a -> Pattern [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Pattern b
sep Pattern b -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Pattern a
p) 

-- | Like @star dot@ or @star anyChar@, except more efficient
chars :: Pattern Text
chars :: Pattern Text
chars = StateT Text [] Text -> Pattern Text
forall a. StateT Text [] a -> Pattern a
Pattern ((Text -> [(Text, Text)]) -> StateT Text [] Text
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (\Text
txt ->
    [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a]
reverse ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Text -> [Text]
Text.inits Text
txt) (Text -> [Text]
Text.tails Text
txt)) ))

-- | Like @plus dot@ or @plus anyChar@, except more efficient
chars1 :: Pattern Text
chars1 :: Pattern Text
chars1 = Char -> Text -> Text
Text.cons (Char -> Text -> Text) -> Pattern Char -> Pattern (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Char
dot Pattern (Text -> Text) -> Pattern Text -> Pattern Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Text
chars