diff options
Diffstat (limited to 'compiler/parser')
| -rw-r--r-- | compiler/parser/Parser.y | 6 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 20 |
2 files changed, 18 insertions, 8 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 25eb008895..74db997bbb 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -998,7 +998,7 @@ impspec :: { Located (Bool, Located [LIE GhcPs]) } prec :: { Located (SourceText,Int) } : {- empty -} { noLoc (NoSourceText,9) } | INTEGER - {% checkPrecP (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) } + { sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1))) } infix :: { Located FixityDirection } : 'infix' { sL1 $1 InfixN } @@ -2378,7 +2378,8 @@ sigdecl :: { LHsDecl GhcPs } [mu AnnDcolon $4] } } | infix prec ops - {% ams (sLL $1 $> $ SigD noExt + {% checkPrecP $2 $3 >> + ams (sLL $1 $> $ SigD noExt (FixSig noExt (FixitySig noExt (fromOL $ unLoc $3) (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) [mj AnnInfix $1,mj AnnVal $2] } @@ -3243,6 +3244,7 @@ op :: { Located RdrName } -- used in infix decls : varop { $1 } | conop { $1 } | '->' { sL1 $1 $ getRdrName funTyCon } + | '~' { sL1 $1 $ eqTyCon_RDR } varop :: { Located RdrName } : varsym { $1 } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 91fcb0d3fd..1015319986 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -87,7 +87,7 @@ import BasicTypes import TcEvidence ( idHsWrapper ) import Lexer import Lexeme ( isLexCon ) -import Type ( TyThing(..) ) +import Type ( TyThing(..), funTyCon ) import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, listTyConName, listTyConKey, eqTyCon_RDR, @@ -1756,11 +1756,19 @@ cmdStmtFail loc e = parseErrorSDoc loc --------------------------------------------------------------------------- -- Miscellaneous utilities -checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int)) -checkPrecP (L l (src,i)) - | 0 <= i && i <= maxPrecedence = return (L l (src,i)) - | otherwise - = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) +-- | Check if a fixity is valid. We support bypassing the usual bound checks +-- for some special operators. +checkPrecP + :: Located (SourceText,Int) -- ^ precedence + -> Located (OrdList (Located RdrName)) -- ^ operators + -> P () +checkPrecP (L l (_,i)) (L _ ol) + | 0 <= i, i <= maxPrecedence = pure () + | all specialOp ol = pure () + | otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) + where + specialOp op = unLoc op `elem` [ eqTyCon_RDR + , getRdrName funTyCon ] mkRecConstrOrUpdate :: LHsExpr GhcPs |