PrecCheck.lhs 19.9 KB
Newer Older
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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
% $Id: PrecCheck.lhs,v 1.21 2004/02/15 22:10:34 wlux Exp $
%
% Copyright (c) 2001-2004, Wolfgang Lux
% See LICENSE for the full license.
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
%
\nwfilename{PrecCheck.lhs}
\section{Checking Precedences of Infix Operators}
The parser does not know the relative precedences of infix operators
and therefore parses them as if they all associate to the right and
have the same precedence. After performing the definition checks,
the compiler is going to process the infix applications in the module
and rearrange infix applications according to the relative precedences
of the operators involved.
\begin{verbatim}

> module Check.PrecCheck (precCheck) where

> import Data.List (partition, mapAccumL)

> import Curry.Base.Position
> import Curry.Base.Ident
> import Curry.Syntax

26
> import Base.Expr
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
> import Base.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP, qualLookupP)
> import Messages (errorAt')
> import Utils (findDouble)

\end{verbatim}
For each declaration group, including the module-level, the compiler
first checks that its fixity declarations contain no duplicates and
that there is a corresponding value or constructor declaration in that
group. The fixity declarations are then used for extending the
imported precedence environment.
\begin{verbatim}

> bindPrecs :: ModuleIdent -> [Decl] -> PEnv -> PEnv
> bindPrecs m ds pEnv =
>   case findDouble ops of
>     Nothing ->
>       case [ op | op <- ops, op `notElem` bvs] of
>         [] -> foldr bindPrec pEnv fixDs
>         op : _ -> errorAt' (undefinedOperator op)
>     Just op -> errorAt' (duplicatePrecedence op)
>   where (fixDs,nonFixDs) = partition isInfixDecl ds
>         bvs = concatMap boundValues nonFixDs
>         ops = [ op | InfixDecl _ _ _ ops' <- fixDs, op <- ops']
>         bindPrec (InfixDecl _ fix pr ops') pEnv'
>           | p == defaultP = pEnv'
>           | otherwise = foldr (flip (bindP m) p) pEnv' ops'
>           where p = OpPrec fix pr
>         bindPrec _ _ = error "PrecCheck.bindPrecs.bindPrec: no infix declaration"

> boundValues :: Decl -> [Ident]
> boundValues (DataDecl _ _ _ cs) = map constr cs
>   where constr (ConstrDecl _ _ c _) = c
>         constr (ConOpDecl _ _ _ op _) = op
> boundValues (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
> boundValues (FunctionDecl _ f _) = [f]
> boundValues (ExternalDecl _ _ _ f _) = [f]
> boundValues (FlatExternalDecl _ fs) = fs
> boundValues (PatternDecl _ t _) = bv t
> boundValues (ExtraVariables _ vs) = vs
> boundValues _ = []

\end{verbatim}
With the help of the precedence environment, the compiler checks all
infix applications and sections in the program. This pass will modify
the parse tree such that for a nested infix application the operator
with the lowest precedence becomes the root and that two adjacent
operators with the same precedence will not have conflicting
associativities. Note that the top-level precedence environment has to
be returned because it is needed for constructing the module's
interface.
\begin{verbatim}

> precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
> precCheck = checkDecls

> checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
> checkDecls m pEnv ds = pEnv' `seq` (pEnv',ds')
>   where pEnv' = bindPrecs m ds pEnv
>         ds' = map (checkDecl m pEnv') ds

> checkDecl :: ModuleIdent -> PEnv -> Decl -> Decl
> checkDecl m pEnv (FunctionDecl p f eqs) =
>   FunctionDecl p f (map (checkEqn m pEnv) eqs)
> checkDecl m pEnv (PatternDecl p t rhs) =
>   PatternDecl p (checkConstrTerm pEnv t) (checkRhs m pEnv rhs)
> checkDecl _ _ d = d

> checkEqn :: ModuleIdent -> PEnv -> Equation -> Equation
> checkEqn m pEnv (Equation p lhs rhs) =
>   Equation p (checkLhs pEnv lhs) (checkRhs m pEnv rhs)

> checkLhs :: PEnv -> Lhs -> Lhs
> checkLhs pEnv (FunLhs f ts) = FunLhs f (map (checkConstrTerm pEnv) ts)
> checkLhs pEnv (OpLhs t1 op t2) = t1' `seq` t2' `seq` OpLhs t1' op t2'
>   where t1' = checkOpL pEnv op (checkConstrTerm pEnv t1)
>         t2' = checkOpR pEnv op (checkConstrTerm pEnv t2)
> checkLhs pEnv (ApLhs lhs ts) =
>   ApLhs (checkLhs pEnv lhs) (map (checkConstrTerm pEnv) ts)

> checkConstrTerm :: PEnv -> ConstrTerm -> ConstrTerm
> checkConstrTerm _ (LiteralPattern l) = LiteralPattern l
> checkConstrTerm _ (NegativePattern op l) = NegativePattern op l
> checkConstrTerm _ (VariablePattern v) = VariablePattern v
> checkConstrTerm pEnv (ConstructorPattern c ts) =
>   ConstructorPattern c (map (checkConstrTerm pEnv) ts)
> checkConstrTerm pEnv (InfixPattern t1 op t2) =
>   fixPrecT pEnv InfixPattern
>	 (checkConstrTerm pEnv t1) op (checkConstrTerm pEnv t2)
> checkConstrTerm pEnv (ParenPattern t) =
>   ParenPattern (checkConstrTerm pEnv t)
> checkConstrTerm pEnv (TuplePattern p ts) =
>   TuplePattern p (map (checkConstrTerm pEnv) ts)
> checkConstrTerm pEnv (ListPattern p ts) =
>   ListPattern p (map (checkConstrTerm pEnv) ts)
> checkConstrTerm pEnv (AsPattern v t) =
>   AsPattern v (checkConstrTerm pEnv t)
> checkConstrTerm pEnv (LazyPattern p t) =
>   LazyPattern p (checkConstrTerm pEnv t)
> checkConstrTerm pEnv (FunctionPattern f ts) =
>   FunctionPattern f (map (checkConstrTerm pEnv) ts)
> checkConstrTerm pEnv (InfixFuncPattern t1 op t2) =
>   fixPrecT pEnv InfixFuncPattern
>	 (checkConstrTerm pEnv t1) op (checkConstrTerm pEnv t2)
> checkConstrTerm pEnv (RecordPattern fs r) =
>   RecordPattern (map (checkFieldPattern pEnv) fs)
>	          (maybe Nothing (Just . checkConstrTerm pEnv) r)

> checkFieldPattern :: PEnv -> Field ConstrTerm -> Field ConstrTerm
> checkFieldPattern pEnv (Field p label patt) =
>     Field p label (checkConstrTerm pEnv patt)

> checkRhs :: ModuleIdent -> PEnv -> Rhs -> Rhs
> checkRhs m pEnv (SimpleRhs p e ds) = SimpleRhs p (checkExpr m pEnv' e) ds'
>   where (pEnv',ds') = checkDecls m pEnv ds
> checkRhs m pEnv (GuardedRhs es ds) =
>   GuardedRhs (map (checkCondExpr m pEnv') es) ds'
>   where (pEnv',ds') = checkDecls m pEnv ds

> checkCondExpr :: ModuleIdent -> PEnv -> CondExpr -> CondExpr
> checkCondExpr m pEnv (CondExpr p g e) =
>   CondExpr p (checkExpr m pEnv g) (checkExpr m pEnv e)

> checkExpr :: ModuleIdent -> PEnv -> Expression -> Expression
> checkExpr _ _ (Literal l) = Literal l
> checkExpr _ _ (Variable v) = Variable v
> checkExpr _ _ (Constructor c) = Constructor c
> checkExpr m pEnv (Paren e) = Paren (checkExpr m  pEnv e)
> checkExpr m pEnv (Typed e ty) = Typed (checkExpr m  pEnv e) ty
> checkExpr m pEnv (Tuple p es) = Tuple p (map (checkExpr m  pEnv) es)
> checkExpr m pEnv (List p es) = List p (map (checkExpr m  pEnv) es)
> checkExpr m pEnv (ListCompr p e qs) = ListCompr p (checkExpr m  pEnv' e) qs'
>   where (pEnv',qs') = mapAccumL (checkStmt m ) pEnv qs
> checkExpr m pEnv (EnumFrom e) = EnumFrom (checkExpr m pEnv e)
> checkExpr m pEnv (EnumFromThen e1 e2) =
>   EnumFromThen (checkExpr m pEnv e1) (checkExpr m pEnv e2)
> checkExpr m pEnv (EnumFromTo e1 e2) =
>   EnumFromTo (checkExpr m pEnv e1) (checkExpr m pEnv e2)
> checkExpr m pEnv (EnumFromThenTo e1 e2 e3) =
>   EnumFromThenTo (checkExpr m pEnv e1)
>                  (checkExpr m pEnv e2)
>                  (checkExpr m pEnv e3)
> checkExpr m pEnv (UnaryMinus op e) = UnaryMinus op (checkExpr m pEnv e)
> checkExpr m pEnv (Apply e1 e2) =
>   Apply (checkExpr m pEnv e1) (checkExpr m pEnv e2)
> checkExpr m pEnv (InfixApply e1 op e2) =
>   fixPrec pEnv (checkExpr m pEnv e1) op (checkExpr m pEnv e2)
> checkExpr m pEnv (LeftSection e op) =
>   checkLSection pEnv op (checkExpr m pEnv e)
> checkExpr m pEnv (RightSection op e) =
>   checkRSection pEnv op (checkExpr m pEnv e)
> checkExpr m pEnv (Lambda r ts e) =
>   Lambda r (map (checkConstrTerm pEnv) ts) (checkExpr m pEnv e)
> checkExpr m pEnv (Let ds e) = Let ds' (checkExpr m pEnv' e)
>   where (pEnv',ds') = checkDecls m pEnv ds
> checkExpr m pEnv (Do sts e) = Do sts' (checkExpr m pEnv' e)
>   where (pEnv',sts') = mapAccumL (checkStmt m ) pEnv sts
> checkExpr m pEnv (IfThenElse r e1 e2 e3) =
>   IfThenElse r (checkExpr m pEnv e1)
>              (checkExpr m pEnv e2)
>              (checkExpr m pEnv e3)
> checkExpr m pEnv (Case r e alts) =
>   Case r (checkExpr m pEnv e) (map (checkAlt m pEnv) alts)
> checkExpr m pEnv (RecordConstr fs) =
>   RecordConstr (map (checkFieldExpr m pEnv) fs)
> checkExpr m pEnv (RecordSelection e label) =
>   RecordSelection (checkExpr m pEnv e) label
> checkExpr m pEnv (RecordUpdate fs e) =
>   RecordUpdate (map (checkFieldExpr m pEnv) fs) (checkExpr m pEnv e)

> checkFieldExpr :: ModuleIdent -> PEnv -> Field Expression -> Field Expression
> checkFieldExpr m pEnv (Field p label e) =
>   Field p label (checkExpr m  pEnv e)

> checkStmt :: ModuleIdent -> PEnv -> Statement -> (PEnv,Statement)
> checkStmt m pEnv (StmtExpr p e) = (pEnv,StmtExpr p (checkExpr m pEnv e))
> checkStmt m pEnv (StmtDecl ds) = pEnv' `seq` (pEnv',StmtDecl ds')
>   where (pEnv',ds') = checkDecls m pEnv ds
> checkStmt m pEnv (StmtBind p t e) =
>   (pEnv,StmtBind p (checkConstrTerm pEnv t) (checkExpr m pEnv e))

> checkAlt :: ModuleIdent -> PEnv -> Alt -> Alt
> checkAlt m pEnv (Alt p t rhs) =
>   Alt p (checkConstrTerm pEnv t) (checkRhs m pEnv rhs)

\end{verbatim}
The functions \texttt{fixPrec}, \texttt{fixUPrec}, and
\texttt{fixRPrec} check the relative precedences of adjacent infix
operators in nested infix applications and unary negations. The
expressions will be reordered such that the infix operator with the
lowest precedence becomes the root of the expression. \emph{The
functions rely on the fact that the parser constructs infix
applications in a right-associative fashion}, i.e., the left argument
of an infix application will never be an infix application. In
addition, a unary negation will never have an infix application as
its argument.

The function \texttt{fixPrec} checks whether the left argument of an
infix application is a unary negation and eventually reorders the
expression if the precedence of the infix operator is higher than that
of the negation. This will be done with the help of the function
\texttt{fixUPrec}. In any case, the function \texttt{fixRPrec} is used
for fixing the precedence of the infix operator and that of its right
argument. Note that both arguments already have been checked before
\texttt{fixPrec} is called.
\begin{verbatim}

> fixPrec :: PEnv -> Expression -> InfixOp -> Expression
>         -> Expression
> fixPrec pEnv (UnaryMinus uop e1) op e2
>   | pr < 6 || pr == 6 && fix == InfixL =
>       fixRPrec pEnv (UnaryMinus uop e1) op e2
>   | pr > 6 = fixUPrec pEnv uop e1 op e2
>   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op)
>   where OpPrec fix pr = opPrec op pEnv
> fixPrec pEnv e1 op e2 = fixRPrec pEnv e1 op e2

> fixUPrec :: PEnv -> Ident -> Expression -> InfixOp -> Expression
>          -> Expression
> fixUPrec _ uop  _ op (UnaryMinus _ _) =
>   errorAt' $ ambiguousParse "operator" (opName op) (qualify uop)
> fixUPrec pEnv uop e1 op1 (InfixApply e2 op2 e3)
>   | pr2 < 6 || pr2 == 6 && fix2 == InfixL =
>       InfixApply (fixUPrec pEnv uop e1 op1 e2) op2 e3
>   | pr2 > 6 = UnaryMinus uop (fixRPrec pEnv e1 op1 (InfixApply e2 op2 e3))
>   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op2)
>   where OpPrec fix2 pr2 = opPrec op2 pEnv
> fixUPrec _ uop e1 op e2 = UnaryMinus uop (InfixApply e1 op e2)

> fixRPrec :: PEnv -> Expression -> InfixOp -> Expression
>          -> Expression
> fixRPrec pEnv e1 op (UnaryMinus uop e2)
>   | pr < 6 = InfixApply e1 op (UnaryMinus uop e2)
>   | otherwise =
>       errorAt' $ ambiguousParse "operator" (opName op) (qualify uop)
>   where OpPrec _ pr = opPrec op pEnv
> fixRPrec pEnv e1 op1 (InfixApply e2 op2 e3)
>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR =
>       InfixApply e1 op1 (InfixApply e2 op2 e3)
>   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL =
>       InfixApply (fixPrec pEnv e1 op1 e2) op2 e3
>   | otherwise =
>       errorAt' $ ambiguousParse "operator" (opName op1) (opName op2)
>   where OpPrec fix1 pr1 = opPrec op1 pEnv
>         OpPrec fix2 pr2 = opPrec op2 pEnv
> fixRPrec _ e1 op e2 = InfixApply e1 op e2

\end{verbatim}
The functions \texttt{checkLSection} and \texttt{checkRSection} are
used for handling the precedences inside left and right sections.
These functions only need to check that an infix operator occurring in
the section has either a higher precedence than the section operator
or both operators have the same precedence and are both left
associative for a left section and right associative for a right
section, respectively.
\begin{verbatim}

> checkLSection :: PEnv -> InfixOp -> Expression -> Expression
> checkLSection pEnv op e@(UnaryMinus uop _)
>   | pr < 6 || pr == 6 && fix == InfixL = LeftSection e op
>   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op)
>   where OpPrec fix pr = opPrec op pEnv
> checkLSection pEnv op1 e@(InfixApply _ op2 _)
>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL =
>       LeftSection e op1
>   | otherwise =
>       errorAt' $ ambiguousParse "operator" (opName op1) (opName op2)
>   where OpPrec fix1 pr1 = opPrec op1 pEnv
>         OpPrec fix2 pr2 = opPrec op2 pEnv
> checkLSection _ op e = LeftSection e op

> checkRSection :: PEnv -> InfixOp -> Expression -> Expression
> checkRSection pEnv op e@(UnaryMinus uop _)
>   | pr < 6 = RightSection op e
>   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op)
>   where OpPrec _ pr = opPrec op pEnv
> checkRSection pEnv op1 e@(InfixApply _ op2 _)
>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR =
>       RightSection op1 e
>   | otherwise =
>       errorAt' $ ambiguousParse "operator" (opName op1) (opName op2)
>   where OpPrec fix1 pr1 = opPrec op1 pEnv
>         OpPrec fix2 pr2 = opPrec op2 pEnv
> checkRSection _ op e = RightSection op e

