PrecCheck.lhs 21.2 KB
Newer Older
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1
2
3
4
5
6
% $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)
Björn Peemöller 's avatar
Björn Peemöller committed
7
% Modified by Björn Peemöller (bjp@informatik.uni-kiel.de)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
8
9
10
11
12
13
14
15
16
17
18
%
\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}

Björn Peemöller 's avatar
Björn Peemöller committed
19
> module Checks.PrecCheck (precCheck) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
20

Björn Peemöller 's avatar
Björn Peemöller committed
21
22
23
> import Control.Monad (liftM, liftM2, liftM3, unless, when)
> import qualified Control.Monad.State as S (State, runState, gets, modify)
> import Data.List (partition)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
24
25
26
27
28

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

29
> import Base.Expr
Björn Peemöller 's avatar
Björn Peemöller committed
30
> import Base.Messages (Message, toMessage)
Björn Peemöller 's avatar
Björn Peemöller committed
31
32
33
> import Base.Utils (findDouble)

> import Env.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP, qualLookupP)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
34

Björn Peemöller 's avatar
Björn Peemöller committed
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
> precCheck :: ModuleIdent -> PEnv -> [Decl] -> ([Decl], PEnv, [Message])
> precCheck m pEnv decls = runPCM (checkDecls decls) initState
>  where initState = PCState m pEnv []

\end{verbatim}
The Prec check monad.
\begin{verbatim}

> data PCState = PCState
>   { moduleIdent :: ModuleIdent
>   , precEnv     :: PEnv
>   , errors      :: [Message]
>   }

> type PCM = S.State PCState -- the Prec Check Monad

> runPCM :: PCM a -> PCState -> (a, PEnv, [Message])
> runPCM kcm s = let (a, s') = S.runState kcm s
>                in  (a, precEnv s', reverse $ errors s')

> getModuleIdent :: PCM ModuleIdent
> getModuleIdent = S.gets moduleIdent

> getPrecEnv :: PCM PEnv
> getPrecEnv = S.gets precEnv

> withPrecEnv :: (PEnv -> PEnv) -> PCM ()
> withPrecEnv f = S.modify $ \ s -> s { precEnv = f $ precEnv s }

> withLocalPrecEnv :: PCM a -> PCM a
> withLocalPrecEnv act = do
>   oldEnv <- getPrecEnv
>   res <- act
>   withPrecEnv $ const oldEnv
>   return res

> report :: Message -> PCM ()
> report err = S.modify (\ s -> s { errors = err : errors s })

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
74
75
76
77
78
79
80
81
\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}

Björn Peemöller 's avatar
Björn Peemöller committed
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
> bindPrecs :: [Decl] -> PCM ()
> bindPrecs ds = case findDouble opFixDecls of
>   Just op -> report $ errDuplicatePrecedence op
>   Nothing -> case filter (`notElem` bvs) opFixDecls of
>     op : _ -> report $  errUndefinedOperator op
>     []     -> do
>       m <- getModuleIdent
>       withPrecEnv $ \ env -> foldr (bindPrec m) env fixDs
>   where
>     (fixDs, nonFixDs) = partition isInfixDecl ds
>     opFixDecls        = [ op | InfixDecl _ _ _ ops <- fixDs, op <- ops]
>     bvs               = concatMap boundValues nonFixDs

> bindPrec :: ModuleIdent -> Decl -> PEnv -> PEnv
> bindPrec m (InfixDecl _ fix prc ops) pEnv
>   | p == defaultP = pEnv
>   | otherwise     = foldr (flip (bindP m) p) pEnv ops
>   where p = OpPrec fix prc
> bindPrec _ _ pEnv = pEnv
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
101
102

> boundValues :: Decl -> [Ident]
Björn Peemöller 's avatar
Björn Peemöller committed
103
> boundValues (DataDecl      _ _ _ cs) = map constr cs
104
105
>   where constr (ConstrDecl _ _   c  _) = c
>         constr (ConOpDecl  _ _ _ op _) = op
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
106
> boundValues (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
Björn Peemöller 's avatar
Björn Peemöller committed
107
> boundValues (FunctionDecl     _ f _) = [f]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
108
> boundValues (ExternalDecl _ _ _ f _) = [f]
Björn Peemöller 's avatar
Björn Peemöller committed
109
110
111
112
> boundValues (FlatExternalDecl  _ fs) = fs
> boundValues (PatternDecl      _ t _) = bv t
> boundValues (ExtraVariables    _ vs) = vs
> boundValues _                        = []
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
113
114
115
116
117
118
119
120
121
122
123
124

\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}

