-- |

module KMonad.Gesture

where

import KMonad.Prelude hiding (try)
import KMonad.Parsing

import Control.Monad.Except
import Control.Monad.State
import Data.Char

import RIO.List.Partial (head)
import RIO.Seq (Seq(..))

import qualified RIO.List as L
import qualified RIO.Seq  as Q
import qualified RIO.Set  as S


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

data Toggle a = On a | Off a deriving (Toggle a -> Toggle a -> Bool
(Toggle a -> Toggle a -> Bool)
-> (Toggle a -> Toggle a -> Bool) -> Eq (Toggle a)
forall a. Eq a => Toggle a -> Toggle a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Toggle a -> Toggle a -> Bool
== :: Toggle a -> Toggle a -> Bool
$c/= :: forall a. Eq a => Toggle a -> Toggle a -> Bool
/= :: Toggle a -> Toggle a -> Bool
Eq, Int -> Toggle a -> ShowS
[Toggle a] -> ShowS
Toggle a -> String
(Int -> Toggle a -> ShowS)
-> (Toggle a -> String) -> ([Toggle a] -> ShowS) -> Show (Toggle a)
forall a. Show a => Int -> Toggle a -> ShowS
forall a. Show a => [Toggle a] -> ShowS
forall a. Show a => Toggle a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Toggle a -> ShowS
showsPrec :: Int -> Toggle a -> ShowS
$cshow :: forall a. Show a => Toggle a -> String
show :: Toggle a -> String
$cshowList :: forall a. Show a => [Toggle a] -> ShowS
showList :: [Toggle a] -> ShowS
Show, (forall a b. (a -> b) -> Toggle a -> Toggle b)
-> (forall a b. a -> Toggle b -> Toggle a) -> Functor Toggle
forall a b. a -> Toggle b -> Toggle a
forall a b. (a -> b) -> Toggle a -> Toggle b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Toggle a -> Toggle b
fmap :: forall a b. (a -> b) -> Toggle a -> Toggle b
$c<$ :: forall a b. a -> Toggle b -> Toggle a
<$ :: forall a b. a -> Toggle b -> Toggle a
Functor)

-- | A sequence of toggle-changes guaranteed to be valid
newtype Gesture a = Gesture { forall a. Gesture a -> Seq (Toggle a)
_gesture :: Q.Seq (Toggle a) }
  deriving (Gesture a -> Gesture a -> Bool
(Gesture a -> Gesture a -> Bool)
-> (Gesture a -> Gesture a -> Bool) -> Eq (Gesture a)
forall a. Eq a => Gesture a -> Gesture a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Gesture a -> Gesture a -> Bool
== :: Gesture a -> Gesture a -> Bool
$c/= :: forall a. Eq a => Gesture a -> Gesture a -> Bool
/= :: Gesture a -> Gesture a -> Bool
Eq, Int -> Gesture a -> ShowS
[Gesture a] -> ShowS
Gesture a -> String
(Int -> Gesture a -> ShowS)
-> (Gesture a -> String)
-> ([Gesture a] -> ShowS)
-> Show (Gesture a)
forall a. Show a => Int -> Gesture a -> ShowS
forall a. Show a => [Gesture a] -> ShowS
forall a. Show a => Gesture a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Gesture a -> ShowS
showsPrec :: Int -> Gesture a -> ShowS
$cshow :: forall a. Show a => Gesture a -> String
show :: Gesture a -> String
$cshowList :: forall a. Show a => [Gesture a] -> ShowS
showList :: [Gesture a] -> ShowS
Show, (forall a b. (a -> b) -> Gesture a -> Gesture b)
-> (forall a b. a -> Gesture b -> Gesture a) -> Functor Gesture
forall a b. a -> Gesture b -> Gesture a
forall a b. (a -> b) -> Gesture a -> Gesture b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Gesture a -> Gesture b
fmap :: forall a b. (a -> b) -> Gesture a -> Gesture b
$c<$ :: forall a b. a -> Gesture b -> Gesture a
<$ :: forall a b. a -> Gesture b -> Gesture a
Functor)