\end{verbatim}
The functions \texttt{fixPrecT} and \texttt{fixRPrecT} check the
relative precedences of adjacent infix operators in patterns. The
patterns will be reordered such that the infix operator with the
lowest precedence becomes the root of the term. \emph{The functions
rely on the fact that the parser constructs infix patterns in a
right-associative fashion}, i.e., the left argument of an infix pattern
will never be an infix pattern. The functions also check whether the
left and right arguments of an infix pattern are negative literals. In
this case, the negation must bind more tightly than the operator for
the pattern to be accepted.
\begin{verbatim}

> fixPrecT ::  PEnv
>             -> (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)
>	      -> ConstrTerm -> QualIdent -> ConstrTerm
>             -> ConstrTerm
> fixPrecT pEnv infixpatt t1@(NegativePattern uop _) op t2
>   | pr < 6 || pr == 6 && fix == InfixL
>     = fixRPrecT pEnv infixpatt t1 op t2
>   | otherwise
>     = errorAt' $ invalidParse "unary" uop op
>   where OpPrec fix pr = prec op pEnv
> fixPrecT pEnv infixpatt t1 op t2
>   = fixRPrecT pEnv infixpatt t1 op t2

> fixRPrecT :: PEnv
>              -> (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)
>              -> ConstrTerm  -> QualIdent -> ConstrTerm
>              -> ConstrTerm
> fixRPrecT pEnv infixpatt t1 op t2@(NegativePattern uop _)
>   | pr < 6    = infixpatt t1 op t2
>   | otherwise = errorAt' $ invalidParse "unary" uop op
>   where OpPrec _ pr = prec op pEnv
> fixRPrecT pEnv infixpatt t1 op1 (InfixPattern t2 op2 t3)
>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
>     = infixpatt t1 op1 (InfixPattern t2 op2 t3)
>   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
>     = InfixPattern (fixPrecT pEnv infixpatt t1 op1 t2) op2 t3
>   | otherwise
>     = errorAt' $ ambiguousParse "operator" op1 op2
>   where OpPrec fix1 pr1 = prec op1 pEnv
>         OpPrec fix2 pr2 = prec op2 pEnv
> fixRPrecT pEnv infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)
>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
>     = infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)
>   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
>     = InfixFuncPattern (fixPrecT pEnv infixpatt t1 op1 t2) op2 t3
>   | otherwise
>     = errorAt' $ ambiguousParse "operator" op1 op2
>   where OpPrec fix1 pr1 = prec op1 pEnv
>         OpPrec fix2 pr2 = prec op2 pEnv
> fixRPrecT _ infixpatt t1 op t2 = infixpatt t1 op t2

