never executed always true always false
    1 {-|
    2 Module: Flaw.Script.Lua.StdLib
    3 Description: Lua standard library.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
    8 
    9 module Flaw.Script.Lua.StdLib
   10   ( registerLuaBasicLib
   11   ) where
   12 
   13 import Control.Monad
   14 import Control.Monad.Primitive
   15 import Data.Maybe
   16 import qualified Data.HashTable.ST.Cuckoo as HT
   17 import Data.Primitive.MutVar
   18 import qualified Data.Text as T
   19 import Debug.Trace
   20 
   21 import Flaw.Script.Lua
   22 import Flaw.Script.Lua.Build
   23 import Flaw.Script.Lua.Operations
   24 
   25 registerFunc :: LuaMonad m => LuaValue m -> T.Text -> ([LuaValue m] -> m [LuaValue m]) -> m ()
   26 registerFunc e n f = do
   27   c <- luaNewClosure f
   28   luaValueSet e (LuaString n) c
   29 
   30 registerNotImplementedFunc :: LuaMonad m => LuaValue m -> T.Text -> m ()
   31 registerNotImplementedFunc e n = registerFunc e n $ \_ ->
   32   throwLuaError $ LuaError $ LuaString $ "flaw-lua stdlib: " <> n <> " is not implemented"
   33 
   34 registerValue :: LuaMonad m => LuaValue m -> T.Text -> LuaValue m -> m ()
   35 registerValue e n = luaValueSet e (LuaString n)
   36 
   37 registerLuaBasicLib :: LuaMonad m => LuaValue m -> m ()
   38 registerLuaBasicLib env = do
   39   envVar <- newMutVar env
   40 
   41   let
   42     adjustArgs :: Int -> [LuaValue m] -> [LuaValue m]
   43     adjustArgs 0 _ = []
   44     adjustArgs n (x:xs) = x : adjustArgs (n - 1) xs
   45     adjustArgs n [] = LuaNil : adjustArgs (n - 1) []
   46 
   47   -- basic functions
   48 
   49   registerFunc env "assert" $ \as@(x:xs) -> if luaCoerceToBool x > 0 then return as
   50     else throwLuaError $ LuaError $ case xs of
   51       msg:_ -> msg
   52       _ -> LuaString "assertion failed!"
   53 
   54   registerFunc env "collectgarbage" $ \as -> let
   55     [opt, _arg] = adjustArgs 2 as
   56     in case luaCoerceToString opt of
   57       Just s -> case s of
   58         "collect" -> return []
   59         "stop" -> return []
   60         "restart" -> return []
   61         "count" -> return [LuaReal 0]
   62         "step" -> return [LuaBoolean 0]
   63         "setpause" -> return [LuaInteger 100]
   64         "setstepmul" -> return [LuaInteger 200]
   65         "isrunning" -> return [LuaBoolean 1]
   66         _ -> throwLuaError $ LuaError $ LuaString "collectgarbage: wrong opt"
   67       Nothing -> throwLuaError $ LuaError $ LuaString "collectgarbage: wrong opt"
   68 
   69   registerFunc env "dofile" $ [lua|
   70     local fileName = ...
   71     return loadfile(fileName)()
   72     |] envVar
   73 
   74   registerFunc env "error" $ \(msg:_) -> throwLuaError $ LuaError msg
   75 
   76   registerValue env "_G" env
   77 
   78   registerFunc env "getmetatable" $ \(obj:_) -> case obj of
   79     LuaTable
   80       { luaTableMetaTable = mtVar
   81       } -> do
   82       mt <- readMutVar mtVar
   83       case mt of
   84         LuaTable
   85           { luaTable = mtt
   86           } -> do
   87           maybeMttMt <- liftPrim $ HT.lookup mtt (LuaString "__metatable")
   88           case maybeMttMt of
   89             Just mttmt -> return [mttmt]
   90             Nothing -> return [mt]
   91         _ -> return [LuaNil]
   92     _ -> return [LuaNil]
   93 
   94   registerFunc env "ipairs" $ \(x:_) -> do
   95     f <- luaNewClosure $ case x of
   96       LuaTable
   97         { luaTable = t
   98         } -> \[_t, LuaInteger i] -> do
   99         let k = LuaInteger $ i + 1
  100         mv <- liftPrim $ HT.lookup t k
  101         case mv of
  102           Just v -> return [k, v]
  103           Nothing -> return []
  104       _ -> \_ -> return []
  105     return [f, x, LuaInteger 0]
  106 
  107   registerNotImplementedFunc env "load"
  108 
  109   registerFunc env "loadfile" $ [lua|
  110     local fileName = ...
  111     return _chunks[fileName]
  112     |] envVar
  113 
  114   registerNotImplementedFunc env "next"
  115 
  116   registerNotImplementedFunc env "pairs"
  117 
  118   registerFunc env "pcall" $ \(f:as) -> catchLuaError ((LuaBoolean 1 : ) <$> luaValueCall f as) $ \e ->
  119     return [LuaBoolean 0, LuaString $ T.pack $ show e]
  120 
  121   registerFunc env "print" $ \as -> do
  122     forM_ as $ \a -> case luaCoerceToString a of
  123       Just s -> traceM $ T.unpack s
  124       Nothing -> traceM "<<???>>"
  125     return []
  126 
  127   registerFunc env "rawequal" $ \(a:b:_) -> return [LuaBoolean $ if a == b then 1 else 0]
  128 
  129   registerFunc env "rawget" $ \(t:i:_) -> case t of
  130     LuaTable
  131       { luaTable = tt
  132       } -> do
  133       r <- liftPrim $ HT.lookup tt i
  134       return [fromMaybe LuaNil r]
  135     _ -> return [LuaNil]
  136 
  137   registerFunc env "rawlen" $ \(t:_) -> case t of
  138     LuaString s -> return [LuaInteger $ T.length s]
  139     LuaTable
  140       { luaTableLength = lenVar
  141       } -> do
  142       r <- readMutVar lenVar
  143       return [LuaInteger r]
  144     _ -> throwLuaError $ LuaBadOperation "rawlen: table or string expected"
  145 
  146   registerFunc env "rawset" $ \(t:i:v:_) -> case t of
  147     LuaTable
  148       { luaTable = tt
  149       , luaTableLength = lenVar
  150       } -> do
  151       mv <- liftPrim $ HT.lookup tt i
  152       case mv of
  153         Just _ -> case v of
  154           LuaNil -> do
  155             liftPrim $ HT.delete tt i
  156             modifyMutVar' lenVar (+ (-1))
  157           _ -> liftPrim $ HT.insert tt i v
  158         Nothing -> case v of
  159           LuaNil -> return ()
  160           _ -> do
  161             liftPrim $ HT.insert tt i v
  162             modifyMutVar' lenVar (+ 1)
  163       return [t]
  164     _ -> throwLuaError $ LuaBadOperation "rawset: table expected"
  165 
  166   registerFunc env "select" $ \(n:as) -> case n of
  167     LuaInteger i -> if i == 0 then throwLuaError $ LuaBadOperation "select: zero index"
  168       else return $ if i > 0 then drop (i - 1) as else drop (length as + i) as
  169     LuaString "#" -> return [LuaInteger $ length as]
  170     _ -> throwLuaError $ LuaBadOperation "select: non-zero index or string '#' expected"
  171 
  172   registerFunc env "setmetatable" $ \(t:mt:_) -> case t of
  173     LuaTable
  174       { luaTableMetaTable = mtVar
  175       } -> do
  176       omt <- readMutVar mtVar
  177       case omt of
  178         LuaTable
  179           { luaTable = omtt
  180           } -> do
  181           momtmt <- liftPrim $ HT.lookup omtt $ LuaString "__metatable"
  182           case momtmt of
  183             Just _ -> throwLuaError $ LuaError $ LuaString "setmetatable: table has __metatable metafield"
  184             Nothing -> return ()
  185         _ -> return ()
  186       writeMutVar mtVar mt
  187       return [t]
  188     _ -> throwLuaError $ LuaError $ LuaString "setmetatable: not a table"
  189 
  190   registerFunc env "tonumber" $ \(x:_) -> let
  191     r = case luaCoerceToNumber x of
  192       Just n -> LuaReal n
  193       Nothing -> LuaNil
  194     in return [r]
  195 
  196   registerFunc env "tostring" $ \(x:_) -> let
  197     r = case luaCoerceToString x of
  198       Just s -> LuaString s
  199       Nothing -> LuaNil
  200     in return [r]
  201 
  202   registerFunc env "type" $ \(x:_) -> let
  203     t = case x of
  204       LuaNil -> "nil"
  205       LuaBoolean _ -> "boolean"
  206       LuaInteger _ -> "number"
  207       LuaReal _ -> "number"
  208       LuaString _ -> "string"
  209       LuaClosure {} -> "function"
  210       LuaUserData {} -> "userdata"
  211       LuaTable {} -> "table"
  212     in return [LuaString t]
  213 
  214   registerValue env "_VERSION" $ LuaString "Lua 5.3"
  215 
  216   registerNotImplementedFunc env "xpcall"