instance Semigroup (Gesture a) where
  (Gesture Seq (Toggle a)
a) <> :: Gesture a -> Gesture a -> Gesture a
<> (Gesture Seq (Toggle a)
b) = Seq (Toggle a) -> Gesture a
forall a. Seq (Toggle a) -> Gesture a
Gesture (Seq (Toggle a) -> Gesture a) -> Seq (Toggle a) -> Gesture a
forall a b. (a -> b) -> a -> b
$ Seq (Toggle a)
a Seq (Toggle a) -> Seq (Toggle a) -> Seq (Toggle a)
forall a. Semigroup a => a -> a -> a
<> Seq (Toggle a)
b
instance Monoid (Gesture a) where
  mempty :: Gesture a
mempty = Seq (Toggle a) -> Gesture a
forall a. Seq (Toggle a) -> Gesture a
Gesture Seq (Toggle a)
forall a. Seq a
Q.empty

-- | All the ways a '[Toggle a]' can be an invalid 'Gesture'
data GestureError a
  = OffWithoutOn a -- ^ An Off not preceded by an On
  | OnWithoutOff a -- ^ An On not succeeded by an Off
  deriving (GestureError a -> GestureError a -> Bool
(GestureError a -> GestureError a -> Bool)
-> (GestureError a -> GestureError a -> Bool)
-> Eq (GestureError a)
forall a. Eq a => GestureError a -> GestureError a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => GestureError a -> GestureError a -> Bool
== :: GestureError a -> GestureError a -> Bool
$c/= :: forall a. Eq a => GestureError a -> GestureError a -> Bool
/= :: GestureError a -> GestureError a -> Bool
Eq, Int -> GestureError a -> ShowS
[GestureError a] -> ShowS
GestureError a -> String
(Int -> GestureError a -> ShowS)
-> (GestureError a -> String)
-> ([GestureError a] -> ShowS)
-> Show (GestureError a)
forall a. Show a => Int -> GestureError a -> ShowS
forall a. Show a => [GestureError a] -> ShowS
forall a. Show a => GestureError a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> GestureError a -> ShowS
showsPrec :: Int -> GestureError a -> ShowS
$cshow :: forall a. Show a => GestureError a -> String
show :: GestureError a -> String
$cshowList :: forall a. Show a => [GestureError a] -> ShowS
showList :: [GestureError a] -> ShowS
Show)


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

-- | A lens into the i
tag :: Lens' (Toggle a) a
tag :: forall a (f :: * -> *).
Functor f =>
(a -> f a) -> Toggle a -> f (Toggle a)
tag = (Toggle a -> a)
-> (Toggle a -> a -> Toggle a) -> Lens (Toggle a) (Toggle a) a a
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Toggle a -> a
forall {a}. Toggle a -> a
get Toggle a -> a -> Toggle a
forall {a} {a}. Toggle a -> a -> Toggle a
set
  where get :: Toggle a -> a
get (On a
x)    = a
x
        get (Off a
x)   = a
x
        set :: Toggle a -> a -> Toggle a
set (On a
_) a
x  = a -> Toggle a
forall a. a -> Toggle a
On a
x
        set (Off a
_) a
x = a -> Toggle a
forall a. a -> Toggle a
Off a
x

