From 27ac926d66f0eac4465c4eed52804463f7e01703 Mon Sep 17 00:00:00 2001 From: Jan Tikovsky Date: Thu, 7 Aug 2014 13:28:44 +0200 Subject: [PATCH] Declaration of operator precedences is now optional --- CHANGELOG.md | 3 +++ src/Checks/InterfaceCheck.hs | 2 +- src/Checks/PrecCheck.hs | 8 ++++---- src/Checks/SyntaxCheck.hs | 7 ++++--- src/Env/OpPrec.hs | 25 +++++++++++++++++++++---- src/Exports.hs | 2 +- src/Generators/GenAbstractCurry.hs | 5 +++-- src/Generators/GenFlatCurry.hs | 9 +++++---- src/Imports.hs | 5 +++-- 9 files changed, 45 insertions(+), 21 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2fd84069..f45deb0d 100644 --- a/CHANGELOG.md +++ b/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`) diff --git a/src/Checks/InterfaceCheck.hs b/src/Checks/InterfaceCheck.hs index ef2d90c1..a3b289db 100644 --- a/src/Checks/InterfaceCheck.hs +++ b/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' _) diff --git a/src/Checks/PrecCheck.hs b/src/Checks/PrecCheck.hs index a6a1126a..f0198bdd 100644 --- a/src/Checks/PrecCheck.hs +++ b/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,11 +91,11 @@ 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 -bindPrec _ _ pEnv = pEnv + where p = OpPrec fix (mkPrec mprec) +bindPrec _ _ pEnv = pEnv boundValues :: Decl -> [Ident] boundValues (DataDecl _ _ _ cs) = map constr cs diff --git a/src/Checks/SyntaxCheck.hs b/src/Checks/SyntaxCheck.hs index c320c322..46ea0604 100644 --- a/src/Checks/SyntaxCheck.hs +++ b/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 diff --git a/src/Env/OpPrec.hs b/src/Env/OpPrec.hs index 00eb6e56..e6c2489e 100644 --- a/src/Env/OpPrec.hs +++ b/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) diff --git a/src/Exports.hs b/src/Exports.hs index 37fe55ab..fb1b6838 100644 --- a/src/Exports.hs +++ b/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] diff --git a/src/Generators/GenAbstractCurry.hs b/src/Generators/GenAbstractCurry.hs index 5d6741a7..57a44cca 100644 --- a/src/Generators/GenAbstractCurry.hs +++ b/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 diff --git a/src/Generators/GenFlatCurry.hs b/src/Generators/GenFlatCurry.hs index 8c240133..45e695b8 100644 --- a/src/Generators/GenFlatCurry.hs +++ b/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 diff --git a/src/Imports.hs b/src/Imports.hs index 001847ba..613df4ba 100644 --- a/src/Imports.hs +++ b/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 -- GitLab