Declaration of operator precedences is now optional

CHANGELOG.md

@@ -4,6 +4,9 @@ Change log for curry-frontend
 Under development
 =================
 
+  * Declaration of operator precedence is now optional in infix operator
+    declarations
+
   * Moved module `InterfaceEquivalence` to curry-base
     (`Curry.Syntax.InterfaceEquivalence`)
 

src/Checks/InterfaceCheck.hs

@@ -99,7 +99,7 @@ interfaceCheck pEnv tcEnv tyEnv (Interface m _ ds) = reverse (errors s)
 checkImport :: IDecl -> IC ()
 checkImport (IInfixDecl p fix pr op) = checkPrecInfo check p op
   where check (PrecInfo op' (OpPrec fix' pr')) =
-          op == op' && fix == fix' && pr == pr'
+          op == op' && fix == fix' && (mkPrec pr) == pr'
 checkImport (HidingDataDecl p tc tvs)
   = checkTypeInfo "hidden data type" check p tc
   where check (DataType     tc' n' _)

src/Checks/PrecCheck.hs

@@ -34,7 +34,7 @@ import Base.Messages (Message, posMessage)
 import Base.Utils (findDouble)
 
 import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
-  , qualLookupP)
+  , mkPrec, qualLookupP)
 
 precCheck :: ModuleIdent -> OpPrecEnv -> [Decl] -> ([Decl], OpPrecEnv, [Message])
 precCheck m pEnv decls = runPCM (checkDecls decls) initState
@@ -91,10 +91,10 @@ bindPrecs ds = case findDouble opFixDecls of
     bvs               = concatMap boundValues nonFixDs
 
 bindPrec :: ModuleIdent -> Decl -> OpPrecEnv -> OpPrecEnv
-bindPrec m (InfixDecl _ fix prc ops) pEnv
+bindPrec m (InfixDecl _ fix mprec ops) pEnv
   | p == defaultP = pEnv
   | otherwise     = foldr (flip (bindP m) p) pEnv ops
-  where p = OpPrec fix prc
+  where p = OpPrec fix (mkPrec mprec)
 bindPrec _ _                         pEnv = pEnv
 
 boundValues :: Decl -> [Ident]

src/Checks/SyntaxCheck.hs

@@ -382,10 +382,11 @@ checkDeclLhs (FreeDecl             p vs) =
   FreeDecl p `liftM` mapM (checkVar "free variables declaration") vs
 checkDeclLhs d                           = return d
 
-checkPrecedence :: Position -> Integer -> SCM Integer
-checkPrecedence p i = do
+checkPrecedence :: Position -> Maybe Precedence -> SCM (Maybe Precedence)
+checkPrecedence _ Nothing  = return Nothing
+checkPrecedence p (Just i) = do
   unless (0 <= i && i <= 9) $ report $ errPrecedenceOutOfRange p i
-  return i
+  return $ Just i
 
 checkVar :: String -> Ident -> SCM Ident
 checkVar _what v = do

src/Env/OpPrec.hs

@@ -24,7 +24,7 @@
     introduction of unlimited integer constants in the parser / lexer.
 -}
 module Env.OpPrec
-  ( OpPrec (..), defaultP
+  ( OpPrec (..), defaultP, defaultAssoc, defaultPrecedence, mkPrec
   , OpPrecEnv,  PrecInfo (..), bindP, lookupP, qualLookupP, initOpPrecEnv
   ) where
 
@@ -33,18 +33,35 @@ import Curry.Syntax     (Infix (..))
 
 import Base.TopEnv
 
+import Data.Maybe (fromMaybe)
+
 -- |Operator precedence.
-data OpPrec = OpPrec Infix Integer deriving Eq
+data OpPrec = OpPrec Infix Precedence deriving Eq
+
+type Precedence = Integer
 
+-- TODO: Change to real show instance and provide Pretty instance
+-- if used anywhere.
 instance Show OpPrec where
   showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p
     where assoc InfixL = "left "
           assoc InfixR = "right "
           assoc Infix  = "non-assoc "
 
--- |Default operator precedence.
+-- |Default operator declaration (associativity and precedence).
 defaultP :: OpPrec
-defaultP = OpPrec InfixL 9
+defaultP = OpPrec defaultAssoc defaultPrecedence
+
+-- |Default operator associativity.
+defaultAssoc :: Infix
+defaultAssoc = InfixL
+
+-- |Default operator precedence.
+defaultPrecedence :: Precedence
+defaultPrecedence = 9
+
+mkPrec :: Maybe Precedence -> Precedence
+mkPrec mprec = fromMaybe defaultPrecedence mprec
 
 -- |Precedence information for an identifier.
 data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq, Show)