Björn Peemöller 's avatar
Björn Peemöller committed
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
> checkDecls :: [Decl] -> PCM [Decl]
> checkDecls decls = bindPrecs decls >> mapM checkDecl decls

> checkDecl :: Decl -> PCM Decl
> checkDecl (FunctionDecl p f eqs) =
>   FunctionDecl p f `liftM` mapM checkEquation eqs
> checkDecl (PatternDecl p  t rhs) =
>   liftM2 (PatternDecl p) (checkConstrTerm t) (checkRhs rhs)
> checkDecl d                      = return d

> checkEquation :: Equation -> PCM Equation
> checkEquation (Equation p lhs rhs) =
>   liftM2 (Equation p) (checkLhs lhs) (checkRhs rhs)

> checkLhs :: Lhs -> PCM Lhs
> checkLhs (FunLhs f ts) = FunLhs f `liftM` mapM checkConstrTerm ts
> checkLhs (OpLhs t1 op t2) =
>   liftM2 (\u1 u2 -> OpLhs u1 op u2) t1' t2'
>   where t1' = (checkConstrTerm t1 >>= checkOpL op)
>         t2' = (checkConstrTerm t2 >>= checkOpR op)
> checkLhs (ApLhs lhs ts) =
>   liftM2 ApLhs (checkLhs lhs) (mapM checkConstrTerm ts)

> checkConstrTerm :: ConstrTerm -> PCM ConstrTerm
> checkConstrTerm l@(LiteralPattern      _) = return l
> checkConstrTerm n@(NegativePattern   _ _) = return n
> checkConstrTerm v@(VariablePattern     _) = return v
> checkConstrTerm (ConstructorPattern c ts) =
>   ConstructorPattern c `liftM` mapM checkConstrTerm ts
> checkConstrTerm (InfixPattern   t1 op t2) = do
>   t1' <- checkConstrTerm t1
>   t2' <- checkConstrTerm t2
>   fixPrecT InfixPattern t1' op t2'
> checkConstrTerm (ParenPattern          t) =
>   ParenPattern `liftM` checkConstrTerm t
> checkConstrTerm (TuplePattern       p ts) =
>   TuplePattern p `liftM` mapM checkConstrTerm ts
> checkConstrTerm (ListPattern        p ts) =
>   ListPattern p `liftM` mapM checkConstrTerm ts
> checkConstrTerm (AsPattern           v t) =
>   AsPattern v `liftM` checkConstrTerm t
> checkConstrTerm (LazyPattern         p t) =
>   LazyPattern p `liftM` checkConstrTerm t
> checkConstrTerm (FunctionPattern    f ts) =
>   FunctionPattern f `liftM` mapM checkConstrTerm ts
> checkConstrTerm (InfixFuncPattern t1 op t2) = do
>   t1' <- checkConstrTerm t1
>   t2' <- checkConstrTerm t2
>   fixPrecT InfixFuncPattern t1' op t2'
> checkConstrTerm (RecordPattern       fs r) =
>   liftM2 RecordPattern (mapM checkFieldPattern fs) $
>     case r of
>       Nothing -> return Nothing
>       Just r' -> Just `fmap` checkConstrTerm r'

> checkFieldPattern :: Field ConstrTerm -> PCM (Field ConstrTerm)
> checkFieldPattern (Field p l e) = Field p l `liftM` checkConstrTerm e

> checkRhs :: Rhs -> PCM Rhs
> checkRhs (SimpleRhs p e ds) = withLocalPrecEnv $
>   liftM2 (flip (SimpleRhs p)) (checkDecls ds) (checkExpr e)
> checkRhs (GuardedRhs es ds) = withLocalPrecEnv $
>   liftM2 (flip GuardedRhs) (checkDecls ds) (mapM checkCondExpr es)

> checkCondExpr :: CondExpr -> PCM CondExpr
> checkCondExpr (CondExpr p g e) =
>   liftM2 (CondExpr p) (checkExpr g) (checkExpr e)