> {-fixPrecT :: Position -> PEnv -> ConstrTerm -> QualIdent -> ConstrTerm
>          -> ConstrTerm
> fixPrecT p pEnv t1@(NegativePattern uop l) op t2
>   | pr < 6 || pr == 6 && fix == InfixL = fixRPrecT p pEnv t1 op t2
>   | otherwise = errorAt p $ invalidParse "unary" uop op
>   where OpPrec fix pr = prec op pEnv
> fixPrecT p pEnv t1 op t2 = fixRPrecT p pEnv t1 op t2-}

> {-fixRPrecT :: Position -> PEnv -> ConstrTerm -> QualIdent -> ConstrTerm
>           -> ConstrTerm
> fixRPrecT p pEnv t1 op t2@(NegativePattern uop l)
>   | pr < 6 = InfixPattern t1 op t2
>   | otherwise = errorAt p $ invalidParse "unary" uop op
>   where OpPrec _ pr = prec op pEnv
> fixRPrecT p pEnv t1 op1 (InfixPattern t2 op2 t3)
>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR =
>       InfixPattern t1 op1 (InfixPattern t2 op2 t3)
>   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL =
>       InfixPattern (fixPrecT p pEnv t1 op1 t2) op2 t3
>   | otherwise = errorAt p $ ambiguousParse "operator" op1 op2
>   where OpPrec fix1 pr1 = prec op1 pEnv
>         OpPrec fix2 pr2 = prec op2 pEnv
> fixRPrecT _ _ t1 op t2 = InfixPattern t1 op t2-}