-- | A fold of all the unique elements in a gesture
tags :: Ord a => Fold (Gesture a) a
tags :: forall a. Ord a => Fold (Gesture a) a
tags = (Gesture a -> [a]) -> Fold (Gesture a) a
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding ((Gesture a -> [a]) -> Fold (Gesture a) a)
-> (Gesture a -> [a]) -> Fold (Gesture a) a
forall a b. (a -> b) -> a -> b
$ \(Gesture Seq (Toggle a)
as) -> Set a -> [a]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set a -> [a]) -> ([a] -> Set a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Seq (Toggle a)
asSeq (Toggle a) -> Getting (Endo [a]) (Seq (Toggle a)) a -> [a]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^..(Toggle a -> Const (Endo [a]) (Toggle a))
-> Seq (Toggle a) -> Const (Endo [a]) (Seq (Toggle a))
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int (Seq (Toggle a)) (Toggle a)
folded((Toggle a -> Const (Endo [a]) (Toggle a))
 -> Seq (Toggle a) -> Const (Endo [a]) (Seq (Toggle a)))
-> ((a -> Const (Endo [a]) a)
    -> Toggle a -> Const (Endo [a]) (Toggle a))
-> Getting (Endo [a]) (Seq (Toggle a)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Const (Endo [a]) a)
-> Toggle a -> Const (Endo [a]) (Toggle a)
forall a (f :: * -> *).
Functor f =>
(a -> f a) -> Toggle a -> f (Toggle a)
tag

-- | Create a tapping gesture
tap :: a -> Gesture a
tap :: forall a. a -> Gesture a
tap a
a = Seq (Toggle a) -> Gesture a
forall a. Seq (Toggle a) -> Gesture a
Gesture (Seq (Toggle a) -> Gesture a)
-> ([Toggle a] -> Seq (Toggle a)) -> [Toggle a] -> Gesture a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Toggle a] -> Seq (Toggle a)
forall a. [a] -> Seq a
Q.fromList ([Toggle a] -> Gesture a) -> [Toggle a] -> Gesture a
forall a b. (a -> b) -> a -> b
$ [a -> Toggle a
forall a. a -> Toggle a
On a
a, a -> Toggle a
forall a. a -> Toggle a
Off a
a]

-- | Wrap a gesture in a toggle iff the id does not already occur
around :: Ord a => a -> Gesture a -> Either (GestureError a) (Gesture a)
around :: forall a.
Ord a =>
a -> Gesture a -> Either (GestureError a) (Gesture a)
around a
x g :: Gesture a
g@(Gesture Seq (Toggle a)
seq)
  | Getting Any (Gesture a) a -> (a -> Bool) -> Gesture a -> Bool
forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf Getting Any (Gesture a) a
forall a. Ord a => Fold (Gesture a) a
Fold (Gesture a) a
tags (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) Gesture a
g = GestureError a -> Either (GestureError a) (Gesture a)
forall a b. a -> Either a b
Left (GestureError a -> Either (GestureError a) (Gesture a))
-> GestureError a -> Either (GestureError a) (Gesture a)
forall a b. (a -> b) -> a -> b
$ a -> GestureError a
forall a. a -> GestureError a
OnWithoutOff a
x
  | Bool
otherwise = Gesture a -> Either (GestureError a) (Gesture a)
forall a b. b -> Either a b
Right (Gesture a -> Either (GestureError a) (Gesture a))
-> (Seq (Toggle a) -> Gesture a)
-> Seq (Toggle a)
-> Either (GestureError a) (Gesture a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Toggle a) -> Gesture a
forall a. Seq (Toggle a) -> Gesture a
Gesture (Seq (Toggle a) -> Either (GestureError a) (Gesture a))
-> Seq (Toggle a) -> Either (GestureError a) (Gesture a)
forall a b. (a -> b) -> a -> b
$ (a -> Toggle a
forall a. a -> Toggle a
On a
x Toggle a -> Seq (Toggle a) -> Seq (Toggle a)
forall s a. Cons s s a a => a -> s -> s
<| Seq (Toggle a)
seq) Seq (Toggle a) -> Toggle a -> Seq (Toggle a)
forall s a. Snoc s s a a => s -> a -> s
|> a -> Toggle a
forall a. a -> Toggle a
Off a
x

-- | Create a gesture from a list of toggles
fromList :: Ord a => [Toggle a] -> Either (GestureError a) (Gesture a)
fromList :: forall a.
Ord a =>
[Toggle a] -> Either (GestureError a) (Gesture a)
fromList [Toggle a]
as = case (State (Set a) (Either (GestureError a) (Seq (Toggle a)))
-> Set a -> (Either (GestureError a) (Seq (Toggle a)), Set a)
forall s a. State s a -> s -> (a, s)
`runState` Set a
forall a. Set a
S.empty) (State (Set a) (Either (GestureError a) (Seq (Toggle a)))
 -> (Either (GestureError a) (Seq (Toggle a)), Set a))
-> ([Toggle a]
    -> State (Set a) (Either (GestureError a) (Seq (Toggle a))))
-> [Toggle a]
-> (Either (GestureError a) (Seq (Toggle a)), Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (GestureError a) (StateT (Set a) Identity) (Seq (Toggle a))
-> State (Set a) (Either (GestureError a) (Seq (Toggle a)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   (GestureError a) (StateT (Set a) Identity) (Seq (Toggle a))
 -> State (Set a) (Either (GestureError a) (Seq (Toggle a))))
-> ([Toggle a]
    -> ExceptT
         (GestureError a) (StateT (Set a) Identity) (Seq (Toggle a)))
-> [Toggle a]
-> State (Set a) (Either (GestureError a) (Seq (Toggle a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq (Toggle a)
 -> Toggle a
 -> ExceptT
      (GestureError a) (StateT (Set a) Identity) (Seq (Toggle a)))
-> Seq (Toggle a)
-> [Toggle a]
-> ExceptT
     (GestureError a) (StateT (Set a) Identity) (Seq (Toggle a))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Seq (Toggle a)
-> Toggle a
-> ExceptT
     (GestureError a) (StateT (Set a) Identity) (Seq (Toggle a))
forall {m :: * -> *} {a} {b}.
(MonadState (Set a) m, Ord a, MonadError (GestureError a) m,
 Snoc b b (Toggle a) (Toggle a)) =>
b -> Toggle a -> m b
f Seq (Toggle a)
forall a. Seq a
Q.empty ([Toggle a] -> (Either (GestureError a) (Seq (Toggle a)), Set a))
-> [Toggle a] -> (Either (GestureError a) (Seq (Toggle a)), Set a)
forall a b. (a -> b) -> a -> b
$ [Toggle a]
as of
  (Left GestureError a
e, Set a
_) -> GestureError a -> Either (GestureError a) (Gesture a)
forall a b. a -> Either a b
Left GestureError a
e
  (Right Seq (Toggle a)
g, Set a
s) | Set a -> Bool
forall a. Set a -> Bool
S.null Set a
s -> Gesture a -> Either (GestureError a) (Gesture a)
forall a b. b -> Either a b
Right (Gesture a -> Either (GestureError a) (Gesture a))
-> Gesture a -> Either (GestureError a) (Gesture a)
forall a b. (a -> b) -> a -> b
$ Seq (Toggle a) -> Gesture a
forall a. Seq (Toggle a) -> Gesture a
Gesture Seq (Toggle a)
g
               | Bool
otherwise -> GestureError a -> Either (GestureError a) (Gesture a)
forall a b. a -> Either a b
Left (GestureError a -> Either (GestureError a) (Gesture a))
-> GestureError a -> Either (GestureError a) (Gesture a)
forall a b. (a -> b) -> a -> b
$ a -> GestureError a
forall a. a -> GestureError a
OnWithoutOff ([a] -> a
forall a. HasCallStack => [a] -> a
head ([a] -> a) -> (Set a -> [a]) -> Set a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
S.elems (Set a -> a) -> Set a -> a
forall a b. (a -> b) -> a -> b
$ Set a
s)
  where
    f :: b -> Toggle a -> m b
f b
s Toggle a
x = do
      Set a
pressed <- m (Set a)
forall s (m :: * -> *). MonadState s m => m s
get
      case Toggle a
x of
        On a
c  | a
c a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
pressed -> GestureError a -> m b
forall a. GestureError a -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GestureError a -> m b) -> GestureError a -> m b
forall a b. (a -> b) -> a -> b
$ a -> GestureError a
forall a. a -> GestureError a
OnWithoutOff a
c
        On a
c -> Set a -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
c Set a
pressed) m () -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
s b -> Toggle a -> b
forall s a. Snoc s s a a => s -> a -> s
|> a -> Toggle a
forall a. a -> Toggle a
On a
c)
        Off a
c | Bool -> Bool
not (a
c a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
pressed) -> GestureError a -> m b
forall a. GestureError a -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GestureError a -> m b) -> GestureError a -> m b
forall a b. (a -> b) -> a -> b
$ a -> GestureError a
forall a. a -> GestureError a
OffWithoutOn a
c
        Off a
c -> Set a -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
c Set a
pressed) m () -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
s b -> Toggle a -> b
forall s a. Snoc s s a a => s -> a -> s
|> a -> Toggle a
forall a. a -> Toggle a
Off a
c)

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

type Gest = Q.Seq (Toggle Text)

data GestureReadError
  = GestureParseError ParseError
  | GestureValidateError (GestureError Text)
  deriving GestureReadError -> GestureReadError -> Bool
