{-# LANGUAGE BlockArguments #-}

module Text.Cassette.Internal.Tr where

import Control.Category (Category(..))
import Prelude hiding (flip, id, (.))

-- | The type of string transformers in CPS, /i.e./ functions from strings to
-- strings.
type C r = (String -> r) -> String -> r

-- | @'Tr' r r'@ is the type of string transformers with answer type
-- modification from @r@ to @r'@ through control effects.
newtype Tr r r' = Tr { forall r r'. Tr r r' -> C r -> C r'
unTr :: C r -> C r' }

instance Category Tr where
  id :: forall a. Tr a a
id = (C a -> C a) -> Tr a a
forall r r'. (C r -> C r') -> Tr r r'
Tr C a -> C a
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  Tr C b -> C c
f . :: forall b c a. Tr b c -> Tr a b -> Tr a c
. Tr C a -> C b
g = (C a -> C c) -> Tr a c
forall r r'. (C r -> C r') -> Tr r r'
Tr (C b -> C c
f (C b -> C c) -> (C a -> C b) -> C a -> C c
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. C a -> C b
g)

-- | '(<>)' is the choice operator. Note that this is an unrestricted
-- backtracking operator: it never commits to any particular choice.
instance Semigroup (Tr r r') where
  Tr C r -> C r'
f <> :: Tr r r' -> Tr r r' -> Tr r r'
<> Tr C r -> C r'
g = (C r -> C r') -> Tr r r'
forall r r'. (C r -> C r') -> Tr r r'
Tr \C r
k String -> r'
k' String
s -> C r -> C r'
f C r
k (\String
_ -> C r -> C r'
g C r
k String -> r'
k' String
s) String
s

-- | 'mempty' is the string transformer that always fails.
instance Monoid (Tr r r') where
  mempty :: Tr r r'
mempty = (C r -> C r') -> Tr r r'
forall r r'. (C r -> C r') -> Tr r r'
Tr \C r
_ String -> r'
k' String
s -> String -> r'
k' String
s

-- | Capture continuation up to the closest 'reset'.
shift :: (C r -> Tr w r') -> Tr r r'
shift :: forall r w r'. (C r -> Tr w r') -> Tr r r'
shift C r -> Tr w r'
f = (C r -> C r') -> Tr r r'
forall r r'. (C r -> C r') -> Tr r r'
Tr \C r
k -> Tr w r' -> C w -> C r'
forall r r'. Tr r r' -> C r -> C r'
unTr (C r -> Tr w r'
f C r
k) C w
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | Inverse of 'shift'.
plug :: C r -> Tr r r' -> Tr w r'
plug :: forall r r' w. C r -> Tr r r' -> Tr w r'
plug C r
k (Tr C r -> C r'
f) = (C w -> C r') -> Tr w r'
forall r r'. (C r -> C r') -> Tr r r'
Tr \C w
_ -> C r -> C r'
f C r
k

-- | Replace the success continuation.
replace :: C r -> Tr w r
replace :: forall r w. C r -> Tr w r
replace C r
k = C r -> Tr r r -> Tr w r
forall r r' w. C r -> Tr r r' -> Tr w r'
plug C r
k Tr r r
forall a. Tr a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

pushNeg :: a -> Tr (a -> r) r
pushNeg :: forall a r. a -> Tr (a -> r) r
pushNeg a
x = (C (a -> r) -> Tr Any r) -> Tr (a -> r) r
forall r w r'. (C r -> Tr w r') -> Tr r r'
shift \C (a -> r)
k -> C r -> Tr Any r
forall r w. C r -> Tr w r
replace \String -> r
k' String
s -> C (a -> r)
k (\String
s a
_ -> String -> r
k' String
s) String
s a
x

popNeg :: Tr r (a -> r)
popNeg :: forall r a. Tr r (a -> r)
popNeg = (C r -> Tr Any (a -> r)) -> Tr r (a -> r)
forall r w r'. (C r -> Tr w r') -> Tr r r'
shift \C r
k -> C (a -> r) -> Tr Any (a -> r)
forall r w. C r -> Tr w r
replace \String -> a -> r
k' String
s a
x -> C r
k (\String
s -> String -> a -> r
k' String
s a
x) String
s

pushPos :: a -> Tr (r -> r') ((a -> r) -> r')
pushPos :: forall a r r'. a -> Tr (r -> r') ((a -> r) -> r')
pushPos a
x = (C (r -> r') -> Tr Any ((a -> r) -> r'))
-> Tr (r -> r') ((a -> r) -> r')
forall r w r'. (C r -> Tr w r') -> Tr r r'
shift \C (r -> r')
k -> C ((a -> r) -> r') -> Tr Any ((a -> r) -> r')
forall r w. C r -> Tr w r
replace \String -> (a -> r) -> r'
k' String
s a -> r
u -> C (r -> r')
k (\String
s r
_ -> String -> (a -> r) -> r'
k' String
s a -> r
u) String
s (a -> r
u a
x)

popPos :: Tr ((a -> r) -> r') (r -> r')
popPos :: forall a r r'. Tr ((a -> r) -> r') (r -> r')
popPos = (C ((a -> r) -> r') -> Tr Any (r -> r'))
-> Tr ((a -> r) -> r') (r -> r')
forall r w r'. (C r -> Tr w r') -> Tr r r'
shift \C ((a -> r) -> r')
k -> C (r -> r') -> Tr Any (r -> r')
forall r w. C r -> Tr w r
replace \String -> r -> r'
k' String
s r
u -> C ((a -> r) -> r')
k (\String
s a -> r
_ -> String -> r -> r'
k' String
s r
u) String
s (\a
_ -> r
u)