\end{verbatim}
The functions \texttt{checkOpL} and \texttt{checkOpR} check the left
and right arguments of an operator declaration. If they are infix
patterns they must bind more tightly than the operator, otherwise the
left-hand side of the declaration is invalid.
\begin{verbatim}

> checkOpL :: PEnv -> Ident -> ConstrTerm -> ConstrTerm
> checkOpL pEnv op t@(NegativePattern uop _)
>   | pr < 6 || pr == 6 && fix == InfixL = t
>   | otherwise = errorAt' $ invalidParse "unary" uop (qualify op)
>   where OpPrec fix pr = prec (qualify op) pEnv
> checkOpL pEnv op1 t@(InfixPattern _ op2 _)
>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL = t
>   | otherwise = errorAt' $ invalidParse "operator" op1 op2
>   where OpPrec fix1 pr1 = prec (qualify op1) pEnv
>         OpPrec fix2 pr2 = prec op2 pEnv
> checkOpL _ _ t = t

> checkOpR :: PEnv -> Ident -> ConstrTerm -> ConstrTerm
> checkOpR pEnv op t@(NegativePattern uop _)
>   | pr < 6 = t
>   | otherwise = errorAt' $ invalidParse "unary" uop (qualify op)
>   where OpPrec _ pr = prec (qualify op) pEnv
> checkOpR pEnv op1 t@(InfixPattern _ op2 _)
>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR = t
>   | otherwise = errorAt' $ invalidParse "operator" op1 op2
>   where OpPrec fix1 pr1 = prec (qualify op1) pEnv
>         OpPrec fix2 pr2 = prec op2 pEnv
> checkOpR _ _ t = t

