summaryrefslogtreecommitdiff
path: root/src/Control/PatternArrows.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Control/PatternArrows.hs')
-rw-r--r--src/Control/PatternArrows.hs113
1 files changed, 113 insertions, 0 deletions
diff --git a/src/Control/PatternArrows.hs b/src/Control/PatternArrows.hs
new file mode 100644
index 0000000..c42d5d6
--- /dev/null
+++ b/src/Control/PatternArrows.hs
@@ -0,0 +1,113 @@
+-----------------------------------------------------------------------------
+--
+-- 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 { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
+
+instance Functor (Pattern u a) where
+ fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli 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 p u = flip evalStateT u . A.runKleisli (runPattern p)
+
+-- |
+-- Construct a pattern from a function
+--
+mkPattern :: (a -> Maybe b) -> Pattern u a b
+mkPattern f = Pattern $ A.Kleisli (lift . f)
+
+-- |
+-- Construct a pattern from a stateful function
+--
+mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
+mkPattern' = Pattern . 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 g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry 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 g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry 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 g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry 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 s f = s >>> A.arr (uncurry f)
+
+-- |
+-- A table of operators
+--
+data OperatorTable u a r = OperatorTable { 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 table p = foldl (\p' ops -> foldl1 (<+>) (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'
+ Split pat g -> split pat g
+ ) <+> p') p $ runOperatorTable table