-- Copyright (c) 2019  Herbert Valerio Riedel <hvr@gnu.org>
--
--  This file is free software: you may copy, redistribute and/or modify it
--  under the terms of the GNU General Public License as published by the
--  Free Software Foundation, either version 2 of the License, or (at your
--  option) any later version.
--
--  This file is distributed in the hope that it will be useful, but
--  WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program (see `LICENSE`).  If not, see
--  <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html>.

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | String representation of LDAPv3 search 'Filter's as defined by <https://tools.ietf.org/html/rfc4515 RFC4515>.
--
-- @since 0.1.0
module LDAPv3.SearchFilter
  ( r'Filter
  , p'Filter
  ) where

import           Common                      hiding (many, option, some, (<|>))
import           LDAPv3.AttributeDescription
import           LDAPv3.Message
import           LDAPv3.StringRepr.Class

import qualified Data.ByteString             as BS
import qualified Data.List.NonEmpty          as NE
import qualified Data.Text                   as T
import qualified Data.Text.Encoding          as T
import           Data.Text.Lazy.Builder      as B
import           Data.Text.Lazy.Builder.Int  (hexadecimal)

import           Text.Parsec                 as P

-- NB: technically an orphan; we mitigate this by ensuring that all modules by which the 'StringRepr' class is exported
-- imports this module as to avoid making this observable from outside this package.
instance StringRepr Filter where
  asBuilder :: Filter -> Builder
asBuilder = Filter -> Builder
r'Filter
  asParsec :: Parsec s () Filter
asParsec  = Parsec s () Filter
forall s. Stream s Identity Char => Parsec s () Filter
p'Filter

-- -- | Render LDAPv3 search 'Filter's into <https://tools.ietf.org/html/rfc4515 RFC4515> text representation
-- renderFilter :: Filter -> Text
-- renderFilter = T.toStrict . B.toLazyText . r'Filter

r'Filter :: Filter -> Builder
r'Filter :: Filter -> Builder
r'Filter = Filter -> Builder
r'filter
  where
    r'filter :: Filter -> Builder
    r'filter :: Filter -> Builder
r'filter f0 :: Filter
f0 = Char -> Builder
singleton '(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
f' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton ')'
      where
        f' :: Builder
f' = case Filter
f0 of
               Filter'and (SET1 fs :: NonEmpty Filter
fs)       -> Char -> Builder
singleton '&' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> NonEmpty Builder -> Builder
forall a. Semigroup a => NonEmpty a -> a
sconcat ((Filter -> Builder) -> NonEmpty Filter -> NonEmpty Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Filter -> Builder
r'filter NonEmpty Filter
fs)
               Filter'or  (SET1 fs :: NonEmpty Filter
fs)       -> Char -> Builder
singleton '|' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> NonEmpty Builder -> Builder
forall a. Semigroup a => NonEmpty a -> a
sconcat ((Filter -> Builder) -> NonEmpty Filter -> NonEmpty Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Filter -> Builder
r'filter NonEmpty Filter
fs)
               Filter'not f :: Filter
f               -> Char -> Builder
singleton '!' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Filter -> Builder
r'filter Filter
f
               Filter'equalityMatch  ava :: IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
ava  -> Builder
-> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Builder
r'simple (Char -> Builder
singleton '=') IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
ava
               Filter'greaterOrEqual ava :: IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
ava  -> Builder
-> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Builder
r'simple ">=" IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
ava
               Filter'lessOrEqual    ava :: IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
ava  -> Builder
-> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Builder
r'simple "<=" IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
ava
               Filter'approxMatch    ava :: IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
ava  -> Builder
-> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Builder
r'simple "~=" IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
ava
               Filter'present attr :: IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr        -> IMPLICIT ('CONTEXTUAL 7) AttributeDescription -> Builder
r'AttributeDescription IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "=*"
               Filter'substrings sub :: IMPLICIT ('CONTEXTUAL 4) SubstringFilter
sub      -> IMPLICIT ('CONTEXTUAL 4) SubstringFilter -> Builder
r'substring IMPLICIT ('CONTEXTUAL 4) SubstringFilter
sub
               Filter'extensibleMatch ext :: IMPLICIT ('CONTEXTUAL 9) MatchingRuleAssertion
ext -> IMPLICIT ('CONTEXTUAL 9) MatchingRuleAssertion -> Builder
r'extensible IMPLICIT ('CONTEXTUAL 9) MatchingRuleAssertion
ext


    r'simple :: Builder -> AttributeValueAssertion -> Builder
    r'simple :: Builder
-> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Builder
r'simple filtertype :: Builder
filtertype (AttributeValueAssertion attr :: IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr assertionvalue :: AssertionValue
assertionvalue)
      = IMPLICIT ('CONTEXTUAL 7) AttributeDescription -> Builder
r'AttributeDescription IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
filtertype Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> AssertionValue -> Builder
r'assertionvalue AssertionValue
assertionvalue

    r'substring :: SubstringFilter -> Builder
    r'substring :: IMPLICIT ('CONTEXTUAL 4) SubstringFilter -> Builder
r'substring (SubstringFilter attr :: IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr (s1 :: CHOICE Substring
s1:|ss :: [CHOICE Substring]
ss))
      = IMPLICIT ('CONTEXTUAL 7) AttributeDescription -> Builder
r'AttributeDescription IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton '=' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        (case CHOICE Substring
s1 of
            Substring'initial x :: AssertionValue
x -> AssertionValue -> Builder
r'assertionvalue AssertionValue
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [CHOICE Substring] -> Builder
go [CHOICE Substring]
ss
            _                   -> [CHOICE Substring] -> Builder
go (CHOICE Substring
s1CHOICE Substring -> [CHOICE Substring] -> [CHOICE Substring]
forall a. a -> [a] -> [a]
:[CHOICE Substring]
ss)
        )
      where
        go :: [CHOICE Substring] -> Builder
go (Substring'initial _ : _)   = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error "renderFilter: invalid SubstringFilter (misplaced 'initial')"
        go (Substring'final _ : _ : _) = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error "renderFilter: invalid SubstringFilter (misplaced 'final')"
        go [Substring'final x :: AssertionValue
x]         = Char -> Builder
singleton '*' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> AssertionValue -> Builder
r'assertionvalue AssertionValue
x
        go (Substring'any x :: AssertionValue
x : xs :: [CHOICE Substring]
xs)      = Char -> Builder
singleton '*' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> AssertionValue -> Builder
r'assertionvalue AssertionValue
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [CHOICE Substring] -> Builder
go [CHOICE Substring]
xs
        go []                          = Char -> Builder
singleton '*'

    r'assertionvalue :: AssertionValue -> Builder
    r'assertionvalue :: AssertionValue -> Builder
r'assertionvalue bs :: AssertionValue
bs
      | Right t :: Text
t <- AssertionValue -> Either UnicodeException Text
T.decodeUtf8' AssertionValue
bs = Text -> Builder
fromText ((Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escT Text
t)
      | Bool
otherwise = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Word8 -> Builder) -> [Word8] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Builder
escB ([Word8] -> [Builder]) -> [Word8] -> [Builder]
forall a b. (a -> b) -> a -> b
$ AssertionValue -> [Word8]
BS.unpack AssertionValue
bs)
      where
        escT :: Char -> Text
        escT :: Char -> Text
escT = \case
           -- minimal escaping
          '\x00' -> "\\00"
          '\x28' -> "\\28"
          '\x29' -> "\\29"
          '\x2a' -> "\\2a"
          '\x5c' -> "\\5c"
          c :: Char
c      -> Char -> Text
T.singleton Char
c

        escB :: Word8 -> Builder
        escB :: Word8 -> Builder
escB = \case
          0x00 -> "\\00"
          0x28 -> "\\28"
          0x29 -> "\\29"
          0x2a -> "\\2a"
          0x5c -> "\\5c"
          w :: Word8
w | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80  -> Char -> Builder
singleton (Int -> Char
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word8
w))
            | Bool
otherwise -> Char -> Builder
singleton '\\' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
forall a. Integral a => a -> Builder
hexadecimal Word8
w

    r'extensible :: MatchingRuleAssertion -> Builder
    r'extensible :: IMPLICIT ('CONTEXTUAL 9) MatchingRuleAssertion -> Builder
r'extensible (MatchingRuleAssertion matchingrule :: Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
matchingrule attr :: Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
attr assertionvalue :: AssertionValue
assertionvalue dnattrs :: Bool
dnattrs)
      | Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
matchingrule, Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
attr = "renderFilter: invalid MatchingRuleAssertion (matchingRule field absent and type field not present)"
      | Bool
otherwise = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Builder
-> (IMPLICIT ('CONTEXTUAL 7) AttributeDescription -> Builder)
-> Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty IMPLICIT ('CONTEXTUAL 7) AttributeDescription -> Builder
r'AttributeDescription Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
attr
                            , if Bool
dnattrs then ":dn" else Builder
forall a. Monoid a => a
mempty
                            , Builder
-> (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId -> Builder)
-> Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (\mrid :: IMPLICIT ('CONTEXTUAL 1) MatchingRuleId
mrid -> Char -> Builder
singleton ':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> IMPLICIT ('CONTEXTUAL 1) MatchingRuleId -> Builder
r'MatchingRuleId IMPLICIT ('CONTEXTUAL 1) MatchingRuleId
mrid) Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
matchingrule
                            , ":=", AssertionValue -> Builder
r'assertionvalue AssertionValue
assertionvalue
                            ]

-- TODO
-- -- | Parse <https://tools.ietf.org/html/rfc4515 RFC4515> string representation of a LDAPv3 search 'Filter's
-- parseFilter :: Text -> Either ParseError Filter
-- parseFilter = parse (parsecFilter <* eof) ""

-- | 'Parsec' parser for parsing <https://tools.ietf.org/html/rfc4515 RFC4515> string representations of a LDAPv3 search 'Filter's
p'Filter :: Stream s Identity Char => Parsec s () Filter
p'Filter :: Parsec s () Filter
p'Filter = Parsec s () Filter
p'filter
  where
    -- filter         = LPAREN filtercomp RPAREN
    p'filter :: Parsec s () Filter
p'filter = Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '(' ParsecT s () Identity Char
-> Parsec s () Filter -> Parsec s () Filter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec s () Filter
p'filtercomp Parsec s () Filter
-> ParsecT s () Identity Char -> Parsec s () Filter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char ')'

    -- filtercomp     = and / or / not / item
    --  and           = AMPERSAND filterlist
    --  or            = VERTBAR filterlist
    --  not           = EXCLAMATION filter
    p'filtercomp :: Parsec s () Filter
p'filtercomp
      = [Parsec s () Filter] -> Parsec s () Filter
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ SET1 Filter -> Filter
Filter'and (SET1 Filter -> Filter)
-> ParsecT s () Identity (SET1 Filter) -> Parsec s () Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '&' ParsecT s () Identity Char
-> ParsecT s () Identity (SET1 Filter)
-> ParsecT s () Identity (SET1 Filter)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT s () Identity (SET1 Filter)
p'filterlist)
               , SET1 Filter -> Filter
Filter'or  (SET1 Filter -> Filter)
-> ParsecT s () Identity (SET1 Filter) -> Parsec s () Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '|' ParsecT s () Identity Char
-> ParsecT s () Identity (SET1 Filter)
-> ParsecT s () Identity (SET1 Filter)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT s () Identity (SET1 Filter)
p'filterlist)
               , Filter -> Filter
Filter'not (Filter -> Filter) -> Parsec s () Filter -> Parsec s () Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '!' ParsecT s () Identity Char
-> Parsec s () Filter -> Parsec s () Filter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec s () Filter
p'filter)
               , Parsec s () Filter
p'item
               ]

    -- filterlist     = 1*filter
    p'filterlist :: ParsecT s () Identity (SET1 Filter)
p'filterlist = NonEmpty Filter -> SET1 Filter
forall x. NonEmpty x -> SET1 x
SET1 (NonEmpty Filter -> SET1 Filter)
-> ParsecT s () Identity (NonEmpty Filter)
-> ParsecT s () Identity (SET1 Filter)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec s () Filter -> ParsecT s () Identity (NonEmpty Filter)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (NonEmpty a)
some Parsec s () Filter
p'filter

    -- item            = simple / present / substring / extensible
    -- simple          = attr filtertype assertionvalue
    -- filtertype      = equal / approx / greaterorequal / lessorequal
    --  equal          = EQUALS
    --  approx         = TILDE EQUALS
    --  greaterorequal = RANGLE EQUALS
    --  lessorequal    = LANGLE EQUALS
    -- present         = attr EQUALS ASTERISK
    -- substring       = attr EQUALS [initial] any [final]
    --  initial        = assertionvalue
    --  any            = ASTERISK *(assertionvalue ASTERISK)
    --  final          = assertionvalue
    -- attr            = attributedescription
    --                     ; The attributedescription rule is defined in
    --                     ; Section 2.5 of [RFC4512].
    p'item :: Parsec s () Filter
p'item = Parsec s () Filter
p'itemWithAttr Parsec s () Filter -> Parsec s () Filter -> Parsec s () Filter
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
-> Parsec s () Filter
p'extensible Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
forall a. Maybe a
Nothing

    p'itemWithAttr :: Parsec s () Filter
p'itemWithAttr = do
      IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr <- Parsec s () (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
forall s.
Stream s Identity Char =>
Parsec s () (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
p'AttributeDescription Parsec s () (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
-> [Char]
-> Parsec s () (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> "attributedescription"

      [Parsec s () Filter] -> Parsec s () Filter
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Filter
Filter'approxMatch    (IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Filter)
-> (AssertionValue
    -> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion)
-> AssertionValue
-> Filter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IMPLICIT ('CONTEXTUAL 7) AttributeDescription
-> AssertionValue
-> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
AttributeValueAssertion IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr (AssertionValue -> Filter)
-> ParsecT s () Identity AssertionValue -> Parsec s () Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> ParsecT s () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string "~=" ParsecT s () Identity [Char]
-> ParsecT s () Identity AssertionValue
-> ParsecT s () Identity AssertionValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT s () Identity AssertionValue
forall u. ParsecT s u Identity AssertionValue
p'assertionvalue)
             , IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Filter
Filter'greaterOrEqual (IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Filter)
-> (AssertionValue
    -> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion)
-> AssertionValue
-> Filter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IMPLICIT ('CONTEXTUAL 7) AttributeDescription
-> AssertionValue
-> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
AttributeValueAssertion IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr (AssertionValue -> Filter)
-> ParsecT s () Identity AssertionValue -> Parsec s () Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> ParsecT s () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string ">=" ParsecT s () Identity [Char]
-> ParsecT s () Identity AssertionValue
-> ParsecT s () Identity AssertionValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT s () Identity AssertionValue
forall u. ParsecT s u Identity AssertionValue
p'assertionvalue)
             , IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Filter
Filter'lessOrEqual    (IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Filter)
-> (AssertionValue
    -> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion)
-> AssertionValue
-> Filter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IMPLICIT ('CONTEXTUAL 7) AttributeDescription
-> AssertionValue
-> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
AttributeValueAssertion IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr (AssertionValue -> Filter)
-> ParsecT s () Identity AssertionValue -> Parsec s () Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> ParsecT s () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string "<=" ParsecT s () Identity [Char]
-> ParsecT s () Identity AssertionValue
-> ParsecT s () Identity AssertionValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT s () Identity AssertionValue
forall u. ParsecT s u Identity AssertionValue
p'assertionvalue)
             -- attr EQUALS ([initial] any [final] / assertionvalue)
             , Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '=' ParsecT s () Identity Char
-> Parsec s () Filter -> Parsec s () Filter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (IMPLICIT ('CONTEXTUAL 7) AttributeDescription -> Parsec s () Filter
forall u.
IMPLICIT ('CONTEXTUAL 7) AttributeDescription
-> ParsecT s u Identity Filter
p'substringOrPresent IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr
                            Parsec s () Filter -> Parsec s () Filter -> Parsec s () Filter
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Filter
Filter'equalityMatch (IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion -> Filter)
-> (AssertionValue
    -> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion)
-> AssertionValue
-> Filter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IMPLICIT ('CONTEXTUAL 7) AttributeDescription
-> AssertionValue
-> IMPLICIT ('CONTEXTUAL 3) AttributeValueAssertion
AttributeValueAssertion IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr (AssertionValue -> Filter)
-> ParsecT s () Identity AssertionValue -> Parsec s () Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity AssertionValue
forall u. ParsecT s u Identity AssertionValue
p'assertionvalue))
             -- attr [dnattrs] [matchingrule] COLON EQUALS assertionvalue
             , Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
-> Parsec s () Filter
p'extensible (IMPLICIT ('CONTEXTUAL 7) AttributeDescription
-> Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
forall a. a -> Maybe a
Just IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr)
             ]

    -- extensible     = ( attr [dnattrs]
    --                      [matchingrule] COLON EQUALS assertionvalue )
    --                  / ( [dnattrs]
    --                       matchingrule COLON EQUALS assertionvalue )
    p'extensible :: Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
-> Parsec s () Filter
p'extensible mattr :: Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
mattr = do
      let _MatchingRuleAssertion'type :: Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
_MatchingRuleAssertion'type = Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
mattr
      Bool
_MatchingRuleAssertion'dnAttributes <- Bool -> ParsecT s () Identity Bool -> ParsecT s () Identity Bool
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Bool
False (Bool
True Bool -> ParsecT s () Identity () -> ParsecT s () Identity Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT s () Identity ()
forall u. ParsecT s u Identity ()
p'dnattrs)
      Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
_MatchingRuleAssertion'matchingRule <- case Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
mattr of
        Nothing -> IMPLICIT ('CONTEXTUAL 1) MatchingRuleId
-> Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
forall a. a -> Maybe a
Just (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId
 -> Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId))
-> ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
-> ParsecT
     s () Identity (Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
p'matchingrule
        Just _  -> Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
-> ParsecT
     s () Identity (Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId))
-> ParsecT
     s () Identity (Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId))
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
forall a. Maybe a
Nothing (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId
-> Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
forall a. a -> Maybe a
Just (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId
 -> Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId))
-> ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
-> ParsecT
     s () Identity (Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
-> ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
p'matchingrule)
      ParsecT s () Identity [Char] -> ParsecT s () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([Char] -> ParsecT s () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string ":=")
      AssertionValue
_MatchingRuleAssertion'matchValue <- ParsecT s () Identity AssertionValue
forall u. ParsecT s u Identity AssertionValue
p'assertionvalue
      Filter -> Parsec s () Filter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IMPLICIT ('CONTEXTUAL 9) MatchingRuleAssertion -> Filter
Filter'extensibleMatch (MatchingRuleAssertion :: Maybe (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
-> Maybe (IMPLICIT ('CONTEXTUAL 7) AttributeDescription)
-> AssertionValue
-> Bool
-> IMPLICIT ('CONTEXTUAL 9) MatchingRuleAssertion
MatchingRuleAssertion {..}))

    -- dnattrs        = COLON "dn"
    p'dnattrs :: ParsecT s u Identity ()
p'dnattrs = ParsecT s u Identity () -> ParsecT s u Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Char -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char ':' ParsecT s u Identity Char
-> ParsecT s u Identity Char -> ParsecT s u Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char 'd' ParsecT s u Identity Char
-> ParsecT s u Identity Char -> ParsecT s u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char 'D') ParsecT s u Identity Char
-> ParsecT s u Identity Char -> ParsecT s u Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char 'n' ParsecT s u Identity Char
-> ParsecT s u Identity Char -> ParsecT s u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char 'N') ParsecT s u Identity Char
-> ParsecT s u Identity () -> ParsecT s u Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> ParsecT s u Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    -- matchingrule   = COLON oid
    p'matchingrule :: ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
p'matchingrule = Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char ':' ParsecT s () Identity Char
-> ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
-> ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT s () Identity (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
forall s.
Stream s Identity Char =>
Parsec s () (IMPLICIT ('CONTEXTUAL 1) MatchingRuleId)
p'MatchingRuleId

    -- [assertionvalue] *(assertionvalue ASTERISK) [assertionvalue]
    p'substringOrPresent :: IMPLICIT ('CONTEXTUAL 7) AttributeDescription
-> ParsecT s u Identity Filter
p'substringOrPresent attr :: IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr = ParsecT s u Identity Filter -> ParsecT s u Identity Filter
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s u Identity Filter -> ParsecT s u Identity Filter)
-> ParsecT s u Identity Filter -> ParsecT s u Identity Filter
forall a b. (a -> b) -> a -> b
$ do
      let bs2lst :: AssertionValue -> [AssertionValue]
bs2lst x :: AssertionValue
x = if AssertionValue -> Bool
BS.null AssertionValue
x then [] else [AssertionValue
x]

      [AssertionValue]
initial <- AssertionValue -> [AssertionValue]
bs2lst (AssertionValue -> [AssertionValue])
-> ParsecT s u Identity AssertionValue
-> ParsecT s u Identity [AssertionValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u Identity AssertionValue
forall u. ParsecT s u Identity AssertionValue
p'assertionvalue
      -- TODO: are empty fragments allowed? i.e. f** or ** ; according to ABNF it seems so
      [AssertionValue]
anys    <- Char -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '*' ParsecT s u Identity Char
-> ParsecT s u Identity [AssertionValue]
-> ParsecT s u Identity [AssertionValue]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT s u Identity AssertionValue
-> ParsecT s u Identity [AssertionValue]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT s u Identity AssertionValue
-> ParsecT s u Identity AssertionValue
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s u Identity AssertionValue
forall u. ParsecT s u Identity AssertionValue
p'assertionvalue ParsecT s u Identity AssertionValue
-> ParsecT s u Identity Char -> ParsecT s u Identity AssertionValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '*'))
      [AssertionValue]
final   <- AssertionValue -> [AssertionValue]
bs2lst (AssertionValue -> [AssertionValue])
-> ParsecT s u Identity AssertionValue
-> ParsecT s u Identity [AssertionValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u Identity AssertionValue
forall u. ParsecT s u Identity AssertionValue
p'assertionvalue

      Filter -> ParsecT s u Identity Filter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Filter -> ParsecT s u Identity Filter)
-> Filter -> ParsecT s u Identity Filter
forall a b. (a -> b) -> a -> b
$! case (AssertionValue -> CHOICE Substring
Substring'initial (AssertionValue -> CHOICE Substring)
-> [AssertionValue] -> [CHOICE Substring]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AssertionValue]
initial) [CHOICE Substring] -> [CHOICE Substring] -> [CHOICE Substring]
forall a. [a] -> [a] -> [a]
++
                   (AssertionValue -> CHOICE Substring
Substring'any     (AssertionValue -> CHOICE Substring)
-> [AssertionValue] -> [CHOICE Substring]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AssertionValue]
anys) [CHOICE Substring] -> [CHOICE Substring] -> [CHOICE Substring]
forall a. [a] -> [a] -> [a]
++
                   (AssertionValue -> CHOICE Substring
Substring'final   (AssertionValue -> CHOICE Substring)
-> [AssertionValue] -> [CHOICE Substring]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AssertionValue]
final) of
                []   -> IMPLICIT ('CONTEXTUAL 7) AttributeDescription -> Filter
Filter'present IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr
                x :: CHOICE Substring
x:xs :: [CHOICE Substring]
xs -> IMPLICIT ('CONTEXTUAL 4) SubstringFilter -> Filter
Filter'substrings (IMPLICIT ('CONTEXTUAL 7) AttributeDescription
-> NonEmpty (CHOICE Substring)
-> IMPLICIT ('CONTEXTUAL 4) SubstringFilter
SubstringFilter IMPLICIT ('CONTEXTUAL 7) AttributeDescription
attr (CHOICE Substring
xCHOICE Substring
-> [CHOICE Substring] -> NonEmpty (CHOICE Substring)
forall a. a -> [a] -> NonEmpty a
:|[CHOICE Substring]
xs))

    -- assertionvalue = valueencoding
    -- ; The <valueencoding> rule is used to encode an <AssertionValue>
    -- ; from Section 4.1.6 of [RFC4511].
    -- valueencoding  = 0*(normal / escaped)
    -- normal         = UTF1SUBSET / UTFMB
    -- escaped        = ESC HEX HEX
    -- UTF1SUBSET     = %x01-27 / %x2B-5B / %x5D-7F
    --                     ; UTF1SUBSET excludes 0x00 (NUL), LPAREN,
    --                     ; RPAREN, ASTERISK, and ESC.
    p'assertionvalue :: ParsecT s u Identity AssertionValue
p'assertionvalue = [Either Word8 Char] -> AssertionValue
deescape ([Either Word8 Char] -> AssertionValue)
-> ParsecT s u Identity [Either Word8 Char]
-> ParsecT s u Identity AssertionValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u Identity (Either Word8 Char)
-> ParsecT s u Identity [Either Word8 Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Either Word8 Char
forall a b. b -> Either a b
Right (Char -> Either Word8 Char)
-> ParsecT s u Identity Char
-> ParsecT s u Identity (Either Word8 Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ['\x00','(',')','*','\\'])) ParsecT s u Identity (Either Word8 Char)
-> ParsecT s u Identity (Either Word8 Char)
-> ParsecT s u Identity (Either Word8 Char)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Word8 -> Either Word8 Char
forall a b. a -> Either a b
Left (Word8 -> Either Word8 Char)
-> ParsecT s u Identity Word8
-> ParsecT s u Identity (Either Word8 Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u Identity Word8
forall u. ParsecT s u Identity Word8
p'escaped)

    p'escaped :: ParsecT s u Identity Word8
p'escaped = Char -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '\\' ParsecT s u Identity Char
-> ParsecT s u Identity Word8 -> ParsecT s u Identity Word8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((\hi :: Word8
hi lo :: Word8
lo -> Word8
hiWord8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
*16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
lo) (Word8 -> Word8 -> Word8)
-> ParsecT s u Identity Word8
-> ParsecT s u Identity (Word8 -> Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u Identity Word8
forall u. ParsecT s u Identity Word8
p'HEX ParsecT s u Identity (Word8 -> Word8)
-> ParsecT s u Identity Word8 -> ParsecT s u Identity Word8
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT s u Identity Word8
forall u. ParsecT s u Identity Word8
p'HEX)

    p'HEX :: ParsecT s u Identity Word8
p'HEX = (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word8) (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. (Ord a, Num a) => a -> a
go (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum (Char -> Word8)
-> ParsecT s u Identity Char -> ParsecT s u Identity Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
hexDigit
      where
        go :: a -> a
go n :: a
n
          | a
n a -> (a, a) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (0x30,0x39) = a
n a -> a -> a
forall a. Num a => a -> a -> a
- 0x30
          | a
n a -> (a, a) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (0x61,0x66) = a
n a -> a -> a
forall a. Num a => a -> a -> a
- (0x61 a -> a -> a
forall a. Num a => a -> a -> a
- 10)
          | a
n a -> (a, a) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (0x41,0x46) = a
n a -> a -> a
forall a. Num a => a -> a -> a
- (0x41 a -> a -> a
forall a. Num a => a -> a -> a
- 10)
          | Bool
otherwise              = a
forall a. HasCallStack => a
undefined


----------------------------------------------------------------------------

deescape :: [Either Word8 Char] -> OCTET_STRING
deescape :: [Either Word8 Char] -> AssertionValue
deescape = [AssertionValue] -> AssertionValue
forall a. Monoid a => [a] -> a
mconcat ([AssertionValue] -> AssertionValue)
-> ([Either Word8 Char] -> [AssertionValue])
-> [Either Word8 Char]
-> AssertionValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either (NonEmpty Word8) (NonEmpty Char) -> AssertionValue)
-> [Either (NonEmpty Word8) (NonEmpty Char)] -> [AssertionValue]
forall a b. (a -> b) -> [a] -> [b]
map Either (NonEmpty Word8) (NonEmpty Char) -> AssertionValue
go ([Either (NonEmpty Word8) (NonEmpty Char)] -> [AssertionValue])
-> ([Either Word8 Char]
    -> [Either (NonEmpty Word8) (NonEmpty Char)])
-> [Either Word8 Char]
-> [AssertionValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Word8 Char] -> [Either (NonEmpty Word8) (NonEmpty Char)]
forall l r. [Either l r] -> [Either (NonEmpty l) (NonEmpty r)]
groupEither
  where
    go :: Either (NonEmpty Word8) (NonEmpty Char) -> AssertionValue
go (Left (x :: Word8
x:|xs :: [Word8]
xs))  = [Word8] -> AssertionValue
BS.pack (Word8
xWord8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
xs)
    go (Right (c :: Char
c:|cs :: [Char]
cs)) = Text -> AssertionValue
T.encodeUtf8 ([Char] -> Text
T.pack (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
cs))

groupEither :: [Either l r] -> [Either (NonEmpty l) (NonEmpty r)]
groupEither :: [Either l r] -> [Either (NonEmpty l) (NonEmpty r)]
groupEither = \case
    [] -> []
    Left  l :: l
l : rest :: [Either l r]
rest -> NonEmpty l -> [Either l r] -> [Either (NonEmpty l) (NonEmpty r)]
forall a a.
NonEmpty a -> [Either a a] -> [Either (NonEmpty a) (NonEmpty a)]
goLeft  (l
ll -> [l] -> NonEmpty l
forall a. a -> [a] -> NonEmpty a
:|[]) [Either l r]
rest
    Right r :: r
r : rest :: [Either l r]
rest -> NonEmpty r -> [Either l r] -> [Either (NonEmpty l) (NonEmpty r)]
forall a a.
NonEmpty a -> [Either a a] -> [Either (NonEmpty a) (NonEmpty a)]
goRight (r
rr -> [r] -> NonEmpty r
forall a. a -> [a] -> NonEmpty a
:|[]) [Either l r]
rest
  where
    goLeft :: NonEmpty a -> [Either a a] -> [Either (NonEmpty a) (NonEmpty a)]
goLeft acc :: NonEmpty a
acc []               = NonEmpty a -> Either (NonEmpty a) (NonEmpty a)
forall a b. a -> Either a b
Left (NonEmpty a -> NonEmpty a
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty a
acc) Either (NonEmpty a) (NonEmpty a)
-> [Either (NonEmpty a) (NonEmpty a)]
-> [Either (NonEmpty a) (NonEmpty a)]
forall a. a -> [a] -> [a]
: []
    goLeft acc :: NonEmpty a
acc (Left  l :: a
l : rest :: [Either a a]
rest) =                         NonEmpty a -> [Either a a] -> [Either (NonEmpty a) (NonEmpty a)]
goLeft (a
la -> NonEmpty a -> NonEmpty a
forall a. a -> NonEmpty a -> NonEmpty a
<|NonEmpty a
acc) [Either a a]
rest
    goLeft acc :: NonEmpty a
acc (Right r :: a
r : rest :: [Either a a]
rest) = NonEmpty a -> Either (NonEmpty a) (NonEmpty a)
forall a b. a -> Either a b
Left (NonEmpty a -> NonEmpty a
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty a
acc) Either (NonEmpty a) (NonEmpty a)
-> [Either (NonEmpty a) (NonEmpty a)]
-> [Either (NonEmpty a) (NonEmpty a)]
forall a. a -> [a] -> [a]
: NonEmpty a -> [Either a a] -> [Either (NonEmpty a) (NonEmpty a)]
goRight (a
ra -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:|[]) [Either a a]
rest

    goRight :: NonEmpty a -> [Either a a] -> [Either (NonEmpty a) (NonEmpty a)]
goRight acc :: NonEmpty a
acc []               = NonEmpty a -> Either (NonEmpty a) (NonEmpty a)
forall a b. b -> Either a b
Right (NonEmpty a -> NonEmpty a
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty a
acc) Either (NonEmpty a) (NonEmpty a)
-> [Either (NonEmpty a) (NonEmpty a)]
-> [Either (NonEmpty a) (NonEmpty a)]
forall a. a -> [a] -> [a]
: []
    goRight acc :: NonEmpty a
acc (Left  l :: a
l : rest :: [Either a a]
rest) = NonEmpty a -> Either (NonEmpty a) (NonEmpty a)
forall a b. b -> Either a b
Right (NonEmpty a -> NonEmpty a
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty a
acc) Either (NonEmpty a) (NonEmpty a)
-> [Either (NonEmpty a) (NonEmpty a)]
-> [Either (NonEmpty a) (NonEmpty a)]
forall a. a -> [a] -> [a]
: NonEmpty a -> [Either a a] -> [Either (NonEmpty a) (NonEmpty a)]
goLeft (a
la -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:|[]) [Either a a]
rest
    goRight acc :: NonEmpty a
acc (Right r :: a
r : rest :: [Either a a]
rest) =                          NonEmpty a -> [Either a a] -> [Either (NonEmpty a) (NonEmpty a)]
goRight (a
ra -> NonEmpty a -> NonEmpty a
forall a. a -> NonEmpty a -> NonEmpty a
<|NonEmpty a
acc) [Either a a]
rest

{-# INLINE some #-}
some :: Stream s m t => ParsecT s u m a -> ParsecT s u m (NonEmpty a)
some :: ParsecT s u m a -> ParsecT s u m (NonEmpty a)
some p :: ParsecT s u m a
p = do
  [a]
xs0 <- ParsecT s u m a -> ParsecT s u m [a]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT s u m a
p
  case [a]
xs0 of
    []     -> [Char] -> ParsecT s u m (NonEmpty a)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail "some': the impossible just happened"
    (x :: a
x:xs :: [a]
xs) -> NonEmpty a -> ParsecT s u m (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
xa -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:|[a]
xs)