implementing user defined operators

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

src/Solcore/Frontend/Lexer/SolcoreLexer.hs

@@ -13,6 +13,8 @@ module Solcore.Frontend.Lexer.SolcoreLexer
     comma,
     semicolon,
     colon,
+    isOpChar,
+    parenOpP,
   )
 where
 
@@ -69,9 +71,40 @@ 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) <|> 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. 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"
   where

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
 
@@ -24,15 +29,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 +134,8 @@ itemEntryP :: Parser ItemSelectorEntry
 itemEntryP =
   SelectAllItems
     <$ symbol "*"
+      <|> SelectOperator
+    <$> try parenOpP
       <|> try (SelectItemAs <$> simpleNameP <* keyword "as" <*> simpleNameP)
       <|> SelectItem
     <$> simpleNameP
@@ -140,6 +167,8 @@ exportSpecP :: Parser ExportSpec
 exportSpecP =
   ExportAll
     <$ symbol "*"
+      <|> ExportOperator
+    <$> try parenOpP
       <|> ExportModuleAll
     <$> try moduleAllPathP
       <|> do
@@ -243,19 +272,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 +326,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 +367,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 +414,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
               ]
         )
     ]