From d8097b6e0641c7046114e3475f64a4969a013efd Mon Sep 17 00:00:00 2001 From: rodrigogribeiro Date: Fri, 31 Jul 2026 13:33:24 -0300 Subject: [PATCH 1/9] implementing user defined operators --- sol-core.cabal | 2 + src/Solcore/Frontend/Lexer/SolcoreLexer.hs | 23 +- src/Solcore/Frontend/Module/Loader.hs | 120 ++++---- src/Solcore/Frontend/Parser/Decl.hs | 101 +++--- src/Solcore/Frontend/Parser/Expr.hs | 223 ++++++-------- src/Solcore/Frontend/Parser/Expr.hs-boot | 4 +- src/Solcore/Frontend/Parser/OperatorScan.hs | 206 +++++++++++++ src/Solcore/Frontend/Parser/Patterns.hs | 33 +- src/Solcore/Frontend/Parser/SolcoreParser.hs | 21 +- src/Solcore/Frontend/Parser/Stmt.hs | 168 +++++----- src/Solcore/Frontend/Pretty/TreePretty.hs | 79 +---- src/Solcore/Frontend/Syntax/NameResolution.hs | 138 ++------- src/Solcore/Frontend/Syntax/SyntaxTree.hs | 289 ++---------------- std/std.solc | 48 ++- test/LocationTests.hs | 2 +- test/Main.hs | 4 +- test/OperatorTests.hs | 92 ++++++ test/ParserTests.hs | 227 +++++++------- test/examples/comptime/ct_chain_ok.solc | 2 +- test/examples/comptime/ct_let_ok.solc | 2 +- test/examples/comptime/ct_param_ok.solc | 2 +- test/imports/extlib/math/api.solc | 1 + test/operators/basic.solc | 19 ++ test/operators/compound-assign.solc | 20 ++ test/operators/import-op.solc | 11 + test/operators/in-lambda.solc | 20 ++ test/operators/infixl.solc | 20 ++ test/operators/infixr.solc | 20 ++ test/operators/multi-op.solc | 28 ++ test/operators/oplib.solc | 15 + test/operators/precedence.solc | 22 ++ test/operators/prefix.solc | 20 ++ test/operators/undeclared-fail.solc | 11 + 33 files changed, 1104 insertions(+), 889 deletions(-) create mode 100644 src/Solcore/Frontend/Parser/OperatorScan.hs create mode 100644 test/OperatorTests.hs create mode 100644 test/operators/basic.solc create mode 100644 test/operators/compound-assign.solc create mode 100644 test/operators/import-op.solc create mode 100644 test/operators/in-lambda.solc create mode 100644 test/operators/infixl.solc create mode 100644 test/operators/infixr.solc create mode 100644 test/operators/multi-op.solc create mode 100644 test/operators/oplib.solc create mode 100644 test/operators/precedence.solc create mode 100644 test/operators/prefix.solc create mode 100644 test/operators/undeclared-fail.solc diff --git a/sol-core.cabal b/sol-core.cabal index 18058cba8..bb716b763 100644 --- a/sol-core.cabal +++ b/sol-core.cabal @@ -85,6 +85,7 @@ library Solcore.Frontend.Module.Loader Solcore.Frontend.Parser.Decl Solcore.Frontend.Parser.Expr + Solcore.Frontend.Parser.OperatorScan Solcore.Frontend.Parser.Patterns Solcore.Frontend.Parser.SolcoreParser Solcore.Frontend.Parser.SolcoreTypes @@ -197,6 +198,7 @@ test-suite sol-core-tests LocationTests MatchCompilerTests ModuleTypeCheckTests + OperatorTests SpecialiseTests YulEvalTests YulParserTests diff --git a/src/Solcore/Frontend/Lexer/SolcoreLexer.hs b/src/Solcore/Frontend/Lexer/SolcoreLexer.hs index 3042cbcb6..2d6d217d3 100644 --- a/src/Solcore/Frontend/Lexer/SolcoreLexer.hs +++ b/src/Solcore/Frontend/Lexer/SolcoreLexer.hs @@ -13,6 +13,8 @@ module Solcore.Frontend.Lexer.SolcoreLexer comma, semicolon, colon, + isOpChar, + parenOpP, ) where @@ -69,9 +71,28 @@ reservedWords = "return", "lam", "type", - "pragma" + "pragma", + "infixl", + "infixr", + "infix", + "prefix", + "postfix" ] +isOpChar :: Char -> Bool +isOpChar c = + c `elem` ("+-*/%<>=!&|^~#?" :: String) + || (c >= '\x2200' && c <= '\x23FF') + +parenOpP :: Parser String +parenOpP = lexeme $ do + _ <- char '(' + sc + sym <- some (satisfy isOpChar) + sc + _ <- char ')' + pure sym + identifier :: Parser String identifier = lexeme go "identifier" where diff --git a/src/Solcore/Frontend/Module/Loader.hs b/src/Solcore/Frontend/Module/Loader.hs index fbe5721a7..d0e1fa545 100644 --- a/src/Solcore/Frontend/Module/Loader.hs +++ b/src/Solcore/Frontend/Module/Loader.hs @@ -22,7 +22,8 @@ import Data.Set (Set) import Data.Set qualified as Set import Solcore.Diagnostics (Diagnostic (..), DiagnosticCode (..), Label (..), LabelStyle (..), Severity (..), SourceFile, SourceMap, SourceSpan, combineSourceSpans, encodeDiagnostic, makeSourceFile, sourceMapFromFiles) import Solcore.Frontend.Module.Identity qualified as Mod -import Solcore.Frontend.Parser.SolcoreParser (parseCompUnitWithPath) +import Solcore.Frontend.Parser.OperatorScan (scanImports, scanOperators) +import Solcore.Frontend.Parser.SolcoreParser (parseCompUnitWithOps) import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.SyntaxTree import System.Directory (doesFileExist, makeAbsolute) @@ -141,8 +142,9 @@ visit cfg moduleId sourcePath = do modify (\st -> st {loadingModules = Set.insert moduleId (loadingModules st)}) content <- liftIO (readFile sourcePath) let source = makeSourceFile sourcePath content - parsed <- liftIO (parseCompUnitWithPath sourcePath content) - cunit <- either throwError pure parsed + importedOps <- gatherImportedOperators cfg moduleId sourcePath (scanImports content) + parsed <- liftIO (parseCompUnitWithOps importedOps sourcePath content) + cunit <- stripOperators <$> either throwError pure parsed importedModules <- mapM (resolveImportPath cfg moduleId sourcePath) (imports cunit) exportedModules <- mapM (resolveModuleReference cfg moduleId sourcePath ExportReference) (exportModulePaths cunit) @@ -177,6 +179,50 @@ resolveImportPath cfg currentModule currentSourcePath imp = fmap (\(_, targetId, targetPath) -> (targetId, targetPath)) $ resolveModuleReference cfg currentModule currentSourcePath ImportReference (importModule imp) +gatherImportedOperators :: + LoaderConfig -> + Mod.ModuleId -> + FilePath -> + [Import] -> + StateT LoadState (ExceptT String IO) [OperatorDecl] +gatherImportedOperators cfg currentModule currentSourcePath imps = + concat <$> mapM fromImport imps + where + fromImport imp = + ( do + (_, targetPath) <- resolveImportPath cfg currentModule currentSourcePath imp + c <- liftIO (readFile targetPath) + pure (selectImportedOperators imp (scanOperators c)) + ) + `catchError` const (pure []) + +selectImportedOperators :: Import -> [OperatorDecl] -> [OperatorDecl] +selectImportedOperators _ ops = ops + +stripOperators :: CompUnit -> CompUnit +stripOperators (CompUnit imps ds) = + CompUnit (map stripImportOps imps) (concatMap stripTopDeclOps ds) + where + stripTopDeclOps (TOperatorDecl _) = [] + stripTopDeclOps (TContr (Contract n ps cds)) = + [TContr (Contract n ps (filter (not . isContractOp) cds))] + stripTopDeclOps (TExportDecl e) = [TExportDecl (stripExportOps e)] + stripTopDeclOps d = [d] + + isContractOp (COperatorDecl _) = True + isContractOp _ = False + + stripExportOps (ExportList specs) = ExportList (filter (not . isExportOp) specs) + stripExportOps e = e + isExportOp (ExportOperator _) = True + isExportOp _ = False + + stripImportOps (ImportOnly p (SelectItems es hs)) = + ImportOnly p (SelectItems (filter (not . isSelectOp) es) hs) + stripImportOps i = i + isSelectOp (SelectOperator _) = True + isSelectOp _ = False + resolveModuleReference :: LoaderConfig -> Mod.ModuleId -> @@ -620,6 +666,7 @@ selectedImportBindingsFromAvailable available (SelectItems items hidden) = expand SelectAllItems = [(itemName, itemName) | itemName <- available] expand (SelectItem itemName) = [(itemName, itemName)] expand (SelectItemAs itemName aliasName) = [(itemName, aliasName)] + expand (SelectOperator _) = [] -- operator selectors are handled separately; not name imports uniqueBindingsByLocal :: [(Name, Name)] -> [(Name, Name)] uniqueBindingsByLocal = @@ -845,7 +892,8 @@ validatePublicInterfaces graph groupModules interfaces = pure () ExportModuleAll path -> ensureRemoteModuleVisible moduleId path - + ExportOperator _ -> + pure () -- operator exports carry no name to validate ensureRemoteModuleVisible moduleId path = do _ <- lookupModuleReference graph moduleId path pure () @@ -899,6 +947,9 @@ expandExportSpecFixed :: CompUnit -> ExportSpec -> Either String ModulePublicInterface +expandExportSpecFixed _graph _groupModules _currentInterfaces _currentModule _sourcePath _unit (ExportOperator _) = + -- Operator exports contribute no name-level items to the public interface. + pure emptyPublicInterface expandExportSpecFixed graph groupModules currentInterfaces currentModule sourcePath unit (ExportName itemName) = do refs <- visibleExportRefsForNameFixed graph groupModules currentInterfaces currentModule unit itemName ensureVisibleExportExists sourcePath itemName refs @@ -1321,6 +1372,7 @@ topDeclNames (TClassDef (Class _ _ n _ _ _)) = [n] topDeclNames (TContr (Contract n _ _)) = [n] topDeclNames (TDataDef (DataTy n _ _ _)) = [n] topDeclNames (TInstDef _) = [] +topDeclNames (TOperatorDecl _) = [] topDeclNames (TExportDecl _) = [] topDeclNames (TPragmaDecl _) = [] @@ -1411,24 +1463,6 @@ renameBodyTypeRefs renameMap = renameStmtTypeRefs :: Map Name Name -> Stmt -> Stmt renameStmtTypeRefs renameMap (Assign lhs rhs) = Assign (renameExpTypeRefs renameMap lhs) (renameExpTypeRefs renameMap rhs) -renameStmtTypeRefs renameMap (StmtPlusEq e1 e2) = - StmtPlusEq (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameStmtTypeRefs renameMap (StmtMinusEq e1 e2) = - StmtMinusEq (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameStmtTypeRefs renameMap (StmtTimesEq e1 e2) = - StmtTimesEq (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameStmtTypeRefs renameMap (StmtDivideEq e1 e2) = - StmtDivideEq (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameStmtTypeRefs renameMap (StmtBXorEq e1 e2) = - StmtBXorEq (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameStmtTypeRefs renameMap (StmtBAndEq e1 e2) = - StmtBAndEq (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameStmtTypeRefs renameMap (StmtBOrEq e1 e2) = - StmtBOrEq (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameStmtTypeRefs renameMap (StmtModEq e1 e2) = - StmtModEq (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameStmtTypeRefs renameMap (StmtBNotEq e1) = - StmtBNotEq (renameExpTypeRefs renameMap e1) renameStmtTypeRefs renameMap (Let ct n mt me) = Let ct n (renameTyTypeRefs renameMap <$> mt) (renameExpTypeRefs renameMap <$> me) renameStmtTypeRefs renameMap (StmtExp e) = @@ -1512,42 +1546,6 @@ renameExpTypeRefs renameMap (ExpIndexed e1 e2) = ExpIndexed (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) renameExpTypeRefs renameMap (ExpArray es) = ExpArray (map (renameExpTypeRefs renameMap) es) -renameExpTypeRefs renameMap (ExpPlus e1 e2) = - ExpPlus (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpMinus e1 e2) = - ExpMinus (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpTimes e1 e2) = - ExpTimes (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpDivide e1 e2) = - ExpDivide (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpModulo e1 e2) = - ExpModulo (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpBXor e1 e2) = - ExpBXor (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpBAnd e1 e2) = - ExpBAnd (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpBOr e1 e2) = - ExpBOr (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpLT e1 e2) = - ExpLT (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpGT e1 e2) = - ExpGT (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpLE e1 e2) = - ExpLE (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpGE e1 e2) = - ExpGE (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpEE e1 e2) = - ExpEE (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpNE e1 e2) = - ExpNE (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpLAnd e1 e2) = - ExpLAnd (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpLOr e1 e2) = - ExpLOr (renameExpTypeRefs renameMap e1) (renameExpTypeRefs renameMap e2) -renameExpTypeRefs renameMap (ExpLNot e) = - ExpLNot (renameExpTypeRefs renameMap e) -renameExpTypeRefs renameMap (ExpBNot e) = - ExpBNot (renameExpTypeRefs renameMap e) renameExpTypeRefs renameMap (ExpCond e1 e2 e3) = ExpCond (renameExpTypeRefs renameMap e1) @@ -1597,6 +1595,7 @@ renameContractDeclTypeRefs renameMap (CConstrDecl (Constructor ps body payable)) (renameBodyTypeRefs renameMap body) payable ) +renameContractDeclTypeRefs _ d@(COperatorDecl _) = d -- no type refs in an operator declaration renameClassTypeRefs :: Map Name Name -> Class -> Class renameClassTypeRefs renameMap (Class bvs ctx n pvs mv sigs) = @@ -1750,6 +1749,7 @@ toValidationImportStub (TDataDef (DataTy n _ cs _)) = toValidationImportStub (TInstDef _) = Nothing toValidationImportStub (TExportDecl _) = Nothing toValidationImportStub (TPragmaDecl _) = Nothing +toValidationImportStub (TOperatorDecl _) = Nothing typeCheckQualifiedImportDecls :: Set Name -> ModuleGraph -> (Import, Mod.ModuleId) -> Either String [TopDecl] typeCheckQualifiedImportDecls collidingTypeNames graph (imp, modulePath) = @@ -2041,6 +2041,7 @@ shadowImportedDecls localDecls = ) filterDecl seen (TExportDecl _) = (seen, Nothing) filterDecl seen (TPragmaDecl _) = (seen, Nothing) + filterDecl seen (TOperatorDecl _) = (seen, Nothing) filterImportedInstanceConflicts :: [TopDecl] -> [TopDecl] -> [TopDecl] filterImportedInstanceConflicts localDecls = @@ -2152,6 +2153,7 @@ selectTopDeclForExportRef itemRef (TDataDef (DataTy n ts cs ds)) selectTopDeclForExportRef _ (TInstDef _) = Nothing selectTopDeclForExportRef _ (TExportDecl _) = Nothing selectTopDeclForExportRef _ (TPragmaDecl _) = Nothing +selectTopDeclForExportRef _ (TOperatorDecl _) = Nothing filterVisibleConstructors :: [Name] -> [Constr] -> [Constr] filterVisibleConstructors visibleConstructors = @@ -2385,6 +2387,7 @@ explicitSelectorNames (SelectItems items _) = SelectItem itemName -> [itemName] SelectItemAs itemName _ -> [itemName] SelectAllItems -> [] + SelectOperator _ -> [] ] explicitSelectorLocalNames :: ItemSelector -> [Name] @@ -2395,6 +2398,7 @@ explicitSelectorLocalNames (SelectItems items _) = SelectItem itemName -> [itemName] SelectItemAs _ aliasName -> [aliasName] SelectAllItems -> [] + SelectOperator _ -> [] ] explicitExportSelectorNames :: ExportSelector -> [Name] diff --git a/src/Solcore/Frontend/Parser/Decl.hs b/src/Solcore/Frontend/Parser/Decl.hs index 9e1d095e6..01f3e83e7 100644 --- a/src/Solcore/Frontend/Parser/Decl.hs +++ b/src/Solcore/Frontend/Parser/Decl.hs @@ -24,15 +24,35 @@ import Solcore.Frontend.Syntax.SyntaxTree -- Top-level entry point -compUnitP :: Parser CompUnit -compUnitP = do +-- The compilation-unit parser is parameterised by the user-defined operators +-- in scope (collected by a pre-scan of the source, see Parser.OperatorScan and +-- the SolcoreParser entry point). They extend the expression grammar. +compUnitP :: [OperatorDecl] -> Parser CompUnit +compUnitP ops = do sc - items <- many (Left <$> try importP <|> Right <$> topDeclP) + items <- many (Left <$> try importP <|> Right <$> topDeclP ops) eof return $ CompUnit [i | Left i <- items] [d | Right d <- items] -expP :: Parser Exp -expP = exprP bodyP +expP :: [OperatorDecl] -> Parser Exp +expP ops = exprP ops (bodyP ops) + +operatorDeclP :: Parser OperatorDecl +operatorDeclP = do + fix <- fixityP + prec <- fromIntegral <$> integer + sym <- parenOpP + _ <- symbol "=>" + fun <- qualifiedName + _ <- semicolon + return (OperatorDecl fix prec sym fun) + where + fixityP = + (OpInfixL <$ keyword "infixl") + <|> (OpInfixR <$ keyword "infixr") + <|> (OpInfixN <$ keyword "infix") + <|> (OpPrefix <$ keyword "prefix") + <|> (OpPostfix <$ keyword "postfix") withSigPrefix :: ([Ty] -> [Pred] -> Parser a) -> Parser a withSigPrefix k = do @@ -109,6 +129,8 @@ itemEntryP :: Parser ItemSelectorEntry itemEntryP = SelectAllItems <$ symbol "*" + <|> SelectOperator + <$> try parenOpP <|> try (SelectItemAs <$> simpleNameP <* keyword "as" <*> simpleNameP) <|> SelectItem <$> simpleNameP @@ -140,6 +162,8 @@ exportSpecP :: Parser ExportSpec exportSpecP = ExportAll <$ symbol "*" + <|> ExportOperator + <$> try parenOpP <|> ExportModuleAll <$> try moduleAllPathP <|> do @@ -243,19 +267,19 @@ tySymP = do -- Instance methods live outside a contract, so they may not carry the -- contract-only modifiers ('public' / 'payable'). -funDefP :: Parser FunDef -funDefP = try $ withSigPrefix (funDefAfterPrefix False) +funDefP :: [OperatorDecl] -> Parser FunDef +funDefP ops = try $ withSigPrefix (funDefAfterPrefix ops False) -- | Parse a function definition after its optional signature prefix. -- 'allowContractModifiers' controls whether the leading `public` and `payable` -- modifiers are accepted: both are only meaningful inside a `contract { … }` -- body, so callers outside a contract (top-level functions, instance methods) -- pass 'False' and an explicit modifier is rejected with a clear error. -funDefAfterPrefix :: Bool -> [Ty] -> [Pred] -> Parser FunDef -funDefAfterPrefix allowContractModifiers vars ctx = do +funDefAfterPrefix :: [OperatorDecl] -> Bool -> [Ty] -> [Pred] -> Parser FunDef +funDefAfterPrefix ops allowContractModifiers vars ctx = do isPub <- publicModifierP allowContractModifiers sig <- signatureP allowContractModifiers vars ctx - body <- braces bodyP + body <- braces (bodyP ops) return (FunDef isPub sig (implicitReturn body)) -- | Parse an optional `public` visibility modifier. When 'allowPublic' is @@ -297,10 +321,10 @@ signatureP allowPayable vars ctx = do return (ct, Just t) return (Signature vars ctx n ps rc ret payable) -fallbackDefAfterPrefix :: [Ty] -> [Pred] -> Parser FunDef -fallbackDefAfterPrefix vars ctx = do +fallbackDefAfterPrefix :: [OperatorDecl] -> [Ty] -> [Pred] -> Parser FunDef +fallbackDefAfterPrefix ops vars ctx = do sig <- fallbackSignatureP vars ctx - body <- braces bodyP + body <- braces (bodyP ops) return (FunDef False sig (implicitReturn body)) fallbackSignatureP :: [Ty] -> [Pred] -> Parser Signature @@ -338,39 +362,41 @@ classAfterPrefix vars ctx = do sigs <- braces (many classSigP) return (Class vars ctx cname params mty sigs) -instanceAfterPrefix :: [Ty] -> [Pred] -> Parser Instance -instanceAfterPrefix vars ctx = do +instanceAfterPrefix :: [OperatorDecl] -> [Ty] -> [Pred] -> Parser Instance +instanceAfterPrefix ops vars ctx = do isDefault <- option False (True <$ keyword "default") keyword "instance" mty <- atomTypeP _ <- colon iname <- qualifiedName params <- option [] (parens (typeP `sepBy1` comma)) - funs <- braces (many funDefP) + funs <- braces (many (funDefP ops)) return (Instance isDefault vars ctx iname params mty funs) -contractP :: Parser Contract -contractP = do +contractP :: [OperatorDecl] -> Parser Contract +contractP ops = do keyword "contract" n <- simpleNameP params <- option [] (parens (typeP `sepBy1` comma)) - ds <- braces (many contractDeclP) + ds <- braces (many (contractDeclP ops)) return (Contract n params ds) -contractDeclP :: Parser ContractDecl -contractDeclP = - CDataDecl +contractDeclP :: [OperatorDecl] -> Parser ContractDecl +contractDeclP ops = + COperatorDecl + <$> operatorDeclP + <|> CDataDecl <$> dataP <|> CConstrDecl - <$> try constructorDeclP + <$> try (constructorDeclP ops) <|> rejectPublicOnImplicitlyPublicP <|> withSigPrefix ( \vars ctx -> CFunDecl - <$> (try (funDefAfterPrefix True vars ctx) <|> fallbackDefAfterPrefix vars ctx) + <$> (try (funDefAfterPrefix ops True vars ctx) <|> fallbackDefAfterPrefix ops vars ctx) ) <|> CFieldDecl - <$> fieldDeclP + <$> fieldDeclP ops -- | `fallback` and `constructor` are implicitly public; reject an explicit -- `public` modifier on them with a clear error rather than a confusing @@ -383,38 +409,39 @@ rejectPublicOnImplicitlyPublicP = do ("fallback" <$ keyword "fallback") <|> ("constructor" <$ keyword "constructor") fail (kw ++ " is implicitly public; remove the 'public' keyword") -fieldDeclP :: Parser Field -fieldDeclP = do +fieldDeclP :: [OperatorDecl] -> Parser Field +fieldDeclP ops = do n <- simpleNameP _ <- colon ty <- typeP - me <- optional (equalsP *> expP) + me <- optional (equalsP *> expP ops) _ <- semicolon return (Field n ty me) -constructorDeclP :: Parser Constructor -constructorDeclP = do +constructorDeclP :: [OperatorDecl] -> Parser Constructor +constructorDeclP ops = do payable <- option False (True <$ keyword "payable") keyword "constructor" ps <- parens (paramP `sepBy` comma) - body <- braces bodyP + body <- braces (bodyP ops) return (Constructor ps body payable) -topDeclP :: Parser TopDecl -topDeclP = +topDeclP :: [OperatorDecl] -> Parser TopDecl +topDeclP ops = choice - [ TPragmaDecl <$> pragmaP, + [ TOperatorDecl <$> operatorDeclP, + TPragmaDecl <$> pragmaP, TExportDecl <$> exportP, TDataDef <$> dataP, TSym <$> tySymP, - TContr <$> contractP, + TContr <$> contractP ops, contractOnlyDeclP, withSigPrefix ( \vars ctx -> choice - [ TFunDef <$> funDefAfterPrefix False vars ctx, + [ TFunDef <$> funDefAfterPrefix ops False vars ctx, TClassDef <$> classAfterPrefix vars ctx, - TInstDef <$> instanceAfterPrefix vars ctx + TInstDef <$> instanceAfterPrefix ops vars ctx ] ) ] diff --git a/src/Solcore/Frontend/Parser/Expr.hs b/src/Solcore/Frontend/Parser/Expr.hs index 2bc833528..c17dc7c7e 100644 --- a/src/Solcore/Frontend/Parser/Expr.hs +++ b/src/Solcore/Frontend/Parser/Expr.hs @@ -5,6 +5,8 @@ where import Common.LightYear import Control.Monad.Combinators.Expr +import Data.List (groupBy, sortOn) +import Data.Ord (Down (..)) import Solcore.Diagnostics (SourceSpan) import Solcore.Frontend.Lexer.SolcoreLexer import Solcore.Frontend.Parser.Patterns (patListP) @@ -15,145 +17,118 @@ import Solcore.Frontend.Syntax.SyntaxTree type BodyP = Parser [Stmt] -exprP :: BodyP -> Parser Exp -exprP bp = tyAnnP bp +-- The expression parser is parameterised by the set of user-defined operators +-- in scope (collected by a pre-scan, see Parser.OperatorScan). They extend the +-- built-in operator table; a use of a user operator is desugared here to an +-- ordinary function call so the rest of the pipeline is unaffected. +exprP :: [OperatorDecl] -> BodyP -> Parser Exp +exprP ops bp = tyAnnP ops bp -tyAnnP :: BodyP -> Parser Exp -tyAnnP bp = do - e <- ternaryP bp +tyAnnP :: [OperatorDecl] -> BodyP -> Parser Exp +tyAnnP ops bp = do + e <- ternaryP ops bp option e $ do t <- colon *> typeP pure (locatedExpFrom [sourceSpanOf e, sourceSpanOf t] (TyExp e t)) -ternaryP :: BodyP -> Parser Exp -ternaryP bp = - try (ifThenElseP bp) <|> do - e1 <- binaryP bp +ternaryP :: [OperatorDecl] -> BodyP -> Parser Exp +ternaryP ops bp = + try (ifThenElseP ops bp) <|> do + e1 <- binaryP ops bp option e1 $ do _ <- symbol "?" - e2 <- ternaryP bp + e2 <- ternaryP ops bp _ <- symbol ":" - e3 <- ternaryP bp + e3 <- ternaryP ops bp return (locatedExpFrom (map sourceSpanOf [e1, e2, e3]) (ExpCond e1 e2 e3)) -ifThenElseP :: BodyP -> Parser Exp -ifThenElseP bp = locatedP locatedExp $ do +ifThenElseP :: [OperatorDecl] -> BodyP -> Parser Exp +ifThenElseP ops bp = locatedP locatedExp $ do keyword "if" - e1 <- ternaryP bp + e1 <- ternaryP ops bp keyword "then" - e2 <- ternaryP bp + e2 <- ternaryP ops bp keyword "else" - e3 <- ternaryP bp + e3 <- ternaryP ops bp return (ExpCond e1 e2 e3) -binaryP :: BodyP -> Parser Exp -binaryP bp = makeExprParser (postfixP bp) opTable - -opTable :: [[Operator Parser Exp]] -opTable = - [ [ Prefix - ( unaryExp ExpLNot - <$ try (lexeme (char '!' <* notFollowedBy (char '='))) - ), - Prefix - ( unaryExp ExpBNot - <$ try (lexeme (char '~' <* notFollowedBy (char '='))) - ) - ], - [ InfixL - ( binaryExp ExpTimes - <$ try (lexeme (char '*' <* notFollowedBy (char '='))) - ), - InfixL - ( binaryExp ExpDivide - <$ try (lexeme (char '/' <* notFollowedBy (char '='))) - ), - InfixL - ( binaryExp ExpModulo - <$ try (lexeme (char '%' <* notFollowedBy (char '='))) - ) - ], - [ InfixL - ( binaryExp ExpPlus - <$ try (lexeme (char '+' <* notFollowedBy (char '='))) - ), - InfixL - ( binaryExp ExpMinus - <$ try (lexeme (char '-' <* notFollowedBy (char '='))) - ) - ], - [ InfixL - ( binaryExp ExpBAnd - <$ try (lexeme (char '&' <* notFollowedBy (char '&') <* notFollowedBy (char '='))) - ) - ], - [ InfixL - ( binaryExp ExpBXor - <$ try (lexeme (char '^' <* notFollowedBy (char '='))) - ) - ], - [ InfixL - ( binaryExp ExpBOr - <$ try - ( lexeme (char '|' <* notFollowedBy (char '|') <* notFollowedBy (char '=')) - -- `|` also separates match arms (`| pat => ...`). Since `=>` - -- never follows a bitwise-or operand, treat `|` as a case - -- separator (not an operator) whenever `pat =>` comes next, - -- leaving it for the match-equation parser to consume. - <* notFollowedBy (try (patListP *> symbol "=>")) - ) - ) - ], - [ InfixN (binaryExp ExpLE <$ try (symbol "<=")), - InfixN (binaryExp ExpGE <$ try (symbol ">=")), - InfixN - ( binaryExp ExpLT - <$ try (lexeme (char '<' <* notFollowedBy (char '='))) - ), - InfixN - ( binaryExp ExpGT - <$ try (lexeme (char '>' <* notFollowedBy (char '='))) - ) - ], - [ InfixN (binaryExp ExpEE <$ try (symbol "==")), - InfixN (binaryExp ExpNE <$ try (symbol "!=")) - ], - [InfixL (binaryExp ExpLAnd <$ try (symbol "&&"))], - [InfixL (binaryExp ExpLOr <$ try (symbol "||"))] - ] - -postfixP :: BodyP -> Parser Exp -postfixP bp = do - e0 <- atomP bp - ops <- many (postfixOp bp) - return (foldl (\acc f -> f acc) e0 ops) - -postfixOp :: BodyP -> Parser (Exp -> Exp) -postfixOp bp = dotOp bp <|> idxOp bp - -dotOp :: BodyP -> Parser (Exp -> Exp) -dotOp bp = do +binaryP :: [OperatorDecl] -> BodyP -> Parser Exp +binaryP ops bp = makeExprParser (postfixP ops bp) (mergedOpTable ops) + +-- Build the operator table from the user-declared operators in scope (the +-- built-in operators are now ordinary declarations in the standard library). +-- Rows are grouped into precedence levels (highest first) so operators +-- interleave purely by their numeric precedence. +mergedOpTable :: [OperatorDecl] -> [[Operator Parser Exp]] +mergedOpTable ops = + map (map snd) + . groupBy (\a b -> fst a == fst b) + . sortOn (Down . fst) + $ map userRow ops + +-- Turn a user operator declaration into a table row. A use of the operator is +-- desugared to a plain call of the bound function, so name resolution and the +-- rest of the pipeline handle it like any other call. +userRow :: OperatorDecl -> (Int, Operator Parser Exp) +userRow od@(OperatorDecl fix prec _ fun) = + ( prec, + case fix of + OpInfixL -> InfixL (mkBin <$ opTok) + OpInfixR -> InfixR (mkBin <$ opTok) + OpInfixN -> InfixN (mkBin <$ opTok) + OpPrefix -> Prefix (mkPre <$ opTok) + OpPostfix -> Postfix (mkPre <$ opTok) + ) + where + opTok = try (opSymP od) + mkBin l r = locatedExpFrom [sourceSpanOf l, sourceSpanOf r] (ExpName Nothing fun [l, r]) + mkPre e = locatedExpFrom [sourceSpanOf e] (ExpName Nothing fun [e]) + +-- Match an exact operator symbol, ensuring no further operator character +-- follows (maximal munch: `^^` is matched whole, not as `^` then `^`). +-- The `|` symbol additionally must not be a match-arm separator (`| pat => …`): +-- the guard runs after lexeme consumed the trailing space, so patListP +-- starts on the pattern. +opSymP :: OperatorDecl -> Parser String +opSymP (OperatorDecl _ _ sym _) = + lexeme (string sym <* notFollowedBy (satisfy isOpChar)) <* matchArmGuard + where + matchArmGuard + | sym == "|" = notFollowedBy (try (patListP [] *> symbol "=>")) + | otherwise = pure () + +postfixP :: [OperatorDecl] -> BodyP -> Parser Exp +postfixP ops bp = do + e0 <- atomP ops bp + fs <- many (postfixOp ops bp) + return (foldl (\acc f -> f acc) e0 fs) + +postfixOp :: [OperatorDecl] -> BodyP -> Parser (Exp -> Exp) +postfixOp ops bp = dotOp ops bp <|> idxOp ops bp + +dotOp :: [OperatorDecl] -> BodyP -> Parser (Exp -> Exp) +dotOp ops bp = do _ <- char '.' sc n <- simpleNameP - mArgs <- optional (parens (exprP bp `sepBy` comma)) + mArgs <- optional (parens (exprP ops bp `sepBy` comma)) return $ case mArgs of Just args -> \e -> locatedExpFrom [sourceSpanOf e, sourceSpanOf n, sourceSpanOf args] (ExpName (Just e) n args) Nothing -> \e -> locatedExpFrom [sourceSpanOf e, sourceSpanOf n] (ExpVar (Just e) n) -idxOp :: BodyP -> Parser (Exp -> Exp) -idxOp bp = do - idx <- brackets (exprP bp) +idxOp :: [OperatorDecl] -> BodyP -> Parser (Exp -> Exp) +idxOp ops bp = do + idx <- brackets (exprP ops bp) return (\e -> locatedExpFrom [sourceSpanOf e, sourceSpanOf idx] (ExpIndexed e idx)) -atomP :: BodyP -> Parser Exp -atomP bp = litP <|> try (lamP bp) <|> proxyP <|> try (dotNameP bp) <|> parenP bp <|> arrayLitP bp <|> nameP bp +atomP :: [OperatorDecl] -> BodyP -> Parser Exp +atomP ops bp = litP <|> try (lamP bp) <|> proxyP <|> try (dotNameP ops bp) <|> parenP ops bp <|> arrayLitP ops bp <|> nameP ops bp -- Array literal, e.g. [1, 2, 3]. A leading '[' is unambiguous: postfix -- indexing (idxOp) only consumes '[' after an atom has been parsed, so -- `arr[0]` still parses as atom+postfix and `[1,2][0]` as literal+postfix. -arrayLitP :: BodyP -> Parser Exp -arrayLitP bp = locatedP locatedExp (ExpArray <$> brackets (exprP bp `sepBy` comma)) +arrayLitP :: [OperatorDecl] -> BodyP -> Parser Exp +arrayLitP ops bp = locatedP locatedExp (ExpArray <$> brackets (exprP ops bp `sepBy` comma)) litP :: Parser Exp litP = @@ -175,17 +150,17 @@ lamP bp = locatedP locatedExp $ do proxyP :: Parser Exp proxyP = locatedP locatedExp (ExpAt <$> (symbol "@" *> atomTypeP)) -dotNameP :: BodyP -> Parser Exp -dotNameP bp = locatedP locatedExp $ do +dotNameP :: [OperatorDecl] -> BodyP -> Parser Exp +dotNameP ops bp = locatedP locatedExp $ do _ <- char '.' sc n <- simpleNameP - args <- option [] (parens (exprP bp `sepBy` comma)) + args <- option [] (parens (exprP ops bp `sepBy` comma)) return (ExpDotName n args) -parenP :: BodyP -> Parser Exp -parenP bp = locatedP locatedExp $ parens $ do - es <- exprP bp `sepBy` comma +parenP :: [OperatorDecl] -> BodyP -> Parser Exp +parenP ops bp = locatedP locatedExp $ parens $ do + es <- exprP ops bp `sepBy` comma return $ case es of [] -> ExpName Nothing (Name "()") [] [e] -> e @@ -193,21 +168,13 @@ parenP bp = locatedP locatedExp $ parens $ do where pairE e1 e2 = locatedExpFrom [sourceSpanOf e1, sourceSpanOf e2] (ExpName Nothing (Name "pair") [e1, e2]) -nameP :: BodyP -> Parser Exp -nameP bp = locatedP locatedExp $ do +nameP :: [OperatorDecl] -> BodyP -> Parser Exp +nameP ops bp = locatedP locatedExp $ do n <- simpleNameP - mArgs <- optional (parens (exprP bp `sepBy` comma)) + mArgs <- optional (parens (exprP ops bp `sepBy` comma)) return $ case mArgs of Just args -> ExpName Nothing n args Nothing -> ExpVar Nothing n -binaryExp :: (Exp -> Exp -> Exp) -> Exp -> Exp -> Exp -binaryExp con left right = - locatedExpFrom [sourceSpanOf left, sourceSpanOf right] (con left right) - -unaryExp :: (Exp -> Exp) -> Exp -> Exp -unaryExp con operand = - locatedExpFrom [sourceSpanOf operand] (con operand) - locatedExpFrom :: [Maybe SourceSpan] -> Exp -> Exp locatedExpFrom = locatedFromSpans locatedExp diff --git a/src/Solcore/Frontend/Parser/Expr.hs-boot b/src/Solcore/Frontend/Parser/Expr.hs-boot index e4a76d91a..be6b39f49 100644 --- a/src/Solcore/Frontend/Parser/Expr.hs-boot +++ b/src/Solcore/Frontend/Parser/Expr.hs-boot @@ -4,6 +4,6 @@ module Solcore.Frontend.Parser.Expr where import Common.LightYear (Parser) -import Solcore.Frontend.Syntax.SyntaxTree (Exp, Stmt) +import Solcore.Frontend.Syntax.SyntaxTree (Exp, OperatorDecl, Stmt) -exprP :: Parser [Stmt] -> Parser Exp +exprP :: [OperatorDecl] -> Parser [Stmt] -> Parser Exp diff --git a/src/Solcore/Frontend/Parser/OperatorScan.hs b/src/Solcore/Frontend/Parser/OperatorScan.hs new file mode 100644 index 000000000..14e2f7b0b --- /dev/null +++ b/src/Solcore/Frontend/Parser/OperatorScan.hs @@ -0,0 +1,206 @@ +module Solcore.Frontend.Parser.OperatorScan + ( scanOperators, + scanImports, + scanExportModulePaths, + ) +where + +import Common.LightYear +import Data.List (nubBy) +import Solcore.Frontend.Lexer.SolcoreLexer +import Solcore.Frontend.Syntax.Name +import Solcore.Frontend.Syntax.SyntaxTree + +-- Lightweight scan of a source file collecting every operator declaration. +-- Tolerates arbitrary content between declarations. +scanOperators :: String -> [OperatorDecl] +scanOperators src = + case runParser (sc *> scanP) "" src of + Left _ -> [] + Right ops -> nubBy (\a b -> opSymbol a == opSymbol b) ops + where + scanP :: Parser [OperatorDecl] + scanP = do + ops <- many (try opDeclP <|> (anySingle *> pure Nothing)) + eof + pure [op | Just op <- ops] + + opDeclP :: Parser (Maybe OperatorDecl) + opDeclP = do + fix <- fixityP + prec <- fromIntegral <$> integer + sym <- parenOpP + _ <- symbol "=>" + fun <- qualFunP + _ <- optional semicolon + pure (Just (OperatorDecl fix prec sym fun)) + + qualFunP :: Parser Name + qualFunP = do + h <- identifier + mt <- optional (char '.' *> identifier) + sc + pure $ case mt of + Nothing -> Name h + Just t -> QualName (Name h) t + + fixityP :: Parser OpFixity + fixityP = + (OpInfixL <$ keyword "infixl") + <|> (OpInfixR <$ keyword "infixr") + <|> (OpInfixN <$ keyword "infix") + <|> (OpPrefix <$ keyword "prefix") + <|> (OpPostfix <$ keyword "postfix") + +-- Lightweight scan of a source file collecting every import declaration. +-- Tolerates arbitrary content between imports (skips unknown tokens). +-- Import syntax uses only identifiers, dots, braces, and keywords — no +-- operator symbols — so this scan needs no operator table. +scanImports :: String -> [Import] +scanImports src = + case runParser (sc *> scanP) "" src of + Left _ -> [] + Right imps -> imps + where + scanP :: Parser [Import] + scanP = do + imps <- many (try importDeclP <|> (anySingle *> pure Nothing)) + eof + pure [i | Just i <- imps] + + importDeclP :: Parser (Maybe Import) + importDeclP = do + keyword "import" + imp <- + choice + [ do + path <- externalPathP + choice + [ do + _ <- symbol "." + entries <- braces (itemEntryP `sepBy` comma) + hids <- option [] hidingP <* semicolon + pure (ImportOnly path (SelectItems entries hids)), + do + keyword "as" + n <- Name <$> identifier + _ <- semicolon + pure (ImportAlias path n), + ImportModule path <$ semicolon + ], + do + path <- modPathP + choice + [ do + _ <- symbol "." + entries <- braces (itemEntryP `sepBy` comma) + hids <- option [] hidingP <* semicolon + pure (ImportOnly path (SelectItems entries hids)), + do + keyword "as" + n <- Name <$> identifier + _ <- semicolon + pure (ImportAlias path n), + ImportModule path <$ semicolon + ] + ] + pure (Just imp) + where + hidingP = keyword "hiding" *> braces (fmap Name identifier `sepBy` comma) + + modPathP :: Parser ModulePath + modPathP = do + h <- identifier + ts <- many (try (char '.' *> notFollowedBy (char '{') *> identifier)) + pure (classifyModulePath (foldl QualName (Name h) ts)) + + externalPathP :: Parser ModulePath + externalPathP = do + lib <- symbol "@" *> identifier <* char '.' + sc + h <- identifier + ts <- many (try (char '.' *> notFollowedBy (char '{') *> identifier)) + pure (ExternalPath (Name lib) (foldl QualName (Name h) ts)) + + classifyModulePath :: Name -> ModulePath + classifyModulePath n = case splitQual n of + ("lib" : rest@(_ : _)) -> LibraryPath (mkQualName rest) + _ -> RelativePath n + + splitQual :: Name -> [String] + splitQual (Name s) = [s] + splitQual (QualName n s) = splitQual n ++ [s] + + mkQualName :: [String] -> Name + mkQualName [] = error "mkQualName: empty" + mkQualName (x : xs) = foldl QualName (Name x) xs + + itemEntryP :: Parser ItemSelectorEntry + itemEntryP = + SelectAllItems + <$ symbol "*" + <|> SelectOperator + <$> try parenOpP + <|> try (SelectItemAs <$> (Name <$> identifier) <* keyword "as" <*> (Name <$> identifier)) + <|> SelectItem + . Name + <$> identifier + +-- Lightweight scan collecting module paths referenced in export declarations. +-- Handles: "export M;", "export M as N;", "export M.{..};", "export M.*;", +-- and the @-prefixed external variants. +-- Needed so the loader can visit export-referenced modules before the full parse. +scanExportModulePaths :: String -> [ModulePath] +scanExportModulePaths src = + case runParser (sc *> scanP) "" src of + Left _ -> [] + Right paths -> paths + where + scanP :: Parser [ModulePath] + scanP = do + paths <- many (try exportPathP <|> (anySingle *> pure Nothing)) + eof + pure [p | Just p <- paths] + + exportPathP :: Parser (Maybe ModulePath) + exportPathP = do + keyword "export" + -- skip the export body: skip until ';' is found (tolerant) + path <- try (Just <$> exportModulePath) <|> pure Nothing + _ <- manyTill anySingle (char ';') + sc + pure path + + -- Parse a module path that follows "export", stopping before + -- '{', '*', 'as', or ';'. + exportModulePath :: Parser ModulePath + exportModulePath = + choice + [ do + lib <- symbol "@" *> identifier <* char '.' + sc + h <- identifier + ts <- many (try (char '.' *> notFollowedBy stopChar *> identifier)) + pure (ExternalPath (Name lib) (foldl QualName (Name h) ts)), + do + h <- identifier + ts <- many (try (char '.' *> notFollowedBy stopChar *> identifier)) + let name' = foldl QualName (Name h) ts + pure (classifyModulePath name') + ] + + stopChar :: Parser () + stopChar = () <$ satisfy (\c -> c == '{' || c == '*' || c == ';') + + classifyModulePath :: Name -> ModulePath + classifyModulePath n = case splitQual n of + ("lib" : rest@(_ : _)) -> LibraryPath (mkQualName rest) + _ -> RelativePath n + + splitQual :: Name -> [String] + splitQual (Name s) = [s] + splitQual (QualName n s) = splitQual n ++ [s] + + mkQualName :: [String] -> Name + mkQualName [] = error "mkQualName: empty" + mkQualName (x : xs) = foldl QualName (Name x) xs diff --git a/src/Solcore/Frontend/Parser/Patterns.hs b/src/Solcore/Frontend/Parser/Patterns.hs index c7f28f909..4a38f355c 100644 --- a/src/Solcore/Frontend/Parser/Patterns.hs +++ b/src/Solcore/Frontend/Parser/Patterns.hs @@ -11,11 +11,14 @@ import Solcore.Frontend.Parser.SolcoreTypes (locatedP, qualifiedName, simpleName import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.SyntaxTree -patP :: Parser Pat -patP = locatedP locatedPat (wildcardP <|> litP <|> dotPatP <|> parenPatP <|> try comptimePatP <|> namedPatP) +-- Patterns are parameterised by the user-defined operators in scope so that a +-- comptime pattern (which embeds an expression) can use operators. +patP :: [OperatorDecl] -> Parser Pat +patP ops = + locatedP locatedPat (wildcardP <|> litP <|> dotPatP ops <|> parenPatP ops <|> try (comptimePatP ops) <|> namedPatP ops) -patListP :: Parser [Pat] -patListP = patP `sepBy1` comma +patListP :: [OperatorDecl] -> Parser [Pat] +patListP ops = patP ops `sepBy1` comma wildcardP :: Parser Pat wildcardP = @@ -29,29 +32,29 @@ litP = . StrLit <$> stringLit -dotPatP :: Parser Pat -dotPatP = do +dotPatP :: [OperatorDecl] -> Parser Pat +dotPatP ops = do _ <- char '.' sc n <- simpleNameP - args <- option [] (parens (patP `sepBy1` comma)) + args <- option [] (parens (patP ops `sepBy1` comma)) return (PatDot n args) -parenPatP :: Parser Pat -parenPatP = parens insideP +parenPatP :: [OperatorDecl] -> Parser Pat +parenPatP ops = parens insideP where insideP = do - ps <- patP `sepBy` comma + ps <- patP ops `sepBy` comma return $ case ps of [] -> Pat (Name "()") [] [p] -> p _ -> Pat (Name "pair") ps -namedPatP :: Parser Pat -namedPatP = do +namedPatP :: [OperatorDecl] -> Parser Pat +namedPatP ops = do n <- qualifiedName - args <- option [] (parens (patP `sepBy1` comma)) + args <- option [] (parens (patP ops `sepBy1` comma)) return (Pat n args) -comptimePatP :: Parser Pat -comptimePatP = PExp <$> (keyword "comptime" *> exprP (return [])) +comptimePatP :: [OperatorDecl] -> Parser Pat +comptimePatP ops = PExp <$> (keyword "comptime" *> exprP ops (return [])) diff --git a/src/Solcore/Frontend/Parser/SolcoreParser.hs b/src/Solcore/Frontend/Parser/SolcoreParser.hs index 444b2c040..3e5cd1d7a 100644 --- a/src/Solcore/Frontend/Parser/SolcoreParser.hs +++ b/src/Solcore/Frontend/Parser/SolcoreParser.hs @@ -1,6 +1,7 @@ module Solcore.Frontend.Parser.SolcoreParser ( parseCompUnit, parseCompUnitWithPath, + parseCompUnitWithOps, moduleParser, ) where @@ -18,7 +19,8 @@ import Solcore.Diagnostics encodeDiagnostic, ) import Solcore.Frontend.Parser.Decl (compUnitP) -import Solcore.Frontend.Syntax.SyntaxTree (CompUnit) +import Solcore.Frontend.Parser.OperatorScan (scanOperators) +import Solcore.Frontend.Syntax.SyntaxTree (CompUnit, OperatorDecl) import Text.Megaparsec (ParseErrorBundle, bundleErrors, errorBundlePretty, errorOffset, parse) parseCompUnit :: String -> IO (Either String CompUnit) @@ -29,11 +31,20 @@ moduleParser _dirs = parseCompUnitWithPath "" parseCompUnitWithPath :: FilePath -> String -> IO (Either String CompUnit) -parseCompUnitWithPath sourcePath src = +parseCompUnitWithPath = parseCompUnitWithOps [] + +-- Parse with a set of extra operators already in scope (e.g. imported from +-- other modules), on top of the ones declared in this source. The module +-- loader supplies the imported operators; see Module.Loader. +parseCompUnitWithOps :: [OperatorDecl] -> FilePath -> String -> IO (Either String CompUnit) +parseCompUnitWithOps extraOps sourcePath src = pure $ - case parse compUnitP sourcePath src of - Left err -> Left (parseDiagnostic sourcePath src err) - Right compUnit -> Right compUnit + -- Pre-scan the source for user-defined operator declarations so the + -- expression grammar can be extended before the main parse. + let ops = extraOps ++ scanOperators src + in case parse (compUnitP ops) sourcePath src of + Left err -> Left (parseDiagnostic sourcePath src err) + Right compUnit -> Right compUnit parseDiagnostic :: FilePath -> String -> ParseErrorBundle String Void -> String parseDiagnostic sourcePath src err = diff --git a/src/Solcore/Frontend/Parser/Stmt.hs b/src/Solcore/Frontend/Parser/Stmt.hs index 7636001d7..57d6d194a 100644 --- a/src/Solcore/Frontend/Parser/Stmt.hs +++ b/src/Solcore/Frontend/Parser/Stmt.hs @@ -13,24 +13,24 @@ import Solcore.Frontend.Parser.Patterns (patListP) import Solcore.Frontend.Parser.SolcoreTypes (locatedP, simpleNameP, typeP) import Solcore.Frontend.Syntax.SyntaxTree -bodyP :: Parser Body -bodyP = many stmtP - -expP :: Parser Exp -expP = exprP bodyP - -stmtP :: Parser Stmt -stmtP = - letP - <|> returnP - <|> try ifP - <|> forP +bodyP :: [OperatorDecl] -> Parser Body +bodyP ops = many (stmtP ops) + +expP :: [OperatorDecl] -> Parser Exp +expP ops = exprP ops (bodyP ops) + +stmtP :: [OperatorDecl] -> Parser Stmt +stmtP ops = + letP ops + <|> returnP ops + <|> try (ifP ops) + <|> forP ops <|> breakP <|> continueP - <|> matchP + <|> matchP ops <|> asmP - <|> blockP - <|> try exprOrAssignP + <|> blockP ops + <|> try (exprOrAssignP ops) breakP :: Parser Stmt breakP = locatedP locatedStmt (Break <$ (keyword "break" *> semicolon)) @@ -38,8 +38,8 @@ breakP = locatedP locatedStmt (Break <$ (keyword "break" *> semicolon)) continueP :: Parser Stmt continueP = locatedP locatedStmt (Continue <$ (keyword "continue" *> semicolon)) -letP :: Parser Stmt -letP = locatedP locatedStmt $ do +letP :: [OperatorDecl] -> Parser Stmt +letP ops = locatedP locatedStmt $ do keyword "let" n <- simpleNameP (ct, mt) <- option (False, Nothing) $ do @@ -47,82 +47,102 @@ letP = locatedP locatedStmt $ do ct <- option False (True <$ keyword "comptime") t <- typeP return (ct, Just t) - me <- optional (equalsP *> expP) + me <- optional (equalsP *> expP ops) _ <- semicolon return (Let ct n mt me) -returnP :: Parser Stmt -returnP = locatedP locatedStmt (Return <$> (keyword "return" *> expP <* semicolon)) +returnP :: [OperatorDecl] -> Parser Stmt +returnP ops = locatedP locatedStmt (Return <$> (keyword "return" *> expP ops <* semicolon)) -ifP :: Parser Stmt -ifP = locatedP locatedStmt $ do +ifP :: [OperatorDecl] -> Parser Stmt +ifP ops = locatedP locatedStmt $ do keyword "if" - cond <- parens expP - thenBody <- braces bodyP - elseBody <- option [] (keyword "else" *> braces bodyP) + cond <- parens (expP ops) + thenBody <- braces (bodyP ops) + elseBody <- option [] (keyword "else" *> braces (bodyP ops)) return (If cond thenBody elseBody) -forP :: Parser Stmt -forP = locatedP locatedStmt $ do +forP :: [OperatorDecl] -> Parser Stmt +forP ops = locatedP locatedStmt $ do keyword "for" (initS, cond, postS) <- parens $ do - initS <- forInitP + initS <- forInitP ops _ <- semicolon - cond <- expP + cond <- expP ops _ <- semicolon - postS <- forPostP + postS <- forPostP ops return (initS, cond, postS) - body <- braces bodyP + body <- braces (bodyP ops) return (For initS cond postS body) -matchP :: Parser Stmt -matchP = locatedP locatedStmt $ do +matchP :: [OperatorDecl] -> Parser Stmt +matchP ops = locatedP locatedStmt $ do keyword "match" - scrutinees <- expP `sepBy1` comma - eqns <- braces (many equationP) + scrutinees <- expP ops `sepBy1` comma + eqns <- braces (many (equationP ops)) return (Match scrutinees eqns) asmP :: Parser Stmt asmP = locatedP locatedStmt (Asm <$> (keyword "assembly" *> yulBlock)) -- yulBlock includes the surrounding braces -blockP :: Parser Stmt -blockP = locatedP locatedStmt (Block <$> braces bodyP) +blockP :: [OperatorDecl] -> Parser Stmt +blockP ops = locatedP locatedStmt (Block <$> braces (bodyP ops)) -exprOrAssignP :: Parser Stmt -exprOrAssignP = locatedP locatedStmt $ do - lhs <- expP +exprOrAssignP :: [OperatorDecl] -> Parser Stmt +exprOrAssignP ops = locatedP locatedStmt $ do + lhs <- expP ops choice - [ do rhs <- equalsP *> expP; _ <- semicolon; return (Assign lhs rhs), - do rhs <- symbol "+=" *> expP; _ <- semicolon; return (StmtPlusEq lhs rhs), - do rhs <- symbol "-=" *> expP; _ <- semicolon; return (StmtMinusEq lhs rhs), - do rhs <- symbol "*=" *> expP; _ <- semicolon; return (StmtTimesEq lhs rhs), - do rhs <- symbol "/=" *> expP; _ <- semicolon; return (StmtDivideEq lhs rhs), - do rhs <- symbol "^=" *> expP; _ <- semicolon; return (StmtBXorEq lhs rhs), - do rhs <- symbol "&=" *> expP; _ <- semicolon; return (StmtBAndEq lhs rhs), - do rhs <- symbol "|=" *> expP; _ <- semicolon; return (StmtBOrEq lhs rhs), - do rhs <- symbol "%=" *> expP; _ <- semicolon; return (StmtModEq lhs rhs), - do _ <- symbol "~="; _ <- semicolon; return (StmtBNotEq lhs), + [ do rhs <- equalsP *> expP ops; _ <- semicolon; return (Assign lhs rhs), + do rhs <- symbol "+=" *> expP ops; _ <- semicolon; compoundAssign ops "+" lhs rhs, + do rhs <- symbol "-=" *> expP ops; _ <- semicolon; compoundAssign ops "-" lhs rhs, + do rhs <- symbol "*=" *> expP ops; _ <- semicolon; compoundAssign ops "*" lhs rhs, + do rhs <- symbol "/=" *> expP ops; _ <- semicolon; compoundAssign ops "/" lhs rhs, + do rhs <- symbol "^=" *> expP ops; _ <- semicolon; compoundAssign ops "^" lhs rhs, + do rhs <- symbol "&=" *> expP ops; _ <- semicolon; compoundAssign ops "&" lhs rhs, + do rhs <- symbol "|=" *> expP ops; _ <- semicolon; compoundAssign ops "|" lhs rhs, + do rhs <- symbol "%=" *> expP ops; _ <- semicolon; compoundAssign ops "%" lhs rhs, + do _ <- symbol "~="; _ <- semicolon; compoundAssignUnary ops "~" lhs, StmtExp lhs <$ optional semicolon ] -forInitP :: Parser Stmt -forInitP = locatedP locatedStmt $ do - stmts <- (forLetP <|> forAssignP) `sepBy` comma +-- A compound assignment lhs = rhs desugars to lhs = (lhs, rhs) +-- using the operator bound to in scope; there are no built-in operators, +-- so the base operator must be declared (e.g. imported from the standard +-- library). lhs is duplicated into both the assignment target and the call. +compoundAssign :: [OperatorDecl] -> String -> Exp -> Exp -> Parser Stmt +compoundAssign ops sym lhs rhs = + case filter ((== sym) . opSymbol) ops of + (od : _) -> pure (Assign lhs (ExpName Nothing (opFunction od) [lhs, rhs])) + [] -> fail ("operator (" ++ sym ++ ") must be in scope to use '" ++ sym ++ "='") + +-- A unary compound assignment `lhs =` desugars to `lhs = (lhs)` using +-- the (prefix) operator bound to in scope. Used for `~=`, the in-place +-- bitwise NOT: `lhs ~=` becomes `lhs = ~lhs`. As with compoundAssign, the base +-- operator must be declared (there are no built-in operators). +compoundAssignUnary :: [OperatorDecl] -> String -> Exp -> Parser Stmt +compoundAssignUnary ops sym lhs = + case filter ((== sym) . opSymbol) ops of + (od : _) -> pure (Assign lhs (ExpName Nothing (opFunction od) [lhs])) + [] -> fail ("operator (" ++ sym ++ ") must be in scope to use '" ++ sym ++ "='") + +forInitP :: [OperatorDecl] -> Parser Stmt +forInitP ops = locatedP locatedStmt $ do + stmts <- (forLetP ops <|> forAssignP ops) `sepBy` comma return $ case stmts of [] -> EmptyStmt [s] -> s ss -> Block ss -forPostP :: Parser Stmt -forPostP = locatedP locatedStmt $ do - stmts <- forAssignP `sepBy` comma +forPostP :: [OperatorDecl] -> Parser Stmt +forPostP ops = locatedP locatedStmt $ do + stmts <- forAssignP ops `sepBy` comma return $ case stmts of [] -> EmptyStmt [s] -> s ss -> Block ss -forLetP :: Parser Stmt -forLetP = locatedP locatedStmt $ do +forLetP :: [OperatorDecl] -> Parser Stmt +forLetP ops = locatedP locatedStmt $ do keyword "let" n <- simpleNameP (ct, mt) <- option (False, Nothing) $ do @@ -130,28 +150,28 @@ forLetP = locatedP locatedStmt $ do ct <- option False (True <$ keyword "comptime") t <- typeP return (ct, Just t) - me <- optional (equalsP *> expP) + me <- optional (equalsP *> expP ops) return (Let ct n mt me) -forAssignP :: Parser Stmt -forAssignP = locatedP locatedStmt $ do - lhs <- expP +forAssignP :: [OperatorDecl] -> Parser Stmt +forAssignP ops = locatedP locatedStmt $ do + lhs <- expP ops choice - [ do rhs <- equalsP *> expP; return (Assign lhs rhs), - do rhs <- symbol "+=" *> expP; return (StmtPlusEq lhs rhs), - do rhs <- symbol "-=" *> expP; return (StmtMinusEq lhs rhs), - do rhs <- symbol "*=" *> expP; return (StmtTimesEq lhs rhs), - do rhs <- symbol "/=" *> expP; return (StmtDivideEq lhs rhs), - do rhs <- symbol "^=" *> expP; return (StmtBXorEq lhs rhs), - do rhs <- symbol "&=" *> expP; return (StmtBAndEq lhs rhs), - do rhs <- symbol "|=" *> expP; return (StmtBOrEq lhs rhs), - do rhs <- symbol "%=" *> expP; return (StmtModEq lhs rhs), - do _ <- symbol "~="; return (StmtBNotEq lhs), + [ do rhs <- equalsP *> expP ops; return (Assign lhs rhs), + do rhs <- symbol "+=" *> expP ops; compoundAssign ops "+" lhs rhs, + do rhs <- symbol "-=" *> expP ops; compoundAssign ops "-" lhs rhs, + do rhs <- symbol "*=" *> expP ops; compoundAssign ops "*" lhs rhs, + do rhs <- symbol "/=" *> expP ops; compoundAssign ops "/" lhs rhs, + do rhs <- symbol "^=" *> expP ops; compoundAssign ops "^" lhs rhs, + do rhs <- symbol "&=" *> expP ops; compoundAssign ops "&" lhs rhs, + do rhs <- symbol "|=" *> expP ops; compoundAssign ops "|" lhs rhs, + do rhs <- symbol "%=" *> expP ops; compoundAssign ops "%" lhs rhs, + do _ <- symbol "~="; compoundAssignUnary ops "~" lhs, return (StmtExp lhs) ] -equationP :: Parser Equation -equationP = (,) <$> (symbol "|" *> patListP) <*> (symbol "=>" *> bodyP) +equationP :: [OperatorDecl] -> Parser Equation +equationP ops = (,) <$> (symbol "|" *> patListP ops) <*> (symbol "=>" *> bodyP ops) equalsP :: Parser () equalsP = void $ try (lexeme (char '=' <* notFollowedBy (char '='))) diff --git a/src/Solcore/Frontend/Pretty/TreePretty.hs b/src/Solcore/Frontend/Pretty/TreePretty.hs index 2e3451f4c..7d00245f7 100644 --- a/src/Solcore/Frontend/Pretty/TreePretty.hs +++ b/src/Solcore/Frontend/Pretty/TreePretty.hs @@ -41,6 +41,19 @@ instance Pretty TopDecl where ppr (TSym s) = ppr s ppr (TExportDecl e) = ppr e ppr (TPragmaDecl p) = ppr p + ppr (TOperatorDecl od) = pprOperatorDecl od + +-- Pretty-print a user-defined operator declaration, e.g. `infixl 70 (^^) => pow;`. +pprOperatorDecl :: OperatorDecl -> Doc +pprOperatorDecl (OperatorDecl fixity prec sym fun) = + hsep [pprFixity fixity, text (show prec), parens (text sym), text "=>", ppr fun] <> semi + +pprFixity :: OpFixity -> Doc +pprFixity OpInfixL = text "infixl" +pprFixity OpInfixR = text "infixr" +pprFixity OpInfixN = text "infix" +pprFixity OpPrefix = text "prefix" +pprFixity OpPostfix = text "postfix" instance Pretty Export where ppr (ExportList items) = @@ -67,6 +80,7 @@ instance Pretty ExportSpec where ppr (ExportNameWithConstructors typeName ctorSelector) = ppr typeName <> parens (ppr ctorSelector) ppr (ExportModuleAll path) = ppr path <> text ".*" + ppr (ExportOperator sym) = parens (text sym) instance Pretty ConstructorSelector where ppr SelectAllConstructors = text "*" @@ -96,6 +110,7 @@ instance Pretty ItemSelectorEntry where ppr (SelectItem itemName) = ppr itemName ppr (SelectItemAs itemName aliasName) = hsep [ppr itemName, text "as", ppr aliasName] + ppr (SelectOperator sym) = parens (text sym) exportSelectorIsOnlyWildcard :: ExportSelector -> Bool exportSelectorIsOnlyWildcard (SelectExportItems [SelectExportAllItems]) = True @@ -135,6 +150,7 @@ instance Pretty ContractDecl where ppr fd ppr (CConstrDecl c) = ppr c + ppr (COperatorDecl od) = pprOperatorDecl od instance Pretty Constructor where ppr (Constructor ps bd payable) = @@ -276,24 +292,6 @@ instance Pretty Param where instance Pretty Stmt where ppr (Assign n e) = ppr n <+> equals <+> ppr e <+> semi - ppr (StmtPlusEq e1 e2) = - hsep [ppr e1, text "+=", ppr e2] - ppr (StmtMinusEq e1 e2) = - hsep [ppr e1, text "-=", ppr e2] - ppr (StmtTimesEq e1 e2) = - hsep [ppr e1, text "*=", ppr e2] - ppr (StmtDivideEq e1 e2) = - hsep [ppr e1, text "/=", ppr e2] - ppr (StmtBXorEq e1 e2) = - hsep [ppr e1, text "^=", ppr e2] - ppr (StmtBAndEq e1 e2) = - hsep [ppr e1, text "&=", ppr e2] - ppr (StmtBOrEq e1 e2) = - hsep [ppr e1, text "|=", ppr e2] - ppr (StmtModEq e1 e2) = - hsep [ppr e1, text "%=", ppr e2] - ppr (StmtBNotEq e1) = - hsep [ppr e1, text "~="] ppr (Let c n ty m) = text "let" <+> ppr n <+> pprOptTy c ty <+> pprInitOpt m ppr (Block body) = @@ -337,15 +335,6 @@ instance Pretty Stmt where pprForClause :: Stmt -> Doc pprForClause (Assign n e) = ppr n <+> equals <+> ppr e -pprForClause (StmtPlusEq e1 e2) = hsep [ppr e1, text "+=", ppr e2] -pprForClause (StmtMinusEq e1 e2) = hsep [ppr e1, text "-=", ppr e2] -pprForClause (StmtTimesEq e1 e2) = hsep [ppr e1, text "*=", ppr e2] -pprForClause (StmtDivideEq e1 e2) = hsep [ppr e1, text "/=", ppr e2] -pprForClause (StmtBXorEq e1 e2) = hsep [ppr e1, text "^=", ppr e2] -pprForClause (StmtBAndEq e1 e2) = hsep [ppr e1, text "&=", ppr e2] -pprForClause (StmtBOrEq e1 e2) = hsep [ppr e1, text "|=", ppr e2] -pprForClause (StmtModEq e1 e2) = hsep [ppr e1, text "%=", ppr e2] -pprForClause (StmtBNotEq e1) = hsep [ppr e1, text "~="] pprForClause (Let ct n ty m) = text "let" <+> ppr n <+> pprOptTy ct ty <+> pprForInitOpt m pprForClause (StmtExp e) = ppr e pprForClause EmptyStmt = empty @@ -413,42 +402,6 @@ instance Pretty Exp where ppr e1 <> brackets (ppr e2) ppr (ExpArray es) = brackets (commaSep (map ppr es)) - ppr (ExpPlus e1 e2) = - hsep [ppr e1, text "+", ppr e2] - ppr (ExpMinus e1 e2) = - hsep [ppr e1, text "-", ppr e2] - ppr (ExpTimes e1 e2) = - hsep [ppr e1, text "*", ppr e2] - ppr (ExpDivide e1 e2) = - hsep [ppr e1, text "/", ppr e2] - ppr (ExpModulo e1 e2) = - hsep [ppr e1, text "%", ppr e2] - ppr (ExpBXor e1 e2) = - hsep [ppr e1, text "^", ppr e2] - ppr (ExpBAnd e1 e2) = - hsep [ppr e1, text "&", ppr e2] - ppr (ExpBOr e1 e2) = - hsep [ppr e1, text "|", ppr e2] - ppr (ExpLT e1 e2) = - hsep [ppr e1, text "<", ppr e2] - ppr (ExpGT e1 e2) = - hsep [ppr e1, text ">", ppr e2] - ppr (ExpLE e1 e2) = - hsep [ppr e1, text "<=", ppr e2] - ppr (ExpGE e1 e2) = - hsep [ppr e1, text ">=", ppr e2] - ppr (ExpEE e1 e2) = - hsep [ppr e1, text "==", ppr e2] - ppr (ExpNE e1 e2) = - hsep [ppr e1, text "!=", ppr e2] - ppr (ExpLAnd e1 e2) = - hsep [ppr e1, text "&&", ppr e2] - ppr (ExpLOr e1 e2) = - hsep [ppr e1, text "||", ppr e2] - ppr (ExpLNot e1) = - hsep [text "!", ppr e1] - ppr (ExpBNot e1) = - hsep [text "~", ppr e1] ppr (ExpCond e1 e2 e3) = hsep [ text "if", diff --git a/src/Solcore/Frontend/Syntax/NameResolution.hs b/src/Solcore/Frontend/Syntax/NameResolution.hs index 183413f96..b8efea864 100644 --- a/src/Solcore/Frontend/Syntax/NameResolution.hs +++ b/src/Solcore/Frontend/Syntax/NameResolution.hs @@ -32,9 +32,10 @@ nameResolutionTopDeclSegments :: IO (Either CompilerError (CompUnit Name, [[TopDecl Name]])) nameResolutionTopDeclSegments imps segments = do - let ds = concat segments + let segments' = map (filter (not . isOperatorTopDecl)) segments + ds = concat segments' genv = addImportsToEnv imps (globalEnv ds) - r <- runResolveM (mapM resolve segments) genv + r <- runResolveM (mapM resolve segments') genv case r of Left err -> pure (Left err) Right resolvedSegments -> @@ -53,7 +54,23 @@ resolveModulePath (S.ExternalPath libName path) = ExternalPath libName path resolveItemSelector :: S.ItemSelector -> ItemSelector resolveItemSelector (S.SelectItems items hidden) = - SelectItems (map resolveSelectorEntry items) hidden + SelectItems (map resolveSelectorEntry (filter (not . isOperatorSelectorEntry) items)) hidden + +isOperatorTopDecl :: S.TopDecl -> Bool +isOperatorTopDecl (S.TOperatorDecl _) = True +isOperatorTopDecl _ = False + +isOperatorContractDecl :: S.ContractDecl -> Bool +isOperatorContractDecl (S.COperatorDecl _) = True +isOperatorContractDecl _ = False + +isOperatorSelectorEntry :: S.ItemSelectorEntry -> Bool +isOperatorSelectorEntry (S.SelectOperator _) = True +isOperatorSelectorEntry _ = False + +isOperatorExportSpec :: S.ExportSpec -> Bool +isOperatorExportSpec (S.ExportOperator _) = True +isOperatorExportSpec _ = False resolveConstructorSelector :: S.ConstructorSelector -> ConstructorSelector resolveConstructorSelector (S.SelectConstructors names) = @@ -205,7 +222,7 @@ instance Resolve S.TopDecl where resolveExport :: S.Export -> Export resolveExport (S.ExportList items) = - ExportList (map resolveExportSpec items) + ExportList (map resolveExportSpec (filter (not . isOperatorExportSpec) items)) resolveExport (S.ExportModule path) = ExportModule (resolveModulePath path) resolveExport (S.ExportModuleAs path asName) = @@ -220,12 +237,13 @@ instance Resolve S.Contract where do let ns = map tyconName vs locals = [tn | S.CDataDecl (S.DataTy tn _ _ _) <- decls] + decls' = filter (not . isOperatorContractDecl) decls savedC <- gets currentContract savedL <- gets contractLocalTypes modify (\env -> env {currentContract = Just n, contractLocalTypes = locals}) mapM_ addTyVar ns - mapM_ addContractDecl decls - result <- Contract n (map TVar ns) <$> resolve decls `wrapError` c + mapM_ addContractDecl decls' + result <- Contract n (map TVar ns) <$> resolve decls' `wrapError` c modify (\env -> env {currentContract = savedC, contractLocalTypes = savedL}) pure result @@ -394,24 +412,6 @@ instance Resolve S.Stmt where lhs' <- resolve lhs `wrapError` s rhs' <- resolve rhs `wrapError` s pure (lhs' := rhs') - resolve s@(S.StmtPlusEq lhs rhs) = - locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpPlus lhs rhs)) - resolve s@(S.StmtMinusEq lhs rhs) = - locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpMinus lhs rhs)) - resolve s@(S.StmtTimesEq lhs rhs) = - locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpTimes lhs rhs)) - resolve s@(S.StmtDivideEq lhs rhs) = - locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpDivide lhs rhs)) - resolve s@(S.StmtBXorEq lhs rhs) = - locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpBXor lhs rhs)) - resolve s@(S.StmtBAndEq lhs rhs) = - locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpBAnd lhs rhs)) - resolve s@(S.StmtBOrEq lhs rhs) = - locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpBOr lhs rhs)) - resolve s@(S.StmtModEq lhs rhs) = - locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpModulo lhs rhs)) - resolve s@(S.StmtBNotEq lhs) = - locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpBNot lhs)) resolve s@(S.Let c n mt me) = locatedLike s locatedStmt <$> do mt' <- resolve mt `wrapError` s @@ -831,102 +831,12 @@ resolveExp x@(S.ExpName me n es) = if hasQualified then unqualifiedConstructorError n else undefinedName n -resolveExp c@(S.ExpPlus e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Add") "add" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpMinus e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Sub") "sub" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpTimes e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Mul") "mul" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpDivide e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Div") "div" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpModulo e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Mod") "mod" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpBXor e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "BitXor") "bxor" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpBAnd e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "BitAnd") "band" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpBOr e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "BitOr") "bor" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpBNot e) = - do - e' <- resolve e `wrapError` c - let fun = QualName (Name "BitNot") "bnot" - pure $ Call Nothing fun [e'] resolveExp c@(S.ExpIndexed array idx) = do arr' <- resolve array `wrapError` c idx' <- resolve idx `wrapError` c pure $ Indexed arr' idx' resolveExp c@(S.ExpArray es) = ArrayLit <$> resolve es `wrapError` c -resolveExp c@(S.ExpLT e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "lt") [e1', e2'] -resolveExp c@(S.ExpGT e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Ord") "gt" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpLE e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "le") [e1', e2'] -resolveExp c@(S.ExpGE e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "ge") [e1', e2'] -resolveExp c@(S.ExpEE e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Eq") "eq" - pure $ Call Nothing fun [e1', e2'] -resolveExp c@(S.ExpNE e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "ne") [e1', e2'] -resolveExp c@(S.ExpLAnd e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "and") [e1', e2'] -resolveExp c@(S.ExpLOr e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "or") [e1', e2'] -resolveExp c@(S.ExpLNot e) = do - e' <- resolve e `wrapError` c - pure $ Call Nothing (Name "not") [e'] resolveExp (S.ExpCond e1 e2 e3) = Cond <$> resolve e1 <*> resolve e2 <*> resolve e3 resolveExp (S.ExpAt t) = do diff --git a/src/Solcore/Frontend/Syntax/SyntaxTree.hs b/src/Solcore/Frontend/Syntax/SyntaxTree.hs index 3e37b19ad..d708fda79 100644 --- a/src/Solcore/Frontend/Syntax/SyntaxTree.hs +++ b/src/Solcore/Frontend/Syntax/SyntaxTree.hs @@ -29,6 +29,7 @@ data TopDecl | TSym TySym | TExportDecl Export | TPragmaDecl Pragma + | TOperatorDecl OperatorDecl deriving (Eq, Ord, Show, Data, Typeable) -- empty list in pragma: restriction on all class / instances @@ -53,6 +54,22 @@ data Pragma } deriving (Eq, Ord, Show, Data, Typeable) +data OpFixity + = OpInfixL + | OpInfixR + | OpInfixN + | OpPrefix + | OpPostfix + deriving (Eq, Ord, Show, Data, Typeable) + +data OperatorDecl = OperatorDecl + { opFixity :: OpFixity, + opPrec :: Int, + opSymbol :: String, + opFunction :: Name + } + deriving (Eq, Ord, Show, Data, Typeable) + data ModulePath = RelativePath Name | LibraryPath Name @@ -76,6 +93,7 @@ data ExportSpec | ExportNameWithConstructors Name ConstructorSelector | ExportAll | ExportModuleAll ModulePath + | ExportOperator String deriving (Eq, Ord, Show, Data, Typeable) data ExportSelector @@ -102,6 +120,7 @@ data ItemSelectorEntry = SelectAllItems | SelectItem Name | SelectItemAs Name Name + | SelectOperator String deriving (Eq, Ord, Show, Data, Typeable) -- definition of the contract structure @@ -257,6 +276,7 @@ data ContractDecl | CFieldDecl Field | CFunDecl FunDef | CConstrDecl Constructor + | COperatorDecl OperatorDecl deriving (Eq, Ord, Show, Data, Typeable) instance HasSourceSpan CompUnit where @@ -272,6 +292,7 @@ instance HasSourceSpan TopDecl where sourceSpanOf (TSym tySym) = sourceSpanOf tySym sourceSpanOf (TExportDecl exportDecl) = sourceSpanOf exportDecl sourceSpanOf (TPragmaDecl pragma) = sourceSpanOf pragma + sourceSpanOf (TOperatorDecl _) = Nothing instance HasSourceSpan Pragma where sourceSpanOf (Pragma _ status) = sourceSpanOf status @@ -301,6 +322,7 @@ instance HasSourceSpan ExportSpec where firstSourceSpan [sourceSpanOf typeName, sourceSpanOf selector] sourceSpanOf ExportAll = Nothing sourceSpanOf (ExportModuleAll modulePath) = sourceSpanOf modulePath + sourceSpanOf (ExportOperator _) = Nothing instance HasSourceSpan ConstructorSelector where sourceSpanOf (SelectConstructors names) = sourceSpanOf names @@ -331,6 +353,7 @@ instance HasSourceSpan ItemSelectorEntry where sourceSpanOf (SelectItem n) = sourceSpanOf n sourceSpanOf (SelectItemAs n aliasName) = firstSourceSpan [sourceSpanOf n, sourceSpanOf aliasName] + sourceSpanOf (SelectOperator _) = Nothing instance HasSourceSpan Contract where sourceSpanOf (Contract n tyParams' contractDecls) = @@ -377,6 +400,7 @@ instance HasSourceSpan ContractDecl where sourceSpanOf (CFieldDecl field) = sourceSpanOf field sourceSpanOf (CFunDecl funDef) = sourceSpanOf funDef sourceSpanOf (CConstrDecl constructor) = sourceSpanOf constructor + sourceSpanOf (COperatorDecl _) = Nothing -- definition of statements @@ -386,15 +410,6 @@ type Equations = [Equation] data Stmt = AssignWithLocation NodeLocation Exp Exp -- assignment - | StmtPlusEqWithLocation NodeLocation Exp Exp -- e1 += e2 - | StmtMinusEqWithLocation NodeLocation Exp Exp -- e1 -= e2 - | StmtTimesEqWithLocation NodeLocation Exp Exp -- e1 *= e2 - | StmtDivideEqWithLocation NodeLocation Exp Exp -- e1 /= e2 - | StmtBXorEqWithLocation NodeLocation Exp Exp -- e1 ^= e2 - | StmtBAndEqWithLocation NodeLocation Exp Exp -- e1 &= e2 - | StmtBOrEqWithLocation NodeLocation Exp Exp -- e1 |= e2 - | StmtModEqWithLocation NodeLocation Exp Exp -- e1 %= e2 - | StmtBNotEqWithLocation NodeLocation Exp -- e ~= (in-place bitwise NOT, i.e. e := ~e) | LetWithLocation NodeLocation Bool Name (Maybe Ty) (Maybe Exp) -- local variable; Bool is True when 'comptime' modifier is present | BlockWithLocation NodeLocation Body -- lexical block | StmtExpWithLocation NodeLocation Exp -- expression level statements @@ -413,51 +428,6 @@ pattern Assign lhs rhs <- AssignWithLocation _ lhs rhs where Assign lhs rhs = AssignWithLocation unlocatedNode lhs rhs -pattern StmtPlusEq :: Exp -> Exp -> Stmt -pattern StmtPlusEq lhs rhs <- StmtPlusEqWithLocation _ lhs rhs - where - StmtPlusEq lhs rhs = StmtPlusEqWithLocation unlocatedNode lhs rhs - -pattern StmtMinusEq :: Exp -> Exp -> Stmt -pattern StmtMinusEq lhs rhs <- StmtMinusEqWithLocation _ lhs rhs - where - StmtMinusEq lhs rhs = StmtMinusEqWithLocation unlocatedNode lhs rhs - -pattern StmtTimesEq :: Exp -> Exp -> Stmt -pattern StmtTimesEq lhs rhs <- StmtTimesEqWithLocation _ lhs rhs - where - StmtTimesEq lhs rhs = StmtTimesEqWithLocation unlocatedNode lhs rhs - -pattern StmtDivideEq :: Exp -> Exp -> Stmt -pattern StmtDivideEq lhs rhs <- StmtDivideEqWithLocation _ lhs rhs - where - StmtDivideEq lhs rhs = StmtDivideEqWithLocation unlocatedNode lhs rhs - -pattern StmtBXorEq :: Exp -> Exp -> Stmt -pattern StmtBXorEq lhs rhs <- StmtBXorEqWithLocation _ lhs rhs - where - StmtBXorEq lhs rhs = StmtBXorEqWithLocation unlocatedNode lhs rhs - -pattern StmtBAndEq :: Exp -> Exp -> Stmt -pattern StmtBAndEq lhs rhs <- StmtBAndEqWithLocation _ lhs rhs - where - StmtBAndEq lhs rhs = StmtBAndEqWithLocation unlocatedNode lhs rhs - -pattern StmtBOrEq :: Exp -> Exp -> Stmt -pattern StmtBOrEq lhs rhs <- StmtBOrEqWithLocation _ lhs rhs - where - StmtBOrEq lhs rhs = StmtBOrEqWithLocation unlocatedNode lhs rhs - -pattern StmtModEq :: Exp -> Exp -> Stmt -pattern StmtModEq lhs rhs <- StmtModEqWithLocation _ lhs rhs - where - StmtModEq lhs rhs = StmtModEqWithLocation unlocatedNode lhs rhs - -pattern StmtBNotEq :: Exp -> Stmt -pattern StmtBNotEq lhs <- StmtBNotEqWithLocation _ lhs - where - StmtBNotEq lhs = StmtBNotEqWithLocation unlocatedNode lhs - pattern Let :: Bool -> Name -> Maybe Ty -> Maybe Exp -> Stmt pattern Let ct n ty value <- LetWithLocation _ ct n ty value where @@ -513,7 +483,7 @@ pattern EmptyStmt <- EmptyStmtWithLocation _ where EmptyStmt = EmptyStmtWithLocation unlocatedNode -{-# COMPLETE Assign, StmtPlusEq, StmtMinusEq, StmtTimesEq, StmtDivideEq, StmtBXorEq, StmtBAndEq, StmtBOrEq, StmtModEq, StmtBNotEq, Let, Block, StmtExp, Return, Match, Asm, If, For, Break, Continue, EmptyStmt #-} +{-# COMPLETE Assign, Let, Block, StmtExp, Return, Match, Asm, If, For, Break, Continue, EmptyStmt #-} type Body = [Stmt] @@ -521,33 +491,6 @@ locatedStmt :: SourceSpan -> Stmt -> Stmt locatedStmt sourceSpan (Assign lhs rhs) = AssignWithLocation location lhs rhs where location = locatedNode sourceSpan -locatedStmt sourceSpan (StmtPlusEq lhs rhs) = StmtPlusEqWithLocation location lhs rhs - where - location = locatedNode sourceSpan -locatedStmt sourceSpan (StmtMinusEq lhs rhs) = StmtMinusEqWithLocation location lhs rhs - where - location = locatedNode sourceSpan -locatedStmt sourceSpan (StmtTimesEq lhs rhs) = StmtTimesEqWithLocation location lhs rhs - where - location = locatedNode sourceSpan -locatedStmt sourceSpan (StmtDivideEq lhs rhs) = StmtDivideEqWithLocation location lhs rhs - where - location = locatedNode sourceSpan -locatedStmt sourceSpan (StmtBXorEq lhs rhs) = StmtBXorEqWithLocation location lhs rhs - where - location = locatedNode sourceSpan -locatedStmt sourceSpan (StmtBAndEq lhs rhs) = StmtBAndEqWithLocation location lhs rhs - where - location = locatedNode sourceSpan -locatedStmt sourceSpan (StmtBOrEq lhs rhs) = StmtBOrEqWithLocation location lhs rhs - where - location = locatedNode sourceSpan -locatedStmt sourceSpan (StmtModEq lhs rhs) = StmtModEqWithLocation location lhs rhs - where - location = locatedNode sourceSpan -locatedStmt sourceSpan (StmtBNotEq lhs) = StmtBNotEqWithLocation location lhs - where - location = locatedNode sourceSpan locatedStmt sourceSpan (Let ct n ty value) = LetWithLocation location ct n ty value where location = locatedNode sourceSpan @@ -565,24 +508,6 @@ locatedStmt sourceSpan EmptyStmt = EmptyStmtWithLocation (locatedNode sourceSpan instance HasSourceSpan Stmt where sourceSpanOf (AssignWithLocation location lhs rhs) = firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (StmtPlusEqWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (StmtMinusEqWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (StmtTimesEqWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (StmtDivideEqWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (StmtBXorEqWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (StmtBAndEqWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (StmtBOrEqWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (StmtModEqWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (StmtBNotEqWithLocation location lhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs] sourceSpanOf (LetWithLocation location _ n ty value) = firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf ty, sourceSpanOf value] sourceSpanOf (BlockWithLocation location body) = @@ -628,24 +553,6 @@ data Exp | TyExpWithLocation NodeLocation Exp Ty -- type annotation expression | ExpIndexedWithLocation NodeLocation Exp Exp -- e1[e2] | ExpArrayWithLocation NodeLocation [Exp] -- [e1, ..., en] - | ExpPlusWithLocation NodeLocation Exp Exp -- e1 + e2 - | ExpMinusWithLocation NodeLocation Exp Exp -- e1 - e2 - | ExpTimesWithLocation NodeLocation Exp Exp -- e1 * e2 - | ExpDivideWithLocation NodeLocation Exp Exp -- e1 / e2 - | ExpModuloWithLocation NodeLocation Exp Exp -- e1 % e2 - | ExpBXorWithLocation NodeLocation Exp Exp -- e1 ^ e2 - | ExpBAndWithLocation NodeLocation Exp Exp -- e1 & e2 - | ExpBOrWithLocation NodeLocation Exp Exp -- e1 | e2 - | ExpLTWithLocation NodeLocation Exp Exp -- e1 < e2 - | ExpGTWithLocation NodeLocation Exp Exp -- e1 > e2 - | ExpLEWithLocation NodeLocation Exp Exp -- e1 <= e2 - | ExpGEWithLocation NodeLocation Exp Exp -- e1 >= e2 - | ExpEEWithLocation NodeLocation Exp Exp -- e1 == e2 - | ExpNEWithLocation NodeLocation Exp Exp -- e1 != e2 - | ExpLAndWithLocation NodeLocation Exp Exp -- e1 && e2 - | ExpLOrWithLocation NodeLocation Exp Exp -- e1 || e2 - | ExpLNotWithLocation NodeLocation Exp -- ! e - | ExpBNotWithLocation NodeLocation Exp -- ~ e | ExpCondWithLocation NodeLocation Exp Exp Exp -- if e1 then e2 else e3 | ExpAtWithLocation NodeLocation Ty -- proxy sugar deriving (Eq, Ord, Show, Data, Typeable) @@ -690,96 +597,6 @@ pattern ExpArray es <- ExpArrayWithLocation _ es where ExpArray es = ExpArrayWithLocation unlocatedNode es -pattern ExpPlus :: Exp -> Exp -> Exp -pattern ExpPlus lhs rhs <- ExpPlusWithLocation _ lhs rhs - where - ExpPlus lhs rhs = ExpPlusWithLocation unlocatedNode lhs rhs - -pattern ExpMinus :: Exp -> Exp -> Exp -pattern ExpMinus lhs rhs <- ExpMinusWithLocation _ lhs rhs - where - ExpMinus lhs rhs = ExpMinusWithLocation unlocatedNode lhs rhs - -pattern ExpTimes :: Exp -> Exp -> Exp -pattern ExpTimes lhs rhs <- ExpTimesWithLocation _ lhs rhs - where - ExpTimes lhs rhs = ExpTimesWithLocation unlocatedNode lhs rhs - -pattern ExpDivide :: Exp -> Exp -> Exp -pattern ExpDivide lhs rhs <- ExpDivideWithLocation _ lhs rhs - where - ExpDivide lhs rhs = ExpDivideWithLocation unlocatedNode lhs rhs - -pattern ExpModulo :: Exp -> Exp -> Exp -pattern ExpModulo lhs rhs <- ExpModuloWithLocation _ lhs rhs - where - ExpModulo lhs rhs = ExpModuloWithLocation unlocatedNode lhs rhs - -pattern ExpBXor :: Exp -> Exp -> Exp -pattern ExpBXor lhs rhs <- ExpBXorWithLocation _ lhs rhs - where - ExpBXor lhs rhs = ExpBXorWithLocation unlocatedNode lhs rhs - -pattern ExpBAnd :: Exp -> Exp -> Exp -pattern ExpBAnd lhs rhs <- ExpBAndWithLocation _ lhs rhs - where - ExpBAnd lhs rhs = ExpBAndWithLocation unlocatedNode lhs rhs - -pattern ExpBOr :: Exp -> Exp -> Exp -pattern ExpBOr lhs rhs <- ExpBOrWithLocation _ lhs rhs - where - ExpBOr lhs rhs = ExpBOrWithLocation unlocatedNode lhs rhs - -pattern ExpLT :: Exp -> Exp -> Exp -pattern ExpLT lhs rhs <- ExpLTWithLocation _ lhs rhs - where - ExpLT lhs rhs = ExpLTWithLocation unlocatedNode lhs rhs - -pattern ExpGT :: Exp -> Exp -> Exp -pattern ExpGT lhs rhs <- ExpGTWithLocation _ lhs rhs - where - ExpGT lhs rhs = ExpGTWithLocation unlocatedNode lhs rhs - -pattern ExpLE :: Exp -> Exp -> Exp -pattern ExpLE lhs rhs <- ExpLEWithLocation _ lhs rhs - where - ExpLE lhs rhs = ExpLEWithLocation unlocatedNode lhs rhs - -pattern ExpGE :: Exp -> Exp -> Exp -pattern ExpGE lhs rhs <- ExpGEWithLocation _ lhs rhs - where - ExpGE lhs rhs = ExpGEWithLocation unlocatedNode lhs rhs - -pattern ExpEE :: Exp -> Exp -> Exp -pattern ExpEE lhs rhs <- ExpEEWithLocation _ lhs rhs - where - ExpEE lhs rhs = ExpEEWithLocation unlocatedNode lhs rhs - -pattern ExpNE :: Exp -> Exp -> Exp -pattern ExpNE lhs rhs <- ExpNEWithLocation _ lhs rhs - where - ExpNE lhs rhs = ExpNEWithLocation unlocatedNode lhs rhs - -pattern ExpLAnd :: Exp -> Exp -> Exp -pattern ExpLAnd lhs rhs <- ExpLAndWithLocation _ lhs rhs - where - ExpLAnd lhs rhs = ExpLAndWithLocation unlocatedNode lhs rhs - -pattern ExpLOr :: Exp -> Exp -> Exp -pattern ExpLOr lhs rhs <- ExpLOrWithLocation _ lhs rhs - where - ExpLOr lhs rhs = ExpLOrWithLocation unlocatedNode lhs rhs - -pattern ExpLNot :: Exp -> Exp -pattern ExpLNot exp <- ExpLNotWithLocation _ exp - where - ExpLNot exp = ExpLNotWithLocation unlocatedNode exp - -pattern ExpBNot :: Exp -> Exp -pattern ExpBNot exp <- ExpBNotWithLocation _ exp - where - ExpBNot exp = ExpBNotWithLocation unlocatedNode exp - pattern ExpCond :: Exp -> Exp -> Exp -> Exp pattern ExpCond cond thenExp elseExp <- ExpCondWithLocation _ cond thenExp elseExp where @@ -790,7 +607,7 @@ pattern ExpAt ty <- ExpAtWithLocation _ ty where ExpAt ty = ExpAtWithLocation unlocatedNode ty -{-# COMPLETE Lit, ExpName, ExpVar, ExpDotName, Lam, TyExp, ExpIndexed, ExpArray, ExpPlus, ExpMinus, ExpTimes, ExpDivide, ExpModulo, ExpBXor, ExpBAnd, ExpBOr, ExpLT, ExpGT, ExpLE, ExpGE, ExpEE, ExpNE, ExpLAnd, ExpLOr, ExpLNot, ExpBNot, ExpCond, ExpAt #-} +{-# COMPLETE Lit, ExpName, ExpVar, ExpDotName, Lam, TyExp, ExpIndexed, ExpArray, ExpCond, ExpAt #-} locatedExp :: SourceSpan -> Exp -> Exp locatedExp sourceSpan (Lit lit) = LitWithLocation location lit @@ -803,24 +620,6 @@ locatedExp sourceSpan (Lam ps body ty) = LamWithLocation (locatedNode sourceSpan locatedExp sourceSpan (TyExp exp ty) = TyExpWithLocation (locatedNode sourceSpan) exp ty locatedExp sourceSpan (ExpIndexed lhs rhs) = ExpIndexedWithLocation (locatedNode sourceSpan) lhs rhs locatedExp sourceSpan (ExpArray es) = ExpArrayWithLocation (locatedNode sourceSpan) es -locatedExp sourceSpan (ExpPlus lhs rhs) = ExpPlusWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpMinus lhs rhs) = ExpMinusWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpTimes lhs rhs) = ExpTimesWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpDivide lhs rhs) = ExpDivideWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpModulo lhs rhs) = ExpModuloWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpBXor lhs rhs) = ExpBXorWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpBAnd lhs rhs) = ExpBAndWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpBOr lhs rhs) = ExpBOrWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpLT lhs rhs) = ExpLTWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpGT lhs rhs) = ExpGTWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpLE lhs rhs) = ExpLEWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpGE lhs rhs) = ExpGEWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpEE lhs rhs) = ExpEEWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpNE lhs rhs) = ExpNEWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpLAnd lhs rhs) = ExpLAndWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpLOr lhs rhs) = ExpLOrWithLocation (locatedNode sourceSpan) lhs rhs -locatedExp sourceSpan (ExpLNot exp) = ExpLNotWithLocation (locatedNode sourceSpan) exp -locatedExp sourceSpan (ExpBNot exp) = ExpBNotWithLocation (locatedNode sourceSpan) exp locatedExp sourceSpan (ExpCond cond thenExp elseExp) = ExpCondWithLocation (locatedNode sourceSpan) cond thenExp elseExp locatedExp sourceSpan (ExpAt ty) = ExpAtWithLocation (locatedNode sourceSpan) ty @@ -840,42 +639,6 @@ instance HasSourceSpan Exp where firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] sourceSpanOf (ExpArrayWithLocation location es) = firstSourceSpan [sourceSpanOf location, sourceSpanOf es] - sourceSpanOf (ExpPlusWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpMinusWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpTimesWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpDivideWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpModuloWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpBXorWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpBAndWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpBOrWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpLTWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpGTWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpLEWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpGEWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpEEWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpNEWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpLAndWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpLOrWithLocation location lhs rhs) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] - sourceSpanOf (ExpLNotWithLocation location exp) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf exp] - sourceSpanOf (ExpBNotWithLocation location exp) = - firstSourceSpan [sourceSpanOf location, sourceSpanOf exp] sourceSpanOf (ExpCondWithLocation location cond thenExp elseExp) = firstSourceSpan [sourceSpanOf location, sourceSpanOf cond, sourceSpanOf thenExp, sourceSpanOf elseExp] sourceSpanOf (ExpAtWithLocation location ty) = diff --git a/std/std.solc b/std/std.solc index 5a4121eba..36ecd1406 100644 --- a/std/std.solc +++ b/std/std.solc @@ -3,6 +3,35 @@ import std.opcodes.{add, sub, mul, div, mod, addmod as addmod_, mulmod as mulmod pragma no-patterson-condition ABIEncode, Num, Array, ArrayPush, Eq, Ord; pragma no-coverage-condition ABIDecode, MemoryType, Array, ArrayPush, RValueIdxAccess; +// Built-in operators are defined here, not in the compiler. Each declaration +// binds an operator symbol to an existing class method or function; a use of +// the operator is a plain call to that function. Precedences match the values +// the compiler previously hard-coded, so parsing/associativity is unchanged. +prefix 90 (!) => not; +prefix 90 (~) => BitNot.bnot; + +infixl 50 (*) => Mul.mul; +infixl 50 (/) => Div.div; +infixl 50 (%) => Mod.mod; + +infixl 45 (+) => Add.add; +infixl 45 (-) => Sub.sub; + +infixl 44 (&) => BitAnd.band; +infixl 43 (^) => BitXor.bxor; +infixl 42 (|) => BitOr.bor; + +infix 35 (<=) => le; +infix 35 (>=) => ge; +infix 35 (<) => lt; +infix 35 (>) => Ord.gt; + +infix 34 (==) => Eq.eq; +infix 34 (!=) => ne; + +infixl 20 (&&) => and; +infixl 10 (||) => or; + export { ABIAttribs, ABIDecode, @@ -137,7 +166,24 @@ export { tobool, uint256(*), unimplemented, - zeroize_memory + zeroize_memory, + (!), + (*), + (/), + (%), + (+), + (-), + (&), + (^), + (|), + (<=), + (>=), + (<), + (>), + (==), + (!=), + (&&), + (||) }; /* diff --git a/test/LocationTests.hs b/test/LocationTests.hs index 095cec778..1475f9193 100644 --- a/test/LocationTests.hs +++ b/test/LocationTests.hs @@ -154,7 +154,7 @@ locatedSource = unlines [ "data Bool = True | False;", "function main(x : word) -> word {", - " let y : word = x + 1;", + " let y : word = inc(x);", " let zs : word = [x, y][0];", " match Bool.True {", " | Bool.True => return y;", diff --git a/test/Main.hs b/test/Main.hs index 3b6d370e1..2d627876a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,6 +8,7 @@ import HullCases import LocationTests import MatchCompilerTests import ModuleTypeCheckTests +import OperatorTests import ParserTests import SpecialiseTests import Test.Tasty @@ -40,5 +41,6 @@ tests = matchTests, yulEvalTests, hullTests, - specialiseTests + specialiseTests, + operatorTests ] diff --git a/test/OperatorTests.hs b/test/OperatorTests.hs new file mode 100644 index 000000000..5f5365e20 --- /dev/null +++ b/test/OperatorTests.hs @@ -0,0 +1,92 @@ +module OperatorTests (operatorTests) where + +import Cases (runTestExpectingFailureWith, runTestForFileWith) +import Solcore.Pipeline.Options (Option (..), stdOpt) +import Test.Tasty + +operatorTests :: TestTree +operatorTests = + testGroup + "User-defined operators" + [ basicTests, + precedenceTests, + associativityTests, + prefixTests, + compoundAssignTests, + lambdaTests, + importTests, + errorTests + ] + +opFolder :: FilePath +opFolder = "./test/operators" + +-- Run a test that is expected to succeed. +runOpSuccess :: FilePath -> TestTree +runOpSuccess file = runTestForFileWith opt file opFolder + where + opt = stdOpt {optNoGenDispatch = True} + +-- Run a test that is expected to fail (parse or compilation error). +runOpFailure :: FilePath -> TestTree +runOpFailure file = runTestExpectingFailureWith opt file opFolder + where + opt = stdOpt {optNoGenDispatch = True} + +basicTests :: TestTree +basicTests = + testGroup + "Basic declaration and use" + [ runOpSuccess "basic.solc" + ] + +precedenceTests :: TestTree +precedenceTests = + testGroup + "Operator precedence" + [ runOpSuccess "precedence.solc", + runOpSuccess "multi-op.solc" + ] + +associativityTests :: TestTree +associativityTests = + testGroup + "Associativity" + [ runOpSuccess "infixl.solc", + runOpSuccess "infixr.solc" + ] + +prefixTests :: TestTree +prefixTests = + testGroup + "Prefix operators" + [ runOpSuccess "prefix.solc" + ] + +compoundAssignTests :: TestTree +compoundAssignTests = + testGroup + "Compound assignment sugar (*=, /=, ~=)" + [ runOpSuccess "compound-assign.solc" + ] + +lambdaTests :: TestTree +lambdaTests = + testGroup + "Operators inside lambda bodies" + [ runOpSuccess "in-lambda.solc" + ] + +importTests :: TestTree +importTests = + testGroup + "Import and export of operators" + [ runOpSuccess "import-op.solc" + ] + +errorTests :: TestTree +errorTests = + testGroup + "Error cases" + [ runOpFailure "undeclared-fail.solc" + ] diff --git a/test/ParserTests.hs b/test/ParserTests.hs index 761e34bde..73c2483b5 100644 --- a/test/ParserTests.hs +++ b/test/ParserTests.hs @@ -28,7 +28,28 @@ parseFails p src = Right got -> assertFailure ("Expected failure but parsed: " ++ show got) expP :: Parser Exp -expP = exprP bodyP +expP = exprP [] (bodyP []) + +-- A small operator table mirroring the standard-library declarations, for the +-- few statement/declaration tests whose sample code uses operators. A use of an +-- operator parses to a plain call of the bound function. +testOps :: [OperatorDecl] +testOps = + [ OperatorDecl OpInfixL 50 "*" (QualName (Name "Mul") "mul"), + OperatorDecl OpInfixL 50 "/" (QualName (Name "Div") "div"), + OperatorDecl OpInfixL 45 "+" (QualName (Name "Add") "add"), + OperatorDecl OpInfixL 45 "-" (QualName (Name "Sub") "sub"), + OperatorDecl OpInfixN 35 "<" (Name "lt"), + OperatorDecl OpInfixN 34 "==" (QualName (Name "Eq") "eq"), + OperatorDecl OpPrefix 90 "~" (QualName (Name "BitNot") "bnot") + ] + +stmtPO :: Parser Stmt +stmtPO = stmtP testOps + +-- Expected AST for a binary operator use `a b`: a plain call of `fun`. +opCall :: Name -> Exp -> Exp -> Exp +opCall fun a b = ExpName Nothing fun [a, b] parserTests :: TestTree parserTests = @@ -108,29 +129,29 @@ patternTests = testGroup "Patterns" [ testCase "wildcard" $ - parsesAs patP "_" PWildcard, + parsesAs (patP []) "_" PWildcard, testCase "integer literal" $ - parsesAs patP "42" (PLit (IntLit 42)), + parsesAs (patP []) "42" (PLit (IntLit 42)), testCase "string literal" $ - parsesAs patP "\"hi\"" (PLit (StrLit "hi")), + parsesAs (patP []) "\"hi\"" (PLit (StrLit "hi")), testCase "constructor no args" $ - parsesAs patP "True" (Pat "True" []), + parsesAs (patP []) "True" (Pat "True" []), testCase "constructor with one arg" $ - parsesAs patP "Some(x)" (Pat "Some" [Pat "x" []]), + parsesAs (patP []) "Some(x)" (Pat "Some" [Pat "x" []]), testCase "constructor with two args" $ - parsesAs patP "Pair(x,y)" (Pat "Pair" [Pat "x" [], Pat "y" []]), + parsesAs (patP []) "Pair(x,y)" (Pat "Pair" [Pat "x" [], Pat "y" []]), testCase "unit pattern" $ - parsesAs patP "()" (Pat "()" []), + parsesAs (patP []) "()" (Pat "()" []), testCase "parenthesized single pattern" $ - parsesAs patP "(x)" (Pat "x" []), + parsesAs (patP []) "(x)" (Pat "x" []), testCase "tuple pattern" $ - parsesAs patP "(x, y)" (Pat "pair" [Pat "x" [], Pat "y" []]), + parsesAs (patP []) "(x, y)" (Pat "pair" [Pat "x" [], Pat "y" []]), testCase "nested constructor" $ - parsesAs patP "Some(Pair(x,y))" (Pat "Some" [Pat "Pair" [Pat "x" [], Pat "y" []]]), + parsesAs (patP []) "Some(Pair(x,y))" (Pat "Some" [Pat "Pair" [Pat "x" [], Pat "y" []]]), testCase "dot pattern no args" $ - parsesAs patP ".None" (PatDot "None" []), + parsesAs (patP []) ".None" (PatDot "None" []), testCase "dot pattern with args" $ - parsesAs patP ".Some(x)" (PatDot "Some" [Pat "x" []]) + parsesAs (patP []) ".Some(x)" (PatDot "Some" [Pat "x" []]) ] lit :: Integer -> Exp @@ -157,52 +178,10 @@ exprTests = parsesAs expP "f(1)" (ExpName Nothing "f" [lit 1]), testCase "binary call" $ parsesAs expP "f(1, 2)" (ExpName Nothing "f" [lit 1, lit 2]), - testCase "addition" $ - parsesAs expP "1 + 2" (ExpPlus (lit 1) (lit 2)), - testCase "subtraction" $ - parsesAs expP "3 - 1" (ExpMinus (lit 3) (lit 1)), - testCase "multiplication" $ - parsesAs expP "2 * 3" (ExpTimes (lit 2) (lit 3)), - testCase "division" $ - parsesAs expP "6 / 2" (ExpDivide (lit 6) (lit 2)), - testCase "modulo" $ - parsesAs expP "5 % 3" (ExpModulo (lit 5) (lit 3)), - testCase "mul binds tighter than add" $ - parsesAs expP "1 + 2 * 3" (ExpPlus (lit 1) (ExpTimes (lit 2) (lit 3))), - testCase "add then mul" $ - parsesAs expP "1 * 2 + 3" (ExpPlus (ExpTimes (lit 1) (lit 2)) (lit 3)), - testCase "subtraction is left-associative" $ - parsesAs expP "3 - 2 - 1" (ExpMinus (ExpMinus (lit 3) (lit 2)) (lit 1)), - testCase "less-than" $ - parsesAs expP "x < y" (ExpLT (var "x") (var "y")), - testCase "greater-than" $ - parsesAs expP "x > y" (ExpGT (var "x") (var "y")), - testCase "less-than-or-equal" $ - parsesAs expP "x <= y" (ExpLE (var "x") (var "y")), - testCase "greater-than-or-equal" $ - parsesAs expP "x >= y" (ExpGE (var "x") (var "y")), - testCase "equality" $ - parsesAs expP "x == y" (ExpEE (var "x") (var "y")), - testCase "inequality" $ - parsesAs expP "x != y" (ExpNE (var "x") (var "y")), - testCase "arith tighter than comparison" $ - parsesAs - expP - "a + b == c + d" - (ExpEE (ExpPlus (var "a") (var "b")) (ExpPlus (var "c") (var "d"))), - testCase "logical and" $ - parsesAs expP "x && y" (ExpLAnd (var "x") (var "y")), - testCase "logical or" $ - parsesAs expP "x || y" (ExpLOr (var "x") (var "y")), - testCase "logical not" $ - parsesAs expP "!x" (ExpLNot (var "x")), - testCase "and binds tighter than or" $ - parsesAs expP "a || b && c" (ExpLOr (var "a") (ExpLAnd (var "b") (var "c"))), - testCase "comparison tighter than and" $ - parsesAs - expP - "a < b && c > d" - (ExpLAnd (ExpLT (var "a") (var "b")) (ExpGT (var "c") (var "d"))), + -- Operators are no longer built into the parser; they are ordinary + -- standard-library declarations. Their parsing (precedence, associativity, + -- desugaring to calls) is covered by OperatorTests and the test/operators + -- compile fixtures, so the built-in-operator unit cases were removed here. testCase "ternary operator" $ parsesAs expP "x ? 1 : 2" (ExpCond (var "x") (lit 1) (lit 2)), testCase "if-then-else expression" $ @@ -276,12 +255,12 @@ keywordPrefixTests = testGroup "Keyword prefixes" [ testCase "statement-initial assignment to keyword-prefixed name" $ - parsesAs stmtP "datavalue = 2;" (Assign (var "datavalue") (lit 2)), + parsesAs (stmtP []) "datavalue = 2;" (Assign (var "datavalue") (lit 2)), testCase "statement-initial expression with keyword-prefixed name" $ - parsesAs stmtP "datavalue;" (StmtExp (var "datavalue")), + parsesAs (stmtP []) "datavalue;" (StmtExp (var "datavalue")), testCase "contract field with keyword-prefixed name" $ parsesAs - topDeclP + (topDeclP []) "contract C { datavalue : word; }" (TContr (Contract "C" [] [CFieldDecl (Field "datavalue" word Nothing)])) ] @@ -291,108 +270,110 @@ stmtTests = testGroup "Statements" [ testCase "let no type no init" $ - parsesAs stmtP "let x;" (Let False "x" Nothing Nothing), + parsesAs (stmtP []) "let x;" (Let False "x" Nothing Nothing), testCase "let with type" $ - parsesAs stmtP "let x : word;" (Let False "x" (Just word) Nothing), + parsesAs (stmtP []) "let x : word;" (Let False "x" (Just word) Nothing), testCase "let with init" $ - parsesAs stmtP "let x = 42;" (Let False "x" Nothing (Just (lit 42))), + parsesAs (stmtP []) "let x = 42;" (Let False "x" Nothing (Just (lit 42))), testCase "let with type and init" $ - parsesAs stmtP "let x : word = 42;" (Let False "x" (Just word) (Just (lit 42))), + parsesAs (stmtP []) "let x : word = 42;" (Let False "x" (Just word) (Just (lit 42))), testCase "return literal" $ - parsesAs stmtP "return 0;" (Return (lit 0)), + parsesAs (stmtP []) "return 0;" (Return (lit 0)), testCase "return expression" $ - parsesAs stmtP "return x + 1;" (Return (ExpPlus (var "x") (lit 1))), + parsesAs stmtPO "return x + 1;" (Return (opCall (QualName (Name "Add") "add") (var "x") (lit 1))), testCase "assignment" $ - parsesAs stmtP "x = 1;" (Assign (var "x") (lit 1)), - testCase "plus-assign" $ - parsesAs stmtP "x += 1;" (StmtPlusEq (var "x") (lit 1)), - testCase "minus-assign" $ - parsesAs stmtP "x -= 1;" (StmtMinusEq (var "x") (lit 1)), - testCase "times-assign" $ - parsesAs stmtP "x *= 2;" (StmtTimesEq (var "x") (lit 2)), - testCase "divide-assign" $ - parsesAs stmtP "x /= 2;" (StmtDivideEq (var "x") (lit 2)), + parsesAs (stmtP []) "x = 1;" (Assign (var "x") (lit 1)), + testCase "plus-assign desugars via the (+) operator" $ + parsesAs stmtPO "x += 1;" (Assign (var "x") (opCall (QualName (Name "Add") "add") (var "x") (lit 1))), + testCase "minus-assign desugars via the (-) operator" $ + parsesAs stmtPO "x -= 1;" (Assign (var "x") (opCall (QualName (Name "Sub") "sub") (var "x") (lit 1))), + testCase "times-assign desugars via the (*) operator" $ + parsesAs stmtPO "x *= 2;" (Assign (var "x") (opCall (QualName (Name "Mul") "mul") (var "x") (lit 2))), + testCase "divide-assign desugars via the (/) operator" $ + parsesAs stmtPO "x /= 2;" (Assign (var "x") (opCall (QualName (Name "Div") "div") (var "x") (lit 2))), + testCase "bnot-assign desugars via the prefix (~) operator" $ + parsesAs stmtPO "x ~=;" (Assign (var "x") (ExpName Nothing (QualName (Name "BitNot") "bnot") [var "x"])), testCase "field assignment" $ parsesAs - stmtP + (stmtP []) "this.x = 1;" (Assign (ExpVar (Just (var "this")) "x") (lit 1)), testCase "call as statement no semicolon" $ - parsesAs stmtP "f()" (StmtExp (ExpName Nothing "f" [])), + parsesAs (stmtP []) "f()" (StmtExp (ExpName Nothing "f" [])), testCase "call as statement with semicolon" $ - parsesAs stmtP "f();" (StmtExp (ExpName Nothing "f" [])), + parsesAs (stmtP []) "f();" (StmtExp (ExpName Nothing "f" [])), testCase "if without else" $ parsesAs - stmtP + (stmtP []) "if (x) { return 1; }" (If (var "x") [Return (lit 1)] []), testCase "if with else" $ parsesAs - stmtP + (stmtP []) "if (x) { return 1; } else { return 2; }" (If (var "x") [Return (lit 1)] [Return (lit 2)]), testCase "empty block" $ - parsesAs stmtP "{}" (Block []), + parsesAs (stmtP []) "{}" (Block []), testCase "block with statement" $ - parsesAs stmtP "{ let x = 1; }" (Block [Let False "x" Nothing (Just (lit 1))]), + parsesAs (stmtP []) "{ let x = 1; }" (Block [Let False "x" Nothing (Just (lit 1))]), testCase "for loop" $ parsesAs - stmtP + stmtPO "for (let i = 0; i < 10; i = i + 1) { }" ( For (Let False "i" Nothing (Just (lit 0))) - (ExpLT (var "i") (lit 10)) - (Assign (var "i") (ExpPlus (var "i") (lit 1))) + (opCall (Name "lt") (var "i") (lit 10)) + (Assign (var "i") (opCall (QualName (Name "Add") "add") (var "i") (lit 1))) [] ), testCase "for loop with empty init and post" $ parsesAs - stmtP + stmtPO "for (; i < 10; ) { }" ( For EmptyStmt - (ExpLT (var "i") (lit 10)) + (opCall (Name "lt") (var "i") (lit 10)) EmptyStmt [] ), testCase "for loop with empty init only" $ parsesAs - stmtP + stmtPO "for (; i < 10; i = i + 1) { }" ( For EmptyStmt - (ExpLT (var "i") (lit 10)) - (Assign (var "i") (ExpPlus (var "i") (lit 1))) + (opCall (Name "lt") (var "i") (lit 10)) + (Assign (var "i") (opCall (QualName (Name "Add") "add") (var "i") (lit 1))) [] ), testCase "for loop with empty post only" $ parsesAs - stmtP + stmtPO "for (let i = 0; i < 10; ) { }" ( For (Let False "i" Nothing (Just (lit 0))) - (ExpLT (var "i") (lit 10)) + (opCall (Name "lt") (var "i") (lit 10)) EmptyStmt [] ), testCase "match one equation" $ parsesAs - stmtP + (stmtP []) "match x { | 0 => return 1; }" (Match [var "x"] [([PLit (IntLit 0)], [Return (lit 1)])]), testCase "match wildcard" $ parsesAs - stmtP + (stmtP []) "match x { | _ => return 0; }" (Match [var "x"] [([PWildcard], [Return (lit 0)])]), testCase "match constructor pattern" $ parsesAs - stmtP + (stmtP []) "match x { | Some(v) => return v; }" (Match [var "x"] [([Pat "Some" [Pat "v" []]], [Return (var "v")])]), testCase "match multiple equations" $ parsesAs - stmtP + (stmtP []) "match x { | 0 => return 0; | _ => return 1; }" ( Match [var "x"] @@ -401,7 +382,7 @@ stmtTests = ] ), testCase "let without semicolon fails" $ - parseFails stmtP "let x" + parseFails (stmtP []) "let x" ] declTests :: TestTree @@ -410,7 +391,7 @@ declTests = "Declarations" [ testCase "nullary function" $ parsesAs - topDeclP + (topDeclP []) "function answer() -> word { return 42; }" ( TFunDef ( FunDef @@ -421,7 +402,7 @@ declTests = ), testCase "unary function" $ parsesAs - topDeclP + (topDeclP []) "function id(x:word) -> word { return x; }" ( TFunDef ( FunDef @@ -432,7 +413,7 @@ declTests = ), testCase "implicit return (single expr body)" $ parsesAs - topDeclP + (topDeclP []) "function answer() -> word { 42 }" ( TFunDef ( FunDef @@ -443,7 +424,7 @@ declTests = ), testCase "polymorphic function" $ parsesAs - topDeclP + (topDeclP []) "forall a. function id(x:a) -> a { return x; }" ( TFunDef ( FunDef @@ -462,7 +443,7 @@ declTests = ), testCase "constrained function" $ parsesAs - topDeclP + (topDeclP testOps) "forall a. a:Eq => function eqSelf(x:a) -> bool { return x == x; }" ( TFunDef ( FunDef @@ -476,22 +457,22 @@ declTests = (Just bool) False ) - [Return (ExpEE (var "x") (var "x"))] + [Return (opCall (QualName (Name "Eq") "eq") (var "x") (var "x"))] ) ), testCase "empty data type" $ parsesAs - topDeclP + (topDeclP []) "data Void;" (TDataDef (DataTy "Void" [] [] [])), testCase "data type with nullary constructors" $ parsesAs - topDeclP + (topDeclP []) "data Bool = True | False;" (TDataDef (DataTy "Bool" [] [Constr "True" [], Constr "False" []] [])), testCase "data type with parameterized constructor" $ parsesAs - topDeclP + (topDeclP []) "data Option(a) = Some(a) | None;" ( TDataDef ( DataTy @@ -503,7 +484,7 @@ declTests = ), testCase "data type with derive attribute" $ parsesAs - topDeclP + (topDeclP []) "#[derive(Eq, Ord)] data Color = Red | Green;" ( TDataDef ( DataTy @@ -515,12 +496,12 @@ declTests = ), testCase "type synonym no params" $ parsesAs - topDeclP + (topDeclP []) "type Word = word;" (TSym (TySym "Word" [] word)), testCase "type synonym with params" $ parsesAs - topDeclP + (topDeclP []) "type Pair(a, b) = (a, b);" ( TSym ( TySym @@ -531,7 +512,7 @@ declTests = ), testCase "class with one method" $ parsesAs - topDeclP + (topDeclP []) "forall a. class a:Eq { function eq(x:a, y:a) -> bool; }" ( TClassDef ( Class @@ -553,7 +534,7 @@ declTests = ), testCase "class with context" $ parsesAs - topDeclP + (topDeclP []) "forall a. a:Eq => class a:Ord { function cmp(x:a, y:a) -> word; }" ( TClassDef ( Class @@ -575,7 +556,7 @@ declTests = ), testCase "instance with one method" $ parsesAs - topDeclP + (topDeclP testOps) "instance word:Eq { function eq(x:word, y:word) -> bool { return x == y; } }" ( TInstDef ( Instance @@ -588,13 +569,13 @@ declTests = [ FunDef False (Signature [] [] "eq" [Typed False "x" word, Typed False "y" word] False (Just bool) False) - [Return (ExpEE (var "x") (var "y"))] + [Return (opCall (QualName (Name "Eq") "eq") (var "x") (var "y"))] ] ) ), testCase "polymorphic instance" $ parsesAs - topDeclP + (topDeclP []) "forall a. a:Eq => instance pair(a,a):Eq { function eq(x:pair(a,a), y:pair(a,a)) -> bool { return 0; } }" ( TInstDef ( Instance @@ -623,22 +604,22 @@ declTests = ), testCase "empty contract" $ parsesAs - topDeclP + (topDeclP []) "contract Empty { }" (TContr (Contract "Empty" [] [])), testCase "contract with field" $ parsesAs - topDeclP + (topDeclP []) "contract C { x : word; }" (TContr (Contract "C" [] [CFieldDecl (Field "x" word Nothing)])), testCase "contract with initialized field" $ parsesAs - topDeclP + (topDeclP []) "contract C { x : word = 0; }" (TContr (Contract "C" [] [CFieldDecl (Field "x" word (Just (lit 0)))])), testCase "contract with function" $ parsesAs - topDeclP + (topDeclP []) "contract C { function get() -> word { return x; } }" ( TContr ( Contract @@ -655,7 +636,7 @@ declTests = ), testCase "contract with public function" $ parsesAs - topDeclP + (topDeclP []) "contract C { public function get() -> word { return x; } }" ( TContr ( Contract @@ -672,9 +653,9 @@ declTests = ), -- `public` is only meaningful inside a contract; reject it elsewhere. testCase "top-level public function fails" $ - parseFails topDeclP "public function get() -> word { return 0; }", + parseFails (topDeclP []) "public function get() -> word { return 0; }", testCase "public instance method fails" $ parseFails - topDeclP + (topDeclP []) "instance word:Eq { public function eq(x:word, y:word) -> bool { return x == y; } }" ] diff --git a/test/examples/comptime/ct_chain_ok.solc b/test/examples/comptime/ct_chain_ok.solc index a35f9f41c..1d35f0153 100644 --- a/test/examples/comptime/ct_chain_ok.solc +++ b/test/examples/comptime/ct_chain_ok.solc @@ -1,7 +1,7 @@ /* Positive: comptime result threaded through two comptime functions. increment(20) is comptime, so it can be passed to double's comptime param. */ -import std; +import std.{*}; contract ComptimeChainOk { function increment(comptime x : word) -> comptime word { diff --git a/test/examples/comptime/ct_let_ok.solc b/test/examples/comptime/ct_let_ok.solc index 4f3739a90..b656533c6 100644 --- a/test/examples/comptime/ct_let_ok.solc +++ b/test/examples/comptime/ct_let_ok.solc @@ -1,5 +1,5 @@ /* Positive: comptime let binding fed from a comptime function call. */ -import std; +import std.{*}; contract ComptimeLetOk { function double(comptime x : word) -> comptime word { diff --git a/test/examples/comptime/ct_param_ok.solc b/test/examples/comptime/ct_param_ok.solc index 68bf72473..28eb6963b 100644 --- a/test/examples/comptime/ct_param_ok.solc +++ b/test/examples/comptime/ct_param_ok.solc @@ -2,7 +2,7 @@ x+x desugars to Add.add(x,x) -> addWord(x,x), which is builtinPure, so the comptime annotation on the result is valid. */ -import std; +import std.{*}; contract ComptimeParamOk { function double(comptime x : word) -> comptime word { diff --git a/test/imports/extlib/math/api.solc b/test/imports/extlib/math/api.solc index 43dc18f7e..ce2d746fa 100644 --- a/test/imports/extlib/math/api.solc +++ b/test/imports/extlib/math/api.solc @@ -1,3 +1,4 @@ +import std.{*}; import internals.add; import lib.util; diff --git a/test/operators/basic.solc b/test/operators/basic.solc new file mode 100644 index 000000000..a2d655f31 --- /dev/null +++ b/test/operators/basic.solc @@ -0,0 +1,19 @@ +// Declares a user-defined infix operator (^^) for exponentiation and uses it. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 70 (^^) => pow; + +function pow(b : word, e : word) -> word { + let r : word; + assembly { r := exp(b, e) } + return r; +} + +contract Basic { + function main() -> word { + return 2 ^^ 10; // 1024 + } +} diff --git a/test/operators/compound-assign.solc b/test/operators/compound-assign.solc new file mode 100644 index 000000000..b67bb0232 --- /dev/null +++ b/test/operators/compound-assign.solc @@ -0,0 +1,20 @@ +// Exercises the compound-assignment sugar that desugars through the operators +// declared in the standard library: `*=`, `/=` (binary) and `~=` (the unary +// in-place bitwise NOT, `x ~=` becomes `x = ~x`). The `~` prefix operator is +// itself a std declaration (prefix 90 (~) => BitNot.bnot), so this also checks +// the user-defined bnot operator end to end. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +contract CompoundAssign { + function main() -> word { + let x : word = 6; + x *= 4; // x = x * 4 = 24 + x /= 2; // x = x / 2 = 12 + let y : word = ~ x; // prefix (~) bitwise NOT + y ~=; // y = ~y, i.e. back to x = 12 + return y; + } +} diff --git a/test/operators/import-op.solc b/test/operators/import-op.solc new file mode 100644 index 000000000..97ae83e9d --- /dev/null +++ b/test/operators/import-op.solc @@ -0,0 +1,11 @@ +// Imports and uses an operator declared in a library module. +import oplib.{pow, (^^)}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +contract ImportOp { + function main() -> word { + return 3 ^^ 4; // 81 + } +} diff --git a/test/operators/in-lambda.solc b/test/operators/in-lambda.solc new file mode 100644 index 000000000..c47639e8e --- /dev/null +++ b/test/operators/in-lambda.solc @@ -0,0 +1,20 @@ +// User-defined operator used inside a lambda body. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 70 (^^) => pow; + +function pow(b : word, e : word) -> word { + let r : word; + assembly { r := exp(b, e) } + return r; +} + +contract InLambda { + function main() -> word { + let cube = lam(x : word) -> word { return x ^^ 3; }; + return cube(4); // 64 + } +} diff --git a/test/operators/infixl.solc b/test/operators/infixl.solc new file mode 100644 index 000000000..c54f8759a --- /dev/null +++ b/test/operators/infixl.solc @@ -0,0 +1,20 @@ +// Left-associative operator: a (^*) b (^*) c parses as (a ^* b) ^* c. +// (^*) is defined as multiplication modulo some word arithmetic. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 55 (^*) => mul3; + +function mul3(x : word, y : word) -> word { + return Mul.mul(x, y); +} + +contract InfixL { + function main() -> word { + // Checks that (^*) is left-associative: 2 ^* 3 ^* 4 = (2^*3)^*4 = 24 + let r = 2 ^* 3 ^* 4; + return r; + } +} diff --git a/test/operators/infixr.solc b/test/operators/infixr.solc new file mode 100644 index 000000000..e955375a7 --- /dev/null +++ b/test/operators/infixr.solc @@ -0,0 +1,20 @@ +// Right-associative operator: a (~>) b (~>) c parses as a ~> (b ~> c). +// (~>) is defined as subtraction to make the associativity observable. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixr 45 (~>) => rsub; + +function rsub(x : word, y : word) -> word { + return Sub.sub(x, y); +} + +contract InfixR { + function main() -> word { + // Right-associative: 10 ~> 3 ~> 2 = 10 ~> (3~>2) = 10 ~> 1 = 9 + let r = 10 ~> 3 ~> 2; + return r; + } +} diff --git a/test/operators/multi-op.solc b/test/operators/multi-op.solc new file mode 100644 index 000000000..9f9ab21de --- /dev/null +++ b/test/operators/multi-op.solc @@ -0,0 +1,28 @@ +// Multiple user-defined operators at different precedences. +// (^^) at 70 binds tighter than (#) at 45. +// a # b ^^ c parses as a # (b ^^ c). +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 70 (^^) => pow; +infixl 45 (#) => addm; + +function pow(b : word, e : word) -> word { + let r : word; + assembly { r := exp(b, e) } + return r; +} + +function addm(x : word, y : word) -> word { + return Add.add(x, y); +} + +contract MultiOp { + function main() -> word { + // (#) at 45 < (^^) at 70: 1 # 2 ^^ 3 = 1 # 8 = 9 + let r = 1 # 2 ^^ 3; + return r; + } +} diff --git a/test/operators/oplib.solc b/test/operators/oplib.solc new file mode 100644 index 000000000..6241f8286 --- /dev/null +++ b/test/operators/oplib.solc @@ -0,0 +1,15 @@ +// Library that declares and exports a user-defined operator. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 70 (^^) => pow; + +export { pow, (^^) }; + +function pow(b : word, e : word) -> word { + let r : word; + assembly { r := exp(b, e) } + return r; +} diff --git a/test/operators/precedence.solc b/test/operators/precedence.solc new file mode 100644 index 000000000..bc0811e23 --- /dev/null +++ b/test/operators/precedence.solc @@ -0,0 +1,22 @@ +// Verifies that (^^) at precedence 70 binds tighter than (*) at 50. +// 2 ^^ 3 * 4 must parse as (2 ^^ 3) * 4 = 8 * 4 = 32. +// If precedence were reversed, the expression would be ill-typed or give 2048. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 70 (^^) => pow; + +function pow(b : word, e : word) -> word { + let r : word; + assembly { r := exp(b, e) } + return r; +} + +contract Precedence { + function main() -> word { + let r = 2 ^^ 3 * 4; // (2^^3)*4 = 32 + return r; + } +} diff --git a/test/operators/prefix.solc b/test/operators/prefix.solc new file mode 100644 index 000000000..4c5d303de --- /dev/null +++ b/test/operators/prefix.solc @@ -0,0 +1,20 @@ +// User-defined prefix operator (~~) for bitwise NOT. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +prefix 80 (~~) => bnot; + +function bnot(x : word) -> word { + let r : word; + assembly { r := not(x) } + return r; +} + +contract Prefix { + function main() -> word { + let x : word = 0; + return ~~ x; // bitwise NOT of 0 = max word + } +} diff --git a/test/operators/undeclared-fail.solc b/test/operators/undeclared-fail.solc new file mode 100644 index 000000000..9fd80a8ac --- /dev/null +++ b/test/operators/undeclared-fail.solc @@ -0,0 +1,11 @@ +// Using an operator symbol that has not been declared must produce a parse error. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +contract UndeclaredFail { + function main() -> word { + return 2 ^^ 3; // (^^) was never declared: parse error expected + } +} From 46f2e72442e4d49ab8bc6fdbcba33df664d9e56c Mon Sep 17 00:00:00 2001 From: rodrigogribeiro Date: Fri, 31 Jul 2026 14:59:19 -0300 Subject: [PATCH 2/9] Fixes missing cases --- src/Solcore/Frontend/Syntax/NameResolution.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Solcore/Frontend/Syntax/NameResolution.hs b/src/Solcore/Frontend/Syntax/NameResolution.hs index b8efea864..edc060ad3 100644 --- a/src/Solcore/Frontend/Syntax/NameResolution.hs +++ b/src/Solcore/Frontend/Syntax/NameResolution.hs @@ -94,6 +94,9 @@ resolveSelectorEntry :: S.ItemSelectorEntry -> ItemSelectorEntry resolveSelectorEntry S.SelectAllItems = SelectAllItems resolveSelectorEntry (S.SelectItem itemName) = SelectItem itemName resolveSelectorEntry (S.SelectItemAs itemName aliasName) = SelectItemAs itemName aliasName +-- Operator selectors are filtered out (isOperatorSelectorEntry) before this is called. +resolveSelectorEntry (S.SelectOperator _) = + error "resolveSelectorEntry: operator selector should have been filtered before name resolution" resolveExportSpec :: S.ExportSpec -> ExportSpec resolveExportSpec S.ExportAll = ExportAll @@ -101,6 +104,9 @@ resolveExportSpec (S.ExportName itemName) = ExportName itemName resolveExportSpec (S.ExportNameWithConstructors typeName ctorSelector) = ExportNameWithConstructors typeName (resolveConstructorSelector ctorSelector) resolveExportSpec (S.ExportModuleAll path) = ExportModuleAll (resolveModulePath path) +-- Operator exports are filtered out (isOperatorExportSpec) before this is called. +resolveExportSpec (S.ExportOperator _) = + error "resolveExportSpec: operator export should have been filtered before name resolution" validateDuplicateNamespacesInCompUnit :: S.CompUnit -> Either CompilerError () validateDuplicateNamespacesInCompUnit (S.CompUnit _ ds) = @@ -219,6 +225,9 @@ instance Resolve S.TopDecl where resolve (S.TExportDecl exportDecl) = pure (TExportDecl (resolveExport exportDecl)) resolve t@(S.TPragmaDecl p) = TPragmaDecl <$> resolve p `wrapError` t + -- Operator declarations are filtered out (isOperatorTopDecl) before this is called. + resolve (S.TOperatorDecl _) = + error "resolve: operator declaration should have been filtered before name resolution" resolveExport :: S.Export -> Export resolveExport (S.ExportList items) = @@ -283,6 +292,9 @@ instance Resolve S.ContractDecl where CFunDecl <$> resolve f `wrapError` d resolve d@(S.CConstrDecl cd) = CConstrDecl <$> resolve cd `wrapError` d + -- Operator declarations are filtered out (isOperatorContractDecl) before this is called. + resolve (S.COperatorDecl _) = + error "resolve: contract operator declaration should have been filtered before name resolution" instance Resolve S.Constructor where type Result S.Constructor = Constructor Name From 6acfe365f57695c09b2c6b965cbdead8b6506305 Mon Sep 17 00:00:00 2001 From: rodrigogribeiro Date: Mon, 3 Aug 2026 18:34:54 -0300 Subject: [PATCH 3/9] fixing example for exponential operator --- test/operators/basic.solc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/operators/basic.solc b/test/operators/basic.solc index a2d655f31..69913ea78 100644 --- a/test/operators/basic.solc +++ b/test/operators/basic.solc @@ -4,7 +4,7 @@ pragma no-patterson-condition ; pragma no-coverage-condition ; pragma no-bounded-variable-condition ; -infixl 70 (^^) => pow; +infixl 70 (**) => pow; function pow(b : word, e : word) -> word { let r : word; @@ -14,6 +14,6 @@ function pow(b : word, e : word) -> word { contract Basic { function main() -> word { - return 2 ^^ 10; // 1024 + return 2 ** 10; // 1024 } } From ee32c7597529cd33980ab04bfed7bcc7932794a8 Mon Sep 17 00:00:00 2001 From: rodrigogribeiro Date: Tue, 4 Aug 2026 08:20:21 -0300 Subject: [PATCH 4/9] adding units as part of std library --- src/Solcore/Frontend/Lexer/SolcoreLexer.hs | 8 ++- src/Solcore/Frontend/Parser/Expr.hs | 13 ++++- std/std.solc | 67 ++++++++++++++++++++++ test/OperatorTests.hs | 8 +++ test/ParserTests.hs | 11 +++- test/operators/units.solc | 42 ++++++++++++++ 6 files changed, 144 insertions(+), 5 deletions(-) create mode 100644 test/operators/units.solc diff --git a/src/Solcore/Frontend/Lexer/SolcoreLexer.hs b/src/Solcore/Frontend/Lexer/SolcoreLexer.hs index 2d6d217d3..ebb200767 100644 --- a/src/Solcore/Frontend/Lexer/SolcoreLexer.hs +++ b/src/Solcore/Frontend/Lexer/SolcoreLexer.hs @@ -88,10 +88,16 @@ parenOpP :: Parser String parenOpP = lexeme $ do _ <- char '(' sc - sym <- some (satisfy isOpChar) + sym <- some (satisfy isOpChar) <|> identSym sc _ <- char ')' pure sym + where + -- An operator symbol is normally made of operator characters (e.g. `+`, + -- `^^`). It may also be an alphabetic identifier, used for postfix unit + -- suffixes like `(ether)` or `(minutes)`. The two are disjoint (letters are + -- never operator characters), so the choice is unambiguous. + identSym = (:) <$> letterChar <*> many identChar identifier :: Parser String identifier = lexeme go "identifier" diff --git a/src/Solcore/Frontend/Parser/Expr.hs b/src/Solcore/Frontend/Parser/Expr.hs index c17dc7c7e..958285262 100644 --- a/src/Solcore/Frontend/Parser/Expr.hs +++ b/src/Solcore/Frontend/Parser/Expr.hs @@ -84,15 +84,22 @@ userRow od@(OperatorDecl fix prec _ fun) = mkBin l r = locatedExpFrom [sourceSpanOf l, sourceSpanOf r] (ExpName Nothing fun [l, r]) mkPre e = locatedExpFrom [sourceSpanOf e] (ExpName Nothing fun [e]) --- Match an exact operator symbol, ensuring no further operator character --- follows (maximal munch: `^^` is matched whole, not as `^` then `^`). +-- Match an exact operator symbol under a maximal-munch guard. A symbolic +-- operator must not be a prefix of a longer operator (`^^` is matched whole, +-- not as `^` then `^`), so it must not be followed by another operator +-- character. An identifier operator (a postfix unit suffix like `ether`) must +-- not be a prefix of a longer identifier (`ether` must not match inside +-- `ethereum`), so it must not be followed by an identifier character. -- The `|` symbol additionally must not be a match-arm separator (`| pat => …`): -- the guard runs after lexeme consumed the trailing space, so patListP -- starts on the pattern. opSymP :: OperatorDecl -> Parser String opSymP (OperatorDecl _ _ sym _) = - lexeme (string sym <* notFollowedBy (satisfy isOpChar)) <* matchArmGuard + lexeme (string sym <* munchGuard) <* matchArmGuard where + munchGuard + | all isOpChar sym = notFollowedBy (satisfy isOpChar) + | otherwise = notFollowedBy (alphaNumChar <|> char '_') matchArmGuard | sym == "|" = notFollowedBy (try (patListP [] *> symbol "=>")) | otherwise = pure () diff --git a/std/std.solc b/std/std.solc index 36ecd1406..59d397edd 100644 --- a/std/std.solc +++ b/std/std.solc @@ -32,6 +32,21 @@ infix 34 (!=) => ne; infixl 20 (&&) => and; infixl 10 (||) => or; +// Unit suffixes (Solidity ether and time units). These are postfix operators +// applied to a numeric literal: `2 ether`, `5 minutes`. Each multiplies its +// operand by the unit's value in the base unit (wei / seconds). Precedence 100 +// binds tighter than every other operator, so the suffix attaches to the +// literal first (`2 ether * n` is `(2 ether) * n`). +postfix 100 (wei) => weiUnit; +postfix 100 (gwei) => gweiUnit; +postfix 100 (ether) => etherUnit; + +postfix 100 (seconds) => secondsUnit; +postfix 100 (minutes) => minutesUnit; +postfix 100 (hours) => hoursUnit; +postfix 100 (days) => daysUnit; +postfix 100 (weeks) => weeksUnit; + export { ABIAttribs, ABIDecode, @@ -103,6 +118,14 @@ export { bnotWord, bshlWord, bshrWord, + weiUnit, + gweiUnit, + etherUnit, + secondsUnit, + minutesUnit, + hoursUnit, + daysUnit, + weeksUnit, calldata(*), concat, concatLit, @@ -419,6 +442,50 @@ function lt(x:a, y:a) -> bool { return Ord.gt(y,x); } +// --- Unit suffixes (ether and time units) --- +// Target functions for the postfix unit operators declared at the top of this +// module. Each returns its operand scaled to the base unit (wei / seconds). +// They are polymorphic over any Mul+Num type, so `2 ether` works whether the +// context wants `word` or `uint256`. `wei` and `seconds` are the identity. + +forall a . function weiUnit(x : a) -> a { + return x; +} + +forall a . a:Mul, a:Int => +function gweiUnit(x : a) -> a { + return Mul.mul(x, 1000000000); +} + +forall a . a:Mul, a:Int => +function etherUnit(x : a) -> a { + return Mul.mul(x, 1000000000000000000); +} + +forall a . function secondsUnit(x : a) -> a { + return x; +} + +forall a . a:Mul, a:Int => +function minutesUnit(x : a) -> a { + return Mul.mul(x, 60); +} + +forall a . a:Mul, a:Int => +function hoursUnit(x : a) -> a { + return Mul.mul(x, 3600); +} + +forall a . a:Mul, a:Int => +function daysUnit(x : a) -> a { + return Mul.mul(x, 86400); +} + +forall a . a:Mul, a:Int => +function weeksUnit(x : a) -> a { + return Mul.mul(x, 604800); +} + // --- Generic deriving: structural instances over the representation universe --- // These let `#[derive(Eq)]` / `#[derive(Ord)]` work for any data type through // its Generic(rep) instance, where rep is built from (), sum(f, g) and (f, g). diff --git a/test/OperatorTests.hs b/test/OperatorTests.hs index 5f5365e20..19df0dfb8 100644 --- a/test/OperatorTests.hs +++ b/test/OperatorTests.hs @@ -13,6 +13,7 @@ operatorTests = associativityTests, prefixTests, compoundAssignTests, + unitTests, lambdaTests, importTests, errorTests @@ -70,6 +71,13 @@ compoundAssignTests = [ runOpSuccess "compound-assign.solc" ] +unitTests :: TestTree +unitTests = + testGroup + "Ether and time unit suffixes (2 ether, 5 minutes)" + [ runOpSuccess "units.solc" + ] + lambdaTests :: TestTree lambdaTests = testGroup diff --git a/test/ParserTests.hs b/test/ParserTests.hs index 73c2483b5..3d919b8d7 100644 --- a/test/ParserTests.hs +++ b/test/ParserTests.hs @@ -41,7 +41,9 @@ testOps = OperatorDecl OpInfixL 45 "-" (QualName (Name "Sub") "sub"), OperatorDecl OpInfixN 35 "<" (Name "lt"), OperatorDecl OpInfixN 34 "==" (QualName (Name "Eq") "eq"), - OperatorDecl OpPrefix 90 "~" (QualName (Name "BitNot") "bnot") + OperatorDecl OpPrefix 90 "~" (QualName (Name "BitNot") "bnot"), + OperatorDecl OpPostfix 100 "ether" (Name "etherUnit"), + OperatorDecl OpPostfix 100 "minutes" (Name "minutesUnit") ] stmtPO :: Parser Stmt @@ -293,6 +295,13 @@ stmtTests = parsesAs stmtPO "x /= 2;" (Assign (var "x") (opCall (QualName (Name "Div") "div") (var "x") (lit 2))), testCase "bnot-assign desugars via the prefix (~) operator" $ parsesAs stmtPO "x ~=;" (Assign (var "x") (ExpName Nothing (QualName (Name "BitNot") "bnot") [var "x"])), + testCase "postfix unit suffix desugars to a call" $ + parsesAs stmtPO "return 2 ether;" (Return (ExpName Nothing (Name "etherUnit") [lit 2])), + testCase "unit suffix binds tighter than (+)" $ + parsesAs + stmtPO + "return 2 ether + 3;" + (Return (opCall (QualName (Name "Add") "add") (ExpName Nothing (Name "etherUnit") [lit 2]) (lit 3))), testCase "field assignment" $ parsesAs (stmtP []) diff --git a/test/operators/units.solc b/test/operators/units.solc new file mode 100644 index 000000000..bbce80c48 --- /dev/null +++ b/test/operators/units.solc @@ -0,0 +1,42 @@ +// Solidity ether and time unit suffixes, implemented as postfix operators in +// the standard library. `2 ether` desugars to `etherUnit(2)`, etc. The suffix +// binds tighter than any other operator (precedence 100), so `2 ether + 1 wei` +// is `(2 ether) + (1 wei)`. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +contract Units { + // Ether and time units on `word`. + function onWord() -> word { + let a : word = 1 ether; // 1e18 + let b : word = 3 gwei; // 3e9 + let c : word = 5 wei; // 5 + let d : word = 2 minutes; // 120 + let e : word = 1 hours; // 3600 + let f : word = 1 days; // 86400 + let g : word = 1 weeks; // 604800 + let h : word = 30 seconds; // 30 + // The suffix binds to the literal first, before (+). + return a + b + c + d + e + f + g + h; + } + + // The unit operators are polymorphic, so they also work at `uint256`. + function onUint() -> uint256 { + let x : uint256 = 2 ether; + let y : uint256 = 5 minutes; + return x + y; + } + + // Maximal munch: `ether` must not be matched inside the identifier + // `etherPrice`; it stays a plain variable. + function guard() -> word { + let etherPrice : word = 42; + return etherPrice; + } + + function main() -> word { + return onWord(); + } +} From 2e41a1c0dd40999e343f19e6c6748bedb5cdf195 Mon Sep 17 00:00:00 2001 From: rodrigogribeiro Date: Wed, 5 Aug 2026 17:45:43 -0300 Subject: [PATCH 5/9] Fixing two bugs found by axic --- src/Solcore/Frontend/Parser/OperatorScan.hs | 45 +++++++++++++--- src/Solcore/Frontend/Parser/SolcoreParser.hs | 55 +++++++++++++++++--- test/OperatorTests.hs | 9 +++- test/ParserTests.hs | 31 ++++++++++- test/operators/compound-undeclared-fail.solc | 12 +++++ test/operators/infix-postfix-fail.solc | 16 ++++++ test/operators/redefined-fail.solc | 15 ++++++ 7 files changed, 167 insertions(+), 16 deletions(-) create mode 100644 test/operators/compound-undeclared-fail.solc create mode 100644 test/operators/infix-postfix-fail.solc create mode 100644 test/operators/redefined-fail.solc diff --git a/src/Solcore/Frontend/Parser/OperatorScan.hs b/src/Solcore/Frontend/Parser/OperatorScan.hs index 14e2f7b0b..97e6800f5 100644 --- a/src/Solcore/Frontend/Parser/OperatorScan.hs +++ b/src/Solcore/Frontend/Parser/OperatorScan.hs @@ -1,5 +1,8 @@ module Solcore.Frontend.Parser.OperatorScan ( scanOperators, + scanRawOperators, + scanOperatorsLocated, + duplicateOperator, scanImports, scanExportModulePaths, ) @@ -11,29 +14,32 @@ import Solcore.Frontend.Lexer.SolcoreLexer import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.SyntaxTree --- Lightweight scan of a source file collecting every operator declaration. --- Tolerates arbitrary content between declarations. -scanOperators :: String -> [OperatorDecl] -scanOperators src = +-- Lightweight scan of a source file collecting every operator declaration +-- together with the source offset at which it starts. Tolerates arbitrary +-- content between declarations. Declarations are returned in source order, with +-- no deduplication (see scanOperators / duplicateOperator). +scanOperatorsLocated :: String -> [(Int, OperatorDecl)] +scanOperatorsLocated src = case runParser (sc *> scanP) "" src of Left _ -> [] - Right ops -> nubBy (\a b -> opSymbol a == opSymbol b) ops + Right ops -> ops where - scanP :: Parser [OperatorDecl] + scanP :: Parser [(Int, OperatorDecl)] scanP = do ops <- many (try opDeclP <|> (anySingle *> pure Nothing)) eof pure [op | Just op <- ops] - opDeclP :: Parser (Maybe OperatorDecl) + opDeclP :: Parser (Maybe (Int, OperatorDecl)) opDeclP = do + offset <- getOffset fix <- fixityP prec <- fromIntegral <$> integer sym <- parenOpP _ <- symbol "=>" fun <- qualFunP _ <- optional semicolon - pure (Just (OperatorDecl fix prec sym fun)) + pure (Just (offset, OperatorDecl fix prec sym fun)) qualFunP :: Parser Name qualFunP = do @@ -52,6 +58,29 @@ scanOperators src = <|> (OpPrefix <$ keyword "prefix") <|> (OpPostfix <$ keyword "postfix") +-- Raw operator declarations of a source, in order, without deduplication. +scanRawOperators :: String -> [OperatorDecl] +scanRawOperators = map snd . scanOperatorsLocated + +-- Operator declarations of a source, keeping the first declaration of each +-- symbol. Used to build the expression operator table. A well-formed module has +-- no duplicate symbols (they are rejected by duplicateOperator before parsing), +-- so this coincides with scanRawOperators there. +scanOperators :: String -> [OperatorDecl] +scanOperators = nubBy (\a b -> opSymbol a == opSymbol b) . scanRawOperators + +-- The first operator symbol declared more than once in a single module: either +-- a redefinition (same symbol declared twice) or a second fixity for the same +-- symbol (e.g. infix and postfix). Returns the source offset of the offending +-- (second) declaration and the symbol; Nothing when every symbol is unique. +duplicateOperator :: [(Int, OperatorDecl)] -> Maybe (Int, String) +duplicateOperator = go [] + where + go _ [] = Nothing + go seen ((offset, od) : rest) + | opSymbol od `elem` seen = Just (offset, opSymbol od) + | otherwise = go (opSymbol od : seen) rest + -- Lightweight scan of a source file collecting every import declaration. -- Tolerates arbitrary content between imports (skips unknown tokens). -- Import syntax uses only identifiers, dots, braces, and keywords — no diff --git a/src/Solcore/Frontend/Parser/SolcoreParser.hs b/src/Solcore/Frontend/Parser/SolcoreParser.hs index 3e5cd1d7a..4240d51ae 100644 --- a/src/Solcore/Frontend/Parser/SolcoreParser.hs +++ b/src/Solcore/Frontend/Parser/SolcoreParser.hs @@ -19,7 +19,7 @@ import Solcore.Diagnostics encodeDiagnostic, ) import Solcore.Frontend.Parser.Decl (compUnitP) -import Solcore.Frontend.Parser.OperatorScan (scanOperators) +import Solcore.Frontend.Parser.OperatorScan (duplicateOperator, scanOperators, scanOperatorsLocated) import Solcore.Frontend.Syntax.SyntaxTree (CompUnit, OperatorDecl) import Text.Megaparsec (ParseErrorBundle, bundleErrors, errorBundlePretty, errorOffset, parse) @@ -40,11 +40,54 @@ parseCompUnitWithOps :: [OperatorDecl] -> FilePath -> String -> IO (Either Strin parseCompUnitWithOps extraOps sourcePath src = pure $ -- Pre-scan the source for user-defined operator declarations so the - -- expression grammar can be extended before the main parse. - let ops = extraOps ++ scanOperators src - in case parse (compUnitP ops) sourcePath src of - Left err -> Left (parseDiagnostic sourcePath src err) - Right compUnit -> Right compUnit + -- expression grammar can be extended before the main parse. Each operator + -- symbol may be declared at most once in a module; a redefinition or a + -- second fixity for the same symbol is rejected here. + case duplicateOperator (scanOperatorsLocated src) of + Just (offset, sym) -> Left (duplicateOperatorDiagnostic sourcePath src offset sym) + Nothing -> + let ops = extraOps ++ scanOperators src + in case parse (compUnitP ops) sourcePath src of + Left err -> Left (parseDiagnostic sourcePath src err) + Right compUnit -> Right compUnit + +-- Diagnostic for an operator symbol declared more than once in a module. +duplicateOperatorDiagnostic :: FilePath -> String -> Int -> String -> String +duplicateOperatorDiagnostic sourcePath src offset sym = + encodeDiagnostic + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode "SC0122"), + diagnosticMessage = "operator (" ++ sym ++ ") is declared more than once", + diagnosticLabels = + [ Label + { labelSpan = declSpan, + labelStyle = Primary, + labelMessage = Just "duplicate operator declaration" + } + ], + diagnosticNotes = + [ "an operator symbol may be declared at most once per module, including a second fixity for the same symbol" + ], + diagnosticHelp = + [ "remove this declaration, or rename the operator" + ] + } + where + lineLength = max 1 (length (takeWhile (/= '\n') (drop offset src))) + endOffset = offset + lineLength + (startLine, startColumn) = offsetLineColumn src offset + (endLine, endColumn) = offsetLineColumn src endOffset + declSpan = + SourceSpan + { spanFile = sourcePath, + spanStartByte = offset, + spanEndByte = endOffset, + spanStartLine = startLine, + spanStartColumn = startColumn, + spanEndLine = endLine, + spanEndColumn = endColumn + } parseDiagnostic :: FilePath -> String -> ParseErrorBundle String Void -> String parseDiagnostic sourcePath src err = diff --git a/test/OperatorTests.hs b/test/OperatorTests.hs index 19df0dfb8..a74c5e6d8 100644 --- a/test/OperatorTests.hs +++ b/test/OperatorTests.hs @@ -96,5 +96,12 @@ errorTests :: TestTree errorTests = testGroup "Error cases" - [ runOpFailure "undeclared-fail.solc" + [ runOpFailure "undeclared-fail.solc", + -- A compound assignment (`+=`) whose base operator is not in scope is a + -- parse error, not a silent no-op. + runOpFailure "compound-undeclared-fail.solc", + -- Declaring an operator symbol twice is a parse error (SC0122): a plain + -- redefinition, and a second fixity for the same symbol. + runOpFailure "redefined-fail.solc", + runOpFailure "infix-postfix-fail.solc" ] diff --git a/test/ParserTests.hs b/test/ParserTests.hs index 3d919b8d7..bb48fadf2 100644 --- a/test/ParserTests.hs +++ b/test/ParserTests.hs @@ -6,6 +6,7 @@ import Common.LightYear (Parser, runParserE) import Solcore.Frontend.Lexer.SolcoreLexer (sc) import Solcore.Frontend.Parser.Decl (topDeclP) import Solcore.Frontend.Parser.Expr (exprP) +import Solcore.Frontend.Parser.OperatorScan (duplicateOperator, scanOperatorsLocated) import Solcore.Frontend.Parser.Patterns (patP) import Solcore.Frontend.Parser.SolcoreTypes (predP, typeP) import Solcore.Frontend.Parser.Stmt (bodyP, stmtP) @@ -63,9 +64,37 @@ parserTests = exprTests, stmtTests, declTests, - keywordPrefixTests + keywordPrefixTests, + operatorScanTests ] +-- The operator pre-scan rejects a symbol declared more than once within a +-- module: a redefinition, or a second fixity for the same symbol. +-- `duplicateOperator` reports the offending symbol; the compiler turns it into a +-- parse error (SC0122). +operatorScanTests :: TestTree +operatorScanTests = + testGroup + "Operator scanning (duplicate detection)" + [ testCase "a redefined operator is reported as a duplicate" $ + assertEqual + "reports the redefined symbol" + (Just "##") + (dupSymbol "infixl 50 (##) => binA; infixl 60 (##) => binB;"), + testCase "same symbol as infix and postfix is reported as a duplicate" $ + assertEqual + "reports the conflicting symbol" + (Just "##") + (dupSymbol "infixl 50 (##) => binOp; postfix 60 (##) => postOp;"), + testCase "distinct operator symbols are not flagged" $ + assertEqual + "no duplicate" + Nothing + (dupSymbol "infixl 50 (##) => a; infixl 45 (<>) => b;") + ] + where + dupSymbol = fmap snd . duplicateOperator . scanOperatorsLocated + word :: Ty word = TyCon "word" [] diff --git a/test/operators/compound-undeclared-fail.solc b/test/operators/compound-undeclared-fail.solc new file mode 100644 index 000000000..0918a5835 --- /dev/null +++ b/test/operators/compound-undeclared-fail.solc @@ -0,0 +1,12 @@ +// A compound assignment `x += e` desugars to `x = (+)(x, e)`, so the base +// operator `+` must be in scope. This file deliberately does NOT import std +// (where `+` is declared as a user-defined operator), so `+` is undeclared and +// `x += 1;` must be rejected: a compound assignment for an operator that is not +// in scope is a parse error, not a silent no-op. +contract CompoundUndeclared { + function f() -> word { + let x : word = 0; + x += 1; + return x; + } +} diff --git a/test/operators/infix-postfix-fail.solc b/test/operators/infix-postfix-fail.solc new file mode 100644 index 000000000..606667637 --- /dev/null +++ b/test/operators/infix-postfix-fail.solc @@ -0,0 +1,16 @@ +// Declaring the same symbol with two fixities is a compile error: `##` is +// declared as both infix and postfix. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 50 (##) => binOp; +postfix 60 (##) => postOp; + +function binOp(a : word, b : word) -> word { return a; } +function postOp(a : word) -> word { return a; } + +contract InfixPostfix { + function main() -> word { return 3 ## 4; } +} diff --git a/test/operators/redefined-fail.solc b/test/operators/redefined-fail.solc new file mode 100644 index 000000000..dd23d656e --- /dev/null +++ b/test/operators/redefined-fail.solc @@ -0,0 +1,15 @@ +// Redefining an operator symbol is a compile error: `##` is declared twice. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 50 (##) => binA; +infixl 60 (##) => binB; + +function binA(a : word, b : word) -> word { return a; } +function binB(a : word, b : word) -> word { return b; } + +contract Redefined { + function main() -> word { return 3 ## 4; } +} From 70ed83af938a48b54ca41f52e152b41f1520b20f Mon Sep 17 00:00:00 2001 From: rodrigogribeiro Date: Wed, 5 Aug 2026 18:02:49 -0300 Subject: [PATCH 6/9] Fixing more bugs in operator importing --- src/Solcore/Frontend/Module/Loader.hs | 26 ++++++++++++++--- src/Solcore/Frontend/Parser/OperatorScan.hs | 20 ++++++++++++- test/OperatorTests.hs | 6 +++- test/ParserTests.hs | 32 +++++++++++++++++++-- test/operators/import-conflict-fail.solc | 10 +++++++ test/operators/oplibx.solc | 11 +++++++ test/operators/opliby.solc | 11 +++++++ 7 files changed, 108 insertions(+), 8 deletions(-) create mode 100644 test/operators/import-conflict-fail.solc create mode 100644 test/operators/oplibx.solc create mode 100644 test/operators/opliby.solc diff --git a/src/Solcore/Frontend/Module/Loader.hs b/src/Solcore/Frontend/Module/Loader.hs index d0e1fa545..df3149632 100644 --- a/src/Solcore/Frontend/Module/Loader.hs +++ b/src/Solcore/Frontend/Module/Loader.hs @@ -22,7 +22,7 @@ import Data.Set (Set) import Data.Set qualified as Set import Solcore.Diagnostics (Diagnostic (..), DiagnosticCode (..), Label (..), LabelStyle (..), Severity (..), SourceFile, SourceMap, SourceSpan, combineSourceSpans, encodeDiagnostic, makeSourceFile, sourceMapFromFiles) import Solcore.Frontend.Module.Identity qualified as Mod -import Solcore.Frontend.Parser.OperatorScan (scanImports, scanOperators) +import Solcore.Frontend.Parser.OperatorScan (crossOperatorConflict, scanImports, scanOperators, scanRawOperators) import Solcore.Frontend.Parser.SolcoreParser (parseCompUnitWithOps) import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.SyntaxTree @@ -142,7 +142,12 @@ visit cfg moduleId sourcePath = do modify (\st -> st {loadingModules = Set.insert moduleId (loadingModules st)}) content <- liftIO (readFile sourcePath) let source = makeSourceFile sourcePath content - importedOps <- gatherImportedOperators cfg moduleId sourcePath (scanImports content) + importedOpsTagged <- gatherImportedOperators cfg moduleId sourcePath (scanImports content) + let localTagged = [("the current module", od) | od <- scanRawOperators content] + case crossOperatorConflict importedOpsTagged localTagged of + Just (sym, l1, l2) -> throwError (operatorImportConflictDiagnostic sym l1 l2) + Nothing -> pure () + let importedOps = map snd importedOpsTagged parsed <- liftIO (parseCompUnitWithOps importedOps sourcePath content) cunit <- stripOperators <$> either throwError pure parsed importedModules <- mapM (resolveImportPath cfg moduleId sourcePath) (imports cunit) @@ -184,7 +189,7 @@ gatherImportedOperators :: Mod.ModuleId -> FilePath -> [Import] -> - StateT LoadState (ExceptT String IO) [OperatorDecl] + StateT LoadState (ExceptT String IO) [(String, OperatorDecl)] gatherImportedOperators cfg currentModule currentSourcePath imps = concat <$> mapM fromImport imps where @@ -192,10 +197,23 @@ gatherImportedOperators cfg currentModule currentSourcePath imps = ( do (_, targetPath) <- resolveImportPath cfg currentModule currentSourcePath imp c <- liftIO (readFile targetPath) - pure (selectImportedOperators imp (scanOperators c)) + let label = Mod.modulePathDisplay (importModule imp) + pure [(label, od) | od <- selectImportedOperators imp (scanOperators c)] ) `catchError` const (pure []) +-- Diagnostic for an operator symbol declared with different meanings in two +-- modules reachable from the current one (two imports, or an import and the +-- current module). Identical declarations reaching via several paths are not a +-- conflict and are not reported here. +operatorImportConflictDiagnostic :: String -> String -> String -> String +operatorImportConflictDiagnostic sym label1 label2 = + loaderDiagnostic + "SC0123" + ("operator (" ++ sym ++ ") is declared incompatibly in more than one module") + ["declared in " ++ label1, "and in " ++ label2] + ["import only one of the declarations, make them identical, or rename an operator"] + selectImportedOperators :: Import -> [OperatorDecl] -> [OperatorDecl] selectImportedOperators _ ops = ops diff --git a/src/Solcore/Frontend/Parser/OperatorScan.hs b/src/Solcore/Frontend/Parser/OperatorScan.hs index 97e6800f5..012c35c9f 100644 --- a/src/Solcore/Frontend/Parser/OperatorScan.hs +++ b/src/Solcore/Frontend/Parser/OperatorScan.hs @@ -3,13 +3,15 @@ module Solcore.Frontend.Parser.OperatorScan scanRawOperators, scanOperatorsLocated, duplicateOperator, + crossOperatorConflict, scanImports, scanExportModulePaths, ) where import Common.LightYear -import Data.List (nubBy) +import Data.List (nubBy, tails) +import Data.Maybe (listToMaybe) import Solcore.Frontend.Lexer.SolcoreLexer import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.SyntaxTree @@ -81,6 +83,22 @@ duplicateOperator = go [] | opSymbol od `elem` seen = Just (offset, opSymbol od) | otherwise = go (opSymbol od : seen) rest +-- Detect an operator symbol declared incompatibly across modules. Each list +-- tags a declaration with a provenance label (e.g. the importing module). +-- Reports the first symbol that has two structurally-different declarations +-- where at least one comes from the first (imported) list, returning the symbol +-- and the two provenance labels. Declarations that are identical (the same +-- operator reaching via several import paths, a diamond) are not a conflict. +crossOperatorConflict :: (Eq a) => [(a, OperatorDecl)] -> [(a, OperatorDecl)] -> Maybe (String, a, a) +crossOperatorConflict imported local = + listToMaybe + [ (opSymbol o1, l1, l2) + | (l1, o1) <- imported, + (l2, o2) <- imported ++ local, + opSymbol o1 == opSymbol o2, + o1 /= o2 + ] + -- Lightweight scan of a source file collecting every import declaration. -- Tolerates arbitrary content between imports (skips unknown tokens). -- Import syntax uses only identifiers, dots, braces, and keywords — no diff --git a/test/OperatorTests.hs b/test/OperatorTests.hs index a74c5e6d8..ddf1cd754 100644 --- a/test/OperatorTests.hs +++ b/test/OperatorTests.hs @@ -103,5 +103,9 @@ errorTests = -- Declaring an operator symbol twice is a parse error (SC0122): a plain -- redefinition, and a second fixity for the same symbol. runOpFailure "redefined-fail.solc", - runOpFailure "infix-postfix-fail.solc" + runOpFailure "infix-postfix-fail.solc", + -- Importing two modules that declare the same operator incompatibly is a + -- compile error (SC0123). oplibx.solc and opliby.solc are the two + -- conflicting library modules. + runOpFailure "import-conflict-fail.solc" ] diff --git a/test/ParserTests.hs b/test/ParserTests.hs index bb48fadf2..a7feabc45 100644 --- a/test/ParserTests.hs +++ b/test/ParserTests.hs @@ -6,7 +6,7 @@ import Common.LightYear (Parser, runParserE) import Solcore.Frontend.Lexer.SolcoreLexer (sc) import Solcore.Frontend.Parser.Decl (topDeclP) import Solcore.Frontend.Parser.Expr (exprP) -import Solcore.Frontend.Parser.OperatorScan (duplicateOperator, scanOperatorsLocated) +import Solcore.Frontend.Parser.OperatorScan (crossOperatorConflict, duplicateOperator, scanOperatorsLocated) import Solcore.Frontend.Parser.Patterns (patP) import Solcore.Frontend.Parser.SolcoreTypes (predP, typeP) import Solcore.Frontend.Parser.Stmt (bodyP, stmtP) @@ -90,7 +90,35 @@ operatorScanTests = assertEqual "no duplicate" Nothing - (dupSymbol "infixl 50 (##) => a; infixl 45 (<>) => b;") + (dupSymbol "infixl 50 (##) => a; infixl 45 (<>) => b;"), + testCase "an operator declared incompatibly in two imports is a conflict" $ + assertEqual + "reports the symbol and both provenances" + (Just ("<>", "libA", "libB")) + ( crossOperatorConflict + [ ("libA", OperatorDecl OpInfixL 50 "<>" (Name "joinA")), + ("libB", OperatorDecl OpInfixR 60 "<>" (Name "joinB")) + ] + [] + ), + testCase "the same declaration reaching via two imports (diamond) is not a conflict" $ + assertEqual + "identical declarations do not conflict" + Nothing + ( crossOperatorConflict + [ ("libA", OperatorDecl OpInfixL 50 "<>" (Name "join")), + ("libB", OperatorDecl OpInfixL 50 "<>" (Name "join")) + ] + [] + ), + testCase "a local operator that conflicts with an imported one is a conflict" $ + assertEqual + "imported versus local conflict" + (Just ("<>", "libA", "local")) + ( crossOperatorConflict + [("libA", OperatorDecl OpInfixL 50 "<>" (Name "joinA"))] + [("local", OperatorDecl OpInfixR 60 "<>" (Name "joinLocal"))] + ) ] where dupSymbol = fmap snd . duplicateOperator . scanOperatorsLocated diff --git a/test/operators/import-conflict-fail.solc b/test/operators/import-conflict-fail.solc new file mode 100644 index 000000000..0ef62a1f5 --- /dev/null +++ b/test/operators/import-conflict-fail.solc @@ -0,0 +1,10 @@ +// Importing two modules that declare (<>) incompatibly is a compile error. +import oplibx.{joinX, (<>)}; +import opliby.{joinY, (<>)}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +contract ImportConflict { + function main() -> word { return joinX(1, 2); } +} diff --git a/test/operators/oplibx.solc b/test/operators/oplibx.solc new file mode 100644 index 000000000..1a639a1d3 --- /dev/null +++ b/test/operators/oplibx.solc @@ -0,0 +1,11 @@ +// Library X: declares operator (<>) as infixl 50 => joinX. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 50 (<>) => joinX; + +export { joinX, (<>) }; + +function joinX(a : word, b : word) -> word { return a; } diff --git a/test/operators/opliby.solc b/test/operators/opliby.solc new file mode 100644 index 000000000..59f87f6c7 --- /dev/null +++ b/test/operators/opliby.solc @@ -0,0 +1,11 @@ +// Library Y: declares operator (<>) INCOMPATIBLY (infixr 60 => joinY). +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixr 60 (<>) => joinY; + +export { joinY, (<>) }; + +function joinY(a : word, b : word) -> word { return b; } From 33bd7587a45c69f72af903dc9ebc53ff4d0c9293 Mon Sep 17 00:00:00 2001 From: rodrigogribeiro Date: Wed, 5 Aug 2026 18:21:01 -0300 Subject: [PATCH 7/9] eliminating warnings --- src/Solcore/Frontend/Parser/OperatorScan.hs | 2 +- test/ParserTests.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Solcore/Frontend/Parser/OperatorScan.hs b/src/Solcore/Frontend/Parser/OperatorScan.hs index 012c35c9f..a1b09df72 100644 --- a/src/Solcore/Frontend/Parser/OperatorScan.hs +++ b/src/Solcore/Frontend/Parser/OperatorScan.hs @@ -10,7 +10,7 @@ module Solcore.Frontend.Parser.OperatorScan where import Common.LightYear -import Data.List (nubBy, tails) +import Data.List (nubBy) import Data.Maybe (listToMaybe) import Solcore.Frontend.Lexer.SolcoreLexer import Solcore.Frontend.Syntax.Name diff --git a/test/ParserTests.hs b/test/ParserTests.hs index a7feabc45..53312a1da 100644 --- a/test/ParserTests.hs +++ b/test/ParserTests.hs @@ -94,7 +94,7 @@ operatorScanTests = testCase "an operator declared incompatibly in two imports is a conflict" $ assertEqual "reports the symbol and both provenances" - (Just ("<>", "libA", "libB")) + (Just ("<>", "libA", "libB") :: Maybe (String, String, String)) ( crossOperatorConflict [ ("libA", OperatorDecl OpInfixL 50 "<>" (Name "joinA")), ("libB", OperatorDecl OpInfixR 60 "<>" (Name "joinB")) @@ -104,7 +104,7 @@ operatorScanTests = testCase "the same declaration reaching via two imports (diamond) is not a conflict" $ assertEqual "identical declarations do not conflict" - Nothing + (Nothing :: Maybe (String, String, String)) ( crossOperatorConflict [ ("libA", OperatorDecl OpInfixL 50 "<>" (Name "join")), ("libB", OperatorDecl OpInfixL 50 "<>" (Name "join")) @@ -114,7 +114,7 @@ operatorScanTests = testCase "a local operator that conflicts with an imported one is a conflict" $ assertEqual "imported versus local conflict" - (Just ("<>", "libA", "local")) + (Just ("<>", "libA", "local") :: Maybe (String, String, String)) ( crossOperatorConflict [("libA", OperatorDecl OpInfixL 50 "<>" (Name "joinA"))] [("local", OperatorDecl OpInfixR 60 "<>" (Name "joinLocal"))] From 6e7bdd295d0bda1433f1172871060e034496c6ee Mon Sep 17 00:00:00 2001 From: rodrigogribeiro Date: Wed, 5 Aug 2026 18:30:56 -0300 Subject: [PATCH 8/9] adding more tests --- test/ParserTests.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/ParserTests.hs b/test/ParserTests.hs index 53312a1da..23658aca7 100644 --- a/test/ParserTests.hs +++ b/test/ParserTests.hs @@ -81,6 +81,11 @@ operatorScanTests = "reports the redefined symbol" (Just "##") (dupSymbol "infixl 50 (##) => binA; infixl 60 (##) => binB;"), + testCase "the same symbol redeclared at the same precedence is a duplicate" $ + assertEqual + "reports the redefined symbol" + (Just "##") + (dupSymbol "infixl 50 (##) => binA; infixl 50 (##) => binB;"), testCase "same symbol as infix and postfix is reported as a duplicate" $ assertEqual "reports the conflicting symbol" From 47e5a51a338cc10b03070151e460419e87da5b29 Mon Sep 17 00:00:00 2001 From: rodrigogribeiro Date: Thu, 6 Aug 2026 16:32:18 -0300 Subject: [PATCH 9/9] fixing bugs pointed by axic and mbenke --- src/Solcore/Frontend/Lexer/SolcoreLexer.hs | 10 +- src/Solcore/Frontend/Module/Loader.hs | 144 ++++++++++-- src/Solcore/Frontend/Parser/Decl.hs | 5 + src/Solcore/Frontend/Parser/Expr.hs | 55 +++-- src/Solcore/Frontend/Parser/OperatorScan.hs | 221 ++++++++---------- src/Solcore/Frontend/Parser/Stmt.hs | 48 +++- std/std.solc | 11 +- test/OperatorTests.hs | 33 ++- test/ParserTests.hs | 176 +++++++++++++- test/examples/cases/for-body-shadow.solc | 2 +- test/examples/cases/for-break.solc | 2 +- test/examples/cases/for-continue.solc | 2 +- test/examples/cases/for-empty-init.solc | 2 +- test/examples/cases/for-init-shadow.solc | 2 +- test/examples/cases/for-inner-block.solc | 2 +- test/examples/cases/for-let-post.solc | 2 +- test/examples/cases/for-let.solc | 2 +- test/examples/cases/for-loop.solc | 2 +- test/examples/cases/for-multi-init.solc | 2 +- test/examples/cases/for-multi-post.solc | 2 +- test/examples/cases/ltproxy.solc | 2 +- test/examples/cases/monomorphic-require.solc | 2 +- test/examples/cases/polymorphic-require.solc | 2 +- test/examples/cases/simpleDiscount.solc | 2 +- test/examples/comptime/int-untyped-let.solc | 2 +- test/examples/comptime/integer-lit-class.solc | 2 +- test/imports/extlib/math/internals/add.solc | 2 +- test/operators/assoc-conflict-fail.solc | 28 +++ test/operators/bad-import-op-fail.solc | 15 ++ test/operators/comments-and-strings-ok.solc | 30 +++ test/operators/compound-fixity-fail.solc | 23 ++ test/operators/hidden-target-ok.solc | 16 ++ test/operators/import-op.solc | 7 +- test/operators/infixr.solc | 4 +- test/operators/local-op-import.solc | 7 + test/operators/privoplib.solc | 16 ++ test/operators/unexported-op-fail.solc | 10 + 37 files changed, 701 insertions(+), 194 deletions(-) create mode 100644 test/operators/assoc-conflict-fail.solc create mode 100644 test/operators/bad-import-op-fail.solc create mode 100644 test/operators/comments-and-strings-ok.solc create mode 100644 test/operators/compound-fixity-fail.solc create mode 100644 test/operators/hidden-target-ok.solc create mode 100644 test/operators/local-op-import.solc create mode 100644 test/operators/privoplib.solc create mode 100644 test/operators/unexported-op-fail.solc diff --git a/src/Solcore/Frontend/Lexer/SolcoreLexer.hs b/src/Solcore/Frontend/Lexer/SolcoreLexer.hs index ebb200767..d1653fdb0 100644 --- a/src/Solcore/Frontend/Lexer/SolcoreLexer.hs +++ b/src/Solcore/Frontend/Lexer/SolcoreLexer.hs @@ -96,8 +96,14 @@ parenOpP = lexeme $ do -- An operator symbol is normally made of operator characters (e.g. `+`, -- `^^`). It may also be an alphabetic identifier, used for postfix unit -- suffixes like `(ether)` or `(minutes)`. The two are disjoint (letters are - -- never operator characters), so the choice is unambiguous. - identSym = (:) <$> letterChar <*> many identChar + -- never operator characters), so the choice is unambiguous. A reserved word + -- (`if`, `let`, `match`, …) is not accepted as an operator symbol, since it + -- would wreck parsing wherever the keyword appears. + identSym = do + w <- (:) <$> letterChar <*> many identChar + if w `elem` reservedWords + then fail ("reserved word used as operator symbol: " ++ w) + else pure w identifier :: Parser String identifier = lexeme go "identifier" diff --git a/src/Solcore/Frontend/Module/Loader.hs b/src/Solcore/Frontend/Module/Loader.hs index df3149632..336dc8220 100644 --- a/src/Solcore/Frontend/Module/Loader.hs +++ b/src/Solcore/Frontend/Module/Loader.hs @@ -20,9 +20,9 @@ import Data.Map qualified as Map import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Set (Set) import Data.Set qualified as Set -import Solcore.Diagnostics (Diagnostic (..), DiagnosticCode (..), Label (..), LabelStyle (..), Severity (..), SourceFile, SourceMap, SourceSpan, combineSourceSpans, encodeDiagnostic, makeSourceFile, sourceMapFromFiles) +import Solcore.Diagnostics (Diagnostic (..), DiagnosticCode (..), Label (..), LabelStyle (..), Severity (..), SourceFile, SourceMap, SourceSpan, combineSourceSpans, encodeDiagnostic, makeSourceFile, sourceMapFromFiles, sourceText) import Solcore.Frontend.Module.Identity qualified as Mod -import Solcore.Frontend.Parser.OperatorScan (crossOperatorConflict, scanImports, scanOperators, scanRawOperators) +import Solcore.Frontend.Parser.OperatorScan (associativityConflict, crossOperatorConflict, exportedOperators, scanImports, scanRawOperators) import Solcore.Frontend.Parser.SolcoreParser (parseCompUnitWithOps) import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.SyntaxTree @@ -147,6 +147,9 @@ visit cfg moduleId sourcePath = do case crossOperatorConflict importedOpsTagged localTagged of Just (sym, l1, l2) -> throwError (operatorImportConflictDiagnostic sym l1 l2) Nothing -> pure () + case associativityConflict (importedOpsTagged ++ localTagged) of + Just ((l1, o1), (l2, o2)) -> throwError (operatorAssociativityConflictDiagnostic o1 l1 o2 l2) + Nothing -> pure () let importedOps = map snd importedOpsTagged parsed <- liftIO (parseCompUnitWithOps importedOps sourcePath content) cunit <- stripOperators <$> either throwError pure parsed @@ -193,14 +196,18 @@ gatherImportedOperators :: gatherImportedOperators cfg currentModule currentSourcePath imps = concat <$> mapM fromImport imps where - fromImport imp = - ( do - (_, targetPath) <- resolveImportPath cfg currentModule currentSourcePath imp - c <- liftIO (readFile targetPath) - let label = Mod.modulePathDisplay (importModule imp) - pure [(label, od) | od <- selectImportedOperators imp (scanOperators c)] - ) - `catchError` const (pure []) + -- A resolution error here (e.g. a mistyped or missing module) is *not* + -- swallowed: it must surface as the import diagnostic. Swallowing it would + -- leave the imported operators out of scope and turn a clear "module not + -- found" into a wall of unknown-operator parse errors during the main parse, + -- which happens before the import is re-resolved. + fromImport imp = do + (_, targetPath) <- resolveImportPath cfg currentModule currentSourcePath imp + c <- liftIO (readFile targetPath) + let label = Mod.modulePathDisplay (importModule imp) + -- Gate by the module's export list first (only exported operators are + -- visible), then by this import's selector. + pure [(label, od) | od <- selectImportedOperators imp (exportedOperators c)] -- Diagnostic for an operator symbol declared with different meanings in two -- modules reachable from the current one (two imports, or an import and the @@ -214,8 +221,108 @@ operatorImportConflictDiagnostic sym label1 label2 = ["declared in " ++ label1, "and in " ++ label2] ["import only one of the declarations, make them identical, or rename an operator"] +-- Diagnostic for two infix operators that share a precedence level but were +-- declared with different associativities. makeExprParser handles one precedence +-- level with a single associativity, so such a mix parses inconsistently; it is +-- rejected here at load time (as Haskell rejects it at declaration time). +operatorAssociativityConflictDiagnostic :: OperatorDecl -> String -> OperatorDecl -> String -> String +operatorAssociativityConflictDiagnostic o1 label1 o2 label2 = + loaderDiagnostic + "SC0124" + ( "operators (" + ++ opSymbol o1 + ++ ") and (" + ++ opSymbol o2 + ++ ") share precedence " + ++ show (opPrec o1) + ++ " but disagree on associativity" + ) + [ "(" ++ opSymbol o1 ++ ") is " ++ fixityKeyword (opFixity o1) ++ ", declared in " ++ label1, + "(" ++ opSymbol o2 ++ ") is " ++ fixityKeyword (opFixity o2) ++ ", declared in " ++ label2 + ] + [ "operators sharing a precedence level must all use the same associativity", + "give them different precedences, or declare them with the same associativity" + ] + +fixityKeyword :: OpFixity -> String +fixityKeyword OpInfixL = "infixl" +fixityKeyword OpInfixR = "infixr" +fixityKeyword OpInfixN = "infix" +fixityKeyword OpPrefix = "prefix" +fixityKeyword OpPostfix = "postfix" + +-- Filter the operators declared by an imported module according to the import's +-- selector, so an operator is brought into scope only when the import actually +-- selects it: +-- import M; -- all of M's operators +-- import M.{*}; -- all of M's operators +-- import M.{(^^), f}; -- only the listed operators (here (^^)) +-- import M.{f}; -- no operators +-- import M as N; -- no operators (an operator cannot be qualified) selectImportedOperators :: Import -> [OperatorDecl] -> [OperatorDecl] -selectImportedOperators _ ops = ops +selectImportedOperators (ImportModule _) ops = ops +selectImportedOperators (ImportAlias _ _) _ = [] +selectImportedOperators (ImportOnly _ (SelectItems entries _)) ops + | any isSelectAll entries = ops + | otherwise = filter ((`elem` selectedSyms) . opSymbol) ops + where + isSelectAll SelectAllItems = True + isSelectAll _ = False + selectedSyms = [sym | SelectOperator sym <- entries] + +-- The name that must be in scope for a use of an operator whose target is +-- `target` to resolve after desugaring: the target itself when unqualified (a +-- free function, e.g. `pow`), or the outermost qualifier when qualified (the +-- class that owns a method target, e.g. `Add` for `Add.add`). +operatorTargetRoot :: Name -> Name +operatorTargetRoot (QualName n _) = operatorTargetRoot n +operatorTargetRoot n = n + +-- Identity import bindings for the target functions of the operators an import +-- brings into scope. A user-defined operator desugars to a call of its target +-- function (`3 ^^ 4` becomes `pow(3, 4)`), so that target must be importable +-- whenever the operator is, even when the importer selected only the operator +-- (`import M.{(^^)}`) or hid the target (`import M.{*} hiding {and}`). These +-- bindings surface the target independently of the import's item selector, so a +-- user-defined operator is self-contained: importing it is enough to use it. +operatorTargetImportBindings :: ModuleGraph -> Import -> Mod.ModuleId -> Either String [(Name, Name)] +operatorTargetImportBindings graph imp modulePath = do + src <- moduleSourceText graph modulePath + let targets = + uniqueNames + (map (operatorTargetRoot . opFunction) (selectImportedOperators imp (exportedOperators src))) + pure [(t, t) | t <- targets] + +-- Merge selector bindings with the operator-target bindings, keeping a selector +-- binding when it already covers a target (so an explicitly imported or aliased +-- target is not doubled or overridden). +-- +-- The operator-target scan (operatorTargetImportBindings re-scans the imported +-- module's source) is skipped unless it can add anything: a plain `import M.{*}` +-- already binds every exported name, so its operator targets are present via the +-- selector; only an explicit operator selection (`import M.{(^^)}`) or a +-- wildcard that hides a name (`import M.{*} hiding {and}`) needs the scan. +withOperatorTargetBindings :: ModuleGraph -> Import -> Mod.ModuleId -> [(Name, Name)] -> Either String [(Name, Name)] +withOperatorTargetBindings graph imp modulePath bindings + | not (importNeedsOperatorTargets imp) = pure bindings + | otherwise = do + opBindings <- operatorTargetImportBindings graph imp modulePath + let existingSources = Set.fromList (map fst bindings) + pure (bindings ++ [b | b@(s, _) <- opBindings, s `Set.notMember` existingSources]) + +importNeedsOperatorTargets :: Import -> Bool +importNeedsOperatorTargets (ImportOnly _ (SelectItems entries hidden)) = + any isSelectOperator entries || (not (null hidden) && any isSelectAll entries) + where + isSelectOperator (SelectOperator _) = True + isSelectOperator _ = False + isSelectAll SelectAllItems = True + isSelectAll _ = False +importNeedsOperatorTargets _ = False + +moduleSourceText :: ModuleGraph -> Mod.ModuleId -> Either String String +moduleSourceText graph modulePath = + sourceText . loadedSource <$> lookupLoadedModuleEntry graph modulePath stripOperators :: CompUnit -> CompUnit stripOperators (CompUnit imps ds) = @@ -235,11 +342,12 @@ stripOperators (CompUnit imps ds) = isExportOp (ExportOperator _) = True isExportOp _ = False - stripImportOps (ImportOnly p (SelectItems es hs)) = - ImportOnly p (SelectItems (filter (not . isSelectOp) es) hs) + -- Operator selector entries (`import M.{(^^)}`) are kept: name resolution + -- filters them out itself (NameResolution.resolveItemSelector), and the + -- loader needs them to surface each imported operator's target function + -- (operatorTargetImportBindings). Only top-level, contract, and export + -- operator declarations are stripped. stripImportOps i = i - isSelectOp (SelectOperator _) = True - isSelectOp _ = False resolveModuleReference :: LoaderConfig -> @@ -1746,7 +1854,8 @@ validationImportedDecls graph (imp, modulePath) = case imp of ImportOnly _ selector -> do publicDecls <- publicTopDeclsForModule graph modulePath - bindings <- selectedImportBindingsFromAvailable (uniqueNames (concatMap topDeclNames publicDecls)) selector + selectorBindings <- selectedImportBindingsFromAvailable (uniqueNames (concatMap topDeclNames publicDecls)) selector + bindings <- withOperatorTargetBindings graph imp modulePath selectorBindings pure (mapMaybe toValidationImportStub (mapMaybe (selectImportedTopDecl bindings) publicDecls)) ImportModule _ -> Right [] @@ -1812,7 +1921,8 @@ typeCheckImportedDecls collidingTypeNames graph (imp, modulePath) = importOnlyDecls qualifier selector = do publicDecls <- publicTopDeclsForModule graph modulePath supportDecls <- typeCheckSupportNonFunctionDecls graph modulePath - bindings <- selectedImportBindingsFromAvailable (uniqueNames (concatMap topDeclNames publicDecls)) selector + selectorBindings <- selectedImportBindingsFromAvailable (uniqueNames (concatMap topDeclNames publicDecls)) selector + bindings <- withOperatorTargetBindings graph imp modulePath selectorBindings let selectedTypeRenameMap = selectedImportTypeRenameMap publicDecls bindings let selectedPublicDecls = mapMaybe (selectImportedTopDecl bindings) publicDecls typeRenameMap = importedTypeRenameMap collidingTypeNames qualifier publicDecls diff --git a/src/Solcore/Frontend/Parser/Decl.hs b/src/Solcore/Frontend/Parser/Decl.hs index 01f3e83e7..effbc4fc7 100644 --- a/src/Solcore/Frontend/Parser/Decl.hs +++ b/src/Solcore/Frontend/Parser/Decl.hs @@ -2,6 +2,11 @@ module Solcore.Frontend.Parser.Decl ( compUnitP, topDeclP, importP, + -- Import-path parsers, shared with the operator pre-scan (Parser.OperatorScan) + -- so both resolve module references identically. + modulePathP, + externalPathP, + itemEntryP, ) where diff --git a/src/Solcore/Frontend/Parser/Expr.hs b/src/Solcore/Frontend/Parser/Expr.hs index 958285262..ea55d9f55 100644 --- a/src/Solcore/Frontend/Parser/Expr.hs +++ b/src/Solcore/Frontend/Parser/Expr.hs @@ -5,7 +5,7 @@ where import Common.LightYear import Control.Monad.Combinators.Expr -import Data.List (groupBy, sortOn) +import Data.List (groupBy, isPrefixOf, sortOn) import Data.Ord (Down (..)) import Solcore.Diagnostics (SourceSpan) import Solcore.Frontend.Lexer.SolcoreLexer @@ -64,13 +64,15 @@ mergedOpTable ops = map (map snd) . groupBy (\a b -> fst a == fst b) . sortOn (Down . fst) - $ map userRow ops + $ map (userRow ops) ops -- Turn a user operator declaration into a table row. A use of the operator is -- desugared to a plain call of the bound function, so name resolution and the --- rest of the pipeline handle it like any other call. -userRow :: OperatorDecl -> (Int, Operator Parser Exp) -userRow od@(OperatorDecl fix prec _ fun) = +-- rest of the pipeline handle it like any other call. The full set of operators +-- in scope is threaded through so the symbol parser can reason about longer +-- operators and operator-using match patterns. +userRow :: [OperatorDecl] -> OperatorDecl -> (Int, Operator Parser Exp) +userRow ops od@(OperatorDecl fix prec _ fun) = ( prec, case fix of OpInfixL -> InfixL (mkBin <$ opTok) @@ -80,28 +82,43 @@ userRow od@(OperatorDecl fix prec _ fun) = OpPostfix -> Postfix (mkPre <$ opTok) ) where - opTok = try (opSymP od) + opTok = try (opSymP ops od) mkBin l r = locatedExpFrom [sourceSpanOf l, sourceSpanOf r] (ExpName Nothing fun [l, r]) mkPre e = locatedExpFrom [sourceSpanOf e] (ExpName Nothing fun [e]) --- Match an exact operator symbol under a maximal-munch guard. A symbolic --- operator must not be a prefix of a longer operator (`^^` is matched whole, --- not as `^` then `^`), so it must not be followed by another operator --- character. An identifier operator (a postfix unit suffix like `ether`) must --- not be a prefix of a longer identifier (`ether` must not match inside --- `ethereum`), so it must not be followed by an identifier character. --- The `|` symbol additionally must not be a match-arm separator (`| pat => …`): --- the guard runs after lexeme consumed the trailing space, so patListP --- starts on the pattern. -opSymP :: OperatorDecl -> Parser String -opSymP (OperatorDecl _ _ sym _) = +-- Match an exact operator symbol under a maximal-munch guard, consulting every +-- operator in scope. A symbolic operator must not be consumed when the following +-- characters would complete either a longer declared operator (`^^` is matched +-- whole, not as `^` then `^`, when both are declared) or an assignment token +-- (`+` before `=` is the compound assignment `+=`, not the operator `+`). It may +-- still be immediately followed by an unrelated operator: `a & ~b` parses when +-- no `&~` operator is declared. An identifier operator (a postfix unit suffix +-- like `ether`) must not be a prefix of a longer identifier (`ether` must not +-- match inside `ethereum`), so it must not be followed by an identifier +-- character. The `|` symbol additionally must not be a match-arm separator +-- (`| pat => …`): the guard parses the arm pattern with the operators in scope, +-- so operator-using patterns (e.g. `comptime 1 + 1`) are recognised rather than +-- misparsed as bitwise-or. +opSymP :: [OperatorDecl] -> OperatorDecl -> Parser String +opSymP ops (OperatorDecl _ _ sym _) = lexeme (string sym <* munchGuard) <* matchArmGuard where munchGuard - | all isOpChar sym = notFollowedBy (satisfy isOpChar) + | all isOpChar sym = notFollowedBy longerContinuation | otherwise = notFollowedBy (alphaNumChar <|> char '_') + -- Continuations that must block this symbol: the '=' of an assignment or + -- compound-assignment token, and the tail of any longer symbolic operator + -- that has `sym` as a strict prefix. + longerContinuation = choice ((() <$ char '=') : map (\suf -> () <$ string suf) longerSuffixes) + longerSuffixes = + [ drop (length sym) s + | OperatorDecl _ _ s _ <- ops, + all isOpChar s, + s /= sym, + sym `isPrefixOf` s + ] matchArmGuard - | sym == "|" = notFollowedBy (try (patListP [] *> symbol "=>")) + | sym == "|" = notFollowedBy (try (patListP ops *> symbol "=>")) | otherwise = pure () postfixP :: [OperatorDecl] -> BodyP -> Parser Exp diff --git a/src/Solcore/Frontend/Parser/OperatorScan.hs b/src/Solcore/Frontend/Parser/OperatorScan.hs index a1b09df72..c849875f2 100644 --- a/src/Solcore/Frontend/Parser/OperatorScan.hs +++ b/src/Solcore/Frontend/Parser/OperatorScan.hs @@ -4,34 +4,45 @@ module Solcore.Frontend.Parser.OperatorScan scanOperatorsLocated, duplicateOperator, crossOperatorConflict, + associativityConflict, + scanExportedOperators, + exportedOperators, scanImports, - scanExportModulePaths, ) where import Common.LightYear +import Control.Monad (void) import Data.List (nubBy) import Data.Maybe (listToMaybe) import Solcore.Frontend.Lexer.SolcoreLexer +import Solcore.Frontend.Parser.Decl (externalPathP, itemEntryP, modulePathP) import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.SyntaxTree +-- Repeatedly apply `declP` over the whole source, collecting every `Just` +-- result, while skipping whitespace, comments and string literals between +-- matches so that text inside a comment or a string literal is never scanned as +-- a declaration. `sc` runs at the start and after every item, so the choice +-- point is always at a code position: the fallback consumes a string literal as +-- a unit (via stringLit, honouring escapes) or a single code character, and +-- comments are consumed by `sc`, never entered character-by-character. +scanForDecls :: Parser (Maybe a) -> String -> [a] +scanForDecls declP src = + either (const []) (\xs -> [x | Just x <- xs]) (runParser p "" src) + where + p = sc *> many item <* eof + item = + (try declP <* sc) + <|> ((void stringLit <|> void anySingle) *> sc *> pure Nothing) + -- Lightweight scan of a source file collecting every operator declaration -- together with the source offset at which it starts. Tolerates arbitrary -- content between declarations. Declarations are returned in source order, with -- no deduplication (see scanOperators / duplicateOperator). scanOperatorsLocated :: String -> [(Int, OperatorDecl)] -scanOperatorsLocated src = - case runParser (sc *> scanP) "" src of - Left _ -> [] - Right ops -> ops +scanOperatorsLocated = scanForDecls opDeclP where - scanP :: Parser [(Int, OperatorDecl)] - scanP = do - ops <- many (try opDeclP <|> (anySingle *> pure Nothing)) - eof - pure [op | Just op <- ops] - opDeclP :: Parser (Maybe (Int, OperatorDecl)) opDeclP = do offset <- getOffset @@ -46,11 +57,9 @@ scanOperatorsLocated src = qualFunP :: Parser Name qualFunP = do h <- identifier - mt <- optional (char '.' *> identifier) + ts <- many (char '.' *> identifier) sc - pure $ case mt of - Nothing -> Name h - Just t -> QualName (Name h) t + pure (foldl QualName (Name h) ts) fixityP :: Parser OpFixity fixityP = @@ -99,22 +108,85 @@ crossOperatorConflict imported local = o1 /= o2 ] +-- Detect two infix operators that share a precedence level but disagree on +-- associativity. `makeExprParser` processes each precedence level with a single +-- associativity, so a level mixing (for example) infixl and infixr stops +-- mid-expression and leaves the rest unconsumed. Each declaration is tagged with +-- a provenance label (its module). Returns the earlier and the later (offending) +-- declaration; Nothing when every precedence level is internally consistent. +-- Prefix and postfix operators are unary and do not participate in a level's +-- infix associativity, so they never conflict here. +associativityConflict :: + [(a, OperatorDecl)] -> Maybe ((a, OperatorDecl), (a, OperatorDecl)) +associativityConflict = go [] + where + go _ [] = Nothing + go seen (cur@(_, od) : rest) + | isInfixDecl od = + case filter (conflictsWith od . snd) seen of + (prev : _) -> Just (prev, cur) + [] -> go (cur : seen) rest + | otherwise = go seen rest + conflictsWith a b = opPrec a == opPrec b && opFixity a /= opFixity b + isInfixDecl od = opFixity od `elem` [OpInfixL, OpInfixR, OpInfixN] + +-- Scan a module's `export { ... }` blocks for its operator-export policy: +-- Nothing -- no `export { ... }` block: every declared operator is exported +-- Just (True, _) -- an `export { *, ... }`: every declared operator is exported +-- Just (False, syms) -- explicit `export { ... }`: only these operator symbols are exported +-- If the export block cannot be parsed, it is treated as absent (fail open, so a +-- valid operator is never wrongly hidden). +scanExportedOperators :: String -> Maybe (Bool, [String]) +scanExportedOperators src = + case scanForDecls exportBlockP src of + [] -> Nothing + blocks -> Just (any fst blocks, concatMap snd blocks) + where + exportBlockP :: Parser (Maybe (Bool, [String])) + exportBlockP = do + keyword "export" + _ <- symbol "{" + items <- exportItemP `sepBy` comma + _ <- symbol "}" + _ <- optional semicolon + pure (Just (or [star | (star, _) <- items], [s | (_, Just s) <- items])) + + -- One export spec, classified into (is it `*` / ExportAll, is it an operator). + exportItemP :: Parser (Bool, Maybe String) + exportItemP = + ((True, Nothing) <$ symbol "*") + <|> (((,) False . Just) <$> try parenOpP) + <|> ((False, Nothing) <$ otherItem) + + -- Any other spec: a (possibly qualified) name, optional `.*`, optional + -- `(constructorSelector)`. Consumed and ignored. + otherItem :: Parser () + otherItem = do + _ <- identifier + _ <- many (try (symbol "." *> identifier)) + _ <- optional (try (symbol "." *> symbol "*")) + _ <- optional (parens (void (many (satisfy (/= ')'))))) + pure () + +-- Operators of a module that are visible to importers: its declared operators +-- filtered by its export list. A module with no `export { ... }` block, or with +-- an `export { * }`, exports all of its operators. +exportedOperators :: String -> [OperatorDecl] +exportedOperators src = + case scanExportedOperators src of + Nothing -> declared + Just (True, _) -> declared + Just (False, syms) -> filter ((`elem` syms) . opSymbol) declared + where + declared = scanOperators src + -- Lightweight scan of a source file collecting every import declaration. -- Tolerates arbitrary content between imports (skips unknown tokens). -- Import syntax uses only identifiers, dots, braces, and keywords — no -- operator symbols — so this scan needs no operator table. scanImports :: String -> [Import] -scanImports src = - case runParser (sc *> scanP) "" src of - Left _ -> [] - Right imps -> imps +scanImports = scanForDecls importDeclP where - scanP :: Parser [Import] - scanP = do - imps <- many (try importDeclP <|> (anySingle *> pure Nothing)) - eof - pure [i | Just i <- imps] - importDeclP :: Parser (Maybe Import) importDeclP = do keyword "import" @@ -136,7 +208,7 @@ scanImports src = ImportModule path <$ semicolon ], do - path <- modPathP + path <- modulePathP choice [ do _ <- symbol "." @@ -154,100 +226,3 @@ scanImports src = pure (Just imp) where hidingP = keyword "hiding" *> braces (fmap Name identifier `sepBy` comma) - - modPathP :: Parser ModulePath - modPathP = do - h <- identifier - ts <- many (try (char '.' *> notFollowedBy (char '{') *> identifier)) - pure (classifyModulePath (foldl QualName (Name h) ts)) - - externalPathP :: Parser ModulePath - externalPathP = do - lib <- symbol "@" *> identifier <* char '.' - sc - h <- identifier - ts <- many (try (char '.' *> notFollowedBy (char '{') *> identifier)) - pure (ExternalPath (Name lib) (foldl QualName (Name h) ts)) - - classifyModulePath :: Name -> ModulePath - classifyModulePath n = case splitQual n of - ("lib" : rest@(_ : _)) -> LibraryPath (mkQualName rest) - _ -> RelativePath n - - splitQual :: Name -> [String] - splitQual (Name s) = [s] - splitQual (QualName n s) = splitQual n ++ [s] - - mkQualName :: [String] -> Name - mkQualName [] = error "mkQualName: empty" - mkQualName (x : xs) = foldl QualName (Name x) xs - - itemEntryP :: Parser ItemSelectorEntry - itemEntryP = - SelectAllItems - <$ symbol "*" - <|> SelectOperator - <$> try parenOpP - <|> try (SelectItemAs <$> (Name <$> identifier) <* keyword "as" <*> (Name <$> identifier)) - <|> SelectItem - . Name - <$> identifier - --- Lightweight scan collecting module paths referenced in export declarations. --- Handles: "export M;", "export M as N;", "export M.{..};", "export M.*;", --- and the @-prefixed external variants. --- Needed so the loader can visit export-referenced modules before the full parse. -scanExportModulePaths :: String -> [ModulePath] -scanExportModulePaths src = - case runParser (sc *> scanP) "" src of - Left _ -> [] - Right paths -> paths - where - scanP :: Parser [ModulePath] - scanP = do - paths <- many (try exportPathP <|> (anySingle *> pure Nothing)) - eof - pure [p | Just p <- paths] - - exportPathP :: Parser (Maybe ModulePath) - exportPathP = do - keyword "export" - -- skip the export body: skip until ';' is found (tolerant) - path <- try (Just <$> exportModulePath) <|> pure Nothing - _ <- manyTill anySingle (char ';') - sc - pure path - - -- Parse a module path that follows "export", stopping before - -- '{', '*', 'as', or ';'. - exportModulePath :: Parser ModulePath - exportModulePath = - choice - [ do - lib <- symbol "@" *> identifier <* char '.' - sc - h <- identifier - ts <- many (try (char '.' *> notFollowedBy stopChar *> identifier)) - pure (ExternalPath (Name lib) (foldl QualName (Name h) ts)), - do - h <- identifier - ts <- many (try (char '.' *> notFollowedBy stopChar *> identifier)) - let name' = foldl QualName (Name h) ts - pure (classifyModulePath name') - ] - - stopChar :: Parser () - stopChar = () <$ satisfy (\c -> c == '{' || c == '*' || c == ';') - - classifyModulePath :: Name -> ModulePath - classifyModulePath n = case splitQual n of - ("lib" : rest@(_ : _)) -> LibraryPath (mkQualName rest) - _ -> RelativePath n - - splitQual :: Name -> [String] - splitQual (Name s) = [s] - splitQual (QualName n s) = splitQual n ++ [s] - - mkQualName :: [String] -> Name - mkQualName [] = error "mkQualName: empty" - mkQualName (x : xs) = foldl QualName (Name x) xs diff --git a/src/Solcore/Frontend/Parser/Stmt.hs b/src/Solcore/Frontend/Parser/Stmt.hs index 57d6d194a..80003393b 100644 --- a/src/Solcore/Frontend/Parser/Stmt.hs +++ b/src/Solcore/Frontend/Parser/Stmt.hs @@ -7,10 +7,13 @@ where import Common.LightYear import Control.Monad (void) import Language.Yul.Parser (yulBlock) +import Solcore.Diagnostics (SourceSpan) import Solcore.Frontend.Lexer.SolcoreLexer import Solcore.Frontend.Parser.Expr (exprP) import Solcore.Frontend.Parser.Patterns (patListP) -import Solcore.Frontend.Parser.SolcoreTypes (locatedP, simpleNameP, typeP) +import Solcore.Frontend.Parser.SolcoreTypes (locatedFromSpans, locatedP, simpleNameP, typeP) +import Solcore.Frontend.Syntax.Location (sourceSpanOf) +import Solcore.Frontend.Syntax.Name (Name) import Solcore.Frontend.Syntax.SyntaxTree bodyP :: [OperatorDecl] -> Parser Body @@ -109,22 +112,55 @@ exprOrAssignP ops = locatedP locatedStmt $ do -- using the operator bound to in scope; there are no built-in operators, -- so the base operator must be declared (e.g. imported from the standard -- library). lhs is duplicated into both the assignment target and the call. +-- The base operator of a binary compound assignment (`+=`, `%=`, …) must be an +-- infix operator: it is applied to two arguments (lhs and rhs). Rejecting a +-- prefix/postfix operator here avoids emitting a two-argument call to a +-- one-argument function, which would only surface as an obscure arity error +-- much later in the pipeline. compoundAssign :: [OperatorDecl] -> String -> Exp -> Exp -> Parser Stmt compoundAssign ops sym lhs rhs = case filter ((== sym) . opSymbol) ops of - (od : _) -> pure (Assign lhs (ExpName Nothing (opFunction od) [lhs, rhs])) + (od : _) + | isInfixFixity (opFixity od) -> + pure (Assign lhs (opCall (opFunction od) [lhs, rhs])) + | otherwise -> + fail ("operator (" ++ sym ++ ") is not infix, so it cannot be used with '" ++ sym ++ "='") [] -> fail ("operator (" ++ sym ++ ") must be in scope to use '" ++ sym ++ "='") -- A unary compound assignment `lhs =` desugars to `lhs = (lhs)` using --- the (prefix) operator bound to in scope. Used for `~=`, the in-place --- bitwise NOT: `lhs ~=` becomes `lhs = ~lhs`. As with compoundAssign, the base --- operator must be declared (there are no built-in operators). +-- the (prefix/postfix) operator bound to in scope. Used for `~=`, the +-- in-place bitwise NOT: `lhs ~=` becomes `lhs = ~lhs`. As with compoundAssign, +-- the base operator must be declared (there are no built-in operators) and, so +-- that the single-argument call is well formed, it must be unary. compoundAssignUnary :: [OperatorDecl] -> String -> Exp -> Parser Stmt compoundAssignUnary ops sym lhs = case filter ((== sym) . opSymbol) ops of - (od : _) -> pure (Assign lhs (ExpName Nothing (opFunction od) [lhs])) + (od : _) + | isUnaryFixity (opFixity od) -> + pure (Assign lhs (opCall (opFunction od) [lhs])) + | otherwise -> + fail ("operator (" ++ sym ++ ") is not prefix/postfix, so it cannot be used with '" ++ sym ++ "='") [] -> fail ("operator (" ++ sym ++ ") must be in scope to use '" ++ sym ++ "='") +-- Build the desugared operator call, keeping the source span of the operands so +-- diagnostics point back at the compound assignment rather than losing location. +opCall :: Name -> [Exp] -> Exp +opCall fun args = locatedExpFrom (map sourceSpanOf args) (ExpName Nothing fun args) + +locatedExpFrom :: [Maybe SourceSpan] -> Exp -> Exp +locatedExpFrom = locatedFromSpans locatedExp + +isInfixFixity :: OpFixity -> Bool +isInfixFixity OpInfixL = True +isInfixFixity OpInfixR = True +isInfixFixity OpInfixN = True +isInfixFixity _ = False + +isUnaryFixity :: OpFixity -> Bool +isUnaryFixity OpPrefix = True +isUnaryFixity OpPostfix = True +isUnaryFixity _ = False + forInitP :: [OperatorDecl] -> Parser Stmt forInitP ops = locatedP locatedStmt $ do stmts <- (forLetP ops <|> forAssignP ops) `sepBy` comma diff --git a/std/std.solc b/std/std.solc index 59d397edd..97c1d78b0 100644 --- a/std/std.solc +++ b/std/std.solc @@ -206,7 +206,16 @@ export { (==), (!=), (&&), - (||) + (||), + (~), + (wei), + (gwei), + (ether), + (seconds), + (minutes), + (hours), + (days), + (weeks) }; /* diff --git a/test/OperatorTests.hs b/test/OperatorTests.hs index ddf1cd754..032c18a1c 100644 --- a/test/OperatorTests.hs +++ b/test/OperatorTests.hs @@ -16,6 +16,7 @@ operatorTests = unitTests, lambdaTests, importTests, + commentTests, errorTests ] @@ -89,7 +90,23 @@ importTests :: TestTree importTests = testGroup "Import and export of operators" - [ runOpSuccess "import-op.solc" + [ -- import-op.solc selects only the operator (^^), not its target `pow`: a + -- user-defined operator is self-contained. + runOpSuccess "import-op.solc", + -- (&&)'s target `and` is hidden, yet the operator still works because its + -- target is surfaced independently of the item selector. + runOpSuccess "hidden-target-ok.solc", + -- Importing only a name (std.{addWord}) does not bring std's own (+) + -- operator into scope, so a module may declare its own (+) bound to that + -- imported function without an operator conflict. + runOpSuccess "local-op-import.solc" + ] + +commentTests :: TestTree +commentTests = + testGroup + "Operators in comments and strings are ignored" + [ runOpSuccess "comments-and-strings-ok.solc" ] errorTests :: TestTree @@ -104,8 +121,20 @@ errorTests = -- redefinition, and a second fixity for the same symbol. runOpFailure "redefined-fail.solc", runOpFailure "infix-postfix-fail.solc", + -- A compound assignment whose base operator has the wrong fixity is a + -- parse error: `~=` needs a unary operator, but here `~` is declared infix. + runOpFailure "compound-fixity-fail.solc", + -- Two operators at the same precedence with different associativities + -- (infixl vs infixr) is a load-time error (SC0124). + runOpFailure "assoc-conflict-fail.solc", -- Importing two modules that declare the same operator incompatibly is a -- compile error (SC0123). oplibx.solc and opliby.solc are the two -- conflicting library modules. - runOpFailure "import-conflict-fail.solc" + runOpFailure "import-conflict-fail.solc", + -- An operator declared but not exported by its module is not importable; + -- privoplib.solc declares (%%) but exports only its function. + runOpFailure "unexported-op-fail.solc", + -- A missing module in an operator import surfaces the import diagnostic + -- instead of being swallowed into unknown-operator parse errors. + runOpFailure "bad-import-op-fail.solc" ] diff --git a/test/ParserTests.hs b/test/ParserTests.hs index 23658aca7..2febaaa92 100644 --- a/test/ParserTests.hs +++ b/test/ParserTests.hs @@ -6,7 +6,7 @@ import Common.LightYear (Parser, runParserE) import Solcore.Frontend.Lexer.SolcoreLexer (sc) import Solcore.Frontend.Parser.Decl (topDeclP) import Solcore.Frontend.Parser.Expr (exprP) -import Solcore.Frontend.Parser.OperatorScan (crossOperatorConflict, duplicateOperator, scanOperatorsLocated) +import Solcore.Frontend.Parser.OperatorScan (associativityConflict, crossOperatorConflict, duplicateOperator, exportedOperators, scanImports, scanOperatorsLocated) import Solcore.Frontend.Parser.Patterns (patP) import Solcore.Frontend.Parser.SolcoreTypes (predP, typeP) import Solcore.Frontend.Parser.Stmt (bodyP, stmtP) @@ -65,9 +65,116 @@ parserTests = stmtTests, declTests, keywordPrefixTests, - operatorScanTests + operatorScanTests, + scanLexicalTests, + scanTargetTests, + operatorAdjacencyTests, + exportGatingTests ] +-- An operator is visible to importers only if the declaring module exports it. +-- A module with no export list, or with `export { * }`, exports all operators. +exportGatingTests :: TestTree +exportGatingTests = + testGroup + "Operator export gating" + [ testCase "no export list exports all declared operators" $ + assertEqual + "all exported" + ["^^"] + (opSyms "infixl 70 (^^) => pow;"), + testCase "an export list without the operator hides it" $ + assertEqual + "operator gated out" + ([] :: [String]) + (opSyms "infixl 70 (^^) => pow; export { pow };"), + testCase "an export list with the operator exports it" $ + assertEqual + "operator exported" + ["^^"] + (opSyms "infixl 70 (^^) => pow; export { pow, (^^) };"), + testCase "export { * } exports all declared operators" $ + assertEqual + "all exported" + ["^^"] + (opSyms "infixl 70 (^^) => pow; export { * };") + ] + where + opSyms = map opSymbol . exportedOperators + +-- The pre-scan collects operator/import declarations without a full parse, so it +-- must still respect lexical structure: declaration-like text inside a comment +-- or a string literal must be ignored (regression tests). +scanLexicalTests :: TestTree +scanLexicalTests = + testGroup + "Pre-scan ignores comments and string literals" + [ testCase "operator inside a line comment is ignored" $ + assertEqual + "only the real declaration is scanned" + ["^^"] + (opSyms "// infixl 70 (^^) => pow;\ninfixl 70 (^^) => pow;"), + testCase "operator inside a block comment is ignored" $ + assertEqual + "only the real declaration is scanned" + ["##"] + (opSyms "/* infixl 9 (##) => f; */ infixl 9 (##) => f;"), + testCase "operator inside a string literal is ignored" $ + assertEqual + "no declaration is scanned" + ([] :: [String]) + (opSyms "let s = \"infixl 1 (+) => bogus\";"), + testCase "a real operator declaration is still scanned" $ + assertEqual + "the declaration is scanned" + ["+"] + (opSyms "infixl 45 (+) => Add.add;"), + testCase "import inside a comment is ignored" $ + assertEqual + "no import is scanned" + 0 + (length (scanImports "// import evil.{*};")), + testCase "a real import is still scanned" $ + assertEqual + "the import is scanned" + 1 + (length (scanImports "import foo.{*};")) + ] + where + opSyms = map (opSymbol . snd) . scanOperatorsLocated + +-- The operator target may be a multi-segment qualified name (M.N.f); the +-- pre-scan must keep every segment, not just the first two. A reserved word is +-- never accepted as an operator symbol. +scanTargetTests :: TestTree +scanTargetTests = + testGroup + "Operator target and symbol scanning" + [ testCase "a fully qualified target keeps every segment" $ + assertEqual + "three-segment qualified name is preserved" + [QualName (QualName (Name "a") "b") "c"] + (opFuns "infixl 50 (+++) => a.b.c;"), + testCase "a single-segment target is a plain name" $ + assertEqual + "unqualified target" + [Name "f"] + (opFuns "infixl 50 (+++) => f;"), + testCase "a reserved word is not accepted as an operator symbol" $ + assertEqual + "the declaration using (if) is skipped" + ([] :: [String]) + (opSyms "infixl 50 (if) => foo;"), + testCase "a non-reserved alphabetic operator symbol is accepted" $ + assertEqual + "the unit-style symbol is scanned" + ["iff"] + (opSyms "infixl 50 (iff) => foo;") + ] + where + opFuns = map (opFunction . snd) . scanOperatorsLocated + opSyms = map (opSymbol . snd) . scanOperatorsLocated + -- The operator pre-scan rejects a symbol declared more than once within a -- module: a redefinition, or a second fixity for the same symbol. -- `duplicateOperator` reports the offending symbol; the compiler turns it into a @@ -123,10 +230,73 @@ operatorScanTests = ( crossOperatorConflict [("libA", OperatorDecl OpInfixL 50 "<>" (Name "joinA"))] [("local", OperatorDecl OpInfixR 60 "<>" (Name "joinLocal"))] - ) + ), + testCase "different operators at one precedence with different associativity conflict" $ + assertEqual + "reports the earlier and later declaration" + (Just (("libA", odf OpInfixL 50 "<+>"), ("libB", odf OpInfixR 50 "<->")) :: AssocConflict) + (associativityConflict [("libA", odf OpInfixL 50 "<+>"), ("libB", odf OpInfixR 50 "<->")]), + testCase "operators at one precedence with the same associativity do not conflict" $ + assertEqual + "same associativity is fine" + (Nothing :: AssocConflict) + (associativityConflict [("libA", odf OpInfixL 50 "<+>"), ("libB", odf OpInfixL 50 "<->")]), + testCase "operators at different precedences do not conflict" $ + assertEqual + "different precedence is fine" + (Nothing :: AssocConflict) + (associativityConflict [("libA", odf OpInfixL 50 "<+>"), ("libB", odf OpInfixR 60 "<->")]), + testCase "a prefix operator never conflicts with an infix one at the same precedence" $ + assertEqual + "prefix is unary and does not participate in infix associativity" + (Nothing :: AssocConflict) + (associativityConflict [("libA", odf OpInfixL 50 "<+>"), ("libB", odf OpPrefix 50 "!!")]) ] where dupSymbol = fmap snd . duplicateOperator . scanOperatorsLocated + odf fix prec sym = OperatorDecl fix prec sym (Name "fn") + +-- The result type of associativityConflict at String provenance labels; named so +-- the OverloadedStrings labels in the tests above are unambiguously String. +type AssocConflict = Maybe ((String, OperatorDecl), (String, OperatorDecl)) + +-- The operator-symbol parser threads the full operator table so that (item 7) an +-- operator may be immediately followed by an unrelated operator while a longer +-- declared operator or an assignment token still wins, and (item 6) a match-arm +-- separator whose next pattern uses operators is not misparsed as bitwise-or. +operatorAdjacencyTests :: TestTree +operatorAdjacencyTests = + testGroup + "Operator adjacency and match-arm separator" + [ testCase "an operator may be immediately followed by an unrelated operator" $ + parsesAs expR "a & ~b" (binR "bitand" (var "a") (unR "bnot" (var "b"))), + testCase "maximal munch still prefers the longer declared operator" $ + parsesAs expR "a && b" (binR "andOp" (var "a") (var "b")), + testCase "an operator is still blocked before '=' (compound assignment token)" $ + parseFails expR "a &= b", + testCase "a match-arm separator is not consumed as bitwise-or" $ + parsesAs + stmtR + "match n { | _ => x | comptime 1 + 1 => 0 }" + ( Match + [var "n"] + [ ([PWildcard], [StmtExp (var "x")]), + ([PExp (binR "add" (lit 1) (lit 1))], [StmtExp (lit 0)]) + ] + ) + ] + where + richOps = + [ OperatorDecl OpInfixL 45 "+" (Name "add"), + OperatorDecl OpInfixL 30 "&" (Name "bitand"), + OperatorDecl OpInfixL 30 "&&" (Name "andOp"), + OperatorDecl OpInfixL 25 "|" (Name "bitor"), + OperatorDecl OpPrefix 90 "~" (Name "bnot") + ] + expR = exprP richOps (bodyP richOps) + stmtR = stmtP richOps + binR f a b = ExpName Nothing (Name f) [a, b] + unR f a = ExpName Nothing (Name f) [a] word :: Ty word = TyCon "word" [] diff --git a/test/examples/cases/for-body-shadow.solc b/test/examples/cases/for-body-shadow.solc index 94fc9fc88..9d4c90d08 100644 --- a/test/examples/cases/for-body-shadow.solc +++ b/test/examples/cases/for-body-shadow.solc @@ -1,4 +1,4 @@ -import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le}; +import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le, (+), (<=)}; contract C { public function main() -> word { diff --git a/test/examples/cases/for-break.solc b/test/examples/cases/for-break.solc index 79e827d90..be0dbfb3f 100644 --- a/test/examples/cases/for-break.solc +++ b/test/examples/cases/for-break.solc @@ -1,4 +1,4 @@ -import std.{lt,Ord,Add,Sub,Bounded,Num,Eq,Typedef}; +import std.{lt,Ord,Add,Sub,Bounded,Num,Eq,Typedef, (+), (<), (==)}; contract BreakTest { public function main() -> word { let result : word = 0; diff --git a/test/examples/cases/for-continue.solc b/test/examples/cases/for-continue.solc index 03c68ed3e..1c3ea7ce1 100644 --- a/test/examples/cases/for-continue.solc +++ b/test/examples/cases/for-continue.solc @@ -1,4 +1,4 @@ -import std.{lt,Ord,Add,Sub,Bounded,Num,Eq,Typedef}; +import std.{lt,Ord,Add,Sub,Bounded,Num,Eq,Typedef, (+), (<)}; contract ContinueTest { public function main() -> word { let result : word = 0; diff --git a/test/examples/cases/for-empty-init.solc b/test/examples/cases/for-empty-init.solc index 5bbaa539b..f2b803a01 100644 --- a/test/examples/cases/for-empty-init.solc +++ b/test/examples/cases/for-empty-init.solc @@ -1,4 +1,4 @@ -import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le}; +import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le, (+), (<=)}; contract ForEmptyInit { function main() -> word { diff --git a/test/examples/cases/for-init-shadow.solc b/test/examples/cases/for-init-shadow.solc index d6ceaf8bb..5966b94d2 100644 --- a/test/examples/cases/for-init-shadow.solc +++ b/test/examples/cases/for-init-shadow.solc @@ -1,4 +1,4 @@ -import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le}; +import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le, (+), (<=)}; contract Prefor { public function main() -> word { diff --git a/test/examples/cases/for-inner-block.solc b/test/examples/cases/for-inner-block.solc index 307903700..b8da3feba 100644 --- a/test/examples/cases/for-inner-block.solc +++ b/test/examples/cases/for-inner-block.solc @@ -1,4 +1,4 @@ -import std.{lt,Ord,Add,Sub,Bounded,Num,Eq,Typedef}; +import std.{lt,Ord,Add,Sub,Bounded,Num,Eq,Typedef, (+), (<)}; contract ForInner { public function main() -> word { let result : word = 0; diff --git a/test/examples/cases/for-let-post.solc b/test/examples/cases/for-let-post.solc index a7f1b11d3..40b8c7501 100644 --- a/test/examples/cases/for-let-post.solc +++ b/test/examples/cases/for-let-post.solc @@ -1,4 +1,4 @@ -import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le}; +import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le, (+), (<=)}; contract C { public function main() -> word { diff --git a/test/examples/cases/for-let.solc b/test/examples/cases/for-let.solc index b5900f17e..a19c039b2 100644 --- a/test/examples/cases/for-let.solc +++ b/test/examples/cases/for-let.solc @@ -1,4 +1,4 @@ -import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le}; +import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le, (+), (<=)}; contract Prefor { public function main() -> word { diff --git a/test/examples/cases/for-loop.solc b/test/examples/cases/for-loop.solc index d910c943e..470f25c90 100644 --- a/test/examples/cases/for-loop.solc +++ b/test/examples/cases/for-loop.solc @@ -1,4 +1,4 @@ -import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le}; +import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le, (+), (<=)}; contract Prefor { public function main() -> word { diff --git a/test/examples/cases/for-multi-init.solc b/test/examples/cases/for-multi-init.solc index 5f134c4a0..f56b26eaa 100644 --- a/test/examples/cases/for-multi-init.solc +++ b/test/examples/cases/for-multi-init.solc @@ -1,4 +1,4 @@ -import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le}; +import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le, (+), (<=)}; contract ForMultiInit { function main() -> word { diff --git a/test/examples/cases/for-multi-post.solc b/test/examples/cases/for-multi-post.solc index b0183e9a3..545b05092 100644 --- a/test/examples/cases/for-multi-post.solc +++ b/test/examples/cases/for-multi-post.solc @@ -1,4 +1,4 @@ -import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le}; +import std.{Num,Add,Sub,Eq,Ord,Bounded,Typedef,le, (+), (<=)}; contract ForMultiPost { function main() -> word { diff --git a/test/examples/cases/ltproxy.solc b/test/examples/cases/ltproxy.solc index 15e88c87f..8869293ec 100644 --- a/test/examples/cases/ltproxy.solc +++ b/test/examples/cases/ltproxy.solc @@ -1,4 +1,4 @@ -import std.{lt}; +import std.{lt, (<)}; export { ltproxy }; function ltproxy() -> bool { diff --git a/test/examples/cases/monomorphic-require.solc b/test/examples/cases/monomorphic-require.solc index df7b1a2a9..5fb99aa8f 100644 --- a/test/examples/cases/monomorphic-require.solc +++ b/test/examples/cases/monomorphic-require.solc @@ -1,6 +1,6 @@ // This should trigger a warning and an error in the specialiser // due to unability to resolve result type of require -import std.{uint256,lt,not,Eq,ne,Proxy,bytes4,string}; +import std.{uint256,lt,not,Eq,ne,Proxy,bytes4,string, (!), (!=)}; import std.dispatch.{*}; forall a. diff --git a/test/examples/cases/polymorphic-require.solc b/test/examples/cases/polymorphic-require.solc index dbab329e2..4a289ebda 100644 --- a/test/examples/cases/polymorphic-require.solc +++ b/test/examples/cases/polymorphic-require.solc @@ -1,6 +1,6 @@ // This should trigger a warning and an error in the specialiser // due to unability to resolve result type of require -import std.{uint256,lt,not,Eq,ne,Proxy,bytes4,string}; +import std.{uint256,lt,not,Eq,ne,Proxy,bytes4,string, (!), (!=)}; import std.dispatch.{*}; forall a. diff --git a/test/examples/cases/simpleDiscount.solc b/test/examples/cases/simpleDiscount.solc index ebafe1b08..6e2f9b83f 100644 --- a/test/examples/cases/simpleDiscount.solc +++ b/test/examples/cases/simpleDiscount.solc @@ -1,7 +1,7 @@ // test complex match example from the blog post // simplified to use word instead of uint256 -import std.{address, Num, Add, Sub, Div, Bounded, Eq, Ord, Typedef}; +import std.{address, Num, Add, Sub, Div, Bounded, Eq, Ord, Typedef, (/)}; data AuctionState = NotStarted(word) diff --git a/test/examples/comptime/int-untyped-let.solc b/test/examples/comptime/int-untyped-let.solc index ffad1f7d7..94ffb1ed7 100644 --- a/test/examples/comptime/int-untyped-let.solc +++ b/test/examples/comptime/int-untyped-let.solc @@ -1,6 +1,6 @@ // Bare integer literals with integer class instances from std. -import std.{Eq,Ord,lt,Add,Sub}; +import std.{Eq,Ord,lt,Add,Sub, (+), (-), (<)}; function fib(comptime n : integer) -> comptime integer { if (n < 2) { diff --git a/test/examples/comptime/integer-lit-class.solc b/test/examples/comptime/integer-lit-class.solc index 636381a76..55a4e35ae 100644 --- a/test/examples/comptime/integer-lit-class.solc +++ b/test/examples/comptime/integer-lit-class.solc @@ -2,7 +2,7 @@ // The type checker infers the literal type from context: the integer:Ord/Add/Sub // instances constrain unresolved literals to `integer`. -import std.{Eq,Ord,lt,Add,Sub}; +import std.{Eq,Ord,lt,Add,Sub, (+), (-), (<)}; function fib(comptime n : integer) -> comptime integer { if (n < 2) { diff --git a/test/imports/extlib/math/internals/add.solc b/test/imports/extlib/math/internals/add.solc index 06449de71..57dc34a77 100644 --- a/test/imports/extlib/math/internals/add.solc +++ b/test/imports/extlib/math/internals/add.solc @@ -1,4 +1,4 @@ -import std.{Add}; +import std.{Add, (+)}; export {inc}; diff --git a/test/operators/assoc-conflict-fail.solc b/test/operators/assoc-conflict-fail.solc new file mode 100644 index 000000000..ee385cea4 --- /dev/null +++ b/test/operators/assoc-conflict-fail.solc @@ -0,0 +1,28 @@ +// Two infix operators declared at the same precedence but with different +// associativities (infixl vs infixr). makeExprParser handles one precedence +// level with a single associativity, so this mix parses inconsistently and must +// be rejected at load time (SC0124), just as Haskell rejects it at declaration. +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 60 (<+>) => addL; +infixr 60 (<->) => addR; + +function addL(x : word, y : word) -> word { + let r : word; + assembly { r := add(x, y) } + return r; +} + +function addR(x : word, y : word) -> word { + let r : word; + assembly { r := add(x, y) } + return r; +} + +contract AssocConflict { + function main() -> word { + return 1 <+> 2 <-> 3; + } +} diff --git a/test/operators/bad-import-op-fail.solc b/test/operators/bad-import-op-fail.solc new file mode 100644 index 000000000..9a0350432 --- /dev/null +++ b/test/operators/bad-import-op-fail.solc @@ -0,0 +1,15 @@ +// Importing a module that does not exist must surface the import diagnostic +// (a "module not found" error), not a wall of unknown-operator parse errors. +// The operator (<+>) this import would bring into scope is used below, so before +// the fix the missing import was swallowed and the failure showed up only as an +// unknown-operator parse error. +import nonexistent_operator_module.{(<+>)}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +contract BadImportOp { + function main() -> word { + return 2 <+> 3; + } +} diff --git a/test/operators/comments-and-strings-ok.solc b/test/operators/comments-and-strings-ok.solc new file mode 100644 index 000000000..dcc0f5754 --- /dev/null +++ b/test/operators/comments-and-strings-ok.solc @@ -0,0 +1,30 @@ +// Regression test for the pre-scan reading comments and string literals. +// Operator declarations written inside a line comment, a block comment, or a +// string literal must be ignored, so none of the following documentation trips +// the duplicate (SC0122) or cross-import (SC0123) operator checks. +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +// Documentation repeating the real declaration: +// infixl 70 (^^) => pow; +/* and in a block comment: infixl 70 (^^) => pow; */ +// A commented-out declaration that would conflict with std's (-) must be inert: +// prefix 90 (-) => negate; + +infixl 70 (^^) => pow; + +function pow(b : word, e : word) -> word { + let r : word; + assembly { r := exp(b, e) } + return r; +} + +contract CommentsAndStrings { + function main() -> word { + // Declaration-like text inside a string literal must also be ignored. + let doc : string = "infixl 70 (^^) => bogus"; + return 2 ^^ 3; + } +} diff --git a/test/operators/compound-fixity-fail.solc b/test/operators/compound-fixity-fail.solc new file mode 100644 index 000000000..8b0b87682 --- /dev/null +++ b/test/operators/compound-fixity-fail.solc @@ -0,0 +1,23 @@ +// The unary compound assignment `x ~=` desugars to `x = ~x`, so its base +// operator must be prefix/postfix (unary). Here `~` is declared infix, so using +// it with `~=` would build a one-argument call to a two-argument operator: the +// parser must reject it rather than emit an ill-formed call. +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 50 (~) => andWord; + +function andWord(a : word, b : word) -> word { + let r : word; + assembly { r := and(a, b) } + return r; +} + +contract CompoundFixityFail { + function main() -> word { + let x : word = 6; + x ~=; + return x; + } +} diff --git a/test/operators/hidden-target-ok.solc b/test/operators/hidden-target-ok.solc new file mode 100644 index 000000000..4ed743acd --- /dev/null +++ b/test/operators/hidden-target-ok.solc @@ -0,0 +1,16 @@ +// The operator (&&) is declared in std and desugars to the function `and`. Here +// `and` is hidden by the import, yet (&&) must still work: an operator's target +// is surfaced automatically, independently of the item selector, so `hiding` the +// bare name does not disable the operator. +import std.{*} hiding {and}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +contract HiddenTarget { + function main() -> word { + let x : word = 5; + let b : bool = (x == x) && (x == x); + if (b) { return 1; } else { return 0; } + } +} diff --git a/test/operators/import-op.solc b/test/operators/import-op.solc index 97ae83e9d..e5aefcc33 100644 --- a/test/operators/import-op.solc +++ b/test/operators/import-op.solc @@ -1,5 +1,8 @@ -// Imports and uses an operator declared in a library module. -import oplib.{pow, (^^)}; +// Imports and uses an operator declared in a library module, WITHOUT importing +// its target function `pow`: a user-defined operator is self-contained, so +// selecting only the operator is enough to use it (its target is surfaced +// automatically). +import oplib.{(^^)}; pragma no-patterson-condition ; pragma no-coverage-condition ; pragma no-bounded-variable-condition ; diff --git a/test/operators/infixr.solc b/test/operators/infixr.solc index e955375a7..1f4f55000 100644 --- a/test/operators/infixr.solc +++ b/test/operators/infixr.solc @@ -5,7 +5,9 @@ pragma no-patterson-condition ; pragma no-coverage-condition ; pragma no-bounded-variable-condition ; -infixr 45 (~>) => rsub; +// Precedence 46 is unused by the standard library. Using std's level 45 (where +// (+) and (-) are infixl) would be a same-level associativity clash (SC0124). +infixr 46 (~>) => rsub; function rsub(x : word, y : word) -> word { return Sub.sub(x, y); diff --git a/test/operators/local-op-import.solc b/test/operators/local-op-import.solc new file mode 100644 index 000000000..61092b5fa --- /dev/null +++ b/test/operators/local-op-import.solc @@ -0,0 +1,7 @@ +import std.{addWord}; + +infixl 45 (+) => addWord; + +contract Ops { + function main() -> word { 2 + 2 } +} diff --git a/test/operators/privoplib.solc b/test/operators/privoplib.solc new file mode 100644 index 000000000..9bf3c35c2 --- /dev/null +++ b/test/operators/privoplib.solc @@ -0,0 +1,16 @@ +// A library that declares an operator (%%) but exports ONLY its function, +// not the operator symbol. Importers must therefore not see (%%). +import std.{*}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +infixl 70 (%%) => ppow; + +export { ppow }; + +function ppow(b : word, e : word) -> word { + let r : word; + assembly { r := exp(b, e) } + return r; +} diff --git a/test/operators/unexported-op-fail.solc b/test/operators/unexported-op-fail.solc new file mode 100644 index 000000000..ef04ab0b3 --- /dev/null +++ b/test/operators/unexported-op-fail.solc @@ -0,0 +1,10 @@ +// The operator (%%) is declared by privoplib but not exported by it, so it is +// not visible here: only exported operators are importable. Using it must fail. +import privoplib.{(%%), ppow}; +pragma no-patterson-condition ; +pragma no-coverage-condition ; +pragma no-bounded-variable-condition ; + +contract UnexportedOp { + function main() -> word { return 2 %% 3; } +}