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