(GestureReadError -> GestureReadError -> Bool)
-> (GestureReadError -> GestureReadError -> Bool)
-> Eq GestureReadError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GestureReadError -> GestureReadError -> Bool
== :: GestureReadError -> GestureReadError -> Bool
$c/= :: GestureReadError -> GestureReadError -> Bool
/= :: GestureReadError -> GestureReadError -> Bool
Eq

instance Show GestureReadError where
  show :: GestureReadError -> String
show (GestureParseError ParseError
e) = ParseError -> String
forall a. Show a => a -> String
show ParseError
e
  show (GestureValidateError GestureError Text
e) = GestureError Text -> String
forall a. Show a => a -> String
show GestureError Text
e

instance Exception GestureReadError

-- | Parse a Gesture straight from Text
prsGesture :: Text -> Either GestureReadError (Gesture Text)
prsGesture :: Text -> Either GestureReadError (Gesture Text)
prsGesture Text
t = case Parsec Void Text Gest
-> String -> Text -> Either (ParseErrorBundle Text Void) Gest
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parsec Void Text Gest
gest String
"" Text
t of
  Left ParseErrorBundle Text Void
e -> GestureReadError -> Either GestureReadError (Gesture Text)
forall a b. a -> Either a b
Left (GestureReadError -> Either GestureReadError (Gesture Text))
-> (ParseErrorBundle Text Void -> GestureReadError)
-> ParseErrorBundle Text Void
-> Either GestureReadError (Gesture Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> GestureReadError
GestureParseError (ParseError -> GestureReadError)
-> (ParseErrorBundle Text Void -> ParseError)
-> ParseErrorBundle Text Void
-> GestureReadError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> ParseError
ParseError (ParseErrorBundle Text Void
 -> Either GestureReadError (Gesture Text))
-> ParseErrorBundle Text Void
-> Either GestureReadError (Gesture Text)
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void
e
  Right Gest
gs -> case [Toggle Text] -> Either (GestureError Text) (Gesture Text)
forall a.
Ord a =>
[Toggle a] -> Either (GestureError a) (Gesture a)
fromList (Gest -> [Toggle Text]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Gest
gs) of
    Left GestureError Text
e -> GestureReadError -> Either GestureReadError (Gesture Text)
forall a b. a -> Either a b
Left (GestureReadError -> Either GestureReadError (Gesture Text))
-> (GestureError Text -> GestureReadError)
-> GestureError Text
-> Either GestureReadError (Gesture Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GestureError Text -> GestureReadError
GestureValidateError (GestureError Text -> Either GestureReadError (Gesture Text))
-> GestureError Text -> Either GestureReadError (Gesture Text)
forall a b. (a -> b) -> a -> b
$ GestureError Text
e
    Right Gesture Text
g -> Gesture Text -> Either GestureReadError (Gesture Text)
forall a. a -> Either GestureReadError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Gesture Text
g

-- | Characters that may not occur in tag-names
reserved :: [Char]
reserved :: String
reserved = String
"()-~[]"

-- | Parse a series of valid characters as a tag
tag_ :: Parser Text
tag_ :: Parser Text
tag_ = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"tag-character") Char -> Bool
Token Text -> Bool
f
  where f :: Char -> Bool
f Char
c = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
reserved

-- | Parse a "S-" sequence as 1 tag around another
around_ :: Parser Gest
around_ :: Parsec Void Text Gest
around_ = do
  Text
a <- Parser Text
tag_
  Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-'
  Gest
b <- Parsec Void Text Gest -> Parsec Void Text Gest
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Gest
around_ Parsec Void Text Gest
-> Parsec Void Text Gest -> Parsec Void Text Gest
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Gest
subg Parsec Void Text Gest
-> Parsec Void Text Gest -> Parsec Void Text Gest
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Gest
tap_
  Gest -> Parsec Void Text Gest
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Gest -> Parsec Void Text Gest) -> Gest -> Parsec Void Text Gest
forall a b. (a -> b) -> a -> b
$ (Text -> Toggle Text
forall a. a -> Toggle a
On Text
a Toggle Text -> Gest -> Gest
forall s a. Cons s s a a => a -> s -> s
<| Gest
b) Gest -> Toggle Text -> Gest
forall s a. Snoc s s a a => s -> a -> s
|> Text -> Toggle Text
forall a. a -> Toggle a
Off Text
a

