{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
-- |
-- Module: Language.KURE.BiTransform
-- Copyright: (c) 2012--2021 The University of Kansas
-- License: BSD3
--
-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>
-- Stability: beta
-- Portability: ghc
--
-- A bi-directional transformation is a transformation that can be applied in either direction.

module Language.KURE.BiTransform
       (  -- * Bi-directional Transformations
          BiTransform, BiTranslate
        , BiRewrite
        , bidirectional
        , forwardT
        , backwardT
        , whicheverR
        , invertBiT
        , beforeBiR
        , afterBiR
          -- * Bi-directional Injections
        , extractBiT
        , promoteBiT
        , extractBiR
        , promoteBiR
        , extractWithFailMsgBiT
        , promoteWithFailMsgBiT
        , extractWithFailMsgBiR
        , promoteWithFailMsgBiR
) where

import Prelude hiding (id, (.))

import Control.Category

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif

import Language.KURE.MonadCatch
import Language.KURE.Transform
import Language.KURE.Injection

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

-- | An undirected 'Transform'.
data BiTransform c m a b = BiTransform {BiTransform c m a b -> Transform c m a b
forwardT :: Transform c m a b, -- ^ Extract the forward 'Transform' from a 'BiTransform'.
                                        BiTransform c m a b -> Transform c m b a
backwardT :: Transform c m b a  -- ^ Extract the backward 'Transform' from a 'BiTransform'.
                                       }

-- | A deprecated synonym for 'BiTranslate'.
type BiTranslate c m a b = BiTransform c m a b

-- | A 'BiTransform' that shares the same source and target type.
type BiRewrite c m a = BiTransform c m a a

-- | Construct a 'BiTransform' from two opposite 'Transform's.
bidirectional :: Transform c m a b -> Transform c m b a -> BiTransform c m a b
bidirectional :: Transform c m a b -> Transform c m b a -> BiTransform c m a b
bidirectional = Transform c m a b -> Transform c m b a -> BiTransform c m a b
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
BiTransform
{-# INLINE bidirectional #-}

-- | Try the 'BiRewrite' forwards, then backwards if that fails.
--   Useful when you know which rule you want to apply, but not which direction to apply it in.
whicheverR :: MonadCatch m => BiRewrite c m a -> Rewrite c m a
whicheverR :: BiRewrite c m a -> Rewrite c m a
whicheverR BiRewrite c m a
r = BiRewrite c m a -> Rewrite c m a
forall c (m :: * -> *) a b.
BiTransform c m a b -> Transform c m a b
forwardT BiRewrite c m a
r Rewrite c m a -> Rewrite c m a -> Rewrite c m a
forall (m :: * -> *) a. MonadCatch m => m a -> m a -> m a
<+ BiRewrite c m a -> Rewrite c m a
forall c (m :: * -> *) a b.
BiTransform c m a b -> Transform c m b a
backwardT BiRewrite c m a
r
{-# INLINE whicheverR #-}

-- | Invert the forwards and backwards directions of a 'BiTransform'.
invertBiT :: BiTransform c m a b -> BiTransform c m b a
invertBiT :: BiTransform c m a b -> BiTransform c m b a
invertBiT (BiTransform Transform c m a b
t1 Transform c m b a
t2) = Transform c m b a -> Transform c m a b -> BiTransform c m b a
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
BiTransform Transform c m b a
t2 Transform c m a b
t1
{-# INLINE invertBiT #-}

instance Monad m => Category (BiTransform c m) where
   id :: BiTransform c m a a
   id :: BiTransform c m a a
id = Transform c m a a -> Transform c m a a -> BiTransform c m a a
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
bidirectional Transform c m a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Transform c m a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
   {-# INLINE id #-}

   (.) :: BiTransform c m b d -> BiTransform c m a b -> BiTransform c m a d
   (BiTransform Transform c m b d
f1 Transform c m d b
b1) . :: BiTransform c m b d -> BiTransform c m a b -> BiTransform c m a d
. (BiTransform Transform c m a b
f2 Transform c m b a
b2) = Transform c m a d -> Transform c m d a -> BiTransform c m a d
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
BiTransform (Transform c m b d
f1 Transform c m b d -> Transform c m a b -> Transform c m a d
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Transform c m a b
f2) (Transform c m b a
b2 Transform c m b a -> Transform c m d b -> Transform c m d a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Transform c m d b
b1)
   {-# INLINE (.) #-}

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

-- | Perform the argument transformation before /either/ direction of the bidirectional rewrite.
beforeBiR :: Monad m => Transform c m a b -> (b -> BiRewrite c m a) -> BiRewrite c m a
beforeBiR :: Transform c m a b -> (b -> BiRewrite c m a) -> BiRewrite c m a
beforeBiR Transform c m a b
t b -> BiRewrite c m a
f = Transform c m a a -> Transform c m a a -> BiRewrite c m a
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
bidirectional (Transform c m a b
t Transform c m a b -> (b -> Transform c m a a) -> Transform c m a a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (BiRewrite c m a -> Transform c m a a
forall c (m :: * -> *) a b.
BiTransform c m a b -> Transform c m a b
forwardT (BiRewrite c m a -> Transform c m a a)
-> (b -> BiRewrite c m a) -> b -> Transform c m a a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> BiRewrite c m a
f)) (Transform c m a b
t Transform c m a b -> (b -> Transform c m a a) -> Transform c m a a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (BiRewrite c m a -> Transform c m a a
forall c (m :: * -> *) a b.
BiTransform c m a b -> Transform c m b a
backwardT (BiRewrite c m a -> Transform c m a a)
-> (b -> BiRewrite c m a) -> b -> Transform c m a a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> BiRewrite c m a
f))
{-# INLINE beforeBiR #-}

-- | Apply the argument rewrite to the result of /either/ direction of the bidirectional rewrite.
afterBiR :: Monad m => BiRewrite c m a -> Rewrite c m a -> BiRewrite c m a
afterBiR :: BiRewrite c m a -> Rewrite c m a -> BiRewrite c m a
afterBiR BiRewrite c m a
b Rewrite c m a
rr = Rewrite c m a -> Rewrite c m a -> BiRewrite c m a
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
bidirectional (BiRewrite c m a -> Rewrite c m a
forall c (m :: * -> *) a b.
BiTransform c m a b -> Transform c m a b
forwardT BiRewrite c m a
b Rewrite c m a -> Rewrite c m a -> Rewrite c m a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Rewrite c m a
rr) (BiRewrite c m a -> Rewrite c m a
forall c (m :: * -> *) a b.
BiTransform c m a b -> Transform c m b a
backwardT BiRewrite c m a
b Rewrite c m a -> Rewrite c m a -> Rewrite c m a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Rewrite c m a
rr)
{-# INLINE afterBiR #-}

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

-- | As 'extractBiT', but takes a custom error message to use if extraction fails.
extractWithFailMsgBiT :: (MonadFail m, Injection a u, Injection b u) => String -> BiTransform c m u u -> BiTransform c m a b
extractWithFailMsgBiT :: String -> BiTransform c m u u -> BiTransform c m a b
extractWithFailMsgBiT String
msg (BiTransform Transform c m u u
t1 Transform c m u u
t2) = Transform c m a b -> Transform c m b a -> BiTransform c m a b
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
BiTransform (Transform c m u u -> Transform c m a u
forall (m :: * -> *) a u c b.
(Monad m, Injection a u) =>
Transform c m u b -> Transform c m a b
extractT Transform c m u u
t1 Transform c m a u -> Transform c m u b -> Transform c m a b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> Transform c m u b
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> Transform c m u a
projectWithFailMsgT String
msg)
                                                            (Transform c m u u -> Transform c m b u
forall (m :: * -> *) a u c b.
(Monad m, Injection a u) =>
Transform c m u b -> Transform c m a b
extractT Transform c m u u
t2 Transform c m b u -> Transform c m u a -> Transform c m b a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> Transform c m u a
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> Transform c m u a
projectWithFailMsgT String
msg)
{-# INLINE extractWithFailMsgBiT #-}

-- | Convert a bidirectional transformation over an injected value into a bidirectional transformation over non-injected values,
--   (failing if an injected value cannot be projected).
extractBiT :: (MonadFail m, Injection a u, Injection b u) => BiTransform c m u u -> BiTransform c m a b
extractBiT :: BiTransform c m u u -> BiTransform c m a b
extractBiT = String -> BiTransform c m u u -> BiTransform c m a b
forall (m :: * -> *) a u b c.
(MonadFail m, Injection a u, Injection b u) =>
String -> BiTransform c m u u -> BiTransform c m a b
extractWithFailMsgBiT String
"extractBiT failed"
{-# INLINE extractBiT #-}

-- | As 'promoteBiT', but takes a custom error message to use if promotion fails.
promoteWithFailMsgBiT  :: (MonadFail m, Injection a u, Injection b u) => String -> BiTransform c m a b -> BiTransform c m u u
promoteWithFailMsgBiT :: String -> BiTransform c m a b -> BiTransform c m u u
promoteWithFailMsgBiT String
msg (BiTransform Transform c m a b
t1 Transform c m b a
t2) = Transform c m u u -> Transform c m u u -> BiTransform c m u u
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
BiTransform (String -> Transform c m u a
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> Transform c m u a
projectWithFailMsgT String
msg Transform c m u a -> Transform c m a u -> Transform c m u u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Transform c m a b
t1 Transform c m a b -> Transform c m b u -> Transform c m a u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Transform c m b u
forall (m :: * -> *) a u c.
(Monad m, Injection a u) =>
Transform c m a u
injectT)
                                                            (String -> Transform c m u b
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> Transform c m u a
projectWithFailMsgT String
msg Transform c m u b -> Transform c m b u -> Transform c m u u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Transform c m b a
t2 Transform c m b a -> Transform c m a u -> Transform c m b u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Transform c m a u
forall (m :: * -> *) a u c.
(Monad m, Injection a u) =>
Transform c m a u
injectT)
{-# INLINE promoteWithFailMsgBiT #-}

-- | Promote a bidirectional transformation from value to value into a transformation over an injection of those values,
--   (failing if an injected value cannot be projected).
promoteBiT  :: (MonadFail m, Injection a u, Injection b u) => BiTransform c m a b -> BiTransform c m u u
promoteBiT :: BiTransform c m a b -> BiTransform c m u u
promoteBiT = String -> BiTransform c m a b -> BiTransform c m u u
forall (m :: * -> *) a u b c.
(MonadFail m, Injection a u, Injection b u) =>
String -> BiTransform c m a b -> BiTransform c m u u
promoteWithFailMsgBiT String
"promoteBiT failed"
{-# INLINE promoteBiT #-}

-- | As 'extractBiR', but takes a custom error message to use if extraction fails.
extractWithFailMsgBiR :: (MonadFail m, Injection a u) => String -> BiRewrite c m u -> BiRewrite c m a
extractWithFailMsgBiR :: String -> BiRewrite c m u -> BiRewrite c m a
extractWithFailMsgBiR String
msg (BiTransform Transform c m u u
r1 Transform c m u u
r2) = Transform c m a a -> Transform c m a a -> BiRewrite c m a
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
BiTransform (String -> Transform c m u u -> Transform c m a a
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> Rewrite c m u -> Rewrite c m a
extractWithFailMsgR String
msg Transform c m u u
r1)
                                                            (String -> Transform c m u u -> Transform c m a a
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> Rewrite c m u -> Rewrite c m a
extractWithFailMsgR String
msg Transform c m u u
r2)
{-# INLINE extractWithFailMsgBiR #-}

-- | Convert a bidirectional rewrite over an injected value into a bidirectional rewrite over a projection of that value,
--   (failing if an injected value cannot be projected).
extractBiR :: (MonadFail m, Injection a u) => BiRewrite c m u -> BiRewrite c m a
extractBiR :: BiRewrite c m u -> BiRewrite c m a
extractBiR = String -> BiRewrite c m u -> BiRewrite c m a
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> BiRewrite c m u -> BiRewrite c m a
extractWithFailMsgBiR String
"extractBiR failed"
{-# INLINE extractBiR #-}

-- | As 'promoteBiR', but takes a custom error message to use if promotion fails.
promoteWithFailMsgBiR :: (MonadFail m, Injection a u) => String -> BiRewrite c m a -> BiRewrite c m u
promoteWithFailMsgBiR :: String -> BiRewrite c m a -> BiRewrite c m u
promoteWithFailMsgBiR String
msg (BiTransform Transform c m a a
r1 Transform c m a a
r2) = Transform c m u u -> Transform c m u u -> BiRewrite c m u
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
BiTransform (String -> Transform c m a a -> Transform c m u u
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> Rewrite c m a -> Rewrite c m u
promoteWithFailMsgR String
msg Transform c m a a
r1)
                                                            (String -> Transform c m a a -> Transform c m u u
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> Rewrite c m a -> Rewrite c m u
promoteWithFailMsgR String
msg Transform c m a a
r2)
{-# INLINE promoteWithFailMsgBiR #-}

-- | Promote a bidirectional rewrite over a value into a bidirectional rewrite over an injection of that value,
--   (failing if an injected value cannot be projected).
promoteBiR :: (MonadFail m, Injection a u) => BiRewrite c m a -> BiRewrite c m u
promoteBiR :: BiRewrite c m a -> BiRewrite c m u
promoteBiR = String -> BiRewrite c m a -> BiRewrite c m u
forall (m :: * -> *) a u c.
(MonadFail m, Injection a u) =>
String -> BiRewrite c m a -> BiRewrite c m u
promoteWithFailMsgBiR String
"promoteBiR failed"
{-# INLINE promoteBiR #-}

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