diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# Changelog + +`hslua-list` uses [PVP Versioning](https://pvp.haskell.org). + +## hslua-list-1.0.0 + +Released 2022-10-10. + +- To boldly go where no Haskell library has gone before. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright © 2021-2022 Albert Krewinkel + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +hslua-list +========== + +Opinionated, fast, and extensible implementation of a Lua *List* +type. The type re-uses some parts of Lua's base library, so the +*base* library must be loaded before this one. diff --git a/cbits/listmod.c b/cbits/listmod.c new file mode 100644 --- /dev/null +++ b/cbits/listmod.c @@ -0,0 +1,354 @@ +#include +#include "lua.h" +#include "lauxlib.h" +#include "lualib.h" + +#define LIST_T "List" + +/* compatibility with older Lua versions, which did not define this in the + * header. */ +#ifndef LUA_LOADED_TABLE +/* key, in the registry, for table of loaded modules */ +#define LUA_LOADED_TABLE "_LOADED" +#endif + +/* +** Placeholder function. +*/ +static int missing (lua_State *L) { + return luaL_error(L, + "Function should have been overwritten with one from the table module." + ); +} + +/* Translate a relative table position: negative means back from end */ +static lua_Integer posrelat (lua_Integer pos, size_t len) { + if (pos >= 0) return pos; + else if (0u - (size_t)pos > len) return 0; + else return (lua_Integer)len + pos + 1; +} + +/* +** Check that 'arg' is either a function or a different callable object. +*/ +static void checkcallable (lua_State *L, int arg) { + if (lua_type(L, arg) != LUA_TFUNCTION) { /* is it not a function? */ + if (luaL_getmetafield(L, arg, "__call")) + lua_pop(L, 1); /* pop metamethod */ + else + luaL_checktype(L, arg, LUA_TFUNCTION); /* force an error */ + } +} + +/* +** Creates a List from a table; uses a fresh, empty table if none is +** given. +*/ +static int list_new (lua_State *L) { + lua_settop(L, 2); + if (lua_isnoneornil(L, 2)) { + lua_newtable(L); + lua_remove(L, 2); + } else { + luaL_checktype(L, 2, LUA_TTABLE); + } + lua_pushvalue(L, 1); + lua_setmetatable(L, 2); + return 1; +} + +/* +** Creates a shallow clone of the given list; the clone will contain +** only the list elements, not any other elements that might have been +** present. +*/ +static int list_clone (lua_State *L) { + lua_settop(L, 1); + luaL_checktype(L, 1, LUA_TTABLE); + lua_Integer len = luaL_len(L, 1); + lua_createtable(L, len, 0); /* create new table */ + lua_getmetatable(L, 1); + lua_setmetatable(L, 2); + for (lua_Integer i = 1; i <= len; i++) { + lua_geti(L, 1, i); + lua_seti(L, 2, i); + } + return 1; +} + +/* +** Creates a new list that is the concatenation of its two arguments. +** The result has the same metatable as the first operand. +*/ +static int list_concat (lua_State *L) { + lua_settop(L, 2); + luaL_checktype(L, 1, LUA_TTABLE); + luaL_checktype(L, 2, LUA_TTABLE); + lua_Integer len1 = luaL_len(L, 1); + lua_Integer len2 = luaL_len(L, 2); + lua_createtable(L, len1 + len2, 0); /* result table */ + if (lua_getmetatable(L, 1)) { + lua_setmetatable(L, 3); + } + for (lua_Integer i = 1; i <= len1; i++) { + lua_geti(L, 1, i); + lua_seti(L, 3, i); + } + for (lua_Integer i = 1; i <= len2; i++) { + lua_geti(L, 2, i); + lua_seti(L, 3, len1 + i); + } + return 1; +} + +/* +** Checks equality. Two lists are equal if and only if they have the same +** metatable and if all items are equal. +*/ +static int list_eq (lua_State *L) { + lua_settop(L, 2); + /* compare meta tables */ + if (!(lua_getmetatable(L, 1) && + lua_getmetatable(L, 2) && + lua_rawequal(L, -1, -2))) { + lua_pushboolean(L, 0); + return 1; + }; + lua_pop(L, 2); /* remove metatables */ + + /* ensure both lists have the same length */ + lua_Integer len1 = luaL_len(L, 1); + lua_Integer len2 = luaL_len(L, 2); + if (len1 != len2) { + lua_pushboolean(L, 0); + return 1; + } + + /* check element-wise equality */ + for (lua_Integer i = 1; i <= len1; i++) { + lua_geti(L, 1, i); + lua_geti(L, 2, i); + if (!lua_compare(L, -1, -2, LUA_OPEQ)) { + lua_pushboolean(L, 0); + return 1; + } + } + lua_pushboolean(L, 1); + return 1; +} + +/* +** Appends the second list to the first. +*/ +static int list_extend (lua_State *L) { + lua_settop(L, 2); + luaL_checktype(L, 1, LUA_TTABLE); + luaL_checktype(L, 2, LUA_TTABLE); + lua_Integer len1 = luaL_len(L, 1); + lua_Integer len2 = luaL_len(L, 2); + for (lua_Integer i = 1; i <= len2; i++) { + lua_geti(L, 2, i); + lua_seti(L, 1, len1 + i); + } + return 1; +} + +/* +** Removes elements that do not have the desired property. +*/ +static int list_filter (lua_State *L) { + lua_settop(L, 2); + luaL_checktype(L, 1, LUA_TTABLE); + checkcallable(L, 2); + luaL_checkstack(L, 4, NULL); + lua_Integer len = luaL_len(L, 1); + lua_createtable(L, len, 0); /* create new table */ + lua_getmetatable(L, 1); + lua_setmetatable(L, 3); + for (lua_Integer i = 1, j = 0; i <= len; i++) { + lua_pushvalue(L, 2); /* push predicate function */ + lua_geti(L, 1, i); + lua_pushinteger(L, i); + lua_call(L, 2, 1); + if (lua_toboolean(L, -1)) { + lua_geti(L, 1, i); + lua_seti(L, 3, ++j); + } + lua_pop(L, 1); /* remove predicate call result */ + } + return 1; +} + +/* +** Returns the first element that is equal to `needle`, along with that +** element's index, or `nil` if no such element exists. +*/ +static int list_find (lua_State *L) { + luaL_checkstack(L, 2, "List.find"); + lua_settop(L, 3); + luaL_checktype(L, 1, LUA_TTABLE); + lua_Integer len = luaL_len(L, 1); + lua_Integer start = posrelat(luaL_optinteger(L, 3, 1), len); + for (lua_Integer i = start; i <= len; i++) { + lua_geti(L, 1, i); + if (lua_compare(L, 2, -1, LUA_OPEQ)) { + lua_pushinteger(L, i); + return 2; + } + lua_pop(L, 1); /* remove list element result */ + } + lua_pushnil(L); + return 1; +} + +/* +** Returns the first element after the given start index for which the +** predicate function returns a truthy value, along with that element's +** index; returns `nil` if no such element exists. +*/ +static int list_find_if (lua_State *L) { + lua_settop(L, 3); + luaL_checktype(L, 1, LUA_TTABLE); + checkcallable(L, 2); + lua_Integer len = luaL_len(L, 1); + lua_Integer start = posrelat(luaL_optinteger(L, 3, 1), len); + for (lua_Integer i = start; i <= len; i++) { + lua_pushvalue(L, 2); /* predicate function */ + lua_geti(L, 1, i); + lua_pushinteger(L, i); + lua_call(L, 2, 1); + if (lua_toboolean(L, -1)) { + lua_geti(L, 1, i); + lua_pushinteger(L, i); + return 2; + } + lua_pop(L, 1); /* remove predicate call result */ + } + lua_pushnil(L); + return 1; +} + +/* +** Returns a boolean value indicating whether or not the element exists +** in the given list. +*/ +static int list_includes(lua_State *L) { + lua_settop(L, 3); + lua_pushcfunction(L, list_find); + lua_insert(L, 1); + lua_call(L, 3, 1); + luaL_checkstack(L, 1, "List.includes"); + lua_pushboolean(L, lua_toboolean(L, -1)); + return 1; +} + +/* +** Returns a copy of the current list by applying the given function to +** all elements. +*/ +static int list_map(lua_State *L) { + lua_settop(L, 2); + luaL_checktype(L, 1, LUA_TTABLE); + checkcallable(L, 2); + lua_Integer len = luaL_len(L, 1); + lua_createtable(L, len, 0); /* create new table */ + luaL_getmetatable(L, LIST_T); /* make result a generic list */ + lua_setmetatable(L, 3); + for (lua_Integer i = 1; i <= len; i++) { + lua_pushvalue(L, 2); /* map function */ + lua_geti(L, 1, i); + lua_pushinteger(L, i); + lua_call(L, 2, 1); + lua_seti(L, 3, i); + } + return 1; +} + +/* +** Pushes the standard `table` module to the stack. +*/ +static void pushtablemodule (lua_State *L) { + lua_getfield(L, LUA_REGISTRYINDEX, LUA_LOADED_TABLE); + if (!lua_getfield(L, -1, LUA_TABLIBNAME)) { + /* apparently it's not been loaded yes. So open it here (but don't + * 'load' it). */ + lua_pushcfunction(L, luaopen_table); + lua_pushliteral(L, LUA_TABLIBNAME); + lua_call(L, 1, 1); + } + lua_remove(L, -2); /* remove LOADED table */ +} + +/* +** Fields to copy from standard `table` package. +*/ +static const char *tablelib_functions[] = { + "insert", + "remove", + "sort", + NULL +}; + +/* +** Copy fields from standard `table` module to the table at the given +** index. +*/ +static void copyfromtablelib (lua_State *L, int idx) { + int absidx = lua_absindex(L, idx); + pushtablemodule(L); + for (const char **name = tablelib_functions; *name != NULL; *name++) { + if (lua_getfield(L, -1, *name)) { + lua_setfield(L, absidx, *name); + } else { + lua_pop(L, 1); + } + } + lua_pop(L, 1); /* remove table module */ +} + +static const luaL_Reg list_funcs[] = { + {"__concat", list_concat}, + {"__eq", list_eq}, + {"clone", list_clone}, + {"extend", list_extend}, + {"filter", list_filter}, + {"find", list_find}, + {"find_if", list_find_if}, + {"includes", list_includes}, + {"insert", missing}, + {"map", list_map}, + {"new", list_new}, + {"remove", missing}, + {"sort", missing}, + {NULL, NULL} +}; + +static const luaL_Reg metareg[] = { + {"__call", list_new}, + {NULL, NULL} +}; + +/* +** Creates a new metatable for a new List-like type. + */ +int lualist_newmetatable (lua_State *L, const char *name) { + if (luaL_newmetatable(L, name)) { + luaL_setfuncs(L, list_funcs, 0); + /* use functions from standard table module. */ + copyfromtablelib(L, -1); + lua_pushvalue(L, -1); + lua_setfield(L, -2, "__index"); + return 1; + } + return 0; +} + +int luaopen_list (lua_State *L) { + luaL_checkversion(L); + lualist_newmetatable(L, LIST_T); + + lua_newtable(L); + luaL_setfuncs(L, metareg, 0); + lua_setmetatable(L, -2); + return 1; +} diff --git a/hslua-list.cabal b/hslua-list.cabal new file mode 100644 --- /dev/null +++ b/hslua-list.cabal @@ -0,0 +1,71 @@ +cabal-version: 2.2 +name: hslua-list +version: 1.0.0 +synopsis: Opinionated, but extensible Lua list type. +description: List type for Lua, with a Haskell interface. +homepage: https://hslua.org/ +bug-reports: https://github.com/hslua/hslua/issues +license: MIT +license-file: LICENSE +author: Albert Krewinkel +maintainer: Albert Krewinkel +copyright: © 2022 Albert Krewinkel +category: Foreign +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.3 + +source-repository head + type: git + location: https://github.com/hslua/hslua + subdir: hslua-list + +common common-options + build-depends: base >= 4.9.1 && < 5 + , hslua-core >= 2.3 && < 2.4 + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + if impl(ghc >= 9.0) + ghc-options: -Winvalid-haddock + + default-language: Haskell2010 + +library + import: common-options + hs-source-dirs: src + c-sources: cbits/listmod.c + exposed-modules: HsLua.List + build-depends: bytestring + , hslua-marshalling >= 2.1 && < 2.3 + +test-suite hslua-list-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test-hslua-list.hs + build-depends: hslua-list + , tasty >= 0.11 + , tasty-lua >= 1.0 + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N diff --git a/src/HsLua/List.hs b/src/HsLua/List.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/List.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{- | +Copyright : © 2021-2022 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Lua lists with additional methods. +-} +module HsLua.List + ( pushPandocList + , luaopen_list_ptr + , pushListModule + , newListMetatable + ) where + +import Data.ByteString (useAsCString) +import Foreign.C +import HsLua.Core +import HsLua.Marshalling (Pusher, pushList) + +-- | Pushes a list as a numerically-indexed Lua table, and sets a +-- metatable that offers a number of convenience functions. +pushPandocList :: LuaError e => Pusher e a -> Pusher e [a] +pushPandocList pushItem items = do + pushList pushItem items + getmetatable' "List" >>= \case + TypeTable -> setmetatable (nth 2) + _ -> failLua "List has not been initialized correctly." + +-- | Pointer to the function that opens the List module and pushes it to the +-- stack. +foreign import ccall unsafe "listmod.c &luaopen_list" + luaopen_list_ptr :: CFunction + +-- | Opens the List module and pushes it to the stack. +pushListModule :: LuaError e => LuaE e () +pushListModule = do + pushcfunction luaopen_list_ptr + call 0 1 + +-- | Creates a new list metatable with the given name. +foreign import ccall "listmod.c lualist_newmetatable" + lualist_newmetatable :: State -> CString -> IO CInt + +-- | Pushes the metatable of the given List type, creating it if +-- necessary. The @setup@ operation is run when the metatable did not +-- exists, was created, and is then at the top of the stack. The +-- operation may modify the table but must be balanced, and must leave +-- the stack as it found it. +newListMetatable :: Name -> LuaE e () {-^ setup -} -> LuaE e () +newListMetatable (Name name) setup = do + l <- state + liftIO (useAsCString name (lualist_newmetatable l)) >>= \case + 0 -> pure () -- metatable already registered; no need to setup again + _ -> setup diff --git a/test/test-hslua-list.hs b/test/test-hslua-list.hs new file mode 100644 --- /dev/null +++ b/test/test-hslua-list.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : Main +Copyright : © 2021-2022 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Tests for the list type. +-} +module Main (main) where + +import HsLua.Core as Lua +import HsLua.List +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.Lua (translateResultsFromFile) + +main :: IO () +main = do + listTests <- run @Lua.Exception $ do + openlibs + -- Init default List module + pushListModule *> setglobal "List" + -- Create a custom List type with constructor "CustomList" + pushHaskellFunction $ do + settop 1 + newListMetatable "CustomList" (pure ()) + setmetatable (nthBottom 1) + return 1 + setglobal "CustomList" + translateResultsFromFile "test/test-list.lua" + + defaultMain $ testGroup "hslua-list" [listTests]