> checkExpr :: Expression -> PCM Expression
> checkExpr l@(Literal     _) = return l
> checkExpr v@(Variable    _) = return v
> checkExpr c@(Constructor _) = return c
> checkExpr (Paren    e) = Paren `liftM` checkExpr e
> checkExpr (Typed e ty) = flip Typed ty `liftM` checkExpr e
> checkExpr (Tuple p es) = Tuple p `liftM` mapM checkExpr es
> checkExpr (List  p es) = List  p `liftM` mapM checkExpr es
> checkExpr (ListCompr p e qs) = withLocalPrecEnv $
>   liftM2 (flip (ListCompr p)) (mapM checkStmt qs) (checkExpr e)
> checkExpr (EnumFrom              e) = EnumFrom `liftM` checkExpr e
> checkExpr (EnumFromThen      e1 e2) =
>   liftM2 EnumFromThen (checkExpr e1) (checkExpr e2)
> checkExpr (EnumFromTo        e1 e2) =
>   liftM2 EnumFromTo (checkExpr e1) (checkExpr e2)
> checkExpr (EnumFromThenTo e1 e2 e3) =
>   liftM3 EnumFromThenTo (checkExpr e1) (checkExpr e2) (checkExpr e3)
> checkExpr (UnaryMinus         op e) = UnaryMinus op `liftM` (checkExpr e)
> checkExpr (Apply e1 e2) =
>   liftM2 Apply (checkExpr e1) (checkExpr e2)
> checkExpr (InfixApply e1 op e2) = do
>   e1' <- checkExpr e1
>   e2' <- checkExpr e2
>   fixPrec e1' op e2'
> checkExpr (LeftSection      e op) = checkExpr e >>= checkLSection op
> checkExpr (RightSection     op e) = checkExpr e >>= checkRSection op
> checkExpr (Lambda         r ts e) =
>   liftM2 (Lambda r) (mapM checkConstrTerm ts) (checkExpr e)
> checkExpr (Let              ds e) = withLocalPrecEnv $
>   liftM2 Let (checkDecls ds) (checkExpr e)
> checkExpr (Do              sts e) = withLocalPrecEnv $
>   liftM2 Do  (mapM checkStmt sts) (checkExpr e)
> checkExpr (IfThenElse r e1 e2 e3) =
>   liftM3 (IfThenElse r) (checkExpr e1) (checkExpr e2) (checkExpr e3)
> checkExpr (Case         r e alts) =
>   liftM2 (Case r) (checkExpr e) (mapM checkAlt alts)
> checkExpr (RecordConstr       fs) =
>   RecordConstr `liftM` mapM checkFieldExpr fs
> checkExpr (RecordSelection   e l) =
>   flip RecordSelection l `liftM` checkExpr e
> checkExpr (RecordUpdate     fs e) =
>   liftM2 RecordUpdate (mapM checkFieldExpr fs) (checkExpr e)

> checkFieldExpr :: Field Expression -> PCM (Field Expression)
> checkFieldExpr (Field p l e) = Field p l `liftM` checkExpr e

> checkStmt :: Statement -> PCM Statement
> checkStmt (StmtExpr   p e) = StmtExpr p `liftM` checkExpr e
> checkStmt (StmtDecl    ds) = StmtDecl `liftM` checkDecls ds
> checkStmt (StmtBind p t e) =
>   liftM2 (StmtBind p) (checkConstrTerm t) (checkExpr e)

> checkAlt :: Alt -> PCM Alt
> checkAlt (Alt p t rhs) = liftM2 (Alt p) (checkConstrTerm t) (checkRhs rhs)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269

\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}

Björn Peemöller 's avatar
Björn Peemöller committed
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
> fixPrec :: Expression -> InfixOp -> Expression -> PCM Expression
> fixPrec (UnaryMinus uop e1) op e2 = do
>   OpPrec fix pr <- getOpPrec op
>   if pr < 6 || pr == 6 && fix == InfixL
>     then fixRPrec (UnaryMinus uop e1) op e2
>     else if pr > 6
>       then fixUPrec uop e1 op e2
>       else do
>         report $ errAmbiguousParse "unary" (qualify uop) (opName op)
>         return $ InfixApply (UnaryMinus uop e1) op e2
> fixPrec e1 op e2 = fixRPrec e1 op e2

> fixUPrec :: Ident -> Expression -> InfixOp -> Expression -> PCM Expression
> fixUPrec uop e1 op e2@(UnaryMinus _ _) = do
>   report $ errAmbiguousParse "operator" (opName op) (qualify uop)
>   return $ UnaryMinus uop (InfixApply e1 op e2)
> fixUPrec uop e1 op1 e'@(InfixApply e2 op2 e3) = do
>   OpPrec fix2 pr2 <- getOpPrec op2
>   if pr2 < 6 || pr2 == 6 && fix2 == InfixL
>     then do
>       left <- fixUPrec uop e1 op1 e2
>       return $ InfixApply left op2 e3
>     else if pr2 > 6
>       then do
>         op <- fixRPrec e1 op1 $ InfixApply e2 op2 e3
>         return $ UnaryMinus uop op
>       else do
>         report $ errAmbiguousParse "unary" (qualify uop) (opName op2)
>         return $ InfixApply (UnaryMinus uop e1) op1 e'
> fixUPrec uop e1 op e2 = return $ UnaryMinus uop (InfixApply e1 op e2)

> fixRPrec :: Expression -> InfixOp -> Expression -> PCM Expression
> fixRPrec e1 op (UnaryMinus uop e2) = do
>   OpPrec _ pr <- getOpPrec op
>   unless (pr < 6) $ report $ errAmbiguousParse "operator" (opName op) (qualify uop)
>   return $ InfixApply e1 op $ UnaryMinus uop e2
> fixRPrec e1 op1 (InfixApply e2 op2 e3) = do
>   OpPrec fix1 pr1 <- getOpPrec op1
>   OpPrec fix2 pr2 <- getOpPrec op2
>   if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
>      then return $ InfixApply e1 op1 $ InfixApply e2 op2 e3
>      else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
>        then do
>           left <- fixPrec e1 op1 e2
>           return $ InfixApply left op2 e3
>        else do
>          report $ errAmbiguousParse "operator" (opName op1) (opName op2)
>          return $ InfixApply e1 op1 $ InfixApply e2 op2 e3
> fixRPrec e1 op e2 = return $ InfixApply e1 op e2
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
319
320
321
322
323
324
325
326
327
328
329

\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}

Björn Peemöller 's avatar
Björn Peemöller committed
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
> checkLSection :: InfixOp -> Expression -> PCM Expression
> checkLSection op e@(UnaryMinus uop _) = do
>   OpPrec fix pr <- getOpPrec op
>   unless (pr < 6 || pr == 6 && fix == InfixL) $
>     report $ errAmbiguousParse "unary" (qualify uop) (opName op)
>   return $ LeftSection e op
> checkLSection op1 e@(InfixApply _ op2 _) = do
>   OpPrec fix1 pr1 <- getOpPrec op1
>   OpPrec fix2 pr2 <- getOpPrec op2
>   unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL) $
>     report $ errAmbiguousParse "operator" (opName op1) (opName op2)
>   return $ LeftSection e op1
> checkLSection op e = return $ LeftSection e op

> checkRSection :: InfixOp -> Expression -> PCM Expression
> checkRSection op e@(UnaryMinus uop _) = do
>   OpPrec _ pr <- getOpPrec op
>   unless (pr < 6) $ report $ errAmbiguousParse "unary" (qualify uop) (opName op)
>   return $ RightSection op e
> checkRSection op1 e@(InfixApply _ op2 _) = do
>   OpPrec fix1 pr1 <- getOpPrec op1
>   OpPrec fix2 pr2 <- getOpPrec op2
>   unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR) $
>     report $ errAmbiguousParse "operator" (opName op1) (opName op2)
>   return $ RightSection op1 e
> checkRSection op e = return $ RightSection op e
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
356
357
358
359
360
361
362
363
364
365
366
367
368
369

\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}

Björn Peemöller 's avatar
Björn Peemöller committed
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
> fixPrecT :: (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)
>          -> ConstrTerm -> QualIdent -> ConstrTerm -> PCM ConstrTerm
> fixPrecT infixpatt t1@(NegativePattern uop _) op t2 = do
>   OpPrec fix pr <- prec op `liftM` getPrecEnv
>   unless (pr < 6 || pr == 6 && fix == InfixL) $
>     report $ errInvalidParse "unary" uop op
>   fixRPrecT infixpatt t1 op t2
> fixPrecT infixpatt t1 op t2 = fixRPrecT infixpatt t1 op t2

> fixRPrecT :: (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)
>           -> ConstrTerm  -> QualIdent -> ConstrTerm -> PCM ConstrTerm
> fixRPrecT infixpatt t1 op t2@(NegativePattern uop _) = do
>   OpPrec _ pr <- prec op `liftM` getPrecEnv
>   unless (pr < 6) $ report $ errInvalidParse "unary" uop op
>   return $ infixpatt t1 op t2
> fixRPrecT infixpatt t1 op1 (InfixPattern t2 op2 t3) = do
>   OpPrec fix1 pr1 <- prec op1 `liftM` getPrecEnv
>   OpPrec fix2 pr2 <- prec op2 `liftM` getPrecEnv
>   if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
>     then return $ infixpatt t1 op1 (InfixPattern t2 op2 t3)
>     else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
>       then do
>         left <- fixPrecT infixpatt t1 op1 t2
>         return $ InfixPattern left op2 t3
>       else do
>         report $ errAmbiguousParse "operator" op1 op2
>         return $ infixpatt t1 op1 (InfixPattern t2 op2 t3)
> fixRPrecT infixpatt t1 op1 (InfixFuncPattern t2 op2 t3) = do
>   OpPrec fix1 pr1 <- prec op1 `liftM` getPrecEnv
>   OpPrec fix2 pr2 <- prec op2 `liftM` getPrecEnv
>   if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
>     then return $ infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)
>     else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
>       then do
>         left <- fixPrecT infixpatt t1 op1 t2
>         return $ InfixFuncPattern left op2 t3
>       else do
>         report $ errAmbiguousParse "operator" op1 op2
>         return $ infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)
> fixRPrecT infixpatt t1 op t2 = return $ infixpatt t1 op t2
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
410
411
412
413
414

> {-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
Björn Peemöller 's avatar
Björn Peemöller committed
415
>   | otherwise = errorAt p $ errInvalidParse "unary" uop op
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
416
417
418
419
420
421
422
>   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
Björn Peemöller 's avatar
Björn Peemöller committed
423
>   | otherwise = errorAt p $ errInvalidParse "unary" uop op
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
424
425
426
427
428
429
>   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
Björn Peemöller 's avatar
Björn Peemöller committed
430
>   | otherwise = errorAt p $ errAmbiguousParse "operator" op1 op2
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
431
432
433
434
435
436
437
438
439
440
441
>   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}

Björn Peemöller 's avatar
Björn Peemöller committed
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
> checkOpL :: Ident -> ConstrTerm -> PCM ConstrTerm
> checkOpL op t@(NegativePattern uop _) = do
>   OpPrec fix pr <- prec (qualify op) `liftM` getPrecEnv
>   unless (pr < 6 || pr == 6 && fix == InfixL) $
>     report $ errInvalidParse "unary" uop (qualify op)
>   return t
> checkOpL op1 t@(InfixPattern _ op2 _) = do
>   OpPrec fix1 pr1 <- prec (qualify op1) `liftM` getPrecEnv
>   OpPrec fix2 pr2 <- prec op2 `liftM` getPrecEnv
>   unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL) $
>     report $ errInvalidParse "operator" op1 op2
>   return t
> checkOpL _ t = return t

> checkOpR :: Ident -> ConstrTerm -> PCM ConstrTerm
> checkOpR op t@(NegativePattern uop _) = do
>   OpPrec _ pr <- prec (qualify op)  `liftM` getPrecEnv
>   when (pr >= 6) $ report $ errInvalidParse "unary" uop (qualify op)
>   return t
> checkOpR op1 t@(InfixPattern _ op2 _) = do
>   OpPrec fix1 pr1 <- prec (qualify op1)  `liftM` getPrecEnv
>   OpPrec fix2 pr2 <- prec op2  `liftM` getPrecEnv
>   unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR) $
>     report $ errInvalidParse "operator" op1 op2
>   return t
> checkOpR _ t = return t
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
468
469
470
471
472
473
474
475
476

\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}

Björn Peemöller 's avatar
Björn Peemöller committed
477
478
479
> getOpPrec :: InfixOp -> PCM OpPrec
> getOpPrec op = opPrec op `liftM` getPrecEnv

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
480
481
482
483
> opPrec :: InfixOp -> PEnv -> OpPrec
> opPrec op = prec (opName op)

> prec :: QualIdent -> PEnv -> OpPrec
484
485
486
> prec op env = case qualLookupP op env of
>   [] -> defaultP
>   PrecInfo _ p : _ -> p
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
487
488
489
490
491

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

Björn Peemöller 's avatar
Björn Peemöller committed
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
> errUndefinedOperator :: Ident -> Message
> errUndefinedOperator op = posErr op $
>   "no definition for " ++ name op ++ " in this scope"

> errDuplicatePrecedence :: Ident -> Message
> errDuplicatePrecedence op = posErr op $
>   "More than one fixity declaration for " ++ name op

> errInvalidParse :: String -> Ident -> QualIdent -> Message
> errInvalidParse what op1 op2 = posErr op1 $
>   "Invalid use of " ++ what ++ " " ++ name op1
>   ++ " with " ++ qualName op2 ++ (showLine $ positionOfQualIdent op2)

> errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message
> errAmbiguousParse what op1 op2 = toMessage (positionOfQualIdent op1) $
>   "Ambiguous use of " ++ what ++ " " ++ qualName op1
>   ++ " with " ++ qualName op2 ++ (showLine $ positionOfQualIdent op2)

> posErr :: Ident -> String -> Message
> posErr i msg = toMessage (positionOfIdent i) msg
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
512
513

\end{verbatim}