summaryrefslogtreecommitdiff
path: root/src/Control/PatternArrows.hs
blob: d382c1913c6d6fa5e670622cc0454f30d7bd62df (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
-----------------------------------------------------------------------------
--
-- 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 (A.Arrow, A.ArrowZero, A.ArrowPlus)

instance C.Category (Pattern u) where
    id = Pattern (C.id)
    Pattern p1 . Pattern p2 = Pattern (p1 C.. p2)

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