flaw-lua/Flaw/Script/Lua/Operations.hs
{-|
Module: Flaw.Script.Lua.Operations
Description: Operations on Lua values.
License: MIT
-}
{-# LANGUAGE OverloadedStrings #-}
module Flaw.Script.Lua.Operations
( luaCoerceToNumber
, luaCoerceToInt
, luaCoerceToBool
, luaCoerceToString
, luaValueShow
, luaValueAdd
, luaValueSub
, luaValueMul
, luaValueMod
, luaValuePow
, luaValueDiv
, luaValueIDiv
, luaValueBAnd
, luaValueBOr
, luaValueBXor
, luaValueShl
, luaValueShr
, luaValueUnm
, luaValueBNot
, luaValueNot
, luaValueLen
, luaValueConcat
, luaValueEq
, luaValueLt
, luaValueLe
, luaValueGet
, luaValueSet
, luaValueCall
, luaNewTable
, luaNewTableSized
, luaNewClosure
) where
import Control.Monad
import Control.Monad.Primitive
import Data.Bits
import qualified Data.HashTable.Class as HT(toList)
import qualified Data.HashTable.ST.Cuckoo as HT
import Data.Primitive.MutVar
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TL
import Data.Unique
import Data.Word
import Flaw.Script.Lua
{-# INLINABLE luaCoerceToNumber #-}
luaCoerceToNumber :: LuaValue m -> Maybe Double
luaCoerceToNumber v = case v of
LuaInteger i -> Just $ fromIntegral i
LuaReal r -> Just r
LuaString s -> case reads $ T.unpack $ T.strip s of
[(n, "")] -> Just n
_ -> Nothing
_ -> Nothing
{-# INLINABLE luaCoerceToInt #-}
luaCoerceToInt :: LuaValue m -> Maybe Int
luaCoerceToInt v = case v of
LuaInteger i -> Just i
LuaReal r -> let i = floor r in if r == fromIntegral i then Just i else Nothing
LuaString s -> case reads $ T.unpack $ T.strip s of
[(n, "")] -> Just n
_ -> Nothing
_ -> Nothing
{-# INLINABLE luaCoerceToBool #-}
luaCoerceToBool :: LuaValue m -> Word8
luaCoerceToBool v = case v of
LuaNil -> 0
LuaBoolean b -> b
_ -> 1
{-# INLINABLE luaCoerceToString #-}
luaCoerceToString :: LuaValue m -> Maybe T.Text
luaCoerceToString v = case v of
LuaInteger i -> Just $ T.pack $ show i
LuaReal r -> Just $ T.pack $ show r
LuaString s -> Just s
_ -> Nothing
{-# INLINABLE luaValueShow #-}
luaValueShow :: LuaMonad m => LuaValue m -> m TL.Builder
luaValueShow a = case a of
LuaNil -> return "nil"
LuaBoolean b -> return $ if b > 0 then "true" else "false"
LuaInteger i -> return $ TL.fromString $ show i
LuaReal r -> return $ TL.fromString $ show r
LuaString t -> return $ TL.fromString $ show $ T.unpack t
LuaClosure
{ luaClosureUnique = u
} -> return $ "<<closure" <> TL.fromString (show $ hashUnique u) <> ">>"
LuaUserData
{ luaUserDataUnique = u
} -> return $ "<<userdata" <> TL.fromString (show $ hashUnique u) <> ">>"
LuaTable
{ luaTable = t
} -> do
l <- liftPrim $ HT.toList t
s <- forM l $ \(k, v) -> do
ks <- luaValueShow k
vs <- luaValueShow v
return $ "[ " <> ks <> " ] = " <> vs <> "; "
return $ "{ " <> foldr (<>) "}" s
{-# INLINABLE getMetaTable #-}
getMetaTable :: LuaMonad m => LuaValue m -> m (Maybe (HT.HashTable (PrimState m) (LuaValue m) (LuaValue m)))
getMetaTable v = case v of
LuaTable
{ luaTableMetaTable = metaTableVar
} -> do
metaTable <- readMutVar metaTableVar
return $ case metaTable of
LuaTable
{ luaTable = table
} -> Just table
_ -> Nothing
_ -> return Nothing
{-# INLINABLE tryUnaryMetaMethod #-}
tryUnaryMetaMethod :: LuaMonad m => T.Text -> LuaValue m -> m (LuaValue m)
tryUnaryMetaMethod opName a = tryUnaryMetaMethodOr opName a $ throwLuaError $ LuaBadOperation opName
{-# INLINABLE tryUnaryMetaMethodOr #-}
tryUnaryMetaMethodOr :: LuaMonad m => T.Text -> LuaValue m -> m (LuaValue m) -> m (LuaValue m)
tryUnaryMetaMethodOr opName a other = do
maybeMetaTable <- getMetaTable a
case maybeMetaTable of
Just metaTable -> do
maybeMetaMethod <- liftPrim $ HT.lookup metaTable (LuaString opName)
case maybeMetaMethod of
Just _metaMethod -> fail "calling unary metamethods is not implemented yet"
Nothing -> other
Nothing -> other
{-# INLINABLE tryBinaryMetaMethod #-}
tryBinaryMetaMethod :: LuaMonad m => T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m)
tryBinaryMetaMethod opName a b = tryBinaryMetaMethodOr opName a b $ throwLuaError $ LuaBadOperation opName
{-# INLINABLE tryBinaryMetaMethodOr #-}
tryBinaryMetaMethodOr :: LuaMonad m => T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m) -> m (LuaValue m)
tryBinaryMetaMethodOr opName a b other = do
maybeMetaTable <- do
maybeMetaTableA <- getMetaTable a
case maybeMetaTableA of
Just metaTable -> return $ Just metaTable
Nothing -> getMetaTable b
case maybeMetaTable of
Just metaTable -> do
maybeMetaMethod <- liftPrim $ HT.lookup metaTable (LuaString opName)
case maybeMetaMethod of
Just _metaMethod -> fail "caling binary metamethods is not implemented yet"
Nothing -> other
Nothing -> other
{-# INLINABLE numberBinaryOp #-}
numberBinaryOp :: LuaMonad m => (Double -> Double -> Double) -> T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m)
numberBinaryOp op opName a b = let
ma = luaCoerceToNumber a
mb = luaCoerceToNumber b
in case (ma, mb) of
(Just na, Just nb) -> return $ LuaReal $ op na nb
_ -> tryBinaryMetaMethod opName a b
{-# INLINABLE integerBinaryOp #-}
integerBinaryOp :: LuaMonad m => (Int -> Int -> Int) -> T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m)
integerBinaryOp op opName a b = let
ma = luaCoerceToInt a
mb = luaCoerceToInt b
in case (ma, mb) of
(Just na, Just nb) -> return $ LuaInteger $ op na nb
_ -> tryBinaryMetaMethod opName a b
{-# INLINABLE integerOrNumberBinaryOp #-}
integerOrNumberBinaryOp :: LuaMonad m => (Int -> Int -> Int) -> (Double -> Double -> Double) -> T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m)
integerOrNumberBinaryOp integerOp numberOp opName a b = case (a, b) of
(LuaInteger na, LuaInteger nb) -> return $ LuaInteger $ integerOp na nb
_ -> numberBinaryOp numberOp opName a b
{-# INLINABLE luaValueAdd #-}
luaValueAdd :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueAdd = integerOrNumberBinaryOp (+) (+) "__add"
{-# INLINABLE luaValueSub #-}
luaValueSub :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueSub = integerOrNumberBinaryOp (-) (-) "__sub"
{-# INLINABLE luaValueMul #-}
luaValueMul :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueMul = integerOrNumberBinaryOp (*) (*) "__mul"
{-# INLINABLE luaValueMod #-}
luaValueMod :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueMod = integerOrNumberBinaryOp rem irem "__mod" where
irem a b = a - fromIntegral ((truncate $ a / b) :: Int) * b
{-# INLINABLE luaValuePow #-}
luaValuePow :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValuePow = numberBinaryOp pow "__pow" where
pow a b = exp $ log a * b
{-# INLINABLE luaValueDiv #-}
luaValueDiv :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueDiv = numberBinaryOp (/) "__div"
{-# INLINABLE luaValueIDiv #-}
luaValueIDiv :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueIDiv = integerOrNumberBinaryOp quot iquot "__idiv" where
iquot a b = fromIntegral ((truncate $ a / b) :: Int)
{-# INLINABLE luaValueBAnd #-}
luaValueBAnd :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueBAnd = integerBinaryOp (.&.) "__band"
{-# INLINABLE luaValueBOr #-}
luaValueBOr :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueBOr = integerBinaryOp (.|.) "__bor"
{-# INLINABLE luaValueBXor #-}
luaValueBXor :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueBXor = integerBinaryOp xor "__bxor"
{-# INLINABLE luaValueShl #-}
luaValueShl :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueShl = integerBinaryOp shiftL "__shl"
{-# INLINABLE luaValueShr #-}
luaValueShr :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueShr = integerBinaryOp shiftR "__shr"
{-# INLINABLE luaValueUnm #-}
luaValueUnm :: LuaMonad m => LuaValue m -> m (LuaValue m)
luaValueUnm a = case a of
LuaInteger n -> return $ LuaInteger $ negate n
_ -> case luaCoerceToNumber a of
Just n -> return $ LuaReal $ negate n
Nothing -> tryUnaryMetaMethod "__unm" a
{-# INLINABLE luaValueBNot #-}
luaValueBNot :: LuaMonad m => LuaValue m -> m (LuaValue m)
luaValueBNot a = case luaCoerceToInt a of
Just n -> return $ LuaInteger $ complement n
Nothing -> tryUnaryMetaMethod "__bnot" a
{-# INLINABLE luaValueNot #-}
luaValueNot :: LuaMonad m => LuaValue m -> m (LuaValue m)
luaValueNot a = return $ LuaBoolean $ luaCoerceToBool a `xor` 1
{-# INLINABLE luaValueLen #-}
luaValueLen :: LuaMonad m => LuaValue m -> m (LuaValue m)
luaValueLen a = case a of
LuaString s -> return $ LuaInteger $ T.length s
_ -> tryUnaryMetaMethodOr "__len" a $ case a of
LuaTable
{ luaTableLength = lenVar
} -> LuaInteger <$> readMutVar lenVar
_ -> throwLuaError $ LuaBadOperation "__len"
{-# INLINABLE luaValueConcat #-}
luaValueConcat :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueConcat a b = case (luaCoerceToString a, luaCoerceToString b) of
(Just sa, Just sb) -> return $ LuaString $ sa <> sb
_ -> tryBinaryMetaMethod "__concat" a b
{-# INLINABLE luaValueEq #-}
luaValueEq :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueEq a b = if a == b then return $ LuaBoolean 1
else fmap (LuaBoolean . luaCoerceToBool) $ tryBinaryMetaMethodOr "__eq" a b $ return $ LuaBoolean 0
{-# INLINABLE luaValueLt #-}
luaValueLt :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueLt a b = case (a, b) of
(LuaInteger na, LuaInteger nb) -> return $ LuaBoolean $ if na < nb then 1 else 0
(LuaString na, LuaString nb) -> return $ LuaBoolean $ if na < nb then 1 else 0
_ -> case (luaCoerceToNumber a, luaCoerceToNumber b) of
(Just na, Just nb) -> return $ LuaBoolean $ if na < nb then 1 else 0
_ -> (LuaBoolean . luaCoerceToBool) <$> tryBinaryMetaMethod "__lt" a b
{-# INLINABLE luaValueLe #-}
luaValueLe :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueLe a b = case (a, b) of
(LuaInteger na, LuaInteger nb) -> return $ LuaBoolean $ if na <= nb then 1 else 0
(LuaString na, LuaString nb) -> return $ LuaBoolean $ if na <= nb then 1 else 0
_ -> case (luaCoerceToNumber a, luaCoerceToNumber b) of
(Just na, Just nb) -> return $ LuaBoolean $ if na <= nb then 1 else 0
_ -> fmap (LuaBoolean . luaCoerceToBool) $ tryBinaryMetaMethodOr "__le" a b $
(LuaBoolean . (`xor` 1) . luaCoerceToBool) <$> tryBinaryMetaMethod "__lt" b a
{-# INLINABLE luaValueGet #-}
luaValueGet :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
luaValueGet t i = case t of
LuaTable
{ luaTable = tt
, luaTableMetaTable = mtVar
} -> do
mv <- liftPrim $ HT.lookup tt i
case mv of
Just v -> return v
Nothing -> do
mt <- readMutVar mtVar
case mt of
LuaTable
{ luaTable = mtt
} -> do
mmm <- liftPrim $ HT.lookup mtt $ LuaString "__index"
case mmm of
Just mm -> case mm of
LuaClosure
{ luaClosure = c
} -> head <$> c [t, i]
nt@LuaTable {} -> luaValueGet nt i
_ -> throwLuaError $ LuaBadOperation "__index"
Nothing -> return LuaNil
_ -> return LuaNil
_ -> throwLuaError $ LuaBadOperation "__index"
{-# INLINABLE luaValueSet #-}
luaValueSet :: LuaMonad m => LuaValue m -> LuaValue m -> LuaValue m -> m ()
luaValueSet t i v = case t of
LuaTable
{ luaTable = tt
, luaTableLength = lenVar
, luaTableMetaTable = mtVar
} -> do
let
setExisting = case v of
LuaNil -> do
liftPrim $ HT.delete tt i
modifyMutVar' lenVar (+ (-1))
_ -> liftPrim $ HT.insert tt i v
setNew = case v of
LuaNil -> return ()
_ -> do
liftPrim $ HT.insert tt i v
modifyMutVar' lenVar (+ 1)
mv <- liftPrim $ HT.lookup tt i
case mv of
Just _ -> setExisting
Nothing -> do
mt <- readMutVar mtVar
case mt of
LuaTable
{ luaTable = mtt
} -> do
mmm <- liftPrim $ HT.lookup mtt $ LuaString "__newindex"
case mmm of
Just mm -> case mm of
LuaClosure
{ luaClosure = c
} -> void $ c [t, i, v]
nt@LuaTable {} -> luaValueSet nt i v
_ -> throwLuaError $ LuaBadOperation "__newindex"
Nothing -> setNew
_ -> setNew
_ -> throwLuaError $ LuaBadOperation "__newindex"
{-# INLINABLE luaValueCall #-}
luaValueCall :: LuaMonad m => LuaValue m -> [LuaValue m] -> m [LuaValue m]
luaValueCall func args = case func of
LuaClosure
{ luaClosure = f
} -> f args
LuaTable
{ luaTableMetaTable = mtVar
} -> do
mt <- readMutVar mtVar
case mt of
LuaTable
{ luaTable = mtt
} -> do
mmm <- liftPrim $ HT.lookup mtt $ LuaString "__call"
case mmm of
Just mm -> luaValueCall mm $ func : args
Nothing -> throwLuaError $ LuaBadOperation "__call"
_ -> throwLuaError $ LuaBadOperation "__call"
_ -> throwLuaError $ LuaBadOperation "__call"
{-# INLINABLE luaNewTable #-}
luaNewTable :: LuaMonad m => m (LuaValue m)
luaNewTable = luaCreateTable =<< liftPrim HT.new
{-# INLINABLE luaNewTableSized #-}
luaNewTableSized :: LuaMonad m => Int -> m (LuaValue m)
luaNewTableSized size = luaCreateTable =<< liftPrim (HT.newSized size)
{-# INLINE luaCreateTable #-}
luaCreateTable :: LuaMonad m => HT.HashTable (PrimState m) (LuaValue m) (LuaValue m) -> m (LuaValue m)
luaCreateTable t = do
u <- newLuaUnique
lenVar <- newMutVar 0
mtVar <- newMutVar LuaNil
return LuaTable
{ luaTableUnique = u
, luaTable = t
, luaTableLength = lenVar
, luaTableMetaTable = mtVar
}
{-# INLINABLE luaNewClosure #-}
luaNewClosure :: LuaMonad m => ([LuaValue m] -> m [LuaValue m]) -> m (LuaValue m)
luaNewClosure f = do
u <- newLuaUnique
return LuaClosure
{ luaClosureUnique = u
, luaClosure = f
}