src/Exports.hs

@@ -75,7 +75,7 @@ iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl]
 iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
   []                           -> ds
   [PrecInfo _ (OpPrec fix pr)] ->
-    IInfixDecl NoPos fix pr (qualUnqualify m op) : ds
+    IInfixDecl NoPos fix (Just pr) (qualUnqualify m op) : ds
   _                            -> internalError "Exports.infixDecl"
 
 typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]

src/Generators/GenAbstractCurry.hs

@@ -32,6 +32,7 @@ import Base.Types
 
 import Env.TypeConstructor (TCEnv, lookupTC)
 import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
+import Env.OpPrec (mkPrec)
 
 import CompilerEnv
 
@@ -207,11 +208,11 @@ genTypeExpr env (RecordType fss mr) = case mr of
   ls'        = map idName ls
 
 genOpDecl :: AbstractEnv -> Decl -> [COpDecl]
-genOpDecl env (InfixDecl _ fix prec ops) = map genCOp (reverse ops)
+genOpDecl env (InfixDecl _ fix mprec ops) = map genCOp (reverse ops)
   where
   genCOp op = COp (genQName False env $ qualifyWith (moduleId env) op)
                   (genFixity fix)
-                  (fromInteger prec)
+                  (fromInteger (mkPrec mprec))
 
   genFixity InfixL = CInfixlOp
   genFixity InfixR = CInfixrOp

src/Generators/GenFlatCurry.hs

@@ -36,6 +36,7 @@ import Base.Types
  -- environments
 import Env.Interface
 import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
+import Env.OpPrec (mkPrec)
 import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
 
 -- other
@@ -386,9 +387,9 @@ visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
 
 --
 visitOpIDecl :: CS.IDecl -> FlatState OpDecl
-visitOpIDecl (CS.IInfixDecl _ fixi prec op) = do
+visitOpIDecl (CS.IInfixDecl _ fixi mprec op) = do
   op' <- visitQualIdent op
-  return $ Op op' (genFixity fixi) prec
+  return $ Op op' (genFixity fixi) (mkPrec mprec)
 visitOpIDecl _ = internalError "GenFlatCurry.visitOpIDecl: no pattern match"
 
 -------------------------------------------------------------------------------
@@ -617,9 +618,9 @@ genOpDecls = fixities >>= mapM genOpDecl
 
 --
 genOpDecl :: CS.IDecl -> FlatState OpDecl
-genOpDecl (CS.IInfixDecl _ fixity prec qident) = do
+genOpDecl (CS.IInfixDecl _ fixity mprec qident) = do
   qname <- visitQualIdent qident
-  return $ Op qname (genFixity fixity) prec
+  return $ Op qname (genFixity fixity) (mkPrec mprec)
 genOpDecl _ = internalError "GenFlatCurry: no infix interface"
 
 genFixity :: CS.Infix -> Fixity

src/Imports.hs

@@ -168,8 +168,9 @@ intfEnv bind (Interface m _ ds) = foldr (bind m) Map.empty ds
 
 -- operator precedences
 bindPrec :: ModuleIdent -> IDecl -> ExpPEnv -> ExpPEnv
-bindPrec m (IInfixDecl _ fix p op) =
-  Map.insert (unqualify op) (PrecInfo (qualQualify m op) (OpPrec fix p))
+bindPrec m (IInfixDecl _ fix mprec op) =
+  Map.insert (unqualify op) (PrecInfo (qualQualify m op)
+                                      (OpPrec fix (mkPrec mprec)))
 bindPrec _ _ = id
 
 bindTCHidden :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv