PrecCheck.hs 20.3 KB
Newer Older
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
{- |
    Module      :  $Header$
    Description :  Checks precedences of infix operators
    Copyright   :  (c) 2001 - 2004 Wolfgang Lux
                                   Martin Engelke
                                   Björn Peemöller
    License     :  OtherLicense

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

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

module Checks.PrecCheck (precCheck) where

import           Control.Monad            (liftM, liftM2, liftM3, unless, when)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import           Data.List                (partition)

import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Syntax

import Base.Expr
import Base.Messages (Message, posMessage)
import Base.Utils (findDouble)

import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
37
  , mkPrec, qualLookupP)
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

precCheck :: ModuleIdent -> OpPrecEnv -> [Decl] -> ([Decl], OpPrecEnv, [Message])
precCheck m pEnv decls = runPCM (checkDecls decls) initState
 where initState = PCState m pEnv []

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

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

runPCM :: PCM a -> PCState -> (a, OpPrecEnv, [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 OpPrecEnv
getPrecEnv = S.gets precEnv

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

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

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

-- 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.

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
      modifyPrecEnv $ \ 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 -> OpPrecEnv -> OpPrecEnv
94
bindPrec m (InfixDecl _ fix mprec ops) pEnv
95 96
  | p == defaultP = pEnv
  | otherwise     = foldr (flip (bindP m) p) pEnv ops
97 98
  where p = OpPrec fix (mkPrec mprec)
bindPrec _ _                         pEnv = pEnv
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 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490

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 (ForeignDecl  _ _ _ f _) = [f]
boundValues (ExternalDecl      _ fs) = fs
boundValues (PatternDecl      _ t _) = bv t
boundValues (FreeDecl          _ vs) = vs
boundValues _                        = []

-- 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.

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) (checkPattern 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 checkPattern ts
checkLhs (OpLhs t1 op t2) =
  liftM2 (flip OpLhs op) (checkPattern t1 >>= checkOpL op)
                         (checkPattern t2 >>= checkOpR op)
checkLhs (ApLhs   lhs ts) =
  liftM2 ApLhs (checkLhs lhs) (mapM checkPattern ts)

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

checkFieldPattern :: Field Pattern -> PCM (Field Pattern)
checkFieldPattern (Field p l e) = Field p l `liftM` checkPattern 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 checkPattern 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 ct e alts) =
  liftM2 (Case r ct) (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) (checkPattern t) (checkExpr e)

checkAlt :: Alt -> PCM Alt
checkAlt (Alt p t rhs) = liftM2 (Alt p) (checkPattern t) (checkRhs rhs)

-- The functions 'fixPrec', 'fixUPrec', and '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. 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 '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
-- 'fixUPrec'. In any case, the function '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 'fixPrec'
-- is called.

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

-- The functions 'checkLSection' and '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.

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

-- The functions 'fixPrecT' and '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. 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.

fixPrecT :: (Pattern -> QualIdent -> Pattern -> Pattern)
         -> Pattern -> QualIdent -> Pattern -> PCM Pattern
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 :: (Pattern -> QualIdent -> Pattern -> Pattern)
          -> Pattern  -> QualIdent -> Pattern -> PCM Pattern
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

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

{-fixRPrecT :: Position -> OpPrecEnv -> Pattern -> QualIdent -> Pattern
          -> Pattern
fixRPrecT p pEnv t1 op t2@(NegativePattern uop l)
  | pr < 6 = InfixPattern t1 op t2
  | otherwise = errorAt p $ errInvalidParse "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 $ errAmbiguousParse "operator" op1 op2
  where OpPrec fix1 pr1 = prec op1 pEnv
        OpPrec fix2 pr2 = prec op2 pEnv
fixRPrecT _ _ t1 op t2 = InfixPattern t1 op t2-}

-- The functions 'checkOpL' and '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.

checkOpL :: Ident -> Pattern -> PCM Pattern
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 -> Pattern -> PCM Pattern
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

-- The functions 'opPrec' and '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.

getOpPrec :: InfixOp -> PCM OpPrec
getOpPrec op = opPrec op `liftM` getPrecEnv

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

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

-- ---------------------------------------------------------------------------
-- Error messages
-- ---------------------------------------------------------------------------

errUndefinedOperator :: Ident -> Message
errUndefinedOperator op = posMessage op $ hsep $ map text
  ["No definition for", idName op, "in this scope"]

errDuplicatePrecedence :: Ident -> Message
errDuplicatePrecedence op = posMessage op $ hsep $ map text
  ["More than one fixity declaration for", idName op]

errInvalidParse :: String -> Ident -> QualIdent -> Message
errInvalidParse what op1 op2 = posMessage op1 $ hsep $ map text
  [ "Invalid use of", what, idName op1, "with", qualName op2
  , showLine $ qidPosition op2]

errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message
errAmbiguousParse what op1 op2 = posMessage op1 $ hsep $ map text
  ["Ambiguous use of", what, qualName op1, "with", qualName op2
  , showLine $ qidPosition op2]