never executed always true always false
    1 {-|
    2 Module: Flaw.Script.Lua.Operations
    3 Description: Operations on Lua values.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE OverloadedStrings #-}
    8 
    9 module Flaw.Script.Lua.Operations
   10   ( luaCoerceToNumber
   11   , luaCoerceToInt
   12   , luaCoerceToBool
   13   , luaCoerceToString
   14   , luaValueShow
   15   , luaValueAdd
   16   , luaValueSub
   17   , luaValueMul
   18   , luaValueMod
   19   , luaValuePow
   20   , luaValueDiv
   21   , luaValueIDiv
   22   , luaValueBAnd
   23   , luaValueBOr
   24   , luaValueBXor
   25   , luaValueShl
   26   , luaValueShr
   27   , luaValueUnm
   28   , luaValueBNot
   29   , luaValueNot
   30   , luaValueLen
   31   , luaValueConcat
   32   , luaValueEq
   33   , luaValueLt
   34   , luaValueLe
   35   , luaValueGet
   36   , luaValueSet
   37   , luaValueCall
   38   , luaNewTable
   39   , luaNewTableSized
   40   , luaNewClosure
   41   ) where
   42 
   43 import Control.Monad
   44 import Control.Monad.Primitive
   45 import Data.Bits
   46 import qualified Data.HashTable.Class as HT(toList)
   47 import qualified Data.HashTable.ST.Cuckoo as HT
   48 import Data.Primitive.MutVar
   49 import qualified Data.Text as T
   50 import qualified Data.Text.Lazy.Builder as TL
   51 import Data.Unique
   52 import Data.Word
   53 
   54 import Flaw.Script.Lua
   55 
   56 {-# INLINABLE luaCoerceToNumber #-}
   57 luaCoerceToNumber :: LuaValue m -> Maybe Double
   58 luaCoerceToNumber v = case v of
   59   LuaInteger i -> Just $ fromIntegral i
   60   LuaReal r -> Just r
   61   LuaString s -> case reads $ T.unpack $ T.strip s of
   62     [(n, "")] -> Just n
   63     _ -> Nothing
   64   _ -> Nothing
   65 
   66 {-# INLINABLE luaCoerceToInt #-}
   67 luaCoerceToInt :: LuaValue m -> Maybe Int
   68 luaCoerceToInt v = case v of
   69   LuaInteger i -> Just i
   70   LuaReal r -> let i = floor r in if r == fromIntegral i then Just i else Nothing
   71   LuaString s -> case reads $ T.unpack $ T.strip s of
   72     [(n, "")] -> Just n
   73     _ -> Nothing
   74   _ -> Nothing
   75 
   76 {-# INLINABLE luaCoerceToBool #-}
   77 luaCoerceToBool :: LuaValue m -> Word8
   78 luaCoerceToBool v = case v of
   79   LuaNil -> 0
   80   LuaBoolean b -> b
   81   _ -> 1
   82 
   83 {-# INLINABLE luaCoerceToString #-}
   84 luaCoerceToString :: LuaValue m -> Maybe T.Text
   85 luaCoerceToString v = case v of
   86   LuaInteger i -> Just $ T.pack $ show i
   87   LuaReal r -> Just $ T.pack $ show r
   88   LuaString s -> Just s
   89   _ -> Nothing
   90 
   91 {-# INLINABLE luaValueShow #-}
   92 luaValueShow :: LuaMonad m => LuaValue m -> m TL.Builder
   93 luaValueShow a = case a of
   94   LuaNil -> return "nil"
   95   LuaBoolean b -> return $ if b > 0 then "true" else "false"
   96   LuaInteger i -> return $ TL.fromString $ show i
   97   LuaReal r -> return $ TL.fromString $ show r
   98   LuaString t -> return $ TL.fromString $ show $ T.unpack t
   99   LuaClosure
  100     { luaClosureUnique = u
  101     } -> return $ "<<closure" <> TL.fromString (show $ hashUnique u) <> ">>"
  102   LuaUserData
  103     { luaUserDataUnique = u
  104     } -> return $ "<<userdata" <> TL.fromString (show $ hashUnique u) <> ">>"
  105   LuaTable
  106     { luaTable = t
  107     } -> do
  108     l <- liftPrim $ HT.toList t
  109     s <- forM l $ \(k, v) -> do
  110       ks <- luaValueShow k
  111       vs <- luaValueShow v
  112       return $ "[ " <> ks <> " ] = " <> vs <> "; "
  113     return $ "{ " <> foldr (<>) "}" s
  114 
  115 {-# INLINABLE getMetaTable #-}
  116 getMetaTable :: LuaMonad m => LuaValue m -> m (Maybe (HT.HashTable (PrimState m) (LuaValue m) (LuaValue m)))
  117 getMetaTable v = case v of
  118   LuaTable
  119     { luaTableMetaTable = metaTableVar
  120     } -> do
  121     metaTable <- readMutVar metaTableVar
  122     return $ case metaTable of
  123       LuaTable
  124         { luaTable = table
  125         } -> Just table
  126       _ -> Nothing
  127   _ -> return Nothing
  128 
  129 {-# INLINABLE tryUnaryMetaMethod #-}
  130 tryUnaryMetaMethod :: LuaMonad m => T.Text -> LuaValue m -> m (LuaValue m)
  131 tryUnaryMetaMethod opName a = tryUnaryMetaMethodOr opName a $ throwLuaError $ LuaBadOperation opName
  132 
  133 {-# INLINABLE tryUnaryMetaMethodOr #-}
  134 tryUnaryMetaMethodOr :: LuaMonad m => T.Text -> LuaValue m -> m (LuaValue m) -> m (LuaValue m)
  135 tryUnaryMetaMethodOr opName a other = do
  136   maybeMetaTable <- getMetaTable a
  137   case maybeMetaTable of
  138     Just metaTable -> do
  139       maybeMetaMethod <- liftPrim $ HT.lookup metaTable (LuaString opName)
  140       case maybeMetaMethod of
  141         Just _metaMethod -> fail "calling unary metamethods is not implemented yet"
  142         Nothing -> other
  143     Nothing -> other
  144 
  145 {-# INLINABLE tryBinaryMetaMethod #-}
  146 tryBinaryMetaMethod :: LuaMonad m => T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m)
  147 tryBinaryMetaMethod opName a b = tryBinaryMetaMethodOr opName a b $ throwLuaError $ LuaBadOperation opName
  148 
  149 {-# INLINABLE tryBinaryMetaMethodOr #-}
  150 tryBinaryMetaMethodOr :: LuaMonad m => T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m) -> m (LuaValue m)
  151 tryBinaryMetaMethodOr opName a b other = do
  152   maybeMetaTable <- do
  153     maybeMetaTableA <- getMetaTable a
  154     case maybeMetaTableA of
  155       Just metaTable -> return $ Just metaTable
  156       Nothing -> getMetaTable b
  157   case maybeMetaTable of
  158     Just metaTable -> do
  159       maybeMetaMethod <- liftPrim $ HT.lookup metaTable (LuaString opName)
  160       case maybeMetaMethod of
  161         Just _metaMethod -> fail "caling binary metamethods is not implemented yet"
  162         Nothing -> other
  163     Nothing -> other
  164 
  165 {-# INLINABLE numberBinaryOp #-}
  166 numberBinaryOp :: LuaMonad m => (Double -> Double -> Double) -> T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m)
  167 numberBinaryOp op opName a b = let
  168   ma = luaCoerceToNumber a
  169   mb = luaCoerceToNumber b
  170   in case (ma, mb) of
  171     (Just na, Just nb) -> return $ LuaReal $ op na nb
  172     _ -> tryBinaryMetaMethod opName a b
  173 
  174 {-# INLINABLE integerBinaryOp #-}
  175 integerBinaryOp :: LuaMonad m => (Int -> Int -> Int) -> T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m)
  176 integerBinaryOp op opName a b = let
  177   ma = luaCoerceToInt a
  178   mb = luaCoerceToInt b
  179   in case (ma, mb) of
  180     (Just na, Just nb) -> return $ LuaInteger $ op na nb
  181     _ -> tryBinaryMetaMethod opName a b
  182 
  183 {-# INLINABLE integerOrNumberBinaryOp #-}
  184 integerOrNumberBinaryOp :: LuaMonad m => (Int -> Int -> Int) -> (Double -> Double -> Double) -> T.Text -> LuaValue m -> LuaValue m -> m (LuaValue m)
  185 integerOrNumberBinaryOp integerOp numberOp opName a b = case (a, b) of
  186   (LuaInteger na, LuaInteger nb) -> return $ LuaInteger $ integerOp na nb
  187   _ -> numberBinaryOp numberOp opName a b
  188 
  189 {-# INLINABLE luaValueAdd #-}
  190 luaValueAdd :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  191 luaValueAdd = integerOrNumberBinaryOp (+) (+) "__add"
  192 
  193 {-# INLINABLE luaValueSub #-}
  194 luaValueSub :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  195 luaValueSub = integerOrNumberBinaryOp (-) (-) "__sub"
  196 
  197 {-# INLINABLE luaValueMul #-}
  198 luaValueMul :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  199 luaValueMul = integerOrNumberBinaryOp (*) (*) "__mul"
  200 
  201 {-# INLINABLE luaValueMod #-}
  202 luaValueMod :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  203 luaValueMod = integerOrNumberBinaryOp rem irem "__mod" where
  204   irem a b = a - fromIntegral ((truncate $ a / b) :: Int) * b
  205 
  206 {-# INLINABLE luaValuePow #-}
  207 luaValuePow :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  208 luaValuePow = numberBinaryOp pow "__pow" where
  209   pow a b = exp $ log a * b
  210 
  211 {-# INLINABLE luaValueDiv #-}
  212 luaValueDiv :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  213 luaValueDiv = numberBinaryOp (/) "__div"
  214 
  215 {-# INLINABLE luaValueIDiv #-}
  216 luaValueIDiv :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  217 luaValueIDiv = integerOrNumberBinaryOp quot iquot "__idiv" where
  218   iquot a b = fromIntegral ((truncate $ a / b) :: Int)
  219 
  220 {-# INLINABLE luaValueBAnd #-}
  221 luaValueBAnd :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  222 luaValueBAnd = integerBinaryOp (.&.) "__band"
  223 
  224 {-# INLINABLE luaValueBOr #-}
  225 luaValueBOr :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  226 luaValueBOr = integerBinaryOp (.|.) "__bor"
  227 
  228 {-# INLINABLE luaValueBXor #-}
  229 luaValueBXor :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  230 luaValueBXor = integerBinaryOp xor "__bxor"
  231 
  232 {-# INLINABLE luaValueShl #-}
  233 luaValueShl :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  234 luaValueShl = integerBinaryOp shiftL "__shl"
  235 
  236 {-# INLINABLE luaValueShr #-}
  237 luaValueShr :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  238 luaValueShr = integerBinaryOp shiftR "__shr"
  239 
  240 {-# INLINABLE luaValueUnm #-}
  241 luaValueUnm :: LuaMonad m => LuaValue m -> m (LuaValue m)
  242 luaValueUnm a = case a of
  243   LuaInteger n -> return $ LuaInteger $ negate n
  244   _ -> case luaCoerceToNumber a of
  245     Just n -> return $ LuaReal $ negate n
  246     Nothing -> tryUnaryMetaMethod "__unm" a
  247 
  248 {-# INLINABLE luaValueBNot #-}
  249 luaValueBNot :: LuaMonad m => LuaValue m -> m (LuaValue m)
  250 luaValueBNot a = case luaCoerceToInt a of
  251   Just n -> return $ LuaInteger $ complement n
  252   Nothing -> tryUnaryMetaMethod "__bnot" a
  253 
  254 {-# INLINABLE luaValueNot #-}
  255 luaValueNot :: LuaMonad m => LuaValue m -> m (LuaValue m)
  256 luaValueNot a = return $ LuaBoolean $ luaCoerceToBool a `xor` 1
  257 
  258 {-# INLINABLE luaValueLen #-}
  259 luaValueLen :: LuaMonad m => LuaValue m -> m (LuaValue m)
  260 luaValueLen a = case a of
  261   LuaString s -> return $ LuaInteger $ T.length s
  262   _ -> tryUnaryMetaMethodOr "__len" a $ case a of
  263     LuaTable
  264       { luaTableLength = lenVar
  265       } -> LuaInteger <$> readMutVar lenVar
  266     _ -> throwLuaError $ LuaBadOperation "__len"
  267 
  268 {-# INLINABLE luaValueConcat #-}
  269 luaValueConcat :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  270 luaValueConcat a b = case (luaCoerceToString a, luaCoerceToString b) of
  271   (Just sa, Just sb) -> return $ LuaString $ sa <> sb
  272   _ -> tryBinaryMetaMethod "__concat" a b
  273 
  274 {-# INLINABLE luaValueEq #-}
  275 luaValueEq :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  276 luaValueEq a b = if a == b then return $ LuaBoolean 1
  277   else fmap (LuaBoolean . luaCoerceToBool) $ tryBinaryMetaMethodOr "__eq" a b $ return $ LuaBoolean 0
  278 
  279 {-# INLINABLE luaValueLt #-}
  280 luaValueLt :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  281 luaValueLt a b = case (a, b) of
  282   (LuaInteger na, LuaInteger nb) -> return $ LuaBoolean $ if na < nb then 1 else 0
  283   (LuaString na, LuaString nb) -> return $ LuaBoolean $ if na < nb then 1 else 0
  284   _ -> case (luaCoerceToNumber a, luaCoerceToNumber b) of
  285     (Just na, Just nb) -> return $ LuaBoolean $ if na < nb then 1 else 0
  286     _ -> (LuaBoolean . luaCoerceToBool) <$> tryBinaryMetaMethod "__lt" a b
  287 
  288 {-# INLINABLE luaValueLe #-}
  289 luaValueLe :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  290 luaValueLe a b = case (a, b) of
  291   (LuaInteger na, LuaInteger nb) -> return $ LuaBoolean $ if na <= nb then 1 else 0
  292   (LuaString na, LuaString nb) -> return $ LuaBoolean $ if na <= nb then 1 else 0
  293   _ -> case (luaCoerceToNumber a, luaCoerceToNumber b) of
  294     (Just na, Just nb) -> return $ LuaBoolean $ if na <= nb then 1 else 0
  295     _ -> fmap (LuaBoolean . luaCoerceToBool) $ tryBinaryMetaMethodOr "__le" a b $
  296       (LuaBoolean . (`xor` 1) . luaCoerceToBool) <$> tryBinaryMetaMethod "__lt" b a
  297 
  298 {-# INLINABLE luaValueGet #-}
  299 luaValueGet :: LuaMonad m => LuaValue m -> LuaValue m -> m (LuaValue m)
  300 luaValueGet t i = case t of
  301   LuaTable
  302     { luaTable = tt
  303     , luaTableMetaTable = mtVar
  304     } -> do
  305     mv <- liftPrim $ HT.lookup tt i
  306     case mv of
  307       Just v -> return v
  308       Nothing -> do
  309         mt <- readMutVar mtVar
  310         case mt of
  311           LuaTable
  312             { luaTable = mtt
  313             } -> do
  314             mmm <- liftPrim $ HT.lookup mtt $ LuaString "__index"
  315             case mmm of
  316               Just mm -> case mm of
  317                 LuaClosure
  318                   { luaClosure = c
  319                   } -> head <$> c [t, i]
  320                 nt@LuaTable {} -> luaValueGet nt i
  321                 _ -> throwLuaError $ LuaBadOperation "__index"
  322               Nothing -> return LuaNil
  323           _ -> return LuaNil
  324   _ -> throwLuaError $ LuaBadOperation "__index"
  325 
  326 {-# INLINABLE luaValueSet #-}
  327 luaValueSet :: LuaMonad m => LuaValue m -> LuaValue m -> LuaValue m -> m ()
  328 luaValueSet t i v = case t of
  329   LuaTable
  330     { luaTable = tt
  331     , luaTableLength = lenVar
  332     , luaTableMetaTable = mtVar
  333     } -> do
  334 
  335     let
  336       setExisting = case v of
  337         LuaNil -> do
  338           liftPrim $ HT.delete tt i
  339           modifyMutVar' lenVar (+ (-1))
  340         _ -> liftPrim $ HT.insert tt i v
  341       setNew = case v of
  342         LuaNil -> return ()
  343         _ -> do
  344           liftPrim $ HT.insert tt i v
  345           modifyMutVar' lenVar (+ 1)
  346 
  347     mv <- liftPrim $ HT.lookup tt i
  348     case mv of
  349       Just _ -> setExisting
  350       Nothing -> do
  351         mt <- readMutVar mtVar
  352         case mt of
  353           LuaTable
  354             { luaTable = mtt
  355             } -> do
  356             mmm <- liftPrim $ HT.lookup mtt $ LuaString "__newindex"
  357             case mmm of
  358               Just mm -> case mm of
  359                 LuaClosure
  360                   { luaClosure = c
  361                   } -> void $ c [t, i, v]
  362                 nt@LuaTable {} -> luaValueSet nt i v
  363                 _ -> throwLuaError $ LuaBadOperation "__newindex"
  364               Nothing -> setNew
  365           _ -> setNew
  366   _ -> throwLuaError $ LuaBadOperation "__newindex"
  367 
  368 {-# INLINABLE luaValueCall #-}
  369 luaValueCall :: LuaMonad m => LuaValue m -> [LuaValue m] -> m [LuaValue m]
  370 luaValueCall func args = case func of
  371   LuaClosure
  372     { luaClosure = f
  373     } -> f args
  374   LuaTable
  375     { luaTableMetaTable = mtVar
  376     } -> do
  377     mt <- readMutVar mtVar
  378     case mt of
  379       LuaTable
  380         { luaTable = mtt
  381         } -> do
  382         mmm <- liftPrim $ HT.lookup mtt $ LuaString "__call"
  383         case mmm of
  384           Just mm -> luaValueCall mm $ func : args
  385           Nothing -> throwLuaError $ LuaBadOperation "__call"
  386       _ -> throwLuaError $ LuaBadOperation "__call"
  387   _ -> throwLuaError $ LuaBadOperation "__call"
  388 
  389 {-# INLINABLE luaNewTable #-}
  390 luaNewTable :: LuaMonad m => m (LuaValue m)
  391 luaNewTable = luaCreateTable =<< liftPrim HT.new
  392 
  393 {-# INLINABLE luaNewTableSized #-}
  394 luaNewTableSized :: LuaMonad m => Int -> m (LuaValue m)
  395 luaNewTableSized size = luaCreateTable =<< liftPrim (HT.newSized size)
  396 
  397 {-# INLINE luaCreateTable #-}
  398 luaCreateTable :: LuaMonad m => HT.HashTable (PrimState m) (LuaValue m) (LuaValue m) -> m (LuaValue m)
  399 luaCreateTable t = do
  400   u <- newLuaUnique
  401   lenVar <- newMutVar 0
  402   mtVar <- newMutVar LuaNil
  403   return LuaTable
  404     { luaTableUnique = u
  405     , luaTable = t
  406     , luaTableLength = lenVar
  407     , luaTableMetaTable = mtVar
  408     }
  409 
  410 {-# INLINABLE luaNewClosure #-}
  411 luaNewClosure :: LuaMonad m => ([LuaValue m] -> m [LuaValue m]) -> m (LuaValue m)
  412 luaNewClosure f = do
  413   u <- newLuaUnique
  414   return LuaClosure
  415     { luaClosureUnique = u
  416     , luaClosure = f
  417     }