\end{verbatim}
The functions \texttt{opPrec} and \texttt{prec} return the fixity and
operator precedence of an entity. Even though precedence checking is
performed after the renaming phase, we have to be prepared to see
ambiguous identifiers here. This may happen while checking the root of
an operator definition that shadows an imported definition.
\begin{verbatim}

> opPrec :: InfixOp -> PEnv -> OpPrec
> opPrec op = prec (opName op)

> prec :: QualIdent -> PEnv -> OpPrec
> prec op env =
>   case qualLookupP op env of
>     [] -> defaultP
>     PrecInfo _ p : _ -> p

\end{verbatim}
Error messages.
\begin{verbatim}

> undefinedOperator :: Ident -> (Position,String)
> undefinedOperator op =
>  (positionOfIdent op,
>   "no definition for " ++ name op ++ " in this scope")

> duplicatePrecedence :: Ident -> (Position,String)
> duplicatePrecedence op =
>  (positionOfIdent op,
>   "More than one fixity declaration for " ++ name op)

> invalidParse :: String -> Ident -> QualIdent -> (Position,String)
> invalidParse what op1 op2 =
>  (positionOfIdent op1,
>   "Invalid use of " ++ what ++ " " ++ name op1 ++ " with " ++ qualName op2 ++
>   (showLine $ positionOfQualIdent op2))

> ambiguousParse :: String -> QualIdent -> QualIdent -> (Position,String)
> ambiguousParse what op1 op2 =
>  (positionOfQualIdent op1,
>   "Ambiguous use of " ++ what ++ " " ++ qualName op1 ++
>   " with " ++ qualName op2 ++ (showLine $ positionOfQualIdent op2))

\end{verbatim}