Fixes to function nesting, casts, etc.

Author: rockofox

examples/raylib.in

@@ -0,0 +1,41 @@
+external "__default" = do
+    sin :: Double -> Double
+end
+
+external "libraylib" = do
+    InitWindow :: Int -> Int -> String -> IO
+    BeginDrawing :: IO
+    ClearBackground :: Int -> IO
+    DrawText :: String -> Int -> Int -> Int -> Int -> IO
+    EndDrawing :: IO
+    CloseWindow :: IO
+    WindowShouldClose :: Int
+    SetTargetFPS :: Int -> IO
+    GetFrameTime :: Float
+    DrawTriangle :: Vector2 -> Vector2 -> Vector2 -> Int -> IO
+    DrawRectangle :: Int -> Int -> Int -> Int -> Int -> IO
+    DrawPixel :: Int -> Int -> Int -> IO
+    DrawLine :: Int -> Int -> Int -> Int -> Int -> IO
+end
+
+let gray = 0xFF888888
+let violet = 0xFF8800FF
+let screenWidth = 800
+let screenHeight = 450
+
+let loop (tick: Int) = do
+    BeginDrawing
+    ClearBackground 0
+    DrawText "Hello Indigo", 100, 100, 100, violet
+    EndDrawing
+    if WindowShouldClose == 0 then do
+        loop (tick + 1)
+    else do
+    end
+end
+let main = do
+    InitWindow screenWidth, screenHeight, "Hello Indigo"
+    SetTargetFPS 60
+    loop 0
+    CloseWindow
+end

lib/AST.hs

@@ -224,7 +224,7 @@ typeOf (Struct _ _) = error "Cannot infer type of struct"
 typeOf (StructLit x _) = StructT x
 typeOf (ListLit x) = if null x then List Any else List $ typeOf $ head x
 typeOf (ArrayAccess _ _) = error "Cannot infer type of array access"
-typeOf (Modulo _ _) = error "Cannot infer type of modulo"
+typeOf (Modulo x _) = typeOf x
 typeOf (Target _ _) = error "Cannot infer type of target"
 typeOf (ListConcat{}) = List Any
 typeOf (ListPattern _) = List Any

lib/BytecodeCompiler.hs

@@ -7,7 +7,8 @@ import Control.Monad (when, (>=>))
 import Control.Monad.Loops (firstM)
 import Control.Monad.State (MonadIO (liftIO), StateT, gets, modify)
 import Data.Functor ((<&>))
-import Data.List (elemIndex, find, intercalate, isInfixOf)
+import Data.List (elemIndex, find, inits, intercalate, isInfixOf, tails)
+import Data.List.Split qualified
 import Data.Maybe (fromJust, isJust, isNothing)
 import Data.Text (isPrefixOf, splitOn)
 import Data.Text qualified
@@ -228,7 +229,11 @@ compileExpr (Parser.FuncCall funcName args _) = do
     funcDecs' <- gets funcDecs
     curCon <- gets currentContext
     externals' <- gets externals
-    let fun = case findFunction (curCon ++ "@" ++ funcName) functions' argTypes of
+    let contexts = map (T.pack . intercalate "@") (inits (Data.List.Split.splitOn "@" curCon))
+    -- Find the function in any context using firstM
+    let contextFunctions = firstJust (\context -> findFunction (Data.Text.unpack context ++ "@" ++ funcName) functions' argTypes) contexts
+
+    let fun = case contextFunctions of
             (Just lf) -> lf
             Nothing -> case findFunction funcName functions' argTypes of
                 (Just f) -> f
@@ -358,15 +363,17 @@ compileExpr (Parser.If ifCond ifThen ifElse) = do
     return $ cond' ++ [Jf elseLabel] ++ then' ++ [Jmp endLabel, Label elseLabel] ++ else' ++ [Label endLabel]
 compileExpr (Parser.FloatLit x) = return [Push (DFloat x)]
 compileExpr (Parser.BoolLit x) = return [Push (DBool x)]
-compileExpr (Parser.TypeLit x) = case x of
-    Parser.Int -> return [Push $ DInt 0]
-    Parser.Float -> return [Push $ DFloat 0.0]
-    Parser.String -> return [Push $ DString ""]
-    Parser.Bool -> return [Push $ DBool False]
-    Parser.CPtr -> return [Push $ DCPtr $ ptrToWordPtr nullPtr]
-    Parser.Double -> return [Push $ DDouble 0.0]
-    _ -> error $ "Type " ++ show x ++ " is not implemented"
-compileExpr (Parser.Cast from to) = compileExpr from >>= \x -> compileExpr to >>= \y -> return (x ++ y ++ [Cast])
+compileExpr (Parser.Cast from to) = do
+    from' <- compileExpr from
+    let to' = compileType to
+    return $ from' ++ to' ++ [Cast]
+  where
+    compileType :: Parser.Expr -> [Instruction]
+    compileType (Parser.Var "Int" _) = [Push $ DInt 0]
+    compileType (Parser.Var "Float" _) = [Push $ DFloat 0.0]
+    compileType (Parser.Var "Double" _) = [Push $ DDouble 0.0]
+    compileType (Parser.Var "CPtr" _) = [Push $ DCPtr $ ptrToWordPtr nullPtr]
+    compileType x = error $ "Type " ++ show x ++ " is not implemented"
 compileExpr st@(Parser.Struct _ fields) = do
     modify (\s -> s{structDecs = st : structDecs s})
     mapM_ createFieldTrait fields
@@ -420,14 +427,14 @@ compileExpr (Parser.Impl name for methods) = do
 compileExpr (Parser.Lambda args body) = do
     fId <- allocId
     curCon <- gets currentContext
-    lets' <- gets functions
     let name = "__lambda" ++ show fId
-    let letsOfCurrentContext = filter (\x -> x.context == curCon && not ("__" `isInfixOf` x.baseName)) lets'
-    let argsAndLets = args ++ map (\x -> Parser.Var (drop 1 (dropWhile (/= '@') x.baseName)) zeroPosition) letsOfCurrentContext
-    let ldec = Parser.FuncDec name (replicate (length args + 1) Parser.Any)
-    let ldef = Parser.FuncDef name argsAndLets body
-    mapM_ compileExpr [ldec, ldef]
-    return $ map (\x -> Call x.funame) letsOfCurrentContext ++ [PushPf (curCon ++ "@" ++ name) (length letsOfCurrentContext)]
+    let def = Parser.FuncDef name args body
+    let dec = Parser.FuncDec name (replicate (length args + 1) Parser.Any)
+    let fun = Parser.Function [def] dec
+    _ <- compileExpr fun
+    lets' <- gets functions
+    let fullName = (fromJust $ findAnyFunction (curCon ++ "@" ++ name) lets').funame
+    return [PushPf fullName 0]
 compileExpr (Parser.Pipeline a (Parser.Var b _)) = compileExpr (Parser.FuncCall b [a] zeroPosition)
 compileExpr (Parser.Pipeline a (Parser.FuncCall f args _)) = compileExpr (Parser.FuncCall f (a : args) zeroPosition)
 compileExpr (Parser.Pipeline a (Parser.Then b c)) = compileExpr (Parser.Then (Parser.Pipeline a b) c)

lib/Parser.hs

@@ -156,7 +156,11 @@ identifier = do
             else return x
 
 integer :: Parser Integer
-integer = lexeme L.decimal
+integer =
+    lexeme
+        ( try (char '0' *> char 'x' *> L.hexadecimal)
+            <|> try L.decimal
+        )
 
 float :: Parser Float
 float = lexeme L.float
@@ -443,7 +447,8 @@ recover = withRecovery recover'
         return Placeholder
 
 typeLiteral :: Parser Expr
-typeLiteral = TypeLit <$> validType
+typeLiteral = do
+    TypeLit <$> validType
 
 trait :: Parser Expr
 trait = do
@@ -503,7 +508,6 @@ term =
         , try funcDec
         , try lambda
         , try structLit
-        , typeLiteral
         , array
         , try funcCall
         , try arrayAccess

lib/Util.hs

@@ -1,5 +1,7 @@
 module Util where
 
+import Control.Monad
+
 concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
 concatMapM f xs = concat <$> mapM f xs
 
@@ -11,3 +13,6 @@ startsWith :: (Eq a) => [a] -> [a] -> Bool
 startsWith [] _ = True
 startsWith _ [] = False
 startsWith (x : xs) (y : ys) = x == y && startsWith xs ys
+
+firstJust :: (a -> Maybe b) -> [a] -> Maybe b
+firstJust f = foldr (\x r -> f x `mplus` r) Nothing

lib/VM.hs

@@ -161,7 +161,7 @@ data Data
     | DList [Data]
     | DNone
     | DChar Char
-    | DFuncRef String [Data]
+    | DFuncRef String [Data] [(String, Data)]
     | DMap (Data.Map String Data)
     | DTypeQuery String
     | DCPtr WordPtr
@@ -185,7 +185,7 @@ instance Show Data where
     show (DList x) = show x
     show DNone = "None"
     show (DChar x) = show x
-    show (DFuncRef x args) = "<" ++ x ++ "(" ++ show args ++ ")>"
+    show (DFuncRef x args _) = "<" ++ x ++ "(" ++ show args ++ ")>"
     show (DMap x) = show x
     show (DTypeQuery x) = "TypeQuery " ++ x
     show (DCPtr x) = "CPtr " ++ show x
@@ -320,6 +320,31 @@ run' program = do
     modify $ \vm -> vm{pc = vm.pc + 1}
     gets running >>= flip when (run' program)
 
+instance Real Data where
+    toRational (DInt x) = toRational x
+    toRational (DFloat x) = toRational x
+    toRational (DDouble x) = toRational x
+    toRational x = error $ "Cannot convert " ++ show x ++ " to Rational"
+
+instance Enum Data where
+    toEnum = DInt
+    fromEnum (DInt x) = x
+    fromEnum (DFloat x) = round x
+    fromEnum (DDouble x) = round x
+    fromEnum x = error $ "Cannot convert " ++ show x ++ " to Int"
+
+instance Integral Data where
+    quot (DInt x) (DInt y) = DInt $ quot x y
+    quot _ _ = undefined
+    rem (DInt x) (DInt y) = DInt $ rem x y
+    rem _ _ = undefined
+    quotRem (DInt x) (DInt y) = (DInt $ quot x y, DInt $ rem x y)
+    quotRem _ _ = undefined
+    toInteger (DInt x) = toInteger x
+    toInteger (DFloat x) = round x
+    toInteger (DDouble x) = round x
+    toInteger x = error $ "Cannot convert " ++ show x ++ " to Integer"
+
 instance Num Data where
     (+) (DInt x) (DInt y) = DInt $ x + y
     (+) (DFloat x) (DFloat y) = DFloat $ x + y
@@ -435,6 +460,7 @@ instance Storable Data where
   alignment _ = 4
   peek _ = error "peek"
   poke ptr (DInt x) = poke (castPtr ptr) x
+  poke ptr (DFloat x) = poke (castPtr ptr) x
   poke ptr (DString x) = poke (castPtr ptr) (unsafePerformIO $ newCString x)
   poke ptr (DMap x) = do
     let values = Data.Map.elems (clearMap x)
@@ -561,7 +587,8 @@ runInstruction (Push d) = stackPush d
 -- runInstruction (PushPf name nArgs) = stackPopN nArgs >>= \args -> stackPush $ DFuncRef name args
 runInstruction (PushPf name nArgs) = do
     (label, _) <- findLabelFuzzy name
-    stackPopN nArgs >>= \args -> stackPush $ DFuncRef label args
+    locals <- gets (locals . safeHead . callStack)
+    stackPopN nArgs >>= \args -> stackPush $ DFuncRef label args locals
 runInstruction Pop = void stackPop
 runInstruction StackLength = stackLen >>= stackPush . DInt . fromIntegral
 -- Arithmetic
@@ -575,8 +602,7 @@ runInstruction Abs =
         DInt num -> DInt $ abs num
         DFloat num -> DFloat $ abs num
         _ -> error $ "Cannot take absolute value of " ++ show x
--- runInstruction Mod = stackPopN 2 >>= \[y, x] -> stackPush $ x `mod` y
-runInstruction Mod = error "Mod not implemented"
+runInstruction Mod = stackPopN 2 >>= \[y, x] -> stackPush $ x `mod` y
 -- IO
 runInstruction (Builtin Print) = do
     vm <- get
@@ -610,9 +636,10 @@ runInstruction (Call x) = modify $ \vm -> vm{pc = fromMaybe (error $ "Label not
 runInstruction (CallLocal x) = modify $ \vm -> vm{pc = fromMaybe (error $ "Label not found: " ++ x) $ lookup x $ labels vm, callStack = StackFrame{returnAddress = pc vm, locals = (head (callStack vm)).locals} : callStack vm}
 runInstruction CallS =
     stackPop >>= \d -> case d of
-        DFuncRef x args -> do
+        DFuncRef x args locals -> do
             stackPushN args
             runInstruction $ Call x
+            forM_ locals $ \(name, value) -> runInstruction (Push value) >> runInstruction (LStore name)
         _ -> error $ "Cannot call " ++ show d
 runInstruction (Jmp x) = do
     (_, n) <- findLabelFuzzy x
@@ -696,6 +723,7 @@ runInstruction Length =
         _ -> stackPop >>= \case DList l -> stackPush $ DInt $ length l; DString s -> stackPush $ DInt $ length s; _ -> error "Invalid type for length"
 -- Type
 runInstruction Cast = do
+    -- stackPopN 2 >>= \(x : y : _) -> stackPushN [y, x]
     to <- stackPop
     stackPop >>= \case
         (DInt x) -> stackPush $ case to of
@@ -755,7 +783,7 @@ runInstruction TypeOf =
         DList _ -> stackPush $ DString "List"
         DNone -> stackPush $ DString "None"
         DChar _ -> stackPush $ DString "Char"
-        DFuncRef _ _ -> stackPush $ DString "FuncRef"
+        DFuncRef{} -> stackPush $ DString "FuncRef"
         DMap m -> do
             case Data.Map.lookup "__name" m of
                 Just (DString name) -> stackPush $ DString name
@@ -776,7 +804,7 @@ runInstruction TypeEq =
         (DList _, DList _) -> True
         (DNone, DNone) -> True
         (DChar _, DChar _) -> True
-        (DFuncRef _ _, DFuncRef _ _) -> True
+        (DFuncRef{}, DFuncRef{}) -> True
         (DMap a, DMap b) -> do
             not (isJust (Data.Map.lookup "__name" a) && isJust (Data.Map.lookup "__name" b)) || (Data.Map.lookup "__name" a == Data.Map.lookup "__name" b)
         (DMap m, DTypeQuery tq) -> do
@@ -792,7 +820,7 @@ runInstruction TypeEq =
         (DList _, DTypeQuery s) -> s == "List"
         (DNone, DTypeQuery s) -> s == "None"
         (DChar _, DTypeQuery s) -> s == "Char"
-        (DFuncRef _ _, DTypeQuery s) -> s == "FuncRef"
+        (DFuncRef{}, DTypeQuery s) -> s == "FuncRef"
         _ -> False
 runInstruction (PackList n) = stackPopN n >>= stackPush . DList
 runInstruction (Mov n dat) = do

lib/Verifier.hs

@@ -229,6 +229,7 @@ verifyExpr (Parser.Import{objects = o, from = from, as = as, qualified = qualifi
     mangleAST (Parser.Function fdef dec) alias = Parser.Function (map (`mangleAST` alias) fdef) (mangleAST dec alias)
     mangleAST (Parser.FuncDef name args body) alias = Parser.FuncDef (alias ++ "@" ++ name) args (mangleAST body alias)
     mangleAST x _ = x
+verifyExpr (Parser.Cast _ _) = return [] -- TODO
 verifyExpr x = do
     modify (\state -> state{topLevel = False})
     concatMapM verifyExpr (children x)