@@ -42,96 +42,8 @@ identCharToString c | isAlphaNum c = [c]
4242identCharToString '_' = "_"
4343identCharToString c = '$' : show (ord c)
4444
45−-- |
46−-- A first-order pattern match
47−--
48−-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
49−--
50−newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
51−
52−instance Functor (Pattern u a) where
53− fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
54−
55−-- |
56−-- Run a pattern with an input and initial user state
57−--
58−-- Returns Nothing if the pattern fails to match
59−--
60−pattern :: Pattern u a b -> u -> a -> Maybe b
61−pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
62−
63−-- |
64−-- Construct a pattern from a function
65−--
66−mkPattern :: (a -> Maybe b) -> Pattern u a b
67−mkPattern f = Pattern $ A.Kleisli (lift . f)
68−
69−-- |
70−-- Construct a pattern from a stateful function
71−--
72−mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
73−mkPattern' = Pattern . A.Kleisli
74−
7545-- |
7646-- Wrap a string in parentheses
7747--
7848parens :: String -> String
7949parens s = ('(':s) ++ ")"
80−
81−-- |
82−-- Construct a pattern which recursively matches on the left-hand-side
83−--
84−chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
85−chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
86−
87−-- |
88−-- Construct a pattern which recursively matches on the right-hand side
89−--
90−chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
91−chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
92−
93−-- |
94−-- Construct a pattern which recursively matches on one-side of a tuple
95−--
96−wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
97−wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
98−
99−-- |
100−-- Construct a pattern which matches a part of a tuple
101−--
102−split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
103−split s f = s >>> A.arr (uncurry f)
104−
105−-- |
106−-- A table of operators
107−--
108−data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
109−
110−-- |
111−-- An operator:
112−--
113−-- [@AssocL@] A left-associative operator
114−--
115−-- [@AssocR@] A right-associative operator
116−--
117−-- [@Wrap@] A prefix-like or postfix-like operator
118−--
119−-- [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
120−--
121−data Operator u a r where
122− AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
123− AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
124− Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
125− Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r
126−
127−-- |
128−-- Build a pretty printer from an operator table and an indecomposable pattern
129−--
130−buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r
131−buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
132− case op of
133− AssocL pat g -> chainl pat g p'
134− AssocR pat g -> chainr pat g p'
135− Wrap pat g -> wrap pat g p'
136− Split pat g -> split pat g
137− ) <+> p') p $ runOperatorTable table