{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}
module Control.PatternArrows where
import Data.Char
import Control.Monad.State
import qualified Control.Category as C
import Control.Category ((>>>))
import qualified Control.Arrow as A
import Control.Arrow ((***), (<+>))
newtype Pattern u a b = Pattern { forall u a b. Pattern u a b -> Kleisli (StateT u Maybe) a b
runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (forall {u}. Category (Pattern u)
forall b c. (b -> c) -> Pattern u b c
forall b c d. Pattern u b c -> Pattern u (b, d) (c, d)
forall b c d. Pattern u b c -> Pattern u (d, b) (d, c)
forall b c c'.
Pattern u b c -> Pattern u b c' -> Pattern u b (c, c')
forall u b c. (b -> c) -> Pattern u b c
forall u b c d. Pattern u b c -> Pattern u (b, d) (c, d)
forall u b c d. Pattern u b c -> Pattern u (d, b) (d, c)
forall u b c c'.
Pattern u b c -> Pattern u b c' -> Pattern u b (c, c')
forall b c b' c'.
Pattern u b c -> Pattern u b' c' -> Pattern u (b, b') (c, c')
forall u b c b' c'.
Pattern u b c -> Pattern u b' c' -> Pattern u (b, b') (c, c')
forall (a :: * -> * -> *).
Category a
-> (forall b c. (b -> c) -> a b c)
-> (forall b c d. a b c -> a (b, d) (c, d))
-> (forall b c d. a b c -> a (d, b) (d, c))
-> (forall b c b' c'. a b c -> a b' c' -> a (b, b') (c, c'))
-> (forall b c c'. a b c -> a b c' -> a b (c, c'))
-> Arrow a
&&& :: forall b c c'.
Pattern u b c -> Pattern u b c' -> Pattern u b (c, c')
$c&&& :: forall u b c c'.
Pattern u b c -> Pattern u b c' -> Pattern u b (c, c')
*** :: forall b c b' c'.
Pattern u b c -> Pattern u b' c' -> Pattern u (b, b') (c, c')
$c*** :: forall u b c b' c'.
Pattern u b c -> Pattern u b' c' -> Pattern u (b, b') (c, c')
second :: forall b c d. Pattern u b c -> Pattern u (d, b) (d, c)
$csecond :: forall u b c d. Pattern u b c -> Pattern u (d, b) (d, c)
first :: forall b c d. Pattern u b c -> Pattern u (b, d) (c, d)
$cfirst :: forall u b c d. Pattern u b c -> Pattern u (b, d) (c, d)
arr :: forall b c. (b -> c) -> Pattern u b c
$carr :: forall u b c. (b -> c) -> Pattern u b c
A.Arrow, forall u. Arrow (Pattern u)
forall b c. Pattern u b c
forall u b c. Pattern u b c
forall (a :: * -> * -> *).
Arrow a -> (forall b c. a b c) -> ArrowZero a
zeroArrow :: forall b c. Pattern u b c
$czeroArrow :: forall u b c. Pattern u b c
A.ArrowZero, forall u. ArrowZero (Pattern u)
forall b c. Pattern u b c -> Pattern u b c -> Pattern u b c
forall u b c. Pattern u b c -> Pattern u b c -> Pattern u b c
forall (a :: * -> * -> *).
ArrowZero a -> (forall b c. a b c -> a b c -> a b c) -> ArrowPlus a
<+> :: forall b c. Pattern u b c -> Pattern u b c -> Pattern u b c
$c<+> :: forall u b c. Pattern u b c -> Pattern u b c -> Pattern u b c
A.ArrowPlus)
instance C.Category (Pattern u) where
id :: forall a. Pattern u a a
id = forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern (forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
C.id)
Pattern Kleisli (StateT u Maybe) b c
p1 . :: forall b c a. Pattern u b c -> Pattern u a b -> Pattern u a c
. Pattern Kleisli (StateT u Maybe) a b
p2 = forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern (Kleisli (StateT u Maybe) b c
p1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
C.. Kleisli (StateT u Maybe) a b
p2)
instance Functor (Pattern u a) where
fmap :: forall a b. (a -> b) -> Pattern u a a -> Pattern u a b
fmap a -> b
f (Pattern Kleisli (StateT u Maybe) a a
p) = forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
A.Kleisli forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
A.runKleisli Kleisli (StateT u Maybe) a a
p
pattern :: Pattern u a b -> u -> a -> Maybe b
pattern :: forall u a b. Pattern u a b -> u -> a -> Maybe b
pattern Pattern u a b
p u
u = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT u
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
A.runKleisli (forall u a b. Pattern u a b -> Kleisli (StateT u Maybe) a b
runPattern Pattern u a b
p)
mkPattern :: (a -> Maybe b) -> Pattern u a b
mkPattern :: forall a b u. (a -> Maybe b) -> Pattern u a b
mkPattern a -> Maybe b
f = forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
A.Kleisli (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
f)
mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
mkPattern' :: forall a u b. (a -> StateT u Maybe b) -> Pattern u a b
mkPattern' = forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
A.Kleisli
chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainl :: forall u a r.
Pattern u a (a, a)
-> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainl Pattern u a (a, a)
g r -> r -> r
f Pattern u a r
p = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \Pattern u a r
c -> Pattern u a (a, a)
g forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Pattern u a r
c forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Pattern u a r
p) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Pattern u a r
p) 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 c. Arrow a => (b -> c) -> a b c
A.arr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry r -> r -> r
f)
chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainr :: forall u a r.
Pattern u a (a, a)
-> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainr Pattern u a (a, a)
g r -> r -> r
f Pattern u a r
p = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \Pattern u a r
c -> Pattern u a (a, a)
g forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Pattern u a r
p forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Pattern u a r
c forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Pattern u a r
p)) 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 c. Arrow a => (b -> c) -> a b c
A.arr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry r -> r -> r
f)
wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
wrap :: forall u a s r.
Pattern u a (s, a)
-> (s -> r -> r) -> Pattern u a r -> Pattern u a r
wrap Pattern u a (s, a)
g s -> r -> r
f Pattern u a r
p = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \Pattern u a r
c -> Pattern u a (s, a)
g forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
C.id forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Pattern u a r
c forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Pattern u a r
p)) 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 c. Arrow a => (b -> c) -> a b c
A.arr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> r -> r
f)
split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
split :: forall u a s t r.
Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
split Pattern u a (s, t)
s s -> t -> r
f = Pattern u a (s, t)
s 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 c. Arrow a => (b -> c) -> a b c
A.arr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> t -> r
f)
data OperatorTable u a r = OperatorTable { forall u a r. OperatorTable u a r -> [[Operator u a r]]
runOperatorTable :: [ [Operator u a r] ] }
data Operator u a r where
AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r
buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r
buildPrettyPrinter :: forall u a r. OperatorTable u a r -> Pattern u a r -> Pattern u a r
buildPrettyPrinter OperatorTable u a r
table Pattern u a r
p = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Pattern u a r
p' [Operator u a r]
ops -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
(<+>) (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Operator u a r]
ops forall a b. (a -> b) -> a -> b
$ \Operator u a r
op ->
case Operator u a r
op of
AssocL Pattern u a (a, a)
pat r -> r -> r
g -> forall u a r.
Pattern u a (a, a)
-> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainl Pattern u a (a, a)
pat r -> r -> r
g Pattern u a r
p'
AssocR Pattern u a (a, a)
pat r -> r -> r
g -> forall u a r.
Pattern u a (a, a)
-> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainr Pattern u a (a, a)
pat r -> r -> r
g Pattern u a r
p'
Wrap Pattern u a (s, a)
pat s -> r -> r
g -> forall u a s r.
Pattern u a (s, a)
-> (s -> r -> r) -> Pattern u a r -> Pattern u a r
wrap Pattern u a (s, a)
pat s -> r -> r
g Pattern u a r
p'
Split Pattern u a (s, t)
pat s -> t -> r
g -> forall u a s t r.
Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
split Pattern u a (s, t)
pat s -> t -> r
g
) forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Pattern u a r
p') Pattern u a r
p forall a b. (a -> b) -> a -> b
$ forall u a r. OperatorTable u a r -> [[Operator u a r]]
runOperatorTable OperatorTable u a r
table