Commit 27ac926d authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky

Declaration of operator precedences is now optional

parent c56da5ff
...@@ -4,6 +4,9 @@ Change log for curry-frontend ...@@ -4,6 +4,9 @@ Change log for curry-frontend
Under development Under development
================= =================
* Declaration of operator precedence is now optional in infix operator
declarations
* Moved module `InterfaceEquivalence` to curry-base * Moved module `InterfaceEquivalence` to curry-base
(`Curry.Syntax.InterfaceEquivalence`) (`Curry.Syntax.InterfaceEquivalence`)
......
...@@ -99,7 +99,7 @@ interfaceCheck pEnv tcEnv tyEnv (Interface m _ ds) = reverse (errors s) ...@@ -99,7 +99,7 @@ interfaceCheck pEnv tcEnv tyEnv (Interface m _ ds) = reverse (errors s)
checkImport :: IDecl -> IC () checkImport :: IDecl -> IC ()
checkImport (IInfixDecl p fix pr op) = checkPrecInfo check p op checkImport (IInfixDecl p fix pr op) = checkPrecInfo check p op
where check (PrecInfo op' (OpPrec fix' pr')) = 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) checkImport (HidingDataDecl p tc tvs)
= checkTypeInfo "hidden data type" check p tc = checkTypeInfo "hidden data type" check p tc
where check (DataType tc' n' _) where check (DataType tc' n' _)
......
...@@ -34,7 +34,7 @@ import Base.Messages (Message, posMessage) ...@@ -34,7 +34,7 @@ import Base.Messages (Message, posMessage)
import Base.Utils (findDouble) import Base.Utils (findDouble)
import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
, qualLookupP) , mkPrec, qualLookupP)
precCheck :: ModuleIdent -> OpPrecEnv -> [Decl] -> ([Decl], OpPrecEnv, [Message]) precCheck :: ModuleIdent -> OpPrecEnv -> [Decl] -> ([Decl], OpPrecEnv, [Message])
precCheck m pEnv decls = runPCM (checkDecls decls) initState precCheck m pEnv decls = runPCM (checkDecls decls) initState
...@@ -91,10 +91,10 @@ bindPrecs ds = case findDouble opFixDecls of ...@@ -91,10 +91,10 @@ bindPrecs ds = case findDouble opFixDecls of
bvs = concatMap boundValues nonFixDs bvs = concatMap boundValues nonFixDs
bindPrec :: ModuleIdent -> Decl -> OpPrecEnv -> OpPrecEnv bindPrec :: ModuleIdent -> Decl -> OpPrecEnv -> OpPrecEnv
bindPrec m (InfixDecl _ fix prc ops) pEnv bindPrec m (InfixDecl _ fix mprec ops) pEnv
| p == defaultP = pEnv | p == defaultP = pEnv
| otherwise = foldr (flip (bindP m) p) pEnv ops | otherwise = foldr (flip (bindP m) p) pEnv ops
where p = OpPrec fix prc where p = OpPrec fix (mkPrec mprec)
bindPrec _ _ pEnv = pEnv bindPrec _ _ pEnv = pEnv
boundValues :: Decl -> [Ident] boundValues :: Decl -> [Ident]
......
...@@ -382,10 +382,11 @@ checkDeclLhs (FreeDecl p vs) = ...@@ -382,10 +382,11 @@ checkDeclLhs (FreeDecl p vs) =
FreeDecl p `liftM` mapM (checkVar "free variables declaration") vs FreeDecl p `liftM` mapM (checkVar "free variables declaration") vs
checkDeclLhs d = return d checkDeclLhs d = return d
checkPrecedence :: Position -> Integer -> SCM Integer checkPrecedence :: Position -> Maybe Precedence -> SCM (Maybe Precedence)
checkPrecedence p i = do checkPrecedence _ Nothing = return Nothing
checkPrecedence p (Just i) = do
unless (0 <= i && i <= 9) $ report $ errPrecedenceOutOfRange p i unless (0 <= i && i <= 9) $ report $ errPrecedenceOutOfRange p i
return i return $ Just i
checkVar :: String -> Ident -> SCM Ident checkVar :: String -> Ident -> SCM Ident
checkVar _what v = do checkVar _what v = do
......
...@@ -24,7 +24,7 @@ ...@@ -24,7 +24,7 @@
introduction of unlimited integer constants in the parser / lexer. introduction of unlimited integer constants in the parser / lexer.
-} -}
module Env.OpPrec module Env.OpPrec
( OpPrec (..), defaultP ( OpPrec (..), defaultP, defaultAssoc, defaultPrecedence, mkPrec
, OpPrecEnv, PrecInfo (..), bindP, lookupP, qualLookupP, initOpPrecEnv , OpPrecEnv, PrecInfo (..), bindP, lookupP, qualLookupP, initOpPrecEnv
) where ) where
...@@ -33,18 +33,35 @@ import Curry.Syntax (Infix (..)) ...@@ -33,18 +33,35 @@ import Curry.Syntax (Infix (..))
import Base.TopEnv import Base.TopEnv
import Data.Maybe (fromMaybe)
-- |Operator precedence. -- |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 instance Show OpPrec where
showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p
where assoc InfixL = "left " where assoc InfixL = "left "
assoc InfixR = "right " assoc InfixR = "right "
assoc Infix = "non-assoc " assoc Infix = "non-assoc "
-- |Default operator precedence. -- |Default operator declaration (associativity and precedence).
defaultP :: OpPrec 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. -- |Precedence information for an identifier.
data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq, Show) data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq, Show)
......
...@@ -75,7 +75,7 @@ iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl] ...@@ -75,7 +75,7 @@ iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl]
iInfixDecl m pEnv op ds = case qualLookupP op pEnv of iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
[] -> ds [] -> ds
[PrecInfo _ (OpPrec fix pr)] -> [PrecInfo _ (OpPrec fix pr)] ->
IInfixDecl NoPos fix pr (qualUnqualify m op) : ds IInfixDecl NoPos fix (Just pr) (qualUnqualify m op) : ds
_ -> internalError "Exports.infixDecl" _ -> internalError "Exports.infixDecl"
typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl] typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]
......
...@@ -32,6 +32,7 @@ import Base.Types ...@@ -32,6 +32,7 @@ import Base.Types
import Env.TypeConstructor (TCEnv, lookupTC) import Env.TypeConstructor (TCEnv, lookupTC)
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue) import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
import Env.OpPrec (mkPrec)
import CompilerEnv import CompilerEnv
...@@ -207,11 +208,11 @@ genTypeExpr env (RecordType fss mr) = case mr of ...@@ -207,11 +208,11 @@ genTypeExpr env (RecordType fss mr) = case mr of
ls' = map idName ls ls' = map idName ls
genOpDecl :: AbstractEnv -> Decl -> [COpDecl] 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 where
genCOp op = COp (genQName False env $ qualifyWith (moduleId env) op) genCOp op = COp (genQName False env $ qualifyWith (moduleId env) op)
(genFixity fix) (genFixity fix)
(fromInteger prec) (fromInteger (mkPrec mprec))
genFixity InfixL = CInfixlOp genFixity InfixL = CInfixlOp
genFixity InfixR = CInfixrOp genFixity InfixR = CInfixrOp
......
...@@ -36,6 +36,7 @@ import Base.Types ...@@ -36,6 +36,7 @@ import Base.Types
-- environments -- environments
import Env.Interface import Env.Interface
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC) import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.OpPrec (mkPrec)
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue) import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
-- other -- other
...@@ -386,9 +387,9 @@ visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2) ...@@ -386,9 +387,9 @@ visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
-- --
visitOpIDecl :: CS.IDecl -> FlatState OpDecl visitOpIDecl :: CS.IDecl -> FlatState OpDecl
visitOpIDecl (CS.IInfixDecl _ fixi prec op) = do visitOpIDecl (CS.IInfixDecl _ fixi mprec op) = do
op' <- visitQualIdent op op' <- visitQualIdent op
return $ Op op' (genFixity fixi) prec return $ Op op' (genFixity fixi) (mkPrec mprec)
visitOpIDecl _ = internalError "GenFlatCurry.visitOpIDecl: no pattern match" visitOpIDecl _ = internalError "GenFlatCurry.visitOpIDecl: no pattern match"
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
...@@ -617,9 +618,9 @@ genOpDecls = fixities >>= mapM genOpDecl ...@@ -617,9 +618,9 @@ genOpDecls = fixities >>= mapM genOpDecl
-- --
genOpDecl :: CS.IDecl -> FlatState OpDecl genOpDecl :: CS.IDecl -> FlatState OpDecl
genOpDecl (CS.IInfixDecl _ fixity prec qident) = do genOpDecl (CS.IInfixDecl _ fixity mprec qident) = do
qname <- visitQualIdent qident qname <- visitQualIdent qident
return $ Op qname (genFixity fixity) prec return $ Op qname (genFixity fixity) (mkPrec mprec)
genOpDecl _ = internalError "GenFlatCurry: no infix interface" genOpDecl _ = internalError "GenFlatCurry: no infix interface"
genFixity :: CS.Infix -> Fixity genFixity :: CS.Infix -> Fixity
......
...@@ -168,8 +168,9 @@ intfEnv bind (Interface m _ ds) = foldr (bind m) Map.empty ds ...@@ -168,8 +168,9 @@ intfEnv bind (Interface m _ ds) = foldr (bind m) Map.empty ds
-- operator precedences -- operator precedences
bindPrec :: ModuleIdent -> IDecl -> ExpPEnv -> ExpPEnv bindPrec :: ModuleIdent -> IDecl -> ExpPEnv -> ExpPEnv
bindPrec m (IInfixDecl _ fix p op) = bindPrec m (IInfixDecl _ fix mprec op) =
Map.insert (unqualify op) (PrecInfo (qualQualify m op) (OpPrec fix p)) Map.insert (unqualify op) (PrecInfo (qualQualify m op)
(OpPrec fix (mkPrec mprec)))
bindPrec _ _ = id bindPrec _ _ = id
bindTCHidden :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv bindTCHidden :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment