{-# LANGUAGE CPP   #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Safe  #-}
module Kleene.Functor.NonEmpty (
    K1,
    Greediness (..),
    -- * Constructors
    some1,
    few1,
    anyChar,
    oneof,
    char,
    charRange,
    dot,
    everything1,
    string,
    -- * Queries
    isEmpty,
    isEverything,
    -- * Matching
    match,
    -- * Conversions
    toRE,
    toKleene,
    toRA,
    nullableProof,
    ) where

import Control.Applicative (Alternative (..), liftA2)
import Data.Foldable       (toList)
import Data.Functor.Alt    ((<!>))
import Data.Functor.Apply  (Apply (..))
import Data.List.NonEmpty  (NonEmpty (..))
import Data.RangeSet.Map   (RSet)

import qualified Data.Functor.Alt       as Alt
import qualified Data.List.NonEmpty     as NE
import qualified Data.RangeSet.Map      as RSet
import qualified Text.Regex.Applicative as R

import qualified Kleene.Classes          as C
import           Kleene.Internal.Functor (Greediness (..), K (..))
import           Kleene.Internal.Pretty
import           Kleene.Internal.Sets
import qualified Kleene.RE               as RE

-- $setup
--
-- >>> import Control.Applicative (optional, Alternative (..))
-- >>> import Data.Functor.Apply (Apply (..))
-- >>> import Data.List.NonEmpty (NonEmpty (..))
-- >>> import Kleene.Functor (Greediness (..), K (..))
-- >>> import Data.Foldable (toList)
-- >>> import Kleene.Internal.Pretty (putPretty)
-- >>> import qualified Kleene.RE as RE
-- >>> import qualified Kleene.Classes as C
-- >>> import qualified Text.Regex.Applicative as R

-- | 'Applicative' 'Functor' regular expression.
data K1 c a where
    K1Empty  :: K1 c a
    K1Char   :: (Ord c, Enum c) => RSet c -> K1 c c
    K1Append :: (a -> b -> r) -> K1 c a -> K1 c b -> K1 c r
    K1Union  :: K1 c a -> K1 c a -> K1 c a
    KPlus    :: Greediness -> K1 c a -> K1 c (NonEmpty a)

    -- optimisations
    K1Map    :: (a -> b) -> K1 c a -> K1 c b -- could use Pure and Append
    K1String :: Eq c => NonEmpty c -> K1 c (NonEmpty c)     -- could use Char and Append

instance Functor (K1 c) where
    fmap :: forall a b. (a -> b) -> K1 c a -> K1 c b
fmap a -> b
_ K1 c a
K1Empty          = K1 c b
forall c a. K1 c a
K1Empty
    fmap a -> b
f (K1Map a -> a
g K1 c a
k)      = (a -> b) -> K1 c a -> K1 c b
forall a b c. (a -> b) -> K1 c a -> K1 c b
K1Map (a -> b
f (a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
g) K1 c a
k
    fmap a -> b
f (K1Append a -> b -> a
g K1 c a
a K1 c b
b) = (a -> b -> b) -> K1 c a -> K1 c b -> K1 c b
forall a b r c. (a -> b -> r) -> K1 c a -> K1 c b -> K1 c r
K1Append (\a
x b
y -> a -> b
f (a -> b -> a
g a
x b
y)) K1 c a
a K1 c b
b
    fmap a -> b
f K1 c a
k                = (a -> b) -> K1 c a -> K1 c b
forall a b c. (a -> b) -> K1 c a -> K1 c b
K1Map a -> b
f K1 c a
k

instance Apply (K1 c) where
    K1 c (a -> b)
K1Empty <.> :: forall a b. K1 c (a -> b) -> K1 c a -> K1 c b
<.> K1 c a
_ = K1 c b
forall c a. K1 c a
K1Empty
    K1 c (a -> b)
_ <.> K1 c a
K1Empty = K1 c b
forall c a. K1 c a
K1Empty

    K1 c (a -> b)
f <.> K1 c a
x = ((a -> b) -> a -> b) -> K1 c (a -> b) -> K1 c a -> K1 c b
forall a b r c. (a -> b -> r) -> K1 c a -> K1 c b -> K1 c r
K1Append (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($) K1 c (a -> b)
f K1 c a
x

    liftF2 :: forall a b c. (a -> b -> c) -> K1 c a -> K1 c b -> K1 c c
liftF2 = (a -> b -> c) -> K1 c a -> K1 c b -> K1 c c
forall a b r c. (a -> b -> r) -> K1 c a -> K1 c b -> K1 c r
K1Append

instance Alt.Alt (K1 c) where
    K1 c a
K1Empty <!> :: forall a. K1 c a -> K1 c a -> K1 c a
<!> K1 c a
k = K1 c a
k
    K1 c a
k <!> K1 c a
K1Empty = K1 c a
k
    K1Char RSet c
a <!> K1Char RSet c
b = RSet c -> K1 c c
forall c. (Ord c, Enum c) => RSet c -> K1 c c
K1Char (RSet c -> RSet c -> RSet c
forall a. (Ord a, Enum a) => RSet a -> RSet a -> RSet a
RSet.union RSet c
a RSet c
b)

    K1 c a
a <!> K1 c a
b = K1 c a -> K1 c a -> K1 c a
forall c a. K1 c a -> K1 c a -> K1 c a
K1Union K1 c a
a K1 c a
b

--
some1 :: K1 c a -> K1 c (NonEmpty a)
some1 :: forall c a. K1 c a -> K1 c (NonEmpty a)
some1 K1 c a
K1Empty     = K1 c (NonEmpty a)
forall c a. K1 c a
K1Empty
some1 (KPlus Greediness
_ K1 c a
k) = (a -> NonEmpty a) -> K1 c a -> K1 c (NonEmpty a)
forall a b c. (a -> b) -> K1 c a -> K1 c b
K1Map a -> NonEmpty a
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Greediness -> K1 c a -> K1 c (NonEmpty a)
forall c a. Greediness -> K1 c a -> K1 c (NonEmpty a)
KPlus Greediness
Greedy K1 c a
k)
some1 K1 c a
k           = Greediness -> K1 c a -> K1 c (NonEmpty a)
forall c a. Greediness -> K1 c a -> K1 c (NonEmpty a)
KPlus Greediness
Greedy K1 c a
k

-- | 'few1', not 'some1'.
--
-- Let's define two similar regexps
--
-- >>> let re1 = liftF2 (,) (few1 $ char 'a')  (some1 $ char 'a')
-- >>> let re2 = liftF2 (,) (some1 $ char 'a') (few1  $ char 'a')
--
-- Their 'RE' behaviour is the same:
--
-- >>> C.equivalent (toRE re1) (toRE re2)
-- True
--
-- >>> map (C.match $ toRE re1) ["aaa","bbb"]
-- [True,False]
--
-- However, the 'RA' behaviour is different!
--
-- >>> R.match (toRA re1) "aaaaa"
-- Just ('a' :| "",'a' :| "aaa")
--
-- >>> R.match (toRA re2) "aaaaa"
-- Just ('a' :| "aaa",'a' :| "")
--
few1 :: K1 c a -> K1 c (NonEmpty a)
few1 :: forall c a. K1 c a -> K1 c (NonEmpty a)
few1 K1 c a
K1Empty     = K1 c (NonEmpty a)
forall c a. K1 c a
K1Empty
few1 (KPlus Greediness
_ K1 c a
k) = (a -> NonEmpty a) -> K1 c a -> K1 c (NonEmpty a)
forall a b c. (a -> b) -> K1 c a -> K1 c b
K1Map a -> NonEmpty a
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Greediness -> K1 c a -> K1 c (NonEmpty a)
forall c a. Greediness -> K1 c a -> K1 c (NonEmpty a)
KPlus Greediness
NonGreedy K1 c a
k)
few1 K1 c a
k           = Greediness -> K1 c a -> K1 c (NonEmpty a)
forall c a. Greediness -> K1 c a -> K1 c (NonEmpty a)
KPlus Greediness
NonGreedy K1 c a
k

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

-- | >>> putPretty anyChar
-- ^[^]$
anyChar :: (Ord c, Enum c, Bounded c) => K1 c c
anyChar :: forall c. (Ord c, Enum c, Bounded c) => K1 c c
anyChar = RSet c -> K1 c c
forall c. (Ord c, Enum c) => RSet c -> K1 c c
K1Char RSet c
forall a. Bounded a => RSet a
RSet.full

-- | >>> putPretty $ oneof ("foobar" :: [Char])
-- ^[a-bfor]$
oneof :: (Ord c, Enum c, Foldable f) => f c -> K1 c c
oneof :: forall c (f :: * -> *).
(Ord c, Enum c, Foldable f) =>
f c -> K1 c c
oneof = RSet c -> K1 c c
forall c. (Ord c, Enum c) => RSet c -> K1 c c
K1Char (RSet c -> K1 c c) -> (f c -> RSet c) -> f c -> K1 c c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [c] -> RSet c
forall a. (Ord a, Enum a) => [a] -> RSet a
RSet.fromList ([c] -> RSet c) -> (f c -> [c]) -> f c -> RSet c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f c -> [c]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | >>> putPretty $ char 'x'
-- ^x$
char :: (Ord c, Enum c) => c -> K1 c c
char :: forall c. (Ord c, Enum c) => c -> K1 c c
char = RSet c -> K1 c c
forall c. (Ord c, Enum c) => RSet c -> K1 c c
K1Char (RSet c -> K1 c c) -> (c -> RSet c) -> c -> K1 c c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> RSet c
forall a. a -> RSet a
RSet.singleton

-- | >>> putPretty $ charRange 'a' 'z'
-- ^[a-z]$
charRange :: (Enum c, Ord c) => c -> c -> K1 c c
charRange :: forall c. (Enum c, Ord c) => c -> c -> K1 c c
charRange c
a c
b = RSet c -> K1 c c
forall c. (Ord c, Enum c) => RSet c -> K1 c c
K1Char ((c, c) -> RSet c
forall a. Ord a => (a, a) -> RSet a
RSet.singletonRange (c
a, c
b))

-- | >>> putPretty dot
-- ^.$
dot :: K1 Char Char
dot :: K1 Char Char
dot = RSet Char -> K1 Char Char
forall c. (Ord c, Enum c) => RSet c -> K1 c c
K1Char RSet Char
dotRSet

-- | >>> putPretty everything1
-- ^[^][^]*$
everything1 :: (Ord c, Enum c, Bounded c) => K1 c (NonEmpty c)
everything1 :: forall c. (Ord c, Enum c, Bounded c) => K1 c (NonEmpty c)
everything1 = K1 c c -> K1 c (NonEmpty c)
forall c a. K1 c a -> K1 c (NonEmpty a)
some1 K1 c c
forall c. (Ord c, Enum c, Bounded c) => K1 c c
anyChar

-- | Matches nothing?
isEmpty :: (Ord c, Enum c, Bounded c) => K1 c a -> Bool
isEmpty :: forall c a. (Ord c, Enum c, Bounded c) => K1 c a -> Bool
isEmpty K1 c a
k = RE c -> RE c -> Bool
forall c k. Equivalent c k => k -> k -> Bool
C.equivalent (K1 c a -> RE c
forall c a. (Ord c, Enum c, Bounded c) => K1 c a -> RE c
toRE K1 c a
k) RE c
forall k. Kleene k => k
C.empty

-- | Matches whole input?
isEverything :: (Ord c, Enum c, Bounded c) => K1 c a -> Bool
isEverything :: forall c a. (Ord c, Enum c, Bounded c) => K1 c a -> Bool
isEverything K1 c a
k = RE c -> RE c -> Bool
forall c k. Equivalent c k => k -> k -> Bool
C.equivalent (K1 c a -> RE c
forall c a. (Ord c, Enum c, Bounded c) => K1 c a -> RE c
toRE K1 c a
k) RE c
forall c k. FiniteKleene c k => k
C.everything

string :: String -> K1 Char (NonEmpty Char)
string :: String -> K1 Char (NonEmpty Char)
string []       = String -> K1 Char (NonEmpty Char)
forall a. HasCallStack => String -> a
error String
"panic! K1.string []"
string (Char
x : String
xs) = NonEmpty Char -> K1 Char (NonEmpty Char)
forall c. Eq c => NonEmpty c -> K1 c (NonEmpty c)
K1String (Char
x Char -> String -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| String
xs)

-------------------------------------------------------------------------------
-- Matching
-------------------------------------------------------------------------------

-- | Match using @regex-applicative@
match :: K1 c a -> [c] -> Maybe a
match :: forall c a. K1 c a -> [c] -> Maybe a
match = RE c a -> [c] -> Maybe a
forall s a. RE s a -> [s] -> Maybe a
R.match (RE c a -> [c] -> Maybe a)
-> (K1 c a -> RE c a) -> K1 c a -> [c] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 c a -> RE c a
forall c a. K1 c a -> RE c a
toRA

-------------------------------------------------------------------------------
-- RE
-------------------------------------------------------------------------------

-- | Convert to 'RE'.
--
-- >>> putPretty (toRE $ some1 (string "foo") :: RE.RE Char)
-- ^foo(foo)*$
--
toRE :: (Ord c, Enum c, Bounded c) => K1 c a -> RE.RE c
toRE :: forall c a. (Ord c, Enum c, Bounded c) => K1 c a -> RE c
toRE = K1 c a -> RE c
forall c k a. FiniteKleene c k => K1 c a -> k
toKleene

-- | Convert to any 'Kleene'
toKleene :: C.FiniteKleene c k => K1 c a -> k
toKleene :: forall c k a. FiniteKleene c k => K1 c a -> k
toKleene (K1Map a -> a
_ K1 c a
a)      = K1 c a -> k
forall c k a. FiniteKleene c k => K1 c a -> k
toKleene K1 c a
a
toKleene (K1Union K1 c a
a K1 c a
b)    = [k] -> k
forall k. Kleene k => [k] -> k
C.unions [K1 c a -> k
forall c k a. FiniteKleene c k => K1 c a -> k
toKleene K1 c a
a, K1 c a -> k
forall c k a. FiniteKleene c k => K1 c a -> k
toKleene K1 c a
b]
toKleene (K1Append a -> b -> a
_ K1 c a
a K1 c b
b) = [k] -> k
forall k. Kleene k => [k] -> k
C.appends [K1 c a -> k
forall c k a. FiniteKleene c k => K1 c a -> k
toKleene K1 c a
a, K1 c b -> k
forall c k a. FiniteKleene c k => K1 c a -> k
toKleene K1 c b
b]
toKleene (KPlus Greediness
_ K1 c a
a)      = let k :: k
k = K1 c a -> k
forall c k a. FiniteKleene c k => K1 c a -> k
toKleene K1 c a
a in [k] -> k
forall k. Kleene k => [k] -> k
C.appends [k
k, k -> k
forall k. Kleene k => k -> k
C.star k
k]
toKleene (K1String NonEmpty c
s)     = [k] -> k
forall k. Kleene k => [k] -> k
C.appends ((c -> k) -> [c] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map c -> k
forall c k. CharKleene c k => c -> k
C.char ([c] -> [k]) -> [c] -> [k]
forall a b. (a -> b) -> a -> b
$ NonEmpty c -> [c]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty c
s)
toKleene K1 c a
K1Empty          = k
forall k. Kleene k => k
C.empty
toKleene (K1Char RSet c
cs)      = RSet c -> k
forall c k. FiniteKleene c k => RSet c -> k
C.fromRSet RSet c
cs

-------------------------------------------------------------------------------
-- regex-applicative
-------------------------------------------------------------------------------

-- | Convert 'K' to 'R.RE' from @regex-applicative@.
--
-- >>> R.match (toRA (string "xx" .> everything1 <. string "zz" :: K1 Char (NonEmpty Char))) "xxyyzyyzz"
-- Just ('y' :| "yzyy")
--
-- See also 'match'.
--
toRA :: K1 c a -> R.RE c a
toRA :: forall c a. K1 c a -> RE c a
toRA K1 c a
K1Empty              = RE c a
forall a. RE c a
forall (f :: * -> *) a. Alternative f => f a
empty
toRA (K1Char RSet c
cs)          = (c -> Bool) -> RE c c
forall s. (s -> Bool) -> RE s s
R.psym (\c
c -> c -> RSet c -> Bool
forall a. Ord a => a -> RSet a -> Bool
RSet.member c
c RSet c
cs)
toRA (K1Append a -> b -> a
f K1 c a
a K1 c b
b)     = (a -> b -> a) -> RE c a -> RE c b -> RE c a
forall a b c. (a -> b -> c) -> RE c a -> RE c b -> RE c c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> a
f (K1 c a -> RE c a
forall c a. K1 c a -> RE c a
toRA K1 c a
a) (K1 c b -> RE c b
forall c a. K1 c a -> RE c a
toRA K1 c b
b)
toRA (K1Union K1 c a
a K1 c a
b)        = K1 c a -> RE c a
forall c a. K1 c a -> RE c a
toRA K1 c a
a RE c a -> RE c a -> RE c a
forall a. RE c a -> RE c a -> RE c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> K1 c a -> RE c a
forall c a. K1 c a -> RE c a
toRA K1 c a
b
toRA (KPlus Greediness
Greedy K1 c a
a)     = a -> [a] -> a
a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> a) -> RE c a -> RE c ([a] -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K1 c a -> RE c a
forall c a. K1 c a -> RE c a
toRA K1 c a
a RE c ([a] -> a) -> RE c [a] -> RE c a
forall a b. RE c (a -> b) -> RE c a -> RE c b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE c a -> RE c [a]
forall a. RE c a -> RE c [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (K1 c a -> RE c a
forall c a. K1 c a -> RE c a
toRA K1 c a
a)
toRA (KPlus Greediness
NonGreedy K1 c a
a)  = a -> [a] -> a
a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> a) -> RE c a -> RE c ([a] -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K1 c a -> RE c a
forall c a. K1 c a -> RE c a
toRA K1 c a
a RE c ([a] -> a) -> RE c [a] -> RE c a
forall a b. RE c (a -> b) -> RE c a -> RE c b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE c a -> RE c [a]
forall s a. RE s a -> RE s [a]
R.few (K1 c a -> RE c a
forall c a. K1 c a -> RE c a
toRA K1 c a
a)
toRA (K1Map a -> a
f K1 c a
a)          = (a -> a) -> RE c a -> RE c a
forall a b. (a -> b) -> RE c a -> RE c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f (K1 c a -> RE c a
forall c a. K1 c a -> RE c a
toRA K1 c a
a)
toRA (K1String (c
x :| [c]
xs)) = c -> [c] -> a
c -> [c] -> NonEmpty c
forall a. a -> [a] -> NonEmpty a
(:|) (c -> [c] -> a) -> RE c c -> RE c ([c] -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> RE c c
forall s. Eq s => s -> RE s s
R.sym c
x RE c ([c] -> a) -> RE c [c] -> RE c a
forall a b. RE c (a -> b) -> RE c a -> RE c b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [c] -> RE c [c]
forall a. Eq a => [a] -> RE a [a]
R.string [c]
xs

-------------------------------------------------------------------------------
-- nullableProof
-------------------------------------------------------------------------------

-- |
-- >>> putPretty $ nullableProof (pure True)
-- Right 1 , ^[]$
--
-- >>> putPretty $ nullableProof (many "xyz" :: K Char [String])
-- Right [] , ^xyz(xyz)*$
--
-- >>> putPretty $ nullableProof (many $ toList <$> optional "x" <|> many "yz" :: K Char [[String]])
-- Right [] , ^(x|yz(yz)*)(x|yz(yz)*)*$
--
nullableProof :: K c a -> Either (K1 c a) (a, K1 c a)
nullableProof :: forall c a. K c a -> Either (K1 c a) (a, K1 c a)
nullableProof K c a
KEmpty    = K1 c a -> Either (K1 c a) (a, K1 c a)
forall a b. a -> Either a b
Left K1 c a
forall c a. K1 c a
K1Empty
nullableProof (KPure a
x) = (a, K1 c a) -> Either (K1 c a) (a, K1 c a)
forall a b. b -> Either a b
Right (a
x, K1 c a
forall c a. K1 c a
K1Empty)
nullableProof (KChar RSet c
c) = K1 c a -> Either (K1 c a) (a, K1 c a)
forall a b. a -> Either a b
Left (RSet c -> K1 c c
forall c. (Ord c, Enum c) => RSet c -> K1 c c
K1Char RSet c
c)

nullableProof (KAppend a1 -> b -> a
f K c a1
a K c b
b) = case (K c a1 -> Either (K1 c a1) (a1, K1 c a1)
forall c a. K c a -> Either (K1 c a) (a, K1 c a)
nullableProof K c a1
a, K c b -> Either (K1 c b) (b, K1 c b)
forall c a. K c a -> Either (K1 c a) (a, K1 c a)
nullableProof K c b
b) of
    (Left K1 c a1
x, Left K1 c b
y)               -> K1 c a -> Either (K1 c a) (a, K1 c a)
forall a b. a -> Either a b
Left ((a1 -> b -> a) -> K1 c a1 -> K1 c b -> K1 c a
forall a b r c. (a -> b -> r) -> K1 c a -> K1 c b -> K1 c r
K1Append a1 -> b -> a
f K1 c a1
x K1 c b
y)
    (Left K1 c a1
x, Right (b
y', K1 c b
y))        -> K1 c a -> Either (K1 c a) (a, K1 c a)
forall a b. a -> Either a b
Left ((a1 -> b -> a
`f` b
y') (a1 -> a) -> K1 c a1 -> K1 c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K1 c a1
x K1 c a -> K1 c a -> K1 c a
forall a. K1 c a -> K1 c a -> K1 c a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> (a1 -> b -> a) -> K1 c a1 -> K1 c b -> K1 c a
forall a b r c. (a -> b -> r) -> K1 c a -> K1 c b -> K1 c r
K1Append a1 -> b -> a
f K1 c a1
x K1 c b
y)
    (Right (a1
x', K1 c a1
x), Left K1 c b
y)        -> K1 c a -> Either (K1 c a) (a, K1 c a)
forall a b. a -> Either a b
Left ((a1 -> b -> a) -> K1 c a1 -> K1 c b -> K1 c a
forall a b r c. (a -> b -> r) -> K1 c a -> K1 c b -> K1 c r
K1Append a1 -> b -> a
f K1 c a1
x K1 c b
y K1 c a -> K1 c a -> K1 c a
forall a. K1 c a -> K1 c a -> K1 c a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> a1 -> b -> a
f a1
x' (b -> a) -> K1 c b -> K1 c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K1 c b
y)
    (Right (a1
x', K1 c a1
x), Right (b
y', K1 c b
y)) -> (a, K1 c a) -> Either (K1 c a) (a, K1 c a)
forall a b. b -> Either a b
Right
        (a1 -> b -> a
f a1
x' b
y'
        , (a1 -> b -> a) -> K1 c a1 -> K1 c b -> K1 c a
forall a b r c. (a -> b -> r) -> K1 c a -> K1 c b -> K1 c r
K1Append a1 -> b -> a
f K1 c a1
x K1 c b
y
        K1 c a -> K1 c a -> K1 c a
forall a. K1 c a -> K1 c a -> K1 c a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> (a1 -> b -> a) -> b -> a1 -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a1 -> b -> a
f b
y' (a1 -> a) -> K1 c a1 -> K1 c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K1 c a1
x
        K1 c a -> K1 c a -> K1 c a
forall a. K1 c a -> K1 c a -> K1 c a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> a1 -> b -> a
f a1
x' (b -> a) -> K1 c b -> K1 c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K1 c b
y
        )

nullableProof (KUnion K c a
a K c a
b) = case (K c a -> Either (K1 c a) (a, K1 c a)
forall c a. K c a -> Either (K1 c a) (a, K1 c a)
nullableProof K c a
a, K c a -> Either (K1 c a) (a, K1 c a)
forall c a. K c a -> Either (K1 c a) (a, K1 c a)
nullableProof K c a
b) of
    (Left K1 c a
x', Left K1 c a
_)              -> K1 c a -> Either (K1 c a) (a, K1 c a)
forall a b. a -> Either a b
Left K1 c a
x'
    (Right (a
x, K1 c a
x'), Left K1 c a
y')       -> (a, K1 c a) -> Either (K1 c a) (a, K1 c a)
forall a b. b -> Either a b
Right (a
x, K1 c a
x' K1 c a -> K1 c a -> K1 c a
forall a. K1 c a -> K1 c a -> K1 c a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> K1 c a
y')
    (Left K1 c a
x', Right (a
y, K1 c a
y'))       -> (a, K1 c a) -> Either (K1 c a) (a, K1 c a)
forall a b. b -> Either a b
Right (a
y, K1 c a
x' K1 c a -> K1 c a -> K1 c a
forall a. K1 c a -> K1 c a -> K1 c a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> K1 c a
y')
    (Right (a
x, K1 c a
x'), Right (a
_, K1 c a
y')) -> (a, K1 c a) -> Either (K1 c a) (a, K1 c a)
forall a b. b -> Either a b
Right (a
x, K1 c a
x' K1 c a -> K1 c a -> K1 c a
forall a. K1 c a -> K1 c a -> K1 c a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> K1 c a
y')

nullableProof (KStar Greediness
g K c a1
a) = case K c a1 -> Either (K1 c a1) (a1, K1 c a1)
forall c a. K c a -> Either (K1 c a) (a, K1 c a)
nullableProof K c a1
a of
    Left K1 c a1
x       -> (a, K1 c a) -> Either (K1 c a) (a, K1 c a)
forall a b. b -> Either a b
Right ([], NonEmpty a1 -> a
NonEmpty a1 -> [a1]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty a1 -> a) -> K1 c (NonEmpty a1) -> K1 c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K1 c a1 -> K1 c (NonEmpty a1)
star1 K1 c a1
x)
    Right (a1
_, K1 c a1
x) -> (a, K1 c a) -> Either (K1 c a) (a, K1 c a)
forall a b. b -> Either a b
Right ([], NonEmpty a1 -> a
NonEmpty a1 -> [a1]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty a1 -> a) -> K1 c (NonEmpty a1) -> K1 c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> K1 c a1 -> K1 c (NonEmpty a1)
star1 K1 c a1
x) -- note, we don't left recurse
  where
    star1 :: K1 c a1 -> K1 c (NonEmpty a1)
star1 = case Greediness
g of
        Greediness
Greedy    -> K1 c a1 -> K1 c (NonEmpty a1)
forall c a. K1 c a -> K1 c (NonEmpty a)
some1
        Greediness
NonGreedy -> K1 c a1 -> K1 c (NonEmpty a1)
forall c a. K1 c a -> K1 c (NonEmpty a)
few1

nullableProof (KMap a1 -> a
f K c a1
a) = case K c a1 -> Either (K1 c a1) (a1, K1 c a1)
forall c a. K c a -> Either (K1 c a) (a, K1 c a)
nullableProof K c a1
a of
    Right (a1
x, K1 c a1
x') -> (a, K1 c a) -> Either (K1 c a) (a, K1 c a)
forall a b. b -> Either a b
Right (a1 -> a
f a1
x, (a1 -> a) -> K1 c a1 -> K1 c a
forall a b. (a -> b) -> K1 c a -> K1 c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a1 -> a
f K1 c a1
x')
    Left K1 c a1
x'       -> K1 c a -> Either (K1 c a) (a, K1 c a)
forall a b. a -> Either a b
Left ((a1 -> a) -> K1 c a1 -> K1 c a
forall a b. (a -> b) -> K1 c a -> K1 c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a1 -> a
f K1 c a1
x')

nullableProof (KString [])       = (a, K1 c a) -> Either (K1 c a) (a, K1 c a)
forall a b. b -> Either a b
Right ([], K1 c a
forall c a. K1 c a
K1Empty)
nullableProof (KString (c
c : [c]
cs)) = K1 c a -> Either (K1 c a) (a, K1 c a)
forall a b. a -> Either a b
Left (NonEmpty c -> a
NonEmpty c -> [c]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty c -> a) -> K1 c (NonEmpty c) -> K1 c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty c -> K1 c (NonEmpty c)
forall c. Eq c => NonEmpty c -> K1 c (NonEmpty c)
K1String (c
c c -> [c] -> NonEmpty c
forall a. a -> [a] -> NonEmpty a
:| [c]
cs))

-------------------------------------------------------------------------------
-- JavaScript
-------------------------------------------------------------------------------

-- | Convert to non-matching JavaScript string which can be used
-- as an argument to @new RegExp@
--
-- >>> putPretty ("foobar" :: K Char String)
-- ^foobar$
--
-- >>> putPretty $ many ("foobar" :: K Char String)
-- ^(foobar)*$
--
instance c ~ Char => Pretty (K1 c a) where
    pretty :: K1 c a -> String
pretty = RE c -> String
forall a. Pretty a => a -> String
pretty (RE c -> String) -> (K1 c a -> RE c) -> K1 c a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 c a -> RE c
forall c a. (Ord c, Enum c, Bounded c) => K1 c a -> RE c
toRE