{-# 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 :: (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
iso a -> b
f' b -> a
g' = ((a :- t) -> b :- t)
-> ((b :- t) -> a :- t) -> Grammar p (a :- t) (b :- t)
forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso (a :- t) -> b :- t
forall t. (a :- t) -> b :- t
f (b :- t) -> a :- t
forall t. (b :- t) -> a :- t
g
  where
    f :: (a :- t) -> b :- t
f (a
a :- t
t) = a -> b
f' a
a b -> t -> b :- t
forall h t. h -> t -> h :- t
:- t
t
    g :: (b :- t) -> a :- t
g (b
b :- t
t) = b -> a
g' b
b a -> t -> a :- t
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 :: (b -> a) -> (a -> b) -> Grammar p (a :- t) (b :- t)
osi b -> a
f' a -> b
g' = ((a :- t) -> b :- t)
-> ((b :- t) -> a :- t) -> Grammar p (a :- t) (b :- t)
forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso (a :- t) -> b :- t
forall t. (a :- t) -> b :- t
g (b :- t) -> a :- t
forall t. (b :- t) -> a :- t
f
  where
    f :: (b :- t) -> a :- t
f (b
a :- t
t) = b -> a
f' b
a a -> t -> a :- t
forall h t. h -> t -> h :- t
:- t
t
    g :: (a :- t) -> b :- t
g (a
b :- t
t) = a -> b
g' a
b b -> t -> b :- t
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 :: (a -> b) -> (b -> Either Mismatch a) -> Grammar p (a :- t) (b :- t)
partialIso a -> b
f' b -> Either Mismatch a
g' = ((a :- t) -> b :- t)
-> ((b :- t) -> Either Mismatch (a :- t))
-> Grammar p (a :- t) (b :- t)
forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso (a :- t) -> b :- t
forall t. (a :- t) -> b :- t
f (b :- t) -> Either Mismatch (a :- t)
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 b -> t -> b :- t
forall h t. h -> t -> h :- t
:- t
t
    g :: (b :- t) -> Either Mismatch (a :- t)
g (b
b :- t
t) = (a -> t -> a :- t
forall h t. h -> t -> h :- t
:- t
t) (a -> a :- t) -> Either Mismatch a -> Either Mismatch (a :- 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 :: (a -> Either Mismatch b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
partialOsi a -> Either Mismatch b
g' b -> a
f' = Grammar p (b :- t) (a :- t) -> Grammar p (a :- t) (b :- t)
forall p a b. Grammar p a b -> Grammar p b a
Flip (Grammar p (b :- t) (a :- t) -> Grammar p (a :- t) (b :- t))
-> Grammar p (b :- t) (a :- t) -> Grammar p (a :- t) (b :- t)
forall a b. (a -> b) -> a -> b
$ ((b :- t) -> a :- t)
-> ((a :- t) -> Either Mismatch (b :- t))
-> Grammar p (b :- t) (a :- t)
forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso (b :- t) -> a :- t
forall t. (b :- t) -> a :- t
f (a :- t) -> Either Mismatch (b :- t)
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 a -> t -> a :- t
forall h t. h -> t -> h :- t
:- t
t
    g :: (a :- t) -> Either Mismatch (b :- t)
g (a
b :- t
t) = (b -> t -> b :- t
forall h t. h -> t -> h :- t
:- t
t) (b -> b :- t) -> Either Mismatch b -> Either Mismatch (b :- 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 :: a -> (a -> Bool) -> (a -> Mismatch) -> Grammar p t (a :- t)
push a
a a -> Bool
p a -> Mismatch
e = (t -> a :- t)
-> ((a :- t) -> Either Mismatch t) -> Grammar p t (a :- t)
forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso t -> a :- t
forall t. t -> a :- t
f (a :- t) -> Either Mismatch t
forall b. (a :- b) -> Either Mismatch b
g
  where
    f :: t -> a :- t
f t
t = a
a a -> t -> a :- t
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' = b -> Either Mismatch b
forall a b. b -> Either a b
Right b
t
      | Bool
otherwise = Mismatch -> Either Mismatch b
forall a b. a -> Either a b
Left (Mismatch -> Either Mismatch b) -> Mismatch -> Either Mismatch b
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 :: Grammar p (b :- (a :- t)) ((a, b) :- t)
pair = ((b :- (a :- t)) -> (a, b) :- t)
-> (((a, b) :- t) -> b :- (a :- t))
-> Grammar p (b :- (a :- t)) ((a, b) :- t)
forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso
  (\(b
b :- a
a :- t
t) -> (a
a, b
b) (a, b) -> t -> (a, b) :- t
forall h t. h -> t -> h :- t
:- t
t)
  (\((a
a, b
b) :- t
t) -> b
b b -> (a :- t) -> b :- (a :- t)
forall h t. h -> t -> h :- t
:- a
a a -> t -> a :- t
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 :: Grammar p ([a] :- (a :- t)) ([a] :- t)
cons = (([a] :- (a :- t)) -> [a] :- t)
-> (([a] :- t) -> Either Mismatch ([a] :- (a :- t)))
-> Grammar p ([a] :- (a :- t)) ([a] :- t)
forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso
  (\([a]
lst :- a
el :- t
t) -> (a
ela -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
lst) [a] -> t -> [a] :- t
forall h t. h -> t -> h :- t
:- t
t)
  (\([a]
lst :- t
t) ->
      case [a]
lst of
        [] -> Mismatch -> Either Mismatch ([a] :- (a :- t))
forall a b. a -> Either a b
Left (Text -> Mismatch
expected Text
"list element")
        (a
el:[a]
rest) -> ([a] :- (a :- t)) -> Either Mismatch ([a] :- (a :- t))
forall a b. b -> Either a b
Right ([a]
rest [a] -> (a :- t) -> [a] :- (a :- t)
forall h t. h -> t -> h :- t
:- a
el a -> t -> a :- t
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 :: Grammar p t ([a] :- t)
nil = (t -> [a] :- t)
-> (([a] :- t) -> Either Mismatch t) -> Grammar p t ([a] :- t)
forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso
  (\t
t -> [] [a] -> t -> [a] :- t
forall h t. h -> t -> h :- t
:- t
t)
  (\([a]
lst :- t
t) ->
      case [a]
lst of
        [] -> t -> Either Mismatch t
forall a b. b -> Either a b
Right t
t
        (a
_el:[a]
_rest) -> Mismatch -> Either Mismatch t
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 :: Grammar p (a :- (b :- t)) (b :- (a :- t))
swap = ((a :- (b :- t)) -> b :- (a :- t))
-> ((b :- (a :- t)) -> a :- (b :- t))
-> Grammar p (a :- (b :- t)) (b :- (a :- t))
forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso
  (\(a
a :- b
b :- t
t) -> (b
b b -> (a :- t) -> b :- (a :- t)
forall h t. h -> t -> h :- t
:- a
a a -> t -> a :- t
forall h t. h -> t -> h :- t
:- t
t))
  (\(b
b :- a
a :- t
t) -> (a
a a -> (b :- t) -> a :- (b :- t)
forall h t. h -> t -> h :- t
:- b
b b -> t -> b :- t
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 :: k -> Mismatch -> Grammar p (v :- ([(k, v)] :- t)) ([(k, v)] :- t)
insert k
k Mismatch
m = ((v :- ([(k, v)] :- t)) -> [(k, v)] :- t)
-> (([(k, v)] :- t) -> Either Mismatch (v :- ([(k, v)] :- t)))
-> Grammar p (v :- ([(k, v)] :- t)) ([(k, v)] :- t)
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) (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)]
alist) [(k, v)] -> t -> [(k, v)] :- t
forall h t. h -> t -> h :- t
:- t
t)
  (\([(k, v)]
alist :- t
t) ->
     case k -> [(k, v)] -> Maybe (v, [(k, v)])
forall k v. Eq k => k -> [(k, v)] -> Maybe (v, [(k, v)])
popKey k
k [(k, v)]
alist of
       Maybe (v, [(k, v)])
Nothing -> Mismatch -> Either Mismatch (v :- ([(k, v)] :- t))
forall a b. a -> Either a b
Left Mismatch
m
       Just (v
v, [(k, v)]
alist') -> (v :- ([(k, v)] :- t)) -> Either Mismatch (v :- ([(k, v)] :- t))
forall a b. b -> Either a b
Right (v
v v -> ([(k, v)] :- t) -> v :- ([(k, v)] :- t)
forall h t. h -> t -> h :- t
:- [(k, v)]
alist' [(k, v)] -> t -> [(k, v)] :- t
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 :: k -> Grammar p (Maybe v :- ([(k, v)] :- t)) ([(k, v)] :- t)
insertMay k
k = ((Maybe v :- ([(k, v)] :- t)) -> [(k, v)] :- t)
-> (([(k, v)] :- t)
    -> Either Mismatch (Maybe v :- ([(k, v)] :- t)))
-> Grammar p (Maybe v :- ([(k, v)] :- t)) ([(k, v)] :- t)
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) (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)]
alist) [(k, v)] -> t -> [(k, v)] :- t
forall h t. h -> t -> h :- t
:- t
t
        Maybe v
Nothing -> [(k, v)]
alist [(k, v)] -> t -> [(k, v)] :- t
forall h t. h -> t -> h :- t
:- t
t)
  (\([(k, v)]
alist :- t
t) ->
     case k -> [(k, v)] -> Maybe (v, [(k, v)])
forall k v. Eq k => k -> [(k, v)] -> Maybe (v, [(k, v)])
popKey k
k [(k, v)]
alist of
       Maybe (v, [(k, v)])
Nothing -> (Maybe v :- ([(k, v)] :- t))
-> Either Mismatch (Maybe v :- ([(k, v)] :- t))
forall a b. b -> Either a b
Right (Maybe v
forall a. Maybe a
Nothing Maybe v -> ([(k, v)] :- t) -> Maybe v :- ([(k, v)] :- t)
forall h t. h -> t -> h :- t
:- [(k, v)]
alist [(k, v)] -> t -> [(k, v)] :- t
forall h t. h -> t -> h :- t
:- t
t)
       Just (v
v, [(k, v)]
alist') -> (Maybe v :- ([(k, v)] :- t))
-> Either Mismatch (Maybe v :- ([(k, v)] :- t))
forall a b. b -> Either a b
Right (v -> Maybe v
forall a. a -> Maybe a
Just v
v Maybe v -> ([(k, v)] :- t) -> Maybe v :- ([(k, v)] :- t)
forall h t. h -> t -> h :- t
:- [(k, v)]
alist' [(k, v)] -> t -> [(k, v)] :- t
forall h t. h -> t -> h :- t
:- t
t))


popKey :: forall k v. Eq k => k -> [(k, v)] -> Maybe (v, [(k, v)])
popKey :: 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 k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k' = (v, [(k, v)]) -> Maybe (v, [(k, v)])
forall a. a -> Maybe a
Just (v
v, [(k, v)] -> [(k, v)]
forall a. [a] -> [a]
reverse [(k, v)]
acc [(k, v)] -> [(k, v)] -> [(k, v)]
forall a. [a] -> [a] -> [a]
++ [(k, v)]
xs)
      | Bool
otherwise = [(k, v)] -> [(k, v)] -> Maybe (v, [(k, v)])
go ((k, v)
x(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
:[(k, v)]
acc) [(k, v)]
xs
    go [(k, v)]
_ [] = Maybe (v, [(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 :: a -> Grammar p (Maybe a :- t) (a :- t)
toDefault a
def = (Maybe a -> a)
-> (a -> Maybe a) -> Grammar p (Maybe a :- t) (a :- t)
forall a b p t. (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
iso
  (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def)
  (\a
val -> if a
val a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
def then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
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 :: Grammar p (a :- Void) (b :- Void) -> Grammar p a b
sealed Grammar p (a :- Void) (b :- Void)
g =
  (a -> a :- Void) -> ((a :- Void) -> a) -> Grammar p a (a :- Void)
forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso (a -> Void -> a :- Void
forall h t. h -> t -> h :- t
:- [Char] -> Void
forall a. HasCallStack => [Char] -> a
error [Char]
"void") (\(a
a :- Void
_) -> a
a) Grammar p a (a :- Void) -> Grammar p (a :- Void) b -> Grammar p a b
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 Grammar p (a :- Void) (b :- Void)
-> Grammar p (b :- Void) b -> Grammar p (a :- Void) b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  ((b :- Void) -> b) -> (b -> b :- Void) -> Grammar p (b :- Void) b
forall a b p. (a -> b) -> (b -> a) -> Grammar p a b
Iso (\(b
a :- Void
_) -> b
a) (b -> Void -> b :- Void
forall h t. h -> t -> h :- t
:- [Char] -> Void
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 :: Grammar p a b -> Grammar p (a :- t) (b :- t)
onHead = Grammar p a b -> Grammar p (a :- t) (b :- t)
forall p a b a. Grammar p a b -> Grammar p (a :- a) (b :- a)
OnHead


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


-- | Traverse a structure with a given grammar.
traversed :: (Traversable f) => Grammar p a b -> Grammar p (f a) (f b)
traversed :: Grammar p a b -> Grammar p (f a) (f b)
traversed = Grammar p a b -> Grammar p (f a) (f b)
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 :: Grammar p a b -> Grammar p b a
flipped = Grammar p a b -> Grammar p b a
forall p a b. Grammar p a b -> Grammar p b a
Flip


-- | Run a grammar with an annotation.
annotated :: Text -> Grammar p a b -> Grammar p a b
annotated :: Text -> Grammar p a b -> Grammar p a b
annotated = Text -> Grammar p a b -> Grammar p a b
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 :: Grammar p (a :- t) (b :- t') -> Grammar p (c :- t) (d :- t')
coerced Grammar p (a :- t) (b :- t')
g = (c -> a) -> (a -> c) -> Grammar p (c :- t) (a :- t)
forall a b p t. (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
iso c -> a
coerce a -> c
coerce Grammar p (c :- t) (a :- t)
-> Grammar p (a :- t) (d :- t') -> Grammar p (c :- t) (d :- t')
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 Grammar p (a :- t) (b :- t')
-> Grammar p (b :- t') (d :- t') -> Grammar p (a :- t) (d :- t')
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (b -> d) -> (d -> b) -> Grammar p (b :- t') (d :- t')
forall a b p t. (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t)
iso b -> d
coerce d -> b
coerce


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