-- | Parse a ")-X" as an OFF-toggle
closeTag :: Parser Gest
closeTag :: Parsec Void Text Gest
closeTag = do
  Tokens Text
_ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
")-"
  Text
a <- Parser Text
tag_
  Gest -> Parsec Void Text Gest
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Gest -> Parsec Void Text Gest)
-> (Toggle Text -> Gest) -> Toggle Text -> Parsec Void Text Gest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Toggle Text -> Gest
forall a. a -> Seq a
Q.singleton (Toggle Text -> Parsec Void Text Gest)
-> Toggle Text -> Parsec Void Text Gest
forall a b. (a -> b) -> a -> b
$ Text -> Toggle Text
forall a. a -> Toggle a
Off Text
a

-- | Parse a "X-(" as an ON-toggle
openTag :: Parser Gest
openTag :: Parsec Void Text Gest
openTag = do
  Text
a <- Parser Text
tag_
  Tokens Text
_ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-("
  Gest -> Parsec Void Text Gest
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Gest -> Parsec Void Text Gest)
-> (Toggle Text -> Gest) -> Toggle Text -> Parsec Void Text Gest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Toggle Text -> Gest
forall a. a -> Seq a
Q.singleton (Toggle Text -> Parsec Void Text Gest)
-> Toggle Text -> Parsec Void Text Gest
forall a b. (a -> b) -> a -> b
$ Text -> Toggle Text
forall a. a -> Toggle a
On Text
a

-- | Parse only a tag as a tap of that element
tap_ :: Parser Gest
tap_ :: Parsec Void Text Gest
tap_ = do
  Text
a <- Parser Text
tag_
  Gest -> Parsec Void Text Gest
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Gest -> Parsec Void Text Gest)
-> ([Toggle Text] -> Gest)
-> [Toggle Text]
-> Parsec Void Text Gest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Toggle Text] -> Gest
forall a. [a] -> Seq a
Q.fromList ([Toggle Text] -> Parsec Void Text Gest)
-> [Toggle Text] -> Parsec Void Text Gest
forall a b. (a -> b) -> a -> b
$ [Text -> Toggle Text
forall a. a -> Toggle a
On Text
a, Text -> Toggle Text
forall a. a -> Toggle a
Off Text
a]

-- | Parse a [] delimited series as a nested gesture
subg :: Parser Gest
subg :: Parsec Void Text Gest
subg = do
  Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'['
  Gest
g <- Parsec Void Text Gest
gest
  Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
']'
  Gest -> Parsec Void Text Gest
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Gest
g

-- | Parse a full gesture
gest :: Parser Gest
gest :: Parsec Void Text Gest
gest = do
  let one :: Parsec Void Text Gest
one = Parsec Void Text Gest -> Parsec Void Text Gest
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lex (Parsec Void Text Gest -> Parsec Void Text Gest)
-> ([Parsec Void Text Gest] -> Parsec Void Text Gest)
-> [Parsec Void Text Gest]
-> Parsec Void Text Gest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Parsec Void Text Gest] -> Parsec Void Text Gest
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parsec Void Text Gest] -> Parsec Void Text Gest)
-> [Parsec Void Text Gest] -> Parsec Void Text Gest
forall a b. (a -> b) -> a -> b
$ [Parsec Void Text Gest
subg, Parsec Void Text Gest -> Parsec Void Text Gest
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Gest
openTag, Parsec Void Text Gest -> Parsec Void Text Gest
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Gest
around_, Parsec Void Text Gest -> Parsec Void Text Gest
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Gest
closeTag, Parsec Void Text Gest
tap_]
  [Gest]
es <- Parsec Void Text Gest -> ParsecT Void Text Identity [Gest]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parsec Void Text Gest
one
  Gest -> Parsec Void Text Gest
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Gest -> Parsec Void Text Gest) -> Gest -> Parsec Void Text Gest
forall a b. (a -> b) -> a -> b
$ [Gest] -> Gest
forall a. Monoid a => [a] -> a
mconcat [Gest]
es