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
Under development
=================
* Declaration of operator precedence is now optional in infix operator
declarations
* Moved module `InterfaceEquivalence` to curry-base
(`Curry.Syntax.InterfaceEquivalence`)
......
......@@ -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' _)
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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