]> Git — Sourcephile - haskell/symantic.git/blob - symantic-grammar/Language/Symantic/Grammar/Operators.hs
Separate tests into test/.
[haskell/symantic.git] / symantic-grammar / Language / Symantic / Grammar / Operators.hs
1 -- | Symantics to handle 'Prefix', 'Postfix' or 'Infix' operators,
2 -- of different 'Precedence's and possibly with left and/or right 'Associativity'.
3 module Language.Symantic.Grammar.Operators where
4
5 import Control.Applicative (Applicative(..))
6 import Control.Monad (void)
7 import Data.Foldable
8
9 import Language.Symantic.Grammar.Fixity
10 import Language.Symantic.Grammar.EBNF
11 import Language.Symantic.Grammar.Terminal
12 import Language.Symantic.Grammar.Regular
13 import Language.Symantic.Grammar.ContextFree
14
15 -- * Class 'Gram_Op'
16 -- | Symantics for operators.
17 class
18 ( Gram_Char g
19 , Gram_String g
20 , Gram_Rule g
21 , Gram_Alt g
22 , Gram_Try g
23 , Gram_App g
24 , Gram_AltApp g
25 , Gram_CF g
26 ) => Gram_Op g where
27 operators
28 :: CF g a -- ^ expression
29 -> CF g (Unifix, a -> a) -- ^ prefix operator
30 -> CF g (Infix , a -> a -> a) -- ^ infix operator
31 -> CF g (Unifix, a -> a) -- ^ postfix operator
32 -> CF g (Either Error_Fixity a)
33 operators g prefixG infixG postfixG =
34 (evalOpTree <$>) <$> go g prefixG infixG postfixG
35 where
36 go
37 :: CF g a
38 -> CF g (Unifix, a -> a)
39 -> CF g (Infix , a -> a -> a)
40 -> CF g (Unifix, a -> a)
41 -> CF g (Either Error_Fixity (OpTree a))
42 go = rule4 "operators" $ \aG preG inG postG ->
43 (\pres a posts ->
44 let nod_a =
45 foldr insertUnifix
46 (foldl' (flip insertUnifix) (OpTree0 a) posts)
47 pres
48 in \case
49 Just (in_, b) -> insertInfix nod_a in_ b
50 Nothing -> Right nod_a)
51 <$> many (try preG)
52 <*> aG
53 <*> many (try postG)
54 <*> option Nothing (curry Just <$> try inG <*> go aG preG inG postG)
55 infixrG :: CF g a -> CF g (a -> a -> a) -> CF g a
56 infixrG = rule2 "infixr" $ \g opG ->
57 (\a -> \case
58 Just (op, b) -> a `op` b
59 Nothing -> a)
60 <$> g
61 <*> option Nothing (try $ curry Just <$> opG <*> infixrG g opG)
62 infixlG :: CF g a -> CF g (a -> a -> a) -> CF g a
63 infixlG = rule2 "infixl" $ \g opG ->
64 -- NOTE: infixl uses the same grammar than infixr,
65 -- but build the parsed value by applying
66 -- the operator in the opposite way.
67 ($ id) <$> go g opG
68 where
69 go :: CF g a -> CF g (a -> a -> a) -> CF g ((a -> a) -> a)
70 go g opG =
71 (\a -> \case
72 Just (op, kb) -> \k -> kb (k a `op`)
73 Nothing -> ($ a))
74 <$> g
75 <*> option Nothing (try $ curry Just <$> opG <*> go g opG)
76 deriving instance Gram_Op g => Gram_Op (CF g)
77 instance Gram_Op RuleEBNF
78 instance Gram_Op EBNF
79
80 -- ** Type 'Error_Fixity'
81 data Error_Fixity
82 = Error_Fixity_Infix_not_combinable Infix Infix
83 {-
84 Error_Fixity_NeedPostfixOrInfix
85 Error_Fixity_NeedPrefix
86 Error_Fixity_NeedPostfix
87 Error_Fixity_NeedInfix
88 -}
89 deriving (Eq, Show)
90
91 -- ** Type 'OpTree'
92 -- | Tree of operators.
93 --
94 -- Useful to recombine operators according to their 'Precedence'.
95 data OpTree a
96 = OpTree0 a
97 | OpTree1 Unifix (a -> a) (OpTree a)
98 | OpTree2 Infix (a -> a -> a) (OpTree a) (OpTree a)
99 instance Show a => Show (OpTree a) where
100 showsPrec n (OpTree0 a) =
101 showParen (n > 10) $ showString "OpTree0 "
102 . showsPrec 11 a
103 showsPrec n (OpTree1 f _ a) =
104 showParen (n > 10) $ showString "OpTree1 "
105 . showsPrec 11 f
106 . showChar ' ' . showsPrec 11 a
107 showsPrec n (OpTree2 f _ a b) =
108 showParen (n > 10) $ showString "OpTree2 "
109 . showsPrec 11 f
110 . showChar ' ' . showsPrec 11 a
111 . showChar ' ' . showsPrec 11 b
112
113 -- | Insert an 'Unifix' operator into an 'OpTree'.
114 insertUnifix :: (Unifix, a -> a) -> OpTree a -> OpTree a
115 insertUnifix a@(uni_a@(Prefix prece_a), op_a) nod_b =
116 case nod_b of
117 OpTree0{} -> OpTree1 uni_a op_a nod_b
118 OpTree1 Prefix{} _op_b _nod -> OpTree1 uni_a op_a nod_b
119 OpTree1 uni_b@(Postfix prece_b) op_b nod ->
120 case prece_b `compare` prece_a of
121 GT -> OpTree1 uni_a op_a nod_b
122 EQ -> OpTree1 uni_a op_a nod_b
123 LT -> OpTree1 uni_b op_b $ insertUnifix a nod
124 OpTree2 inf_b op_b l r ->
125 case infix_prece inf_b `compare` prece_a of
126 GT -> OpTree1 uni_a op_a nod_b
127 EQ -> OpTree1 uni_a op_a nod_b
128 LT -> OpTree2 inf_b op_b (insertUnifix a l) r
129 insertUnifix a@(uni_a@(Postfix prece_a), op_a) nod_b =
130 case nod_b of
131 OpTree0{} -> OpTree1 uni_a op_a nod_b
132 OpTree1 uni_b@(Prefix prece_b) op_b nod ->
133 case prece_b `compare` prece_a of
134 GT -> OpTree1 uni_a op_a nod_b
135 EQ -> OpTree1 uni_a op_a nod_b
136 LT -> OpTree1 uni_b op_b $ insertUnifix a nod
137 OpTree1 Postfix{} _op_b _nod -> OpTree1 uni_a op_a nod_b
138 OpTree2 inf_b op_b l r ->
139 case infix_prece inf_b `compare` prece_a of
140 GT -> OpTree1 uni_a op_a nod_b
141 EQ -> OpTree1 uni_a op_a nod_b
142 LT -> OpTree2 inf_b op_b l (insertUnifix a r)
143
144 -- | Insert an 'Infix' operator into an 'OpTree'.
145 insertInfix
146 :: OpTree a
147 -> (Infix, a -> a -> a)
148 -> Either Error_Fixity (OpTree a)
149 -> Either Error_Fixity (OpTree a)
150 insertInfix nod_a in_@(inf_a, op_a) e_nod_b = do
151 nod_b <- e_nod_b
152 case nod_b of
153 OpTree0{} -> Right $ OpTree2 inf_a op_a nod_a nod_b
154 OpTree1 uni_b op_b nod ->
155 case unifix_prece uni_b `compare` infix_prece inf_a of
156 EQ -> Right $ OpTree2 inf_a op_a nod_a nod_b
157 GT -> Right $ OpTree2 inf_a op_a nod_a nod_b
158 LT -> do
159 n <- insertInfix nod_a in_ (Right nod)
160 Right $ OpTree1 uni_b op_b n
161 OpTree2 inf_b op_b l r ->
162 case infix_prece inf_b `compare` infix_prece inf_a of
163 GT -> Right $ OpTree2 inf_a op_a nod_a nod_b
164 LT -> do
165 n <- insertInfix nod_a in_ (Right l)
166 Right $ OpTree2 inf_b op_b n r
167 EQ ->
168 let ass = \case
169 AssocL -> SideL
170 AssocR -> SideR
171 AssocB lr -> lr in
172 case (ass <$> infix_assoc inf_b, ass <$> infix_assoc inf_a) of
173 (Just SideL, Just SideL) -> do
174 n <- insertInfix nod_a in_ (Right l)
175 Right $ OpTree2 inf_b op_b n r
176 (Just SideR, Just SideR) ->
177 Right $ OpTree2 inf_a op_a nod_a nod_b
178 _ -> Left $ Error_Fixity_Infix_not_combinable inf_a inf_b
179 -- NOTE: non-associating infix ops
180 -- of the same precedence cannot be mixed.
181
182 -- | Collapse an 'OpTree'.
183 evalOpTree :: OpTree a -> a
184 evalOpTree (OpTree0 a) = a
185 evalOpTree (OpTree1 _uni op n) = op $ evalOpTree n
186 evalOpTree (OpTree2 _inf op l r) = evalOpTree l `op` evalOpTree r
187
188 gram_operators :: (Gram_Op g, Gram_RuleEBNF g) => [CF g ()]
189 gram_operators =
190 [ void $ operators (argEBNF "expr") (argEBNF "prefix") (argEBNF "infix") (argEBNF "postfix")
191 ]