Patterns.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-} 

import Control.Applicative (Applicative(..), Alternative(..))
import Data.Function (fix)
import qualified Control.Category as C
import Control.Category ((>>>))
import qualified Control.Arrow as A
import Control.Arrow ((***))

newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow)

pattern :: Pattern a b -> a -> Maybe b
pattern = A.runKleisli . runPattern

instance Functor (Pattern a) where
  fmap f p = Pattern $ A.Kleisli $ fmap f . pattern p

instance Applicative (Pattern a) where
  pure = Pattern . A.Kleisli . const . pure
  f <*> x = Pattern . A.Kleisli $ \a -> pattern f a <*> pattern x a

instance Alternative (Pattern a) where
  empty = Pattern $ A.Kleisli $ \a -> empty
  (Pattern (A.Kleisli p)) <|> (Pattern (A.Kleisli q)) = Pattern $ A.Kleisli $ \a -> p a <|> q a

parens :: String -> String
parens s = ('(':s) ++ ")"

chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
chainl split f p = fix $ \c -> (split >>> (c *** p) >>> A.arr (uncurry f)) <|> p

chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
chainr split f p = fix $ \c -> (split >>> (p *** c) >>> A.arr (uncurry f)) <|> p

wrap :: Pattern a (r, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
wrap split f p = fix $ \c -> (split >>> (C.id *** p) >>> A.arr (uncurry f)) <|> p

data OperatorTable a r = OperatorTable { runOperatorTable :: [[Operator a r]] }

data Operator a r
  = AssocL (Pattern a (a, a)) (r -> r -> r)
  | AssocR (Pattern a (a, a)) (r -> r -> r)
  | Wrap (Pattern a (r, a)) (r -> r -> r)

buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
buildPrettyPrinter table p = foldr (\ops p' ->
  foldr (<|>) p' (flip map ops $ \op ->
    case op of
      AssocL pat g -> chainl pat g p'
      AssocR pat g -> chainr pat g p'
      Wrap pat g -> wrap pat g p')
  ) p $ runOperatorTable table

-- Example 1 - Lambda Terms

data Expr = Var String
          | Abs String Expr
          | App Expr Expr deriving Show

var :: Pattern Expr String
var = Pattern $ A.Kleisli var'
  where var' (Var s) = Just s
        var' _ = Nothing

lam :: Pattern Expr (String, Expr)
lam = Pattern $ A.Kleisli abs'
  where abs' (Abs s e) = Just (s, e)
        abs' _ = Nothing

app :: Pattern Expr (Expr, Expr)
app = Pattern $ A.Kleisli app'
  where app' (App e1 e2) = Just (e1, e2)
        app' _ = Nothing

expr = buildPrettyPrinter ops (var <|> fmap parens expr)
  where 
    ops = OperatorTable
      [ [ Wrap lam $ \b s -> "\\" ++ b ++ " -> " ++ s ]
      , [ AssocL app $ \e1 e2 -> e1 ++ " " ++ e2 ]
      ]

-- Example 2 - Integer Expressions with Binary Operations

data Eqn = Const Int
         | Bin Eqn Char Eqn deriving Show

con :: Pattern Eqn Int
con = Pattern $ A.Kleisli con'
  where con' (Const n) = Just n
        con' _ = Nothing

bin :: Char -> Pattern Eqn (Eqn, Eqn)
bin c = Pattern $ A.Kleisli bin'
  where bin' (Bin e1 c' e2) | c == c' = Just (e1, e2)
        bin' _ = Nothing

eqn = buildPrettyPrinter ops (fmap show con <|> fmap parens eqn)
  where 
    ops = OperatorTable
      [ [ binOp '+' ]
      , [ binOp '-' ]
      , [ binOp '*' ]
      , [ binOp '/' ]
      ]
    binOp c = AssocL (bin c) $ \e1 e2 -> e1 ++ c : e2