{-# LANGUAGE Safe #-}
{-# LANGUAGE BlockArguments #-}
module Text.Gigaparsec.State (
    Ref,
    make, unsafeMake,
    get, gets,
    set, sets,
    update,
    updateDuring, setDuring,
    rollback,
    forP, forP', forP_, forP'_
  ) where

import Text.Gigaparsec (Parsec, (<|>), empty)
import Text.Gigaparsec.Internal qualified as Internal (Parsec(..))

import Text.Gigaparsec.Combinator (ifS, whenS)

import Data.Ref (Ref, newRef, readRef, writeRef)

unsafeMake :: (forall r. Ref r a -> Parsec b) -> Parsec b
unsafeMake :: forall a b. (forall r. Ref r a -> Parsec b) -> Parsec b
unsafeMake = a -> (forall r. Ref r a -> Parsec b) -> Parsec b
forall a b. a -> (forall r. Ref r a -> Parsec b) -> Parsec b
make ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"reference used but not set")

_make :: Parsec a -> (forall r. Ref r a -> Parsec b) -> Parsec b
_make :: forall a b. Parsec a -> (forall r. Ref r a -> Parsec b) -> Parsec b
_make Parsec a
p forall r. Ref r a -> Parsec b
f = Parsec a
p Parsec a -> (a -> Parsec b) -> Parsec b
forall a b. Parsec a -> (a -> Parsec b) -> Parsec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> a -> (forall r. Ref r a -> Parsec b) -> Parsec b
forall a b. a -> (forall r. Ref r a -> Parsec b) -> Parsec b
make a
x Ref r a -> Parsec b
forall r. Ref r a -> Parsec b
f

make :: a -> (forall r. Ref r a -> Parsec b) -> Parsec b
make :: forall a b. a -> (forall r. Ref r a -> Parsec b) -> Parsec b
make a
x forall r. Ref r a -> Parsec b
f = (forall r.
 State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec b
forall a.
(forall r.
 State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
Internal.Parsec ((forall r.
  State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
 -> Parsec b)
-> (forall r.
    State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec b
forall a b. (a -> b) -> a -> b
$ \State
st b -> State -> RT r
good Error -> State -> RT r
bad ->
  a -> (forall {r}. Ref r a -> RT r) -> RT r
forall a b. a -> (forall r. Ref r a -> RT b) -> RT b
newRef a
x ((forall {r}. Ref r a -> RT r) -> RT r)
-> (forall {r}. Ref r a -> RT r) -> RT r
forall a b. (a -> b) -> a -> b
$ \Ref r a
ref ->
    let Internal.Parsec forall r.
State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r
p = Ref r a -> Parsec b
forall r. Ref r a -> Parsec b
f Ref r a
ref
    in State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r
forall r.
State -> (b -> State -> RT r) -> (Error -> State -> RT r) -> RT r
p State
st b -> State -> RT r
good Error -> State -> RT r
bad

get :: Ref r a -> Parsec a
get :: forall r a. Ref r a -> Parsec a
get Ref r a
ref = (forall r.
 State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
forall a.
(forall r.
 State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
Internal.Parsec ((forall r.
  State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
 -> Parsec a)
-> (forall r.
    State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
forall a b. (a -> b) -> a -> b
$ \State
st a -> State -> RT r
good Error -> State -> RT r
_ ->
  do a
x <- Ref r a -> RT a
forall r a. Ref r a -> RT a
readRef Ref r a
ref
     a -> State -> RT r
good a
x State
st

-- parsley provides multiple overloadings...
_gets :: Ref r a -> Parsec (a -> b) -> Parsec b
_gets :: forall r a b. Ref r a -> Parsec (a -> b) -> Parsec b
_gets Ref r a
ref Parsec (a -> b)
pf = Parsec (a -> b)
pf Parsec (a -> b) -> Parsec a -> Parsec b
forall a b. Parsec (a -> b) -> Parsec a -> Parsec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ref r a -> Parsec a
forall r a. Ref r a -> Parsec a
get Ref r a
ref

gets :: Ref r a -> (a -> b) -> Parsec b
gets :: forall r a b. Ref r a -> (a -> b) -> Parsec b
gets Ref r a
ref a -> b
f = a -> b
f (a -> b) -> Parsec a -> Parsec b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ref r a -> Parsec a
forall r a. Ref r a -> Parsec a
get Ref r a
ref

_set :: Ref r a -> Parsec a -> Parsec ()
_set :: forall r a. Ref r a -> Parsec a -> Parsec ()
_set Ref r a
ref Parsec a
px = Parsec a
px Parsec a -> (a -> Parsec ()) -> Parsec ()
forall a b. Parsec a -> (a -> Parsec b) -> Parsec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ref r a -> a -> Parsec ()
forall r a. Ref r a -> a -> Parsec ()
set Ref r a
ref

set :: Ref r a -> a -> Parsec ()
set :: forall r a. Ref r a -> a -> Parsec ()
set Ref r a
ref a
x = (forall r.
 State -> (() -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec ()
forall a.
(forall r.
 State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
Internal.Parsec ((forall r.
  State -> (() -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
 -> Parsec ())
-> (forall r.
    State -> (() -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec ()
forall a b. (a -> b) -> a -> b
$ \State
st () -> State -> RT r
good Error -> State -> RT r
_ ->
  do Ref r a -> a -> RT ()
forall r a. Ref r a -> a -> RT ()
writeRef Ref r a
ref a
x
     () -> State -> RT r
good () State
st

sets :: Ref r b -> (a -> b) -> Parsec a -> Parsec ()
sets :: forall r b a. Ref r b -> (a -> b) -> Parsec a -> Parsec ()
sets Ref r b
ref a -> b
f Parsec a
px = Ref r b -> Parsec b -> Parsec ()
forall r a. Ref r a -> Parsec a -> Parsec ()
_set Ref r b
ref (a -> b
f (a -> b) -> Parsec a -> Parsec b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec a
px)

_update :: Ref r a -> Parsec (a -> a) -> Parsec ()
_update :: forall r a. Ref r a -> Parsec (a -> a) -> Parsec ()
_update Ref r a
ref Parsec (a -> a)
pf = Ref r a -> Parsec a -> Parsec ()
forall r a. Ref r a -> Parsec a -> Parsec ()
_set Ref r a
ref (Ref r a -> Parsec (a -> a) -> Parsec a
forall r a b. Ref r a -> Parsec (a -> b) -> Parsec b
_gets Ref r a
ref Parsec (a -> a)
pf)

update :: Ref r a -> (a -> a) -> Parsec ()
update :: forall r a. Ref r a -> (a -> a) -> Parsec ()
update Ref r a
ref a -> a
f = Ref r a -> Parsec a -> Parsec ()
forall r a. Ref r a -> Parsec a -> Parsec ()
_set Ref r a
ref (Ref r a -> (a -> a) -> Parsec a
forall r a b. Ref r a -> (a -> b) -> Parsec b
gets Ref r a
ref a -> a
f)

updateDuring :: Ref r a -> (a -> a) -> Parsec b -> Parsec b
updateDuring :: forall r a b. Ref r a -> (a -> a) -> Parsec b -> Parsec b
updateDuring Ref r a
ref a -> a
f Parsec b
p = do a
x <- Ref r a -> Parsec a
forall r a. Ref r a -> Parsec a
get Ref r a
ref
                          Ref r a -> a -> Parsec ()
forall r a. Ref r a -> a -> Parsec ()
set Ref r a
ref (a -> a
f a
x)
                          Parsec b
p Parsec b -> Parsec () -> Parsec b
forall a b. Parsec a -> Parsec b -> Parsec a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Ref r a -> a -> Parsec ()
forall r a. Ref r a -> a -> Parsec ()
set Ref r a
ref a
x

setDuring :: Ref r a -> a -> Parsec b -> Parsec b
setDuring :: forall r a b. Ref r a -> a -> Parsec b -> Parsec b
setDuring Ref r a
ref a
x = Ref r a -> (a -> a) -> Parsec b -> Parsec b
forall r a b. Ref r a -> (a -> a) -> Parsec b -> Parsec b
updateDuring Ref r a
ref (a -> a -> a
forall a b. a -> b -> a
const a
x)

_setDuring :: Ref r a -> Parsec a -> Parsec b -> Parsec b
_setDuring :: forall r a b. Ref r a -> Parsec a -> Parsec b -> Parsec b
_setDuring Ref r a
ref Parsec a
px Parsec b
q = Parsec a
px Parsec a -> (a -> Parsec b) -> Parsec b
forall a b. Parsec a -> (a -> Parsec b) -> Parsec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> Parsec b -> Parsec b) -> Parsec b -> a -> Parsec b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Ref r a -> a -> Parsec b -> Parsec b
forall r a b. Ref r a -> a -> Parsec b -> Parsec b
setDuring Ref r a
ref) Parsec b
q

rollback :: Ref r a -> Parsec b -> Parsec b
rollback :: forall r a b. Ref r a -> Parsec b -> Parsec b
rollback Ref r a
ref Parsec b
p = Ref r a -> Parsec a
forall r a. Ref r a -> Parsec a
get Ref r a
ref Parsec a -> (a -> Parsec b) -> Parsec b
forall a b. Parsec a -> (a -> Parsec b) -> Parsec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> Parsec b
p Parsec b -> Parsec b -> Parsec b
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Ref r a -> a -> Parsec ()
forall r a. Ref r a -> a -> Parsec ()
set Ref r a
ref a
x Parsec () -> Parsec b -> Parsec b
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec b
forall a. Parsec a
forall (f :: * -> *) a. Alternative f => f a
empty)

forP :: Parsec a -> Parsec (a -> Bool) -> Parsec (a -> a) -> Parsec b -> Parsec [b]
forP :: forall a b.
Parsec a
-> Parsec (a -> Bool) -> Parsec (a -> a) -> Parsec b -> Parsec [b]
forP Parsec a
ini Parsec (a -> Bool)
cond Parsec (a -> a)
step = Parsec a
-> Parsec (a -> Bool)
-> Parsec (a -> a)
-> (a -> Parsec b)
-> Parsec [b]
forall a b.
Parsec a
-> Parsec (a -> Bool)
-> Parsec (a -> a)
-> (a -> Parsec b)
-> Parsec [b]
forP' Parsec a
ini Parsec (a -> Bool)
cond Parsec (a -> a)
step ((a -> Parsec b) -> Parsec [b])
-> (Parsec b -> a -> Parsec b) -> Parsec b -> Parsec [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec b -> a -> Parsec b
forall a b. a -> b -> a
const

forP' :: Parsec a -> Parsec (a -> Bool) -> Parsec (a -> a) -> (a -> Parsec b) -> Parsec [b]
forP' :: forall a b.
Parsec a
-> Parsec (a -> Bool)
-> Parsec (a -> a)
-> (a -> Parsec b)
-> Parsec [b]
forP' Parsec a
ini Parsec (a -> Bool)
cond Parsec (a -> a)
step a -> Parsec b
body = Parsec a
ini Parsec a -> (a -> Parsec [b]) -> Parsec [b]
forall a b. Parsec a -> (a -> Parsec b) -> Parsec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Parsec [b]
go
  where go :: a -> Parsec [b]
go a
i = (Parsec [b] -> Parsec [b] -> Parsec [b])
-> Parsec [b] -> Parsec [b] -> Parsec [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsec Bool -> Parsec [b] -> Parsec [b] -> Parsec [b]
forall a. Parsec Bool -> Parsec a -> Parsec a -> Parsec a
ifS (Parsec (a -> Bool)
cond Parsec (a -> Bool) -> Parsec a -> Parsec Bool
forall a b. Parsec (a -> b) -> Parsec a -> Parsec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Parsec a
forall a. a -> Parsec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
i)) ([b] -> Parsec [b]
forall a. a -> Parsec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) do
                  b
x <- a -> Parsec b
body a
i
                  a -> a
f <- Parsec (a -> a)
step
                  [b]
xs <- a -> Parsec [b]
go (a -> a
f a
i)
                  [b] -> Parsec [b]
forall a. a -> Parsec a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
xs)

forP_ :: Parsec a -> Parsec (a -> Bool) -> Parsec (a -> a) -> Parsec b -> Parsec ()
forP_ :: forall a b.
Parsec a
-> Parsec (a -> Bool) -> Parsec (a -> a) -> Parsec b -> Parsec ()
forP_ Parsec a
ini Parsec (a -> Bool)
cond Parsec (a -> a)
step = Parsec a
-> Parsec (a -> Bool)
-> Parsec (a -> a)
-> (a -> Parsec b)
-> Parsec ()
forall a b.
Parsec a
-> Parsec (a -> Bool)
-> Parsec (a -> a)
-> (a -> Parsec b)
-> Parsec ()
forP'_ Parsec a
ini Parsec (a -> Bool)
cond Parsec (a -> a)
step ((a -> Parsec b) -> Parsec ())
-> (Parsec b -> a -> Parsec b) -> Parsec b -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec b -> a -> Parsec b
forall a b. a -> b -> a
const

forP'_ :: Parsec a -> Parsec (a -> Bool) -> Parsec (a -> a) -> (a -> Parsec b) -> Parsec ()
forP'_ :: forall a b.
Parsec a
-> Parsec (a -> Bool)
-> Parsec (a -> a)
-> (a -> Parsec b)
-> Parsec ()
forP'_ Parsec a
ini Parsec (a -> Bool)
cond Parsec (a -> a)
step a -> Parsec b
body = Parsec a
ini Parsec a -> (a -> Parsec ()) -> Parsec ()
forall a b. Parsec a -> (a -> Parsec b) -> Parsec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Parsec ()
go
  where go :: a -> Parsec ()
go a
i = Parsec Bool -> Parsec () -> Parsec ()
whenS (Parsec (a -> Bool)
cond Parsec (a -> Bool) -> Parsec a -> Parsec Bool
forall a b. Parsec (a -> b) -> Parsec a -> Parsec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Parsec a
forall a. a -> Parsec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
i) do
                  a -> Parsec b
body a
i
                  a -> a
f <- Parsec (a -> a)
step
                  a -> Parsec ()
go (a -> a
f a
i)