More work towards first-class operators

.gitignore

@@ -27,3 +27,4 @@ cabal.project.local~
 *.wat
 *.wasm
 result
+*.tix

app/Main.hs

@@ -42,6 +42,7 @@ data CmdOptions = Options
     , breakpoints :: Maybe String
     , showTime :: Bool
     , showVersion :: Bool
+    , noVerify :: Bool
     }
 
 optionsParser :: Options.Applicative.Parser CmdOptions
@@ -67,6 +68,7 @@ optionsParser =
         <*> optional (strOption (long "breakpoints" <> short 't' <> help "Breakpoints for the VM to trace (space separated list of program counter indices). -1 to trace on every instruction"))
         <*> switch (long "profile" <> short 'p' <> help "Show time spent parsing, compiling and running")
         <*> switch (long "version" <> short 'V' <> help "Show version")
+        <*> switch (long "no-verify" <> short 'n' <> help "Don't verify the program")
 
 prettyPrintExpr :: Expr -> Int -> String
 prettyPrintExpr (DoBlock exprs) i = indent i ++ "DoBlock[\n" ++ intercalate "\n" (map (\x -> prettyPrintExpr x (i + 1)) exprs) ++ "\n" ++ indent i ++ "]"
@@ -97,25 +99,29 @@ inputFileBinary input = case input of
 potentiallyTimedOperation :: (MonadIO m) => String -> Bool -> m a -> m a
 potentiallyTimedOperation msg showTime action = if showTime then timeItNamed msg action else action
 
-parseAndVerify :: String -> T.Text -> CompilerFlags -> IO (Either (ParseErrorBundle T.Text Void, Maybe Program) Program)
-parseAndVerify name t cf = do
-    -- let (result, state) = runIdentity $ runStateT (parseProgramCf' t initCompilerFlags) (ParserState{compilerFlags = cf, validLets = [], validFunctions = []})
-    let result = parseProgram t cf
+parseAndVerify name input compilerFlags =
+    return
+        ( do
+            let result = parseProgram (T.pack input) initCompilerFlags
+            case result of
+                Left err -> return $ Left (err, Nothing)
+                Right program' -> do
+                    let (Program exprs) = program'
+                    verifierResult <- verifyProgram name (T.pack input) exprs
+                    case verifierResult of
+                        Left err -> return $ Left (err, Just program')
+                        Right _ -> return $ Right program'
+        )
+
+parseNoVerify name input compilerFlags = return $ do
+    let result = parseProgram (T.pack input) initCompilerFlags
     case result of
         Left err -> return $ Left (err, Nothing)
-        Right program' -> do
-            let (Program exprs) = program'
-            verifierResult <- verifyProgram name t exprs
-            case verifierResult of
-                Left err -> return $ Left (err, Just program')
-                Right _ -> return $ Right program'
-
--- parse :: String -> String -> CompilerFlags -> IO (Either (ParseErrorBundle T.Text Data.Void.Void) (Program))
-parse name input compilerFlags = return $ parseAndVerify name (T.pack input) initCompilerFlags
+        Right program' -> return $ Right program'
 
 main :: IO ()
 main = do
-    Options input output debug verbose emitBytecode runBytecode breakpoints showTime showVersion <-
+    Options input output debug verbose emitBytecode runBytecode breakpoints showTime showVersion noVerify <-
         execParser $
             info
                 (optionsParser <**> helper)
@@ -127,18 +133,16 @@ main = do
         putStrLn $ "Indigo, version " ++ version
         exitSuccess
     when (isNothing input) $ do
-        -- runStateT repl initREPLState
         newRepl
         exitSuccess
     program <-
         if not runBytecode
             then do
                 i <- inputFile input
-                -- prog <- liftIO $ potentiallyTimedOperation "Parsing" showTime (parse (fromJust input) i CompilerFlags{verboseMode = verbose})
-                -- let expr = case prog of
-                --         Left err -> error $ "Parse error: " ++ errorBundlePretty err
-                --         Right expr -> expr
-                prog <- parse (fromJust input) i CompilerFlags{verboseMode = verbose}
+                prog <-
+                    if noVerify
+                        then parseNoVerify (fromJust input) i CompilerFlags{verboseMode = verbose}
+                        else parseAndVerify (fromJust input) i CompilerFlags{verboseMode = verbose}
                 rprog <- prog
                 expr <- case rprog of
                     Left (err, expr) -> do

examples/scratch.in

@@ -1,33 +1,41 @@
-# let split ([]: String sep: String) => [String] = [""]
-# let split ((c:cs): String sep: String) => [String] = do
-#     let rest = split cs, sep
-#     if c == sep then do
-#         "" : (split cs, sep)
-#     else do
-#         (c : (head rest)) : (tail rest)
-#     end
+# # let split ([]: String sep: String) => [String] = [""]
+# # let split ((c:cs): String sep: String) => [String] = do
+# #     let rest = split cs, sep
+# #     if c == sep then do
+# #         "" : (split cs, sep)
+# #     else do
+# #         (c : (head rest)) : (tail rest)
+# #     end
+# # end
+# trait Number
+# impl Number for Int
+# impl Number for Float
+#
+# # let add<N: Number> (a: N b: N) => N = a + b
+#
+# let split<T> ([]: [T] sep: T) => [T] = [""]
+#
+# let printNumList<N: Number> (l: [N] n: N) => IO = do
+#     
 # end
-trait Number
-impl Number for Int
-impl Number for Float
-
-let add<N: Number> (a: N b: N) => N = a + b
-
-let split<T> ([]: [T] sep: T) => [T] = [""]
-
-let printNumList<N: Number> (l: [N] n: N) => IO = do
-
-end
-
-let xxx (a: Int) => Int = a
-
-# let test (a: A b: B) => C = do
+#
+# let xxx (a: Int) => Int = a
+#
+#
+# struct Child = (name: String, age: Int) satisfies (it.age < 18)
+# let a+ (a: Int b: Int) => Int = a
+# let main => IO = do
+#     println 1 a+ 2
+#     # println Child {name: "John", age: 13}
+#     # println Child {name: "Abram", age: 20}
 # end
 
-let main => IO = do
-    println xxx (add 1,2)
-    # println add 1.0, 10
-    # println split [1, 2, 3, 4, 5], 3
-    # printNumList [1, 2, 3, 4, 5], 3
-    # println "Hello, world!"
-end
+# `+` :: Int -> Int -> Int
+# struct Cat = (name: String, age: Int)
+# # let + (a: Cat b: Cat) => Cat = Cat {name: a.name : b.name, age: a.age + b.age}
+# # let add (a: Int b: Int) => Int = a + b
+# # let add (a: Float b: Float) => Float = a - b
+# add :: Int -> Int -> Int
+# add a b = a + b
+# let main => IO = println add 3.0, 4.0
+2+5

lib/AST.hs

@@ -213,7 +213,7 @@ typeOf (Var{}) = Any -- error "Cannot infer type of variable"
 typeOf (Let _ _) = error "Cannot infer type of let"
 typeOf (If _ b _) = typeOf b
 typeOf (FuncDef{}) = error "Cannot infer type of function definition"
-typeOf (FuncDec{}) = error "Cannot infer type of function declaration"
+typeOf x@(FuncDec{}) = error $ "Cannot infer type of function declaration " ++ show x
 typeOf (Function _ _) = error "Cannot infer type of modern function"
 typeOf (DoBlock x) = if null x then None else typeOf $ last x
 typeOf (ExternDec{}) = error "Cannot infer type of extern declaration"

lib/BytecodeCompiler.hs

@@ -89,13 +89,16 @@ allocId = do
     modify (\s' -> s'{lastLabel = s + 1})
     return s
 
+preludeExpr :: IO [Parser.Expr]
+preludeExpr = do
+    i <- liftIO preludeFile
+    case parseProgram (T.pack i) CompilerFlags{verboseMode = False, needsMain = False} of -- FIXME: pass on flags
+        Left err -> error $ "Parse error: " ++ errorBundlePretty err
+        Right (Parser.Program progExpr) -> return $ progExpr ++ [Parser.FuncDef "__sep" [] Parser.Placeholder]
+
 compileProgram :: Parser.Program -> StateT (CompilerState a) IO [Instruction]
 compileProgram (Parser.Program expr) = do
-    prelude <- do
-        i <- liftIO preludeFile
-        case parseProgram (T.pack i) CompilerFlags{verboseMode = False, needsMain = False} of -- FIXME: pass on flags
-            Left err -> error $ "Parse error: " ++ errorBundlePretty err
-            Right (Parser.Program progExpr) -> return $ progExpr ++ [Parser.FuncDef "__sep" [] Parser.Placeholder]
+    prelude <- liftIO preludeExpr
     prelude' <- concatMapM compileExpr prelude
     freePart <- concatMapM compileExpr expr
     createVirtualFunctions
@@ -218,27 +221,41 @@ implsFor structName = do
     return $ map Parser.trait impls''
 
 compileExpr :: Parser.Expr -> StateT (CompilerState a) IO [Instruction]
-compileExpr (Parser.Add x y) = doBinOp x y Add
-compileExpr (Parser.Sub x y) = doBinOp x y Sub
-compileExpr (Parser.Mul x y) = doBinOp x y Mul
-compileExpr (Parser.Div x y) = doBinOp x y Div
-compileExpr (Parser.Modulo x y) = doBinOp x y Mod
-compileExpr (Parser.Power x y) = doBinOp x y Pow
-compileExpr (Parser.Gt x y) = doBinOp x y Gt
-compileExpr (Parser.Lt x y) = doBinOp x y Lt
-compileExpr (Parser.Ge x y) = doBinOp x y Lt >>= \x' -> return (x' ++ [Not])
-compileExpr (Parser.Le x y) = doBinOp x y Gt >>= \x' -> return (x' ++ [Not])
+compileExpr (Parser.Add x y) = compileExpr (Parser.FuncCall "+" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Sub x y) = compileExpr (Parser.FuncCall "-" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Mul x y) = compileExpr (Parser.FuncCall "*" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Div x y) = compileExpr (Parser.FuncCall "/" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Modulo x y) = compileExpr (Parser.FuncCall "%" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Power x y) = compileExpr (Parser.FuncCall "^" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Gt x y) = compileExpr (Parser.FuncCall ">" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Lt x y) = compileExpr (Parser.FuncCall "<" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Ge x y) = compileExpr (Parser.FuncCall ">=" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Le x y) = compileExpr (Parser.FuncCall "<=" [x, y] zeroPosition) >>= doBinOp x y . last
 compileExpr (Parser.Not x) = compileExpr x >>= \x' -> return (x' ++ [Not])
-compileExpr (Parser.Eq x y) = doBinOp x y Eq
-compileExpr (Parser.Neq x y) = doBinOp x y Eq >>= \x' -> return (x' ++ [Not])
-compileExpr (Parser.And x y) = doBinOp x y And
-compileExpr (Parser.Or x y) = doBinOp x y Or
+compileExpr (Parser.Eq x y) = compileExpr (Parser.FuncCall "==" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Neq x y) = compileExpr (Parser.FuncCall "!=" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.And x y) = compileExpr (Parser.FuncCall "&&" [x, y] zeroPosition) >>= doBinOp x y . last
+compileExpr (Parser.Or x y) = compileExpr (Parser.FuncCall "||" [x, y] zeroPosition) >>= doBinOp x y . last
 compileExpr (Parser.IntLit x) = return [Push $ DInt $ fromIntegral x]
 compileExpr (Parser.UnaryMinus (Parser.FloatLit x)) = return [Push $ DFloat (-x)]
 compileExpr (Parser.UnaryMinus (Parser.IntLit x)) = return [Push $ DInt $ -fromInteger x]
 compileExpr (Parser.StringLit x) = return [Push $ DString x]
 compileExpr (Parser.DoBlock exprs) = concatMapM compileExpr exprs
 compileExpr Parser.Placeholder = return []
+compileExpr (Parser.FuncCall "unsafeAdd" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Add])
+compileExpr (Parser.FuncCall "unsafeSub" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Sub])
+compileExpr (Parser.FuncCall "unsafeMul" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Mul])
+compileExpr (Parser.FuncCall "unsafeDiv" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Div])
+compileExpr (Parser.FuncCall "unsafeMod" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Mod])
+compileExpr (Parser.FuncCall "unsafePow" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Pow])
+compileExpr (Parser.FuncCall "unsafeGt" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Gt])
+compileExpr (Parser.FuncCall "unsafeLt" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Lt])
+compileExpr (Parser.FuncCall "unsafeGe" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Lt, Not])
+compileExpr (Parser.FuncCall "unsafeLe" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Gt, Not])
+compileExpr (Parser.FuncCall "unsafeEq" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Eq])
+compileExpr (Parser.FuncCall "unsafeNeq" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Eq, Not])
+compileExpr (Parser.FuncCall "unsafeAnd" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [And])
+compileExpr (Parser.FuncCall "unsafeOr" [x, y] _) = compileExpr x >>= \x' -> compileExpr y >>= \y' -> return (x' ++ y' ++ [Or])
 compileExpr (Parser.FuncCall "unsafePrint" [x] _) = compileExpr x >>= \x' -> return (x' ++ [Builtin Print])
 compileExpr (Parser.FuncCall "unsafeGetLine" _ _) = return [Builtin GetLine]
 compileExpr (Parser.FuncCall "unsafeGetChar" _ _) = return [Builtin GetChar]

lib/Parser.hs

@@ -8,6 +8,7 @@ module Parser (Expr (..), Program (..), parseProgram', parseProgramPure, ParserS
 -- module Parser where
 
 import AST
+import Control.Applicative.Combinators (someTill)
 import Control.Monad qualified
 import Control.Monad.Combinators
     ( between
@@ -56,6 +57,7 @@ import Text.Megaparsec.Char
     )
 import Text.Megaparsec.Char.Lexer qualified as L
 import Text.Megaparsec.Debug (dbg)
+import Text.ParserCombinators.ReadP (many1)
 
 data CompilerFlags = CompilerFlags
     { verboseMode :: Bool
@@ -96,11 +98,16 @@ binOpTable =
     , [binary "==" Eq, binary "!=" Neq, binary "<=" Le, binary ">=" Ge, binary "<" Lt, binary ">" Gt]
     , [binary "&&" And, binary "||" Or]
     , [binaryAny binaryFunctionCall]
+    -- , [prefixAny pFunctionCall]
+    -- , [postfixAny pFunctionCall]
     ]
 
 binaryFunctionCall :: String -> Expr -> Expr -> Expr
 binaryFunctionCall f a b = FuncCall f [a, b] anyPosition
 
+pFunctionCall :: String -> Expr -> Expr
+pFunctionCall f a = FuncCall f [a] anyPosition
+
 binary :: Text -> (Expr -> Expr -> Expr) -> Operator Parser Expr
 binary name f = InfixL (f <$ symbol name)
 
@@ -114,6 +121,12 @@ prefix, postfix :: Text -> (Expr -> Expr) -> Operator Parser Expr
 prefix name f = Prefix (f <$ symbol name)
 postfix name f = Postfix (f <$ symbol name)
 
+prefixAny :: (String -> Expr -> Expr) -> Operator Parser Expr
+prefixAny f = Prefix (f <$> identifier)
+
+postfixAny :: (String -> Expr -> Expr) -> Operator Parser Expr
+postfixAny f = Postfix (f <$> identifier)
+
 ref :: Parser Expr
 ref = do
     symbol "*"
@@ -162,7 +175,7 @@ identifier = do
         then fail $ "keyword " ++ show name ++ " cannot be an identifier"
         else return name
   where
-    p = (:) <$> letterChar <*> many (alphaNumChar <|> char '_')
+    p = some (alphaNumChar <|> char '_' <|> oneOf ['+', '-', '*', '/', '=', '&', '|', '!', '?', '$', '%', '^', '~'])
     check x =
         if x `elem` rws
             then fail $ "keyword " ++ show x ++ " cannot be an identifier"
@@ -245,11 +258,7 @@ funcDef = do
     FuncDef name args <$> expr <?> "function body"
 
 gravis :: Parser String
-gravis = do
-    symbol "`"
-    name <- many $ noneOf ['`']
-    symbol "`"
-    return name
+gravis = lexeme $ char '`' *> someTill L.charLiteral (char '`')
 
 funcCall :: Parser Expr
 funcCall = do
@@ -262,7 +271,7 @@ funcCall = do
 letExpr :: Parser Expr
 letExpr = do
     keyword "let"
-    name <- identifier
+    name <- identifier <|> gravis
     symbol "="
     value <- recover expr
     state <- get
@@ -308,7 +317,7 @@ generic = do
 combinedFunc :: Parser Expr
 combinedFunc = do
     keyword "let"
-    name <- identifier <?> "function name"
+    name <- identifier <|> gravis <?> "function name"
     generics <- fromMaybe [] <$> optional generic
     (args, argTypes) <- parens argsAndTypes <|> argsAndTypes
     returnType <- optional (symbol "=>" >> validType <?> "return type")