@@ -42,96 +42,8 @@ identCharToString c | isAlphaNum c = [c]
42identCharToString '_' = "_"
42identCharToString '_' = "_"
43identCharToString c = '$' : show (ord c)
43identCharToString c = '$' : show (ord c)
46−-- A first-order pattern match
48−-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
50−newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
52−instance Functor (Pattern u a) where
53− fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
56−-- Run a pattern with an input and initial user state
58−-- Returns Nothing if the pattern fails to match
60−pattern :: Pattern u a b -> u -> a -> Maybe b
61−pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
64−-- Construct a pattern from a function
66−mkPattern :: (a -> Maybe b) -> Pattern u a b
67−mkPattern f = Pattern $ A.Kleisli (lift . f)
70−-- Construct a pattern from a stateful function
72−mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
73−mkPattern' = Pattern . A.Kleisli
76-- Wrap a string in parentheses
46-- Wrap a string in parentheses
78parens :: String -> String
48parens :: String -> String
79parens s = ('(':s) ++ ")"
49parens s = ('(':s) ++ ")"
82−-- Construct a pattern which recursively matches on the left-hand-side
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)
88−-- Construct a pattern which recursively matches on the right-hand side
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)
94−-- Construct a pattern which recursively matches on one-side of a tuple
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)
100−-- Construct a pattern which matches a part of a tuple
102−split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
103−split s f = s >>> A.arr (uncurry f)
106−-- A table of operators
108−data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
113−-- [@AssocL@] A left-associative operator
115−-- [@AssocR@] A right-associative operator
117−-- [@Wrap@] A prefix-like or postfix-like operator
119−-- [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
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
128−-- Build a pretty printer from an operator table and an indecomposable pattern
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 ->
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