{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy         #-}
{-# LANGUAGE TypeOperators       #-}

module Data.InvertibleGrammar.Combinators
  ( iso
  , osi
  , partialIso
  , partialOsi
  , push
  , pair
  , swap
  , cons
  , nil
  , insert
  , insertMay
  , toDefault
  , coproduct
  , onHead
  , onTail
  , traversed
  , flipped
  , sealed
  , coerced
  , annotated
  ) where

import Control.Category ((>>>))
import Data.Coerce
import Data.Maybe
import Data.Void
import Data.Text (Text)
import Data.InvertibleGrammar.Base

#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif

-- | Isomorphism on the stack head.
iso :: (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
iso :: forall a b p t. (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
iso a -> b
f' b -> a
g' = forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso forall {t}. (a :- t) -> b :- t
f forall {t}. (b :- t) -> a :- t
g
  where
    f :: (a :- t) -> b :- t
f (a
a :- t
t) = a -> b
f' a
a forall h t. h -> t -> h :- t
:- t
t
    g :: (b :- t) -> a :- t
g (b
b :- t
t) = b -> a
g' b
b forall h t. h -> t -> h :- t
:- t
t


-- | Flipped isomorphism on the stack head.
osi :: (b -> a) -> (a -> b) -> Grammar p (a :- t) (b :- t)
osi :: forall b a p t. (b -> a) -> (a -> b) -> Grammar p (a :- t) (b :- t)
osi b -> a
f' a -> b
g' = forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso forall {t}. (a :- t) -> b :- t
g forall {t}. (b :- t) -> a :- t
f
  where
    f :: (b :- t) -> a :- t
f (b
a :- t
t) = b -> a
f' b
a forall h t. h -> t -> h :- t
:- t
t
    g :: (a :- t) -> b :- t
g (a
b :- t
t) = a -> b
g' a
b forall h t. h -> t -> h :- t
:- t
t

-- | Partial isomorphism (for backward run) on the stack head.
partialIso :: (a -> b) -> (b -> Either Mismatch a) -> Grammar p (a :- t) (b :- t)
partialIso :: forall a b p t.
(a -> b) -> (b -> Either Mismatch a) -> Grammar p (a :- t) (b :- t)
partialIso a -> b
f' b -> Either Mismatch a
g' = forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso forall {t}. (a :- t) -> b :- t
f forall {t}. (b :- t) -> Either Mismatch (a :- t)
g
  where
    f :: (a :- t) -> b :- t
f (a
a :- t
t) = a -> b
f' a
a forall h t. h -> t -> h :- t
:- t
t
    g :: (b :- t) -> Either Mismatch (a :- t)
g (b
b :- t
t) = (forall h t. h -> t -> h :- t
:- t
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> Either Mismatch a
g' b
b


-- | Partial isomorphism (for forward run) on the stack head.
partialOsi :: (a -> Either Mismatch b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
partialOsi :: forall a b p t.
(a -> Either Mismatch b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
partialOsi a -> Either Mismatch b
g' b -> a
f' = forall p b a. Grammar p b a -> Grammar p a b
Flip forall a b. (a -> b) -> a -> b
$ forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso forall {t}. (b :- t) -> a :- t
f forall {t}. (a :- t) -> Either Mismatch (b :- t)
g
  where
    f :: (b :- t) -> a :- t
f (b
a :- t
t) = b -> a
f' b
a forall h t. h -> t -> h :- t
:- t
t
    g :: (a :- t) -> Either Mismatch (b :- t)
g (a
b :- t
t) = (forall h t. h -> t -> h :- t
:- t
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Either Mismatch b
g' a
b


-- | Push an element to the stack on forward run, check if the element
-- satisfies predicate, otherwise report a mismatch.
push :: a -> (a -> Bool) -> (a -> Mismatch) -> Grammar p t (a :- t)
push :: forall a p t.
a -> (a -> Bool) -> (a -> Mismatch) -> Grammar p t (a :- t)
push a
a a -> Bool
p a -> Mismatch
e = forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso forall {t}. t -> a :- t
f forall {b}. (a :- b) -> Either Mismatch b
g
  where
    f :: t -> a :- t
f t
t = a
a forall h t. h -> t -> h :- t
:- t
t
    g :: (a :- b) -> Either Mismatch b
g (a
a' :- b
t)
      | a -> Bool
p a
a' = forall a b. b -> Either a b
Right b
t
      | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ a -> Mismatch
e a
a'


-- | 2-tuple grammar. Construct on forward run, deconstruct on
-- backward run.
pair :: Grammar p (b :- a :- t) ((a, b) :- t)
pair :: forall p b a t. Grammar p (b :- (a :- t)) ((a, b) :- t)
pair = forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso
  (\(b
b :- a
a :- t
t) -> (a
a, b
b) forall h t. h -> t -> h :- t
:- t
t)
  (\((a
a, b
b) :- t
t) -> b
b forall h t. h -> t -> h :- t
:- a
a forall h t. h -> t -> h :- t
:- t
t)


-- | List cons-cell grammar. Construct on forward run, deconstruct on
-- backward run.
cons :: Grammar p ([a] :- a :- t) ([a] :- t)
cons :: forall p a t. Grammar p ([a] :- (a :- t)) ([a] :- t)
cons = forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso
  (\([a]
lst :- a
el :- t
t) -> (a
elforall a. a -> [a] -> [a]
:[a]
lst) forall h t. h -> t -> h :- t
:- t
t)
  (\([a]
lst :- t
t) ->
      case [a]
lst of
        [] -> forall a b. a -> Either a b
Left (Text -> Mismatch
expected Text
"list element")
        (a
el:[a]
rest) -> forall a b. b -> Either a b
Right ([a]
rest forall h t. h -> t -> h :- t
:- a
el forall h t. h -> t -> h :- t
:- t
t))


-- | Empty list grammar. Construct empty list on forward run, check if
-- list is empty on backward run.
nil :: Grammar p t ([a] :- t)
nil :: forall p t a. Grammar p t ([a] :- t)
nil = forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso
  (\t
t -> [] forall h t. h -> t -> h :- t
:- t
t)
  (\([a]
lst :- t
t) ->
      case [a]
lst of
        [] -> forall a b. b -> Either a b
Right t
t
        (a
_el:[a]
_rest) -> forall a b. a -> Either a b
Left (Text -> Mismatch
expected Text
"end of list"))


-- | Swap two topmost stack elements.
swap :: Grammar p (a :- b :- t) (b :- a :- t)
swap :: forall p a b t. Grammar p (a :- (b :- t)) (b :- (a :- t))
swap = forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso
  (\(a
a :- b
b :- t
t) -> (b
b forall h t. h -> t -> h :- t
:- a
a forall h t. h -> t -> h :- t
:- t
t))
  (\(b
b :- a
a :- t
t) -> (a
a forall h t. h -> t -> h :- t
:- b
b forall h t. h -> t -> h :- t
:- t
t))


-- | Assoc-list element grammar. Inserts an element (with static key)
-- on forward run, look up an element on backward run.
insert :: (Eq k) => k -> Mismatch -> Grammar p (v :- [(k, v)] :- t) ([(k, v)] :- t)
insert :: forall k p v t.
Eq k =>
k -> Mismatch -> Grammar p (v :- ([(k, v)] :- t)) ([(k, v)] :- t)
insert k
k Mismatch
m = forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso
  (\(v
v :- [(k, v)]
alist :- t
t) -> ((k
k, v
v) forall a. a -> [a] -> [a]
: [(k, v)]
alist) forall h t. h -> t -> h :- t
:- t
t)
  (\([(k, v)]
alist :- t
t) ->
     case forall k v. Eq k => k -> [(k, v)] -> Maybe (v, [(k, v)])
popKey k
k [(k, v)]
alist of
       Maybe (v, [(k, v)])
Nothing -> forall a b. a -> Either a b
Left Mismatch
m
       Just (v
v, [(k, v)]
alist') -> forall a b. b -> Either a b
Right (v
v forall h t. h -> t -> h :- t
:- [(k, v)]
alist' forall h t. h -> t -> h :- t
:- t
t))


-- | Optional assoc-list element grammar. Like 'insert', but does not
-- report a mismatch on backward run. Instead takes and produces a
-- Maybe-value.
insertMay :: (Eq k) => k -> Grammar p (Maybe v :- [(k, v)] :- t) ([(k, v)] :- t)
insertMay :: forall k p v t.
Eq k =>
k -> Grammar p (Maybe v :- ([(k, v)] :- t)) ([(k, v)] :- t)
insertMay k
k = forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso
  (\(Maybe v
mv :- [(k, v)]
alist :- t
t) ->
      case Maybe v
mv of
        Just v
v -> ((k
k, v
v) forall a. a -> [a] -> [a]
: [(k, v)]
alist) forall h t. h -> t -> h :- t
:- t
t
        Maybe v
Nothing -> [(k, v)]
alist forall h t. h -> t -> h :- t
:- t
t)
  (\([(k, v)]
alist :- t
t) ->
     case forall k v. Eq k => k -> [(k, v)] -> Maybe (v, [(k, v)])
popKey k
k [(k, v)]
alist of
       Maybe (v, [(k, v)])
Nothing -> forall a b. b -> Either a b
Right (forall a. Maybe a
Nothing forall h t. h -> t -> h :- t
:- [(k, v)]
alist forall h t. h -> t -> h :- t
:- t
t)
       Just (v
v, [(k, v)]
alist') -> forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just v
v forall h t. h -> t -> h :- t
:- [(k, v)]
alist' forall h t. h -> t -> h :- t
:- t
t))


popKey :: forall k v. Eq k => k -> [(k, v)] -> Maybe (v, [(k, v)])
popKey :: forall k v. Eq k => k -> [(k, v)] -> Maybe (v, [(k, v)])
popKey k
k' = [(k, v)] -> [(k, v)] -> Maybe (v, [(k, v)])
go []
  where
    go :: [(k, v)] -> [(k, v)] -> Maybe (v, [(k, v)])
    go :: [(k, v)] -> [(k, v)] -> Maybe (v, [(k, v)])
go [(k, v)]
acc (x :: (k, v)
x@(k
k, v
v) : [(k, v)]
xs)
      | k
k forall a. Eq a => a -> a -> Bool
== k
k' = forall a. a -> Maybe a
Just (v
v, forall a. [a] -> [a]
reverse [(k, v)]
acc forall a. [a] -> [a] -> [a]
++ [(k, v)]
xs)
      | Bool
otherwise = [(k, v)] -> [(k, v)] -> Maybe (v, [(k, v)])
go ((k, v)
xforall a. a -> [a] -> [a]
:[(k, v)]
acc) [(k, v)]
xs
    go [(k, v)]
_ [] = forall a. Maybe a
Nothing


-- | Default value grammar. Replaces 'Nothing' with a default value on
-- forward run, an replaces a default value with 'Nothing' on backward
-- run.
toDefault :: (Eq a) => a -> Grammar p (Maybe a :- t) (a :- t)
toDefault :: forall a p t. Eq a => a -> Grammar p (Maybe a :- t) (a :- t)
toDefault a
def = forall a b p t. (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
iso
  (forall a. a -> Maybe a -> a
fromMaybe a
def)
  (\a
val -> if a
val forall a. Eq a => a -> a -> Bool
== a
def then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just a
val)


-- | Run a grammar operating on the stack head in a context where
-- there is no stack.
sealed :: Grammar p (a :- Void) (b :- Void) -> Grammar p a b
sealed :: forall p a b. Grammar p (a :- Void) (b :- Void) -> Grammar p a b
sealed Grammar p (a :- Void) (b :- Void)
g =
  forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso (forall h t. h -> t -> h :- t
:- forall a. HasCallStack => [Char] -> a
error [Char]
"void") (\(a
a :- Void
_) -> a
a) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  Grammar p (a :- Void) (b :- Void)
g forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso (\(b
a :- Void
_) -> b
a) (forall h t. h -> t -> h :- t
:- forall a. HasCallStack => [Char] -> a
error [Char]
"void")


-- | Focus a given grammar to the stack head.
onHead :: Grammar p a b -> Grammar p (a :- t) (b :- t)
onHead :: forall p a b t. Grammar p a b -> Grammar p (a :- t) (b :- t)
onHead = forall p a b t. Grammar p a b -> Grammar p (a :- t) (b :- t)
OnHead


-- | Focus a given grammar to the stack tail.
onTail :: Grammar p ta tb -> Grammar p (h :- ta) (h :- tb)
onTail :: forall p ta tb h. Grammar p ta tb -> Grammar p (h :- ta) (h :- tb)
onTail = forall p ta tb h. Grammar p ta tb -> Grammar p (h :- ta) (h :- tb)
OnTail


-- | Traverse a structure with a given grammar.
traversed :: (Traversable f) => Grammar p a b -> Grammar p (f a) (f b)
traversed :: forall (f :: * -> *) p a b.
Traversable f =>
Grammar p a b -> Grammar p (f a) (f b)
traversed = forall (f :: * -> *) p a b.
Traversable f =>
Grammar p a b -> Grammar p (f a) (f b)
Traverse


-- | Run a grammar with inputs and outputs flipped.
flipped :: Grammar p a b -> Grammar p b a
flipped :: forall p b a. Grammar p b a -> Grammar p a b
flipped = forall p b a. Grammar p b a -> Grammar p a b
Flip


-- | Run a grammar with an annotation.
annotated :: Text -> Grammar p a b -> Grammar p a b
annotated :: forall p a b. Text -> Grammar p a b -> Grammar p a b
annotated = forall p a b. Text -> Grammar p a b -> Grammar p a b
Annotate


-- | Run a grammar with the stack heads coerced to other ('Coercible')
-- types.
coerced
  :: (Coercible a c, Coercible b d) =>
     Grammar p (a :- t) (b :- t')
  -> Grammar p (c :- t) (d :- t')
coerced :: forall a c b d p t t'.
(Coercible a c, Coercible b d) =>
Grammar p (a :- t) (b :- t') -> Grammar p (c :- t) (d :- t')
coerced Grammar p (a :- t) (b :- t')
g = forall a b p t. (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
iso coerce :: forall a b. Coercible a b => a -> b
coerce coerce :: forall a b. Coercible a b => a -> b
coerce forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Grammar p (a :- t) (b :- t')
g forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a b p t. (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
iso coerce :: forall a b. Coercible a b => a -> b
coerce coerce :: forall a b. Coercible a b => a -> b
coerce


-- | Join alternative grammars in parallel.
coproduct :: [Grammar p a b] -> Grammar p a b
coproduct :: forall p a b. [Grammar p a b] -> Grammar p a b
coproduct = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Semigroup a => a -> a -> a
(<>)