-----------------------------------------------------------------------------
--
-- Module      :  Control.PatternArrows
-- Copyright   :  (c) Phil Freeman 2013
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Arrows for Pretty Printing
--
-----------------------------------------------------------------------------

{-# 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 ((***), (<+>))

-- |
-- A first-order pattern match
--
-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
--
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 (Category (Pattern 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 b' c'.
    Pattern u b c -> Pattern u b' c' -> Pattern u (b, b') (c, c'))
-> (forall b c c'.
    Pattern u b c -> Pattern u b c' -> Pattern u b (c, c'))
-> Arrow (Pattern u)
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
$carr :: forall u b c. (b -> c) -> Pattern u b c
arr :: forall b c. (b -> c) -> Pattern u b c
$cfirst :: forall u b c d. Pattern u b c -> Pattern u (b, d) (c, d)
first :: forall b c d. Pattern u b c -> Pattern u (b, d) (c, d)
$csecond :: forall u b c d. Pattern u b c -> Pattern u (d, b) (d, c)
second :: forall b c d. Pattern u b c -> Pattern u (d, b) (d, c)
$c*** :: forall u b c b' c'.
Pattern u b c -> Pattern u b' c' -> Pattern u (b, 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 c'.
Pattern u b c -> Pattern u b c' -> Pattern u b (c, c')
&&& :: forall b c c'.
Pattern u b c -> Pattern u b c' -> Pattern u b (c, c')
A.Arrow, Arrow (Pattern u)
Arrow (Pattern u)
-> (forall b c. Pattern u b c) -> ArrowZero (Pattern u)
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
$czeroArrow :: forall u b c. Pattern u b c
zeroArrow :: forall b c. Pattern u b c
A.ArrowZero, ArrowZero (Pattern u)
ArrowZero (Pattern u)
-> (forall b c. Pattern u b c -> Pattern u b c -> Pattern u b c)
-> ArrowPlus (Pattern u)
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
$c<+> :: forall u b c. Pattern u b c -> Pattern u b c -> Pattern u b c
<+> :: forall 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 = Kleisli (StateT u Maybe) a a -> Pattern u a a
forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern (Kleisli (StateT u Maybe) a a
forall a. Kleisli (StateT u Maybe) a a
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 = Kleisli (StateT u Maybe) a c -> Pattern u a c
forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern (Kleisli (StateT u Maybe) b c
p1 Kleisli (StateT u Maybe) b c
-> Kleisli (StateT u Maybe) a b -> Kleisli (StateT u Maybe) a c
forall b c a.
Kleisli (StateT u Maybe) b c
-> Kleisli (StateT u Maybe) a b -> Kleisli (StateT u Maybe) 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.. 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) = Kleisli (StateT u Maybe) a b -> Pattern u a b
forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern (Kleisli (StateT u Maybe) a b -> Pattern u a b)
-> Kleisli (StateT u Maybe) a b -> Pattern u a b
forall a b. (a -> b) -> a -> b
$ (a -> StateT u Maybe b) -> Kleisli (StateT u Maybe) a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
A.Kleisli ((a -> StateT u Maybe b) -> Kleisli (StateT u Maybe) a b)
-> (a -> StateT u Maybe b) -> Kleisli (StateT u Maybe) a b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> StateT u Maybe a -> StateT u Maybe b
forall a b. (a -> b) -> StateT u Maybe a -> StateT u Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (StateT u Maybe a -> StateT u Maybe b)
-> (a -> StateT u Maybe a) -> a -> StateT u Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kleisli (StateT u Maybe) a a -> a -> StateT u Maybe a
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
A.runKleisli Kleisli (StateT u Maybe) a a
p

-- |
-- Run a pattern with an input and initial user state
--
-- Returns Nothing if the pattern fails to match
--
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 = (StateT u Maybe b -> u -> Maybe b)
-> u -> StateT u Maybe b -> Maybe b
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT u Maybe b -> u -> Maybe b
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT u
u (StateT u Maybe b -> Maybe b)
-> (a -> StateT u Maybe b) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kleisli (StateT u Maybe) a b -> a -> StateT u Maybe b
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
A.runKleisli (Pattern u a b -> Kleisli (StateT u Maybe) a b
forall u a b. Pattern u a b -> Kleisli (StateT u Maybe) a b
runPattern Pattern u a b
p)

-- |
-- Construct a pattern from a function
--
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 = Kleisli (StateT u Maybe) a b -> Pattern u a b
forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern (Kleisli (StateT u Maybe) a b -> Pattern u a b)
-> Kleisli (StateT u Maybe) a b -> Pattern u a b
forall a b. (a -> b) -> a -> b
$ (a -> StateT u Maybe b) -> Kleisli (StateT u Maybe) a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
A.Kleisli (Maybe b -> StateT u Maybe b
forall (m :: * -> *) a. Monad m => m a -> StateT u m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe b -> StateT u Maybe b)
-> (a -> Maybe b) -> a -> StateT u Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
f)

-- |
-- Construct a pattern from a stateful function
--
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' = Kleisli (StateT u Maybe) a b -> Pattern u a b
forall u a b. Kleisli (StateT u Maybe) a b -> Pattern u a b
Pattern (Kleisli (StateT u Maybe) a b -> Pattern u a b)
-> ((a -> StateT u Maybe b) -> Kleisli (StateT u Maybe) a b)
-> (a -> StateT u Maybe b)
-> Pattern u a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> StateT u Maybe b) -> Kleisli (StateT u Maybe) a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
A.Kleisli

-- |
-- Construct a pattern which recursively matches on the left-hand-side
--
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 = (Pattern u a r -> Pattern u a r) -> Pattern u a r
forall a. (a -> a) -> a
fix ((Pattern u a r -> Pattern u a r) -> Pattern u a r)
-> (Pattern u a r -> Pattern u a r) -> Pattern u a r
forall a b. (a -> b) -> a -> b
$ \Pattern u a r
c -> Pattern u a (a, a)
g Pattern u a (a, a) -> Pattern u (a, a) r -> Pattern u a r
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 Pattern u a r -> Pattern u a r -> Pattern u a r
forall b c. Pattern u b c -> Pattern u b c -> Pattern u b c
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Pattern u a r
p) Pattern u a r -> Pattern u a r -> Pattern u (a, a) (r, r)
forall b c b' c'.
Pattern u b c -> Pattern u b' c' -> Pattern u (b, b') (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Pattern u a r
p) Pattern u (a, a) (r, r) -> Pattern u (r, r) r -> Pattern u (a, a) r
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((r, r) -> r) -> Pattern u (r, r) r
forall b c. (b -> c) -> Pattern u b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
A.arr ((r -> r -> r) -> (r, r) -> r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry r -> r -> r
f)

-- |
-- Construct a pattern which recursively matches on the right-hand side
--
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 = (Pattern u a r -> Pattern u a r) -> Pattern u a r
forall a. (a -> a) -> a
fix ((Pattern u a r -> Pattern u a r) -> Pattern u a r)
-> (Pattern u a r -> Pattern u a r) -> Pattern u a r
forall a b. (a -> b) -> a -> b
$ \Pattern u a r
c -> Pattern u a (a, a)
g Pattern u a (a, a) -> Pattern u (a, a) r -> Pattern u a r
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 Pattern u a r -> Pattern u a r -> Pattern u (a, a) (r, r)
forall b c b' c'.
Pattern u b c -> Pattern u b' c' -> Pattern u (b, b') (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Pattern u a r
c Pattern u a r -> Pattern u a r -> Pattern u a r
forall b c. Pattern u b c -> Pattern u b c -> Pattern u b c
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Pattern u a r
p)) Pattern u (a, a) (r, r) -> Pattern u (r, r) r -> Pattern u (a, a) r
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((r, r) -> r) -> Pattern u (r, r) r
forall b c. (b -> c) -> Pattern u b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
A.arr ((r -> r -> r) -> (r, r) -> r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry r -> r -> r
f)

-- |
-- Construct a pattern which recursively matches on one-side of a tuple
--
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 = (Pattern u a r -> Pattern u a r) -> Pattern u a r
forall a. (a -> a) -> a
fix ((Pattern u a r -> Pattern u a r) -> Pattern u a r)
-> (Pattern u a r -> Pattern u a r) -> Pattern u a r
forall a b. (a -> b) -> a -> b
$ \Pattern u a r
c -> Pattern u a (s, a)
g Pattern u a (s, a) -> Pattern u (s, a) r -> Pattern u a r
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Pattern u s s
forall a. Pattern u a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
C.id Pattern u s s -> Pattern u a r -> Pattern u (s, a) (s, r)
forall b c b' c'.
Pattern u b c -> Pattern u b' c' -> Pattern u (b, b') (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Pattern u a r
c Pattern u a r -> Pattern u a r -> Pattern u a r
forall b c. Pattern u b c -> Pattern u b c -> Pattern u b c
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Pattern u a r
p)) Pattern u (s, a) (s, r) -> Pattern u (s, r) r -> Pattern u (s, a) r
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((s, r) -> r) -> Pattern u (s, r) r
forall b c. (b -> c) -> Pattern u b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
A.arr ((s -> r -> r) -> (s, r) -> r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> r -> r
f)

-- |
-- Construct a pattern which matches a part of a tuple
--
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 Pattern u a (s, t) -> Pattern u (s, t) r -> Pattern u a r
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((s, t) -> r) -> Pattern u (s, t) r
forall b c. (b -> c) -> Pattern u b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
A.arr ((s -> t -> r) -> (s, t) -> r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> t -> r
f)

-- |
-- A table of operators
--
data OperatorTable u a r = OperatorTable { forall u a r. OperatorTable u a r -> [[Operator u a r]]
runOperatorTable :: [ [Operator u a r] ] }

-- |
-- An operator:
--
--  [@AssocL@] A left-associative operator
--
--  [@AssocR@] A right-associative operator
--
--  [@Wrap@] A prefix-like or postfix-like operator
--
--  [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
--
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

-- |
-- Build a pretty printer from an operator table and an indecomposable pattern
--
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 = (Pattern u a r -> [Operator u a r] -> Pattern u a r)
-> Pattern u a r -> [[Operator u a r]] -> Pattern u a r
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Pattern u a r
p' [Operator u a r]
ops -> (Pattern u a r -> Pattern u a r -> Pattern u a r)
-> [Pattern u a r] -> Pattern u a r
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Pattern u a r -> Pattern u a r -> Pattern u a r
forall b c. Pattern u b c -> Pattern u b c -> Pattern u b c
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
(<+>) (((Operator u a r -> Pattern u a r)
 -> [Operator u a r] -> [Pattern u a r])
-> [Operator u a r]
-> (Operator u a r -> Pattern u a r)
-> [Pattern u a r]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Operator u a r -> Pattern u a r)
-> [Operator u a r] -> [Pattern u a r]
forall a b. (a -> b) -> [a] -> [b]
map [Operator u a r]
ops ((Operator u a r -> Pattern u a r) -> [Pattern u a r])
-> (Operator u a r -> Pattern u a r) -> [Pattern u a r]
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 -> Pattern u a (a, a)
-> (r -> r -> r) -> Pattern u a r -> Pattern u a r
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 -> Pattern u a (a, a)
-> (r -> r -> r) -> Pattern u a r -> Pattern u a r
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 -> Pattern u a (s, a)
-> (s -> r -> r) -> Pattern u a r -> Pattern u a r
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 -> Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
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
  ) Pattern u a r -> Pattern u a r -> Pattern u a r
forall b c. Pattern u b c -> Pattern u b c -> Pattern u b c
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 ([[Operator u a r]] -> Pattern u a r)
-> [[Operator u a r]] -> Pattern u a r
forall a b. (a -> b) -> a -> b
$ OperatorTable u a r -> [[Operator u a r]]
forall u a r. OperatorTable u a r -> [[Operator u a r]]
runOperatorTable OperatorTable u a r
table