diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +# Changelog + +`pandoc-lua-marshal` uses [PVP Versioning][1]. +The changelog is available [on GitHub][2]. + +## 0.1.0 + +Released 2021-11-28. + +* Released into the wild. May it live long and prosper. + +[1]: https://pvp.haskell.org +[2]: https://github.com/pandoc/pandoc-lua-marshal/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2021 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,32 @@ +# pandoc-lua-marshal + +[![GitHub CI][]][1] +[![Hackage][]][2] +[![Stackage Lts][]][3] +[![Stackage Nightly][]][4] +[![MIT license]][5] + +Use pandoc types in Lua. + +[GitHub CI]: https://github.com/tarleb/pandoc-lua-marshal/workflows/CI/badge.svg +[1]: https://github.com/tarleb/pandoc-lua-marshal/actions +[Hackage]: https://img.shields.io/hackage/v/pandoc-lua-marshal.svg?logo=haskell +[2]: https://hackage.haskell.org/package/pandoc-lua-marshal +[Stackage Lts]: http://stackage.org/package/pandoc-lua-marshal/badge/lts +[3]: https://stackage.org/lts/package/pandoc-lua-marshal +[Stackage Nightly]: https://stackage.org/package/pandoc-lua-marshal/badge/nightly +[4]: https://stackage.org/nightly/package/pandoc-lua-marshal +[MIT license]: https://img.shields.io/badge/license-MIT-blue.svg +[5]: LICENSE + +## Description + +This package provides functions to marshal and unmarshal pandoc +document types to and from Lua. + +The values of most types are pushed to pandoc as "userdata" +objects that wrap a stable pointer to the Haskell value; these +objects come with methods to access and modify their properties. + +Sequences are pushed as normal Lua tables, but are augmented with +convenience functions. diff --git a/cbits/listmod.c b/cbits/listmod.c new file mode 100644 --- /dev/null +++ b/cbits/listmod.c @@ -0,0 +1,295 @@ +#include +#include "lua.h" +#include "lauxlib.h" +#include "lualib.h" + +#define LIST_T "List" + +/* +** 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; +} + +/* +** 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; +} + +/* +** 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); + luaL_checktype(L, 2, LUA_TFUNCTION); + 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) { + lua_settop(L, 3); + luaL_checktype(L, 1, LUA_TTABLE); + lua_Integer start = luaL_optinteger(L, 3, 1); + lua_Integer len = luaL_len(L, 1); + 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_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); + luaL_checktype(L, 2, LUA_TFUNCTION); + lua_Integer start = luaL_optinteger(L, 3, 1); + lua_Integer len = luaL_len(L, 1); + 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); + 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); + luaL_checktype(L, 2, LUA_TFUNCTION); + 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; 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}, + {"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/pandoc-lua-marshal.cabal b/pandoc-lua-marshal.cabal new file mode 100644 --- /dev/null +++ b/pandoc-lua-marshal.cabal @@ -0,0 +1,106 @@ +cabal-version: 2.4 +name: pandoc-lua-marshal +version: 0.1.0 +synopsis: Use pandoc types in Lua +description: This package provides functions to marshal and unmarshal + pandoc document types to and from Lua. + . + The values of most types are pushed to pandoc as "userdata" + objects that wrap a stable pointer to the Haskell value; + these objects come with methods to access and modify their + properties. + . + Sequences are pushed as normal Lua tables, but are + augmented with convenience functions. + +homepage: https://github.com/pandoc/pandoc-lua-marshal +bug-reports: https://github.com/pandoc/pandoc-lua-marshal/issues +license: MIT +license-file: LICENSE +author: Albert Krewinkel, John MacFarlane +maintainer: Albert Krewinkel +copyright: © 2017-2021 Albert Krewinkel, John MacFarlane +category: Foreign +build-type: Simple +extra-doc-files: README.md + , CHANGELOG.md +tested-with: GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.7 + GHC == 9.0.1 + GHC == 9.2.1 +extra-source-files: test/test-attr.lua + , test/test-block.lua + , test/test-citation.lua + , test/test-inline.lua + , test/test-listattributes.lua + , test/test-list.lua + , test/test-metavalue.lua + , test/test-pandoc.lua + +source-repository head + type: git + location: https://github.com/pandoc/pandoc-lua-marshal.git + +common common-options + build-depends: base >= 4.12 && < 5 + , bytestring >= 0.10 && < 0.12 + , exceptions >= 0.8 && < 0.11 + , lua >= 2.0.2 && < 2.1 + , hslua >= 2.0.1 && < 2.1 + , hslua-marshalling >= 2.0.1 && < 2.1 + , pandoc-types >= 1.22.1 && < 1.23 + , safe >= 0.3 && < 0.4 + , text >= 1.1.1.0 && < 1.3 + + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wpartial-fields + -Wredundant-constraints + -fhide-source-paths + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + + default-language: Haskell2010 + +library + import: common-options + hs-source-dirs: src + c-sources: cbits/listmod.c + exposed-modules: Text.Pandoc.Lua.Marshal.AST + , Text.Pandoc.Lua.Marshal.Alignment + , Text.Pandoc.Lua.Marshal.Attr + , Text.Pandoc.Lua.Marshal.Block + , Text.Pandoc.Lua.Marshal.Cell + , Text.Pandoc.Lua.Marshal.Citation + , Text.Pandoc.Lua.Marshal.CitationMode + , Text.Pandoc.Lua.Marshal.Content + , Text.Pandoc.Lua.Marshal.Format + , Text.Pandoc.Lua.Marshal.Inline + , Text.Pandoc.Lua.Marshal.List + , Text.Pandoc.Lua.Marshal.ListAttributes + , Text.Pandoc.Lua.Marshal.MathType + , Text.Pandoc.Lua.Marshal.MetaValue + , Text.Pandoc.Lua.Marshal.Pandoc + , Text.Pandoc.Lua.Marshal.QuoteType + , Text.Pandoc.Lua.Marshal.SimpleTable + , Text.Pandoc.Lua.Marshal.TableParts + +test-suite pandoc-lua-marshal-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test-pandoc-lua-marshal.hs + build-depends: pandoc-lua-marshal + , QuickCheck >= 2.4 && < 2.15 + , tasty >= 0.11 + , tasty-hunit >= 0.9 + , tasty-lua >= 1.0 + , tasty-quickcheck >= 0.8 && < 0.11 + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N diff --git a/src/Text/Pandoc/Lua/Marshal/AST.hs b/src/Text/Pandoc/Lua/Marshal/AST.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/AST.hs @@ -0,0 +1,45 @@ +{- | +Copyright: (c) 2021 Albert Krewinkel +SPDX-License-Identifier: MIT +Maintainer: Albert Krewinkel + +Use pandoc types in Lua +-} + +module Text.Pandoc.Lua.Marshal.AST + ( module Text.Pandoc.Lua.Marshal.List + , module Text.Pandoc.Lua.Marshal.Alignment + , module Text.Pandoc.Lua.Marshal.Attr + , module Text.Pandoc.Lua.Marshal.Block + , module Text.Pandoc.Lua.Marshal.Cell + , module Text.Pandoc.Lua.Marshal.Citation + , module Text.Pandoc.Lua.Marshal.CitationMode + , module Text.Pandoc.Lua.Marshal.Content + , module Text.Pandoc.Lua.Marshal.Format + , module Text.Pandoc.Lua.Marshal.Inline + , module Text.Pandoc.Lua.Marshal.ListAttributes + , module Text.Pandoc.Lua.Marshal.MathType + , module Text.Pandoc.Lua.Marshal.MetaValue + , module Text.Pandoc.Lua.Marshal.Pandoc + , module Text.Pandoc.Lua.Marshal.QuoteType + , module Text.Pandoc.Lua.Marshal.SimpleTable + , module Text.Pandoc.Lua.Marshal.TableParts + ) where + +import Text.Pandoc.Lua.Marshal.Alignment +import Text.Pandoc.Lua.Marshal.Attr +import Text.Pandoc.Lua.Marshal.Block +import Text.Pandoc.Lua.Marshal.Cell +import Text.Pandoc.Lua.Marshal.Citation +import Text.Pandoc.Lua.Marshal.CitationMode +import Text.Pandoc.Lua.Marshal.Content +import Text.Pandoc.Lua.Marshal.Format +import Text.Pandoc.Lua.Marshal.Inline +import Text.Pandoc.Lua.Marshal.List +import Text.Pandoc.Lua.Marshal.ListAttributes +import Text.Pandoc.Lua.Marshal.MathType +import Text.Pandoc.Lua.Marshal.MetaValue +import Text.Pandoc.Lua.Marshal.Pandoc +import Text.Pandoc.Lua.Marshal.QuoteType +import Text.Pandoc.Lua.Marshal.SimpleTable +import Text.Pandoc.Lua.Marshal.TableParts diff --git a/src/Text/Pandoc/Lua/Marshal/Alignment.hs b/src/Text/Pandoc/Lua/Marshal/Alignment.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Alignment.hs @@ -0,0 +1,22 @@ +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions of 'Alignment' values. +-} +module Text.Pandoc.Lua.Marshal.Alignment + ( peekAlignment + , pushAlignment + ) where + +import HsLua +import Text.Pandoc.Definition (Alignment) + +-- | Retrieves a 'Alignment' value from a string. +peekAlignment :: Peeker e Alignment +peekAlignment = peekRead + +-- | Pushes a 'Alignment' value as a string. +pushAlignment :: Pusher e Alignment +pushAlignment = pushString . show diff --git a/src/Text/Pandoc/Lua/Marshal/Attr.hs b/src/Text/Pandoc/Lua/Marshal/Attr.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Attr.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{- | +Module : Text.Pandoc.Lua.Marshal.Attr +Copyright : © 2017-2021 Albert Krewinkel, John MacFarlane +License : MIT + +Maintainer : Albert Krewinkel + +Helpers to make pandoc's Attr elements usable in Lua, and to get objects +back into Haskell. +-} +module Text.Pandoc.Lua.Marshal.Attr + ( typeAttr + , peekAttr + , pushAttr + , mkAttr + , mkAttributeList + ) where + +import Control.Applicative ((<|>), optional) +import Control.Monad ((<$!>)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import HsLua +import HsLua.Marshalling.Peekers (peekIndexRaw) +import Text.Pandoc.Lua.Marshal.List (pushPandocList) +import Safe (atMay) +import Text.Pandoc.Definition (Attr, nullAttr) + +import qualified Data.Text as T + +-- | Attr object type. +typeAttr :: LuaError e => DocumentedType e Attr +typeAttr = deftype "Attr" + [ operation Eq $ lambda + ### liftPure2 (==) + <#> parameter peekAttr "a1" "Attr" "" + <#> parameter peekAttr "a2" "Attr" "" + =#> functionResult pushBool "boolean" "whether the two are equal" + , operation Tostring $ lambda + ### liftPure show + <#> parameter peekAttr "Attr" "attr" "" + =#> functionResult pushString "string" "native Haskell representation" + ] + [ property "identifier" "element identifier" + (pushText, \(ident,_,_) -> ident) + (peekText, \(_,cls,kv) -> (,cls,kv)) + , property "classes" "element classes" + (pushPandocList pushText, \(_,classes,_) -> classes) + (peekList peekText, \(ident,_,kv) -> (ident,,kv)) + , property "attributes" "various element attributes" + (pushAttribs, \(_,_,attribs) -> attribs) + (peekAttribs, \(ident,cls,_) -> (ident,cls,)) + , method $ defun "clone" + ### return + <#> parameter peekAttr "attr" "Attr" "" + =#> functionResult pushAttr "Attr" "new Attr element" + , readonly "tag" "element type tag (always 'Attr')" + (pushText, const "Attr") + + , alias "t" "alias for `tag`" ["tag"] + ] + +-- | Pushes an 'Attr' value as @Attr@ userdata object. +pushAttr :: LuaError e => Pusher e Attr +pushAttr = pushUD typeAttr + +-- | Retrieves an associated list of attributes from a table or an +-- @AttributeList@ userdata object. +peekAttribs :: LuaError e => Peeker e [(Text,Text)] +peekAttribs idx = liftLua (ltype idx) >>= \case + TypeUserdata -> peekUD typeAttributeList idx + TypeTable -> liftLua (rawlen idx) >>= \case + 0 -> peekKeyValuePairs peekText peekText idx + _ -> peekList (peekPair peekText peekText) idx + _ -> failPeek "unsupported type" + +-- | Pushes an associated list of attributes as @AttributeList@ userdata +-- object. +pushAttribs :: LuaError e => Pusher e [(Text, Text)] +pushAttribs = pushUD typeAttributeList + +-- | Constructor functions for 'AttributeList' elements. +typeAttributeList :: LuaError e => DocumentedType e [(Text, Text)] +typeAttributeList = deftype "AttributeList" + [ operation Eq $ lambda + ### liftPure2 (==) + <#> parameter peekAttribs "a1" "AttributeList" "" + <#> parameter peekAttribs "a2" "AttributeList" "" + =#> functionResult pushBool "boolean" "whether the two are equal" + + , operation Index $ lambda + ### liftPure2 lookupKey + <#> udparam typeAttributeList "t" "attributes list" + <#> parameter peekKey "string|integer" "key" "lookup key" + =#> functionResult (maybe pushnil pushAttribute) "string|table" + "attribute value" + + , operation Newindex $ lambda + ### setKey + <#> udparam typeAttributeList "t" "attributes list" + <#> parameter peekKey "string|integer" "key" "lookup key" + <#> optionalParameter peekAttribute "string|nil" "value" "new value" + =#> [] + + , operation Len $ lambda + ### liftPure length + <#> udparam typeAttributeList "t" "attributes list" + =#> functionResult pushIntegral "integer" "number of attributes in list" + + , operation Pairs $ lambda + ### pushIterator (\(k, v) -> 2 <$ pushText k <* pushText v) + <#> udparam typeAttributeList "t" "attributes list" + =?> "iterator triple" + + , operation Tostring $ lambda + ### liftPure show + <#> udparam typeAttributeList "t" "attributes list" + =#> functionResult pushString "string" "" + ] + [] + +data Key = StringKey Text | IntKey Int + +peekKey :: Peeker e (Maybe Key) +peekKey idx = liftLua (ltype idx) >>= \case + TypeNumber -> Just . IntKey <$!> peekIntegral idx + TypeString -> Just . StringKey <$!> peekText idx + _ -> return Nothing + +data Attribute + = AttributePair (Text, Text) + | AttributeValue Text + +pushAttribute :: LuaError e => Pusher e Attribute +pushAttribute = \case + (AttributePair kv) -> pushPair pushText pushText kv + (AttributeValue v) -> pushText v + +-- | Retrieve an 'Attribute'. +peekAttribute :: LuaError e => Peeker e Attribute +peekAttribute idx = (AttributeValue <$!> peekText idx) + <|> (AttributePair <$!> peekPair peekText peekText idx) + +lookupKey :: [(Text,Text)] -> Maybe Key -> Maybe Attribute +lookupKey !kvs = \case + Just (StringKey str) -> AttributeValue <$!> lookup str kvs + Just (IntKey n) -> AttributePair <$!> atMay kvs (n - 1) + Nothing -> Nothing + +setKey :: forall e. LuaError e + => [(Text, Text)] -> Maybe Key -> Maybe Attribute + -> LuaE e () +setKey kvs mbKey mbValue = case mbKey of + Just (StringKey str) -> + case break ((== str) . fst) kvs of + (prefix, _:suffix) -> case mbValue of + Nothing -> setNew $ prefix ++ suffix + Just (AttributeValue value) -> setNew $ prefix ++ (str, value):suffix + _ -> failLua "invalid attribute value" + _ -> case mbValue of + Nothing -> return () + Just (AttributeValue value) -> setNew (kvs ++ [(str, value)]) + _ -> failLua "invalid attribute value" + Just (IntKey idx) -> + case splitAt (idx - 1) kvs of + (prefix, (k,_):suffix) -> setNew $ case mbValue of + Nothing -> prefix ++ suffix + Just (AttributePair kv) -> prefix ++ kv : suffix + Just (AttributeValue v) -> prefix ++ (k, v) : suffix + (prefix, []) -> case mbValue of + Nothing -> setNew prefix + Just (AttributePair kv) -> setNew $ prefix ++ [kv] + _ -> failLua $ "trying to set an attribute key-value pair, " + ++ "but got a single string instead." + + _ -> failLua "invalid attribute key" + where + setNew :: [(Text, Text)] -> LuaE e () + setNew new = + putuserdata (nthBottom 1) (udName @e typeAttributeList) new >>= \case + True -> return () + False -> failLua "failed to modify attributes list" + +-- | Retrieves an 'Attr' value from a string, a table, or an @Attr@ +-- userdata object. A string is used as an identifier; a table is either +-- an HTML-like set of attributes, or a triple containing the +-- identifier, classes, and attributes. +peekAttr :: LuaError e => Peeker e Attr +peekAttr idx = retrieving "Attr" $ liftLua (ltype idx) >>= \case + TypeString -> (,[],[]) <$!> peekText idx -- treat string as ID + TypeUserdata -> peekUD typeAttr idx + TypeTable -> peekAttrTable idx + x -> liftLua . failLua $ "Cannot get Attr from " ++ show x + +-- | Helper function which gets an Attr from a Lua table. +peekAttrTable :: LuaError e => Peeker e Attr +peekAttrTable idx = do + len' <- liftLua $ rawlen idx + let peekClasses = peekList peekText + if len' > 0 + then do + ident <- peekIndexRaw 1 peekText idx + classes <- fromMaybe [] <$!> optional (peekIndexRaw 2 peekClasses idx) + attribs <- fromMaybe [] <$!> optional (peekIndexRaw 3 peekAttribs idx) + return $ ident `seq` classes `seq` attribs `seq` + (ident, classes, attribs) + else retrieving "HTML-like attributes" $ do + kvs <- peekKeyValuePairs peekText peekText idx + let ident = fromMaybe "" $ lookup "id" kvs + let classes = maybe [] T.words $ lookup "class" kvs + let attribs = filter ((`notElem` ["id", "class"]) . fst) kvs + return $ ident `seq` classes `seq` attribs `seq` + (ident, classes, attribs) + +-- | Constructor for 'Attr'. +mkAttr :: LuaError e => DocumentedFunction e +mkAttr = defun "Attr" + ### (ltype (nthBottom 1) >>= \case + TypeString -> forcePeek $ do + mident <- optional (peekText (nthBottom 1)) + mclass <- optional (peekList peekText (nthBottom 2)) + mattribs <- optional (peekAttribs (nthBottom 3)) + return ( fromMaybe "" mident + , fromMaybe [] mclass + , fromMaybe [] mattribs) + TypeTable -> forcePeek $ peekAttrTable (nthBottom 1) + TypeUserdata -> forcePeek $ peekUD typeAttr (nthBottom 1) <|> do + attrList <- peekUD typeAttributeList (nthBottom 1) + return ("", [], attrList) + TypeNil -> pure nullAttr + TypeNone -> pure nullAttr + x -> failLua $ "Cannot create Attr from " ++ show x) + =#> functionResult pushAttr "Attr" "new Attr object" + +-- | Constructor for 'AttributeList'. +mkAttributeList :: LuaError e => DocumentedFunction e +mkAttributeList = defun "AttributeList" + ### return + <#> parameter peekAttribs "table|AttributeList" "attribs" "an attribute list" + =#> functionResult (pushUD typeAttributeList) "AttributeList" + "new AttributeList object" diff --git a/src/Text/Pandoc/Lua/Marshal/Block.hs b/src/Text/Pandoc/Lua/Marshal/Block.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Block.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{- | + +Marshal values of types that make up 'Block' elements. +-} +module Text.Pandoc.Lua.Marshal.Block + ( -- * Single Block elements + peekBlock + , peekBlockFuzzy + , pushBlock + -- * List of Blocks + , peekBlocks + , peekBlocksFuzzy + , pushBlocks + -- * Constructors + , blockConstructors + , mkBlocks + ) where + +import Control.Applicative ((<|>)) +import Control.Monad.Catch (throwM) +import Control.Monad ((<$!>)) +import Data.Data (showConstr, toConstr) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (Proxy)) +import Data.Text (Text) +import HsLua hiding (Div) +import Text.Pandoc.Lua.Marshal.Attr (peekAttr, pushAttr) +import Text.Pandoc.Lua.Marshal.Content + ( Content (..), contentTypeDescription, peekContent, pushContent + , peekDefinitionItem ) +import Text.Pandoc.Lua.Marshal.Format (peekFormat, pushFormat) +import Text.Pandoc.Lua.Marshal.Inline (peekInlinesFuzzy) +import Text.Pandoc.Lua.Marshal.List (newListMetatable, pushPandocList) +import Text.Pandoc.Lua.Marshal.ListAttributes (peekListAttributes, pushListAttributes) +import Text.Pandoc.Lua.Marshal.TableParts + ( peekCaption, pushCaption + , peekColSpec, pushColSpec + , peekTableBody, pushTableBody + , peekTableFoot, pushTableFoot + , peekTableHead, pushTableHead + ) +import Text.Pandoc.Definition + +-- | Pushes an Block value as userdata object. +pushBlock :: LuaError e => Pusher e Block +pushBlock = pushUD typeBlock +{-# INLINE pushBlock #-} + +-- | Retrieves an Block value. +peekBlock :: LuaError e => Peeker e Block +peekBlock = peekUD typeBlock +{-# INLINE peekBlock #-} + +-- | Retrieves a list of Block values. +peekBlocks :: LuaError e + => Peeker e [Block] +peekBlocks = peekList peekBlock +{-# INLINABLE peekBlocks #-} + +-- | Pushes a list of Block values. +pushBlocks :: LuaError e + => Pusher e [Block] +pushBlocks xs = do + pushList pushBlock xs + newListMetatable "Blocks" $ + pure () + setmetatable (nth 2) +{-# INLINABLE pushBlocks #-} + +-- | Try extra hard to retrieve an Block value from the stack. Treats +-- bare strings as @Str@ values. +peekBlockFuzzy :: LuaError e + => Peeker e Block +peekBlockFuzzy = choice + [ peekBlock + , \idx -> Plain <$!> peekInlinesFuzzy idx + ] +{-# INLINABLE peekBlockFuzzy #-} + +-- | Try extra-hard to return the value at the given index as a list of +-- inlines. +peekBlocksFuzzy :: LuaError e + => Peeker e [Block] +peekBlocksFuzzy = choice + [ peekList peekBlockFuzzy + , (<$!>) pure . peekBlockFuzzy + ] +{-# INLINABLE peekBlocksFuzzy #-} + +-- | Block object type. +typeBlock :: forall e. LuaError e => DocumentedType e Block +typeBlock = deftype "Block" + [ operation Eq $ lambda + ### liftPure2 (==) + <#> parameter peekBlockFuzzy "Block" "a" "" + <#> parameter peekBlockFuzzy "Block" "b" "" + =#> boolResult "whether the two values are equal" + , operation Tostring $ lambda + ### liftPure show + <#> udparam typeBlock "self" "" + =#> functionResult pushString "string" "Haskell representation" + ] + [ possibleProperty "attr" "element attributes" + (pushAttr, \case + CodeBlock attr _ -> Actual attr + Div attr _ -> Actual attr + Header _ attr _ -> Actual attr + Table attr _ _ _ _ _ -> Actual attr + _ -> Absent) + (peekAttr, \case + CodeBlock _ code -> Actual . flip CodeBlock code + Div _ blks -> Actual . flip Div blks + Header lvl _ blks -> Actual . (\attr -> Header lvl attr blks) + Table _ c cs h bs f -> Actual . (\attr -> Table attr c cs h bs f) + _ -> const Absent) + , possibleProperty "bodies" "table bodies" + (pushPandocList pushTableBody, \case + Table _ _ _ _ bs _ -> Actual bs + _ -> Absent) + (peekList peekTableBody, \case + Table attr c cs h _ f -> Actual . (\bs -> Table attr c cs h bs f) + _ -> const Absent) + , possibleProperty "caption" "element caption" + (pushCaption, \case {Table _ capt _ _ _ _ -> Actual capt; _ -> Absent}) + (peekCaption, \case + Table attr _ cs h bs f -> Actual . (\c -> Table attr c cs h bs f) + _ -> const Absent) + , possibleProperty "colspecs" "column alignments and widths" + (pushPandocList pushColSpec, \case + Table _ _ cs _ _ _ -> Actual cs + _ -> Absent) + (peekList peekColSpec, \case + Table attr c _ h bs f -> Actual . (\cs -> Table attr c cs h bs f) + _ -> const Absent) + , possibleProperty "content" "element content" + (pushContent, getBlockContent) + (peekContent, setBlockContent (Proxy @e)) + , possibleProperty "foot" "table foot" + (pushTableFoot, \case {Table _ _ _ _ _ f -> Actual f; _ -> Absent}) + (peekTableFoot, \case + Table attr c cs h bs _ -> Actual . Table attr c cs h bs + _ -> const Absent) + , possibleProperty "format" "format of raw content" + (pushFormat, \case {RawBlock f _ -> Actual f; _ -> Absent}) + (peekFormat, \case + RawBlock _ txt -> Actual . (`RawBlock` txt) + _ -> const Absent) + , possibleProperty "head" "table head" + (pushTableHead, \case {Table _ _ _ h _ _ -> Actual h; _ -> Absent}) + (peekTableHead, \case + Table attr c cs _ bs f -> Actual . (\h -> Table attr c cs h bs f) + _ -> const Absent) + , possibleProperty "level" "heading level" + (pushIntegral, \case {Header lvl _ _ -> Actual lvl; _ -> Absent}) + (peekIntegral, \case + Header _ attr inlns -> Actual . \lvl -> Header lvl attr inlns + _ -> const Absent) + , possibleProperty "listAttributes" "ordered list attributes" + (pushListAttributes, \case + OrderedList listAttr _ -> Actual listAttr + _ -> Absent) + (peekListAttributes, \case + OrderedList _ content -> Actual . (`OrderedList` content) + _ -> const Absent) + , possibleProperty "text" "text contents" + (pushText, getBlockText) + (peekText, setBlockText) + + , readonly "tag" "type of Block" + (pushString, showConstr . toConstr ) + + , alias "t" "tag" ["tag"] + , alias "c" "content" ["content"] + , alias "identifier" "element identifier" ["attr", "identifier"] + , alias "classes" "element classes" ["attr", "classes"] + , alias "attributes" "other element attributes" ["attr", "attributes"] + , alias "start" "ordered list start number" ["listAttributes", "start"] + , alias "style" "ordered list style" ["listAttributes", "style"] + , alias "delimiter" "numbering delimiter" ["listAttributes", "delimiter"] + + , method $ defun "clone" + ### return + <#> parameter peekBlock "Block" "block" "self" + =#> functionResult pushBlock "Block" "cloned Block" + + , method $ defun "show" + ### liftPure show + <#> parameter peekBlock "Block" "self" "" + =#> functionResult pushString "string" "Haskell string representation" + ] + where + boolResult = functionResult pushBool "boolean" + +getBlockContent :: Block -> Possible Content +getBlockContent = \case + -- inline content + Para inlns -> Actual $ ContentInlines inlns + Plain inlns -> Actual $ ContentInlines inlns + Header _ _ inlns -> Actual $ ContentInlines inlns + -- inline content + BlockQuote blks -> Actual $ ContentBlocks blks + Div _ blks -> Actual $ ContentBlocks blks + -- lines content + LineBlock lns -> Actual $ ContentLines lns + -- list items content + BulletList itms -> Actual $ ContentListItems itms + OrderedList _ itms -> Actual $ ContentListItems itms + -- definition items content + DefinitionList itms -> Actual $ ContentDefItems itms + _ -> Absent + +setBlockContent :: forall e. LuaError e + => Proxy e -> Block -> Content -> Possible Block +setBlockContent _ = \case + -- inline content + Para _ -> Actual . Para . inlineContent + Plain _ -> Actual . Plain . inlineContent + Header attr lvl _ -> Actual . Header attr lvl . inlineContent + -- block content + BlockQuote _ -> Actual . BlockQuote . blockContent + Div attr _ -> Actual . Div attr . blockContent + -- lines content + LineBlock _ -> Actual . LineBlock . lineContent + -- list items content + BulletList _ -> Actual . BulletList . listItemContent + OrderedList la _ -> Actual . OrderedList la . listItemContent + -- definition items content + DefinitionList _ -> Actual . DefinitionList . defItemContent + _ -> const Absent + where + inlineContent = \case + ContentInlines inlns -> inlns + c -> throwM . luaException @e $ + "expected Inlines, got " <> contentTypeDescription c + blockContent = \case + ContentBlocks blks -> blks + ContentInlines inlns -> [Plain inlns] + c -> throwM . luaException @e $ + "expected Blocks, got " <> contentTypeDescription c + lineContent = \case + ContentLines lns -> lns + c -> throwM . luaException @e $ + "expected list of lines (Inlines), got " <> contentTypeDescription c + defItemContent = \case + ContentDefItems itms -> itms + c -> throwM . luaException @e $ + "expected definition items, got " <> contentTypeDescription c + listItemContent = \case + ContentBlocks blks -> [blks] + ContentLines lns -> map ((:[]) . Plain) lns + ContentListItems itms -> itms + c -> throwM . luaException @e $ + "expected list of items, got " <> contentTypeDescription c + +getBlockText :: Block -> Possible Text +getBlockText = \case + CodeBlock _ lst -> Actual lst + RawBlock _ raw -> Actual raw + _ -> Absent + +setBlockText :: Block -> Text -> Possible Block +setBlockText = \case + CodeBlock attr _ -> Actual . CodeBlock attr + RawBlock f _ -> Actual . RawBlock f + _ -> const Absent + +-- | Constructor functions for 'Block' elements. +blockConstructors :: LuaError e => [DocumentedFunction e] +blockConstructors = + [ defun "BlockQuote" + ### liftPure BlockQuote + <#> blocksParam + =#> blockResult "BlockQuote element" + + , defun "BulletList" + ### liftPure BulletList + <#> blockItemsParam "list items" + =#> blockResult "BulletList element" + + , defun "CodeBlock" + ### liftPure2 (\code mattr -> CodeBlock (fromMaybe nullAttr mattr) code) + <#> textParam "text" "code block content" + <#> optAttrParam + =#> blockResult "CodeBlock element" + + , defun "DefinitionList" + ### liftPure DefinitionList + <#> parameter (choice + [ peekList peekDefinitionItem + , \idx -> (:[]) <$!> peekDefinitionItem idx + ]) + "{{Inlines, {Blocks,...}},...}" + "content" "definition items" + =#> blockResult "DefinitionList element" + + , defun "Div" + ### liftPure2 (\content mattr -> Div (fromMaybe nullAttr mattr) content) + <#> blocksParam + <#> optAttrParam + =#> blockResult "Div element" + + , defun "Header" + ### liftPure3 (\lvl content mattr -> + Header lvl (fromMaybe nullAttr mattr) content) + <#> parameter peekIntegral "integer" "level" "heading level" + <#> parameter peekInlinesFuzzy "Inlines" "content" "inline content" + <#> optAttrParam + =#> blockResult "Header element" + + , defun "HorizontalRule" + ### return HorizontalRule + =#> blockResult "HorizontalRule element" + + , defun "LineBlock" + ### liftPure LineBlock + <#> parameter (peekList peekInlinesFuzzy) "{Inlines,...}" "content" "lines" + =#> blockResult "LineBlock element" + + , defun "Null" + ### return Null + =#> blockResult "Null element" + + , defun "OrderedList" + ### liftPure2 (\items mListAttrib -> + let defListAttrib = (1, DefaultStyle, DefaultDelim) + in OrderedList (fromMaybe defListAttrib mListAttrib) items) + <#> blockItemsParam "ordered list items" + <#> optionalParameter peekListAttributes "ListAttributes" "listAttributes" + "specifier for the list's numbering" + =#> blockResult "OrderedList element" + + , defun "Para" + ### liftPure Para + <#> parameter peekInlinesFuzzy "Inlines" "content" "paragraph content" + =#> blockResult "Para element" + + , defun "Plain" + ### liftPure Plain + <#> parameter peekInlinesFuzzy "Inlines" "content" "paragraph content" + =#> blockResult "Plain element" + + , defun "RawBlock" + ### liftPure2 RawBlock + <#> parameter peekFormat "Format" "format" "format of content" + <#> parameter peekText "string" "text" "raw content" + =#> blockResult "RawBlock element" + + , defun "Table" + ### (\capt colspecs thead tbodies tfoot mattr -> + let attr = fromMaybe nullAttr mattr + in return $! attr `seq` capt `seq` colspecs `seq` thead `seq` tbodies + `seq` tfoot `seq` Table attr capt colspecs thead tbodies tfoot) + <#> parameter peekCaption "Caption" "caption" "table caption" + <#> parameter (peekList peekColSpec) "{ColSpec,...}" "colspecs" + "column alignments and widths" + <#> parameter peekTableHead "TableHead" "head" "table head" + <#> parameter (peekList peekTableBody) "{TableBody,...}" "bodies" + "table bodies" + <#> parameter peekTableFoot "TableFoot" "foot" "table foot" + <#> optAttrParam + =#> blockResult "Table element" + ] + where + blockResult = functionResult pushBlock "Block" + blocksParam = parameter peekBlocksFuzzy "Blocks" "content" "block content" + blockItemsParam = parameter peekItemsFuzzy "List of Blocks" "content" + peekItemsFuzzy idx = peekList peekBlocksFuzzy idx + <|> ((:[]) <$!> peekBlocksFuzzy idx) + + textParam = parameter peekText "string" + optAttrParam = optionalParameter peekAttr "attr" "Attr" + "additional attributes" + + +-- | Constructor for a list of `Block` values. +mkBlocks :: LuaError e => DocumentedFunction e +mkBlocks = defun "Blocks" + ### liftPure id + <#> parameter peekBlocksFuzzy "Blocks" "blocks" "block elements" + =#> functionResult pushBlocks "Blocks" "list of block elements" diff --git a/src/Text/Pandoc/Lua/Marshal/Block.hs-boot b/src/Text/Pandoc/Lua/Marshal/Block.hs-boot new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Block.hs-boot @@ -0,0 +1,12 @@ +module Text.Pandoc.Lua.Marshal.Block + ( peekBlocksFuzzy + , pushBlocks + ) where + +import HsLua +import Text.Pandoc.Definition + +-- | Pushes a list of Block values. +pushBlocks :: LuaError e => Pusher e [Block] + +peekBlocksFuzzy :: LuaError e => Peeker e [Block] diff --git a/src/Text/Pandoc/Lua/Marshal/Cell.hs b/src/Text/Pandoc/Lua/Marshal/Cell.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Cell.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions of table 'Cell' values. +-} +module Text.Pandoc.Lua.Marshal.Cell + ( peekCell + , pushCell + ) where + +import Control.Monad ((<$!>)) +import HsLua +import Text.Pandoc.Lua.Marshal.Alignment (peekAlignment, pushAlignment) +import Text.Pandoc.Lua.Marshal.Attr (peekAttr, pushAttr) +import {-# SOURCE #-} Text.Pandoc.Lua.Marshal.Block + ( peekBlocksFuzzy, pushBlocks ) +import Text.Pandoc.Definition (Cell (..), RowSpan (..), ColSpan (..)) + +-- | Push a table cell as a table with fields @attr@, @alignment@, +-- @row_span@, @col_span@, and @contents@. +pushCell :: LuaError e => Cell -> LuaE e () +pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do + newtable + addField "attr" (pushAttr attr) + addField "alignment" (pushAlignment align) + addField "row_span" (pushIntegral rowSpan) + addField "col_span" (pushIntegral colSpan) + addField "contents" (pushBlocks contents) + where addField key pusher = pushName key *> pusher *> rawset (nth 3) + +-- | Retrieves a table 'Cell' from the stack. +peekCell :: LuaError e => Peeker e Cell +peekCell = fmap (retrieving "Cell") + . typeChecked "table" istable + $ \idx -> do + attr <- peekFieldRaw peekAttr "attr" idx + algn <- peekFieldRaw peekAlignment "alignment" idx + rs <- RowSpan <$!> peekFieldRaw peekIntegral "row_span" idx + cs <- ColSpan <$!> peekFieldRaw peekIntegral "col_span" idx + blks <- peekFieldRaw peekBlocksFuzzy "contents" idx + return $! Cell attr algn rs cs blks diff --git a/src/Text/Pandoc/Lua/Marshal/Citation.hs b/src/Text/Pandoc/Lua/Marshal/Citation.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Citation.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions and constructor for 'Citation' values. +-} +module Text.Pandoc.Lua.Marshal.Citation + ( -- * Citation + peekCitation + , pushCitation + , typeCitation + , mkCitation + ) where + +import Control.Applicative (optional) +import Data.Maybe (fromMaybe) +import HsLua as Lua +import Text.Pandoc.Lua.Marshal.CitationMode (peekCitationMode, pushCitationMode) +import {-# SOURCE #-} Text.Pandoc.Lua.Marshal.Inline (peekInlinesFuzzy, pushInlines) +import Text.Pandoc.Definition (Citation (..)) + +-- | Pushes a Citation value as userdata object. +pushCitation :: LuaError e + => Pusher e Citation +pushCitation = pushUD typeCitation +{-# INLINE pushCitation #-} + +-- | Retrieves a Citation value. +peekCitation :: LuaError e + => Peeker e Citation +peekCitation = peekUD typeCitation +{-# INLINE peekCitation #-} + +-- | Citation object type. +typeCitation :: LuaError e + => DocumentedType e Citation +typeCitation = deftype "Citation" + [ operation Eq $ lambda + ### liftPure2 (==) + <#> parameter (optional . peekCitation) "Citation" "a" "" + <#> parameter (optional . peekCitation) "Citation" "b" "" + =#> functionResult pushBool "boolean" "true iff the citations are equal" + + , operation Tostring $ lambda + ### liftPure show + <#> parameter peekCitation "Citation" "citation" "" + =#> functionResult pushString "string" "native Haskell representation" + ] + [ property "id" "citation ID / key" + (pushText, citationId) + (peekText, \citation cid -> citation{ citationId = cid }) + , property "mode" "citation mode" + (pushCitationMode, citationMode) + (peekCitationMode, \citation mode -> citation{ citationMode = mode }) + , property "prefix" "citation prefix" + (pushInlines, citationPrefix) + (peekInlinesFuzzy, \citation prefix -> citation{ citationPrefix = prefix }) + , property "suffix" "citation suffix" + (pushInlines, citationSuffix) + (peekInlinesFuzzy, \citation suffix -> citation{ citationSuffix = suffix }) + , property "note_num" "note number" + (pushIntegral, citationNoteNum) + (peekIntegral, \citation noteNum -> citation{ citationNoteNum = noteNum }) + , property "hash" "hash number" + (pushIntegral, citationHash) + (peekIntegral, \citation hash -> citation{ citationHash = hash }) + , method $ defun "clone" + ### return + <#> udparam typeCitation "obj" "" + =#> functionResult pushCitation "Citation" "copy of obj" + ] +{-# INLINABLE typeCitation #-} + +-- | Constructor function for 'Citation' elements. +mkCitation :: LuaError e => DocumentedFunction e +mkCitation = defun "Citation" + ### (\cid mode mprefix msuffix mnote_num mhash -> + cid `seq` mode `seq` mprefix `seq` msuffix `seq` + mnote_num `seq` mhash `seq` return $! Citation + { citationId = cid + , citationMode = mode + , citationPrefix = fromMaybe mempty mprefix + , citationSuffix = fromMaybe mempty msuffix + , citationNoteNum = fromMaybe 0 mnote_num + , citationHash = fromMaybe 0 mhash + }) + <#> parameter peekText "string" "cid" "citation ID (e.g. bibtex key)" + <#> parameter peekCitationMode "CitationMode" "mode" "citation rendering mode" + <#> optionalParameter peekInlinesFuzzy "prefix" "Inlines" "" + <#> optionalParameter peekInlinesFuzzy "suffix" "Inlines" "" + <#> optionalParameter peekIntegral "note_num" "integer" "note number" + <#> optionalParameter peekIntegral "hash" "integer" "hash number" + =#> functionResult pushCitation "Citation" "new citation object" + #? "Creates a single citation." diff --git a/src/Text/Pandoc/Lua/Marshal/CitationMode.hs b/src/Text/Pandoc/Lua/Marshal/CitationMode.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/CitationMode.hs @@ -0,0 +1,24 @@ +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions of 'CitationMode' values. +-} +module Text.Pandoc.Lua.Marshal.CitationMode + ( peekCitationMode + , pushCitationMode + ) where + +import HsLua +import Text.Pandoc.Definition (CitationMode) + +-- | Retrieves a Citation value from a string. +peekCitationMode :: Peeker e CitationMode +peekCitationMode = peekRead +{-# INLINE peekCitationMode #-} + +-- | Pushes a CitationMode value as string. +pushCitationMode :: Pusher e CitationMode +pushCitationMode = pushString . show +{-# INLINE pushCitationMode #-} diff --git a/src/Text/Pandoc/Lua/Marshal/Content.hs b/src/Text/Pandoc/Lua/Marshal/Content.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Content.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Defines a helper type that can handle different types of 'Block' and +'Inline' element contents. +-} +module Text.Pandoc.Lua.Marshal.Content + ( Content (..) + , contentTypeDescription + , peekContent + , pushContent + , peekDefinitionItem + ) where + +import Control.Applicative ((<|>)) +import Control.Monad ((<$!>)) +import HsLua +import {-# SOURCE #-} Text.Pandoc.Lua.Marshal.Block + ( peekBlocksFuzzy, pushBlocks ) +import {-# SOURCE #-} Text.Pandoc.Lua.Marshal.Inline + ( peekInlinesFuzzy, pushInlines ) +import Text.Pandoc.Lua.Marshal.List (pushPandocList) +import Text.Pandoc.Definition (Inline, Block) + +-- +-- Content +-- + +-- | Helper type to represent all the different types a `content` +-- attribute can have. +data Content + = ContentBlocks [Block] + | ContentInlines [Inline] + | ContentLines [[Inline]] + | ContentDefItems [([Inline], [[Block]])] + | ContentListItems [[Block]] + +-- | Gets the text property of an Inline, if present. +contentTypeDescription :: Content -> String +contentTypeDescription = \case + ContentBlocks {} -> "list of Block items" + ContentInlines {} -> "list of Inline items" + ContentLines {} -> "list of Inline lists (i.e., a list of lines)" + ContentDefItems {} -> "list of definition items items" + ContentListItems {} -> "list items (i.e., list of list of Block elements)" + +-- | Pushes the 'Content' to the stack. +pushContent :: LuaError e => Pusher e Content +pushContent = \case + ContentBlocks blks -> pushBlocks blks + ContentInlines inlns -> pushInlines inlns + ContentLines lns -> pushPandocList pushInlines lns + ContentDefItems itms -> pushPandocList pushDefinitionItem itms + ContentListItems itms -> pushPandocList pushBlocks itms + +-- | Gets a 'Content' element from the stack. +peekContent :: LuaError e => Peeker e Content +peekContent idx = + (ContentInlines <$!> peekInlinesFuzzy idx) <|> + (ContentLines <$!> peekList peekInlinesFuzzy idx) <|> + (ContentBlocks <$!> peekBlocksFuzzy idx ) <|> + (ContentListItems <$!> peekList peekBlocksFuzzy idx) <|> + (ContentDefItems <$!> peekList peekDefinitionItem idx) + +-- | Retrieves a single definition item from the stack; it is expected +-- to be a pair of a list of inlines and a list of list of blocks. Uses +-- fuzzy parsing, i.e., tries hard to convert mismatching types into the +-- expected result. +peekDefinitionItem :: LuaError e => Peeker e ([Inline], [[Block]]) +peekDefinitionItem = peekPair peekInlinesFuzzy $ choice + [ peekList peekBlocksFuzzy + , \idx -> (:[]) <$!> peekBlocksFuzzy idx + ] + +-- | Pushes a single definition items on the stack. +pushDefinitionItem :: LuaError e => Pusher e ([Inline], [[Block]]) +pushDefinitionItem = pushPair pushInlines + (pushPandocList pushBlocks) diff --git a/src/Text/Pandoc/Lua/Marshal/Format.hs b/src/Text/Pandoc/Lua/Marshal/Format.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Format.hs @@ -0,0 +1,23 @@ +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions of 'Format' values. +-} +module Text.Pandoc.Lua.Marshal.Format + ( peekFormat + , pushFormat + ) where + +import Control.Monad ((<$!>)) +import HsLua +import Text.Pandoc.Definition (Format (Format)) + +-- | Retrieves a 'Format' value from a string. +peekFormat :: Peeker e Format +peekFormat idx = Format <$!> peekText idx + +-- | Pushes a 'Format' value as a string. +pushFormat :: Pusher e Format +pushFormat (Format f) = pushText f diff --git a/src/Text/Pandoc/Lua/Marshal/Inline.hs b/src/Text/Pandoc/Lua/Marshal/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Inline.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{- | + +Marshal values of types that make up 'Inline' elements. +-} +module Text.Pandoc.Lua.Marshal.Inline + ( -- * Single Inline elements + peekInline + , peekInlineFuzzy + , pushInline + -- * List of Inlines + , peekInlines + , peekInlinesFuzzy + , pushInlines + -- * Constructors + , inlineConstructors + , mkInlines + ) where + +import Control.Monad.Catch (throwM) +import Control.Monad ((<$!>)) +import Data.Data (showConstr, toConstr) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import HsLua +import Text.Pandoc.Lua.Marshal.Attr (peekAttr, pushAttr) +import {-# SOURCE #-} Text.Pandoc.Lua.Marshal.Block + ( peekBlocksFuzzy ) +import Text.Pandoc.Lua.Marshal.Citation (peekCitation, pushCitation) +import Text.Pandoc.Lua.Marshal.Content + ( Content (..), contentTypeDescription, peekContent, pushContent ) +import Text.Pandoc.Lua.Marshal.Format (peekFormat, pushFormat) +import Text.Pandoc.Lua.Marshal.List (pushPandocList, newListMetatable) +import Text.Pandoc.Lua.Marshal.MathType (peekMathType, pushMathType) +import Text.Pandoc.Lua.Marshal.QuoteType (peekQuoteType, pushQuoteType) +import Text.Pandoc.Definition ( Inline (..), nullAttr ) +import qualified Text.Pandoc.Builder as B + +-- | Pushes an Inline value as userdata object. +pushInline :: LuaError e => Pusher e Inline +pushInline = pushUD typeInline +{-# INLINE pushInline #-} + +-- | Retrieves an Inline value. +peekInline :: LuaError e => Peeker e Inline +peekInline = peekUD typeInline +{-# INLINE peekInline #-} + +-- | Retrieves a list of Inline values. +peekInlines :: LuaError e + => Peeker e [Inline] +peekInlines = peekList peekInline +{-# INLINABLE peekInlines #-} + +-- | Pushes a list of Inline values. +pushInlines :: LuaError e + => Pusher e [Inline] +pushInlines xs = do + pushList pushInline xs + newListMetatable "Inlines" $ + pure () + setmetatable (nth 2) +{-# INLINABLE pushInlines #-} + +-- | Try extra hard to retrieve an Inline value from the stack. Treats +-- bare strings as @Str@ values. +peekInlineFuzzy :: LuaError e => Peeker e Inline +peekInlineFuzzy idx = retrieving "Inline" $ liftLua (ltype idx) >>= \case + TypeString -> Str <$!> peekText idx + _ -> peekInline idx +{-# INLINABLE peekInlineFuzzy #-} + +-- | Try extra-hard to return the value at the given index as a list of +-- inlines. +peekInlinesFuzzy :: LuaError e + => Peeker e [Inline] +peekInlinesFuzzy idx = liftLua (ltype idx) >>= \case + TypeString -> B.toList . B.text <$> peekText idx + _ -> choice + [ peekList peekInlineFuzzy + , fmap pure . peekInlineFuzzy + ] idx +{-# INLINABLE peekInlinesFuzzy #-} + +-- | Inline object type. +typeInline :: forall e. LuaError e => DocumentedType e Inline +typeInline = deftype "Inline" + [ operation Tostring $ lambda + ### liftPure (show @Inline) + <#> parameter peekInline "inline" "Inline" "Object" + =#> functionResult pushString "string" "stringified Inline" + , operation Eq $ defun "__eq" + ### liftPure2 (==) + <#> parameter peekInline "a" "Inline" "" + <#> parameter peekInline "b" "Inline" "" + =#> functionResult pushBool "boolean" "whether the two are equal" + ] + [ possibleProperty "attr" "element attributes" + (pushAttr, \case + Code attr _ -> Actual attr + Image attr _ _ -> Actual attr + Link attr _ _ -> Actual attr + Span attr _ -> Actual attr + _ -> Absent) + (peekAttr, \case + Code _ cs -> Actual . (`Code` cs) + Image _ cpt tgt -> Actual . \attr -> Image attr cpt tgt + Link _ cpt tgt -> Actual . \attr -> Link attr cpt tgt + Span _ inlns -> Actual . (`Span` inlns) + _ -> const Absent) + + , possibleProperty "caption" "image caption" + (pushPandocList pushInline, \case + Image _ capt _ -> Actual capt + _ -> Absent) + (peekInlinesFuzzy, \case + Image attr _ target -> Actual . (\capt -> Image attr capt target) + _ -> const Absent) + + , possibleProperty "citations" "list of citations" + (pushPandocList pushCitation, \case + Cite cs _ -> Actual cs + _ -> Absent) + (peekList peekCitation, \case + Cite _ inlns -> Actual . (`Cite` inlns) + _ -> const Absent) + + , possibleProperty "content" "element contents" + (pushContent, \case + Cite _ inlns -> Actual $ ContentInlines inlns + Emph inlns -> Actual $ ContentInlines inlns + Link _ inlns _ -> Actual $ ContentInlines inlns + Quoted _ inlns -> Actual $ ContentInlines inlns + SmallCaps inlns -> Actual $ ContentInlines inlns + Span _ inlns -> Actual $ ContentInlines inlns + Strikeout inlns -> Actual $ ContentInlines inlns + Strong inlns -> Actual $ ContentInlines inlns + Subscript inlns -> Actual $ ContentInlines inlns + Superscript inlns -> Actual $ ContentInlines inlns + Underline inlns -> Actual $ ContentInlines inlns + Note blks -> Actual $ ContentBlocks blks + _ -> Absent) + (peekContent, + let inlineContent = \case + ContentInlines inlns -> inlns + c -> throwM . luaException @e $ + "expected Inlines, got " <> contentTypeDescription c + blockContent = \case + ContentBlocks blks -> blks + ContentInlines [] -> [] + c -> throwM . luaException @e $ + "expected Blocks, got " <> contentTypeDescription c + in \case + -- inline content + Cite cs _ -> Actual . Cite cs . inlineContent + Emph _ -> Actual . Emph . inlineContent + Link a _ tgt -> Actual . (\inlns -> Link a inlns tgt) . inlineContent + Quoted qt _ -> Actual . Quoted qt . inlineContent + SmallCaps _ -> Actual . SmallCaps . inlineContent + Span attr _ -> Actual . Span attr . inlineContent + Strikeout _ -> Actual . Strikeout . inlineContent + Strong _ -> Actual . Strong . inlineContent + Subscript _ -> Actual . Subscript . inlineContent + Superscript _ -> Actual . Superscript . inlineContent + Underline _ -> Actual . Underline . inlineContent + -- block content + Note _ -> Actual . Note . blockContent + _ -> const Absent + ) + + , possibleProperty "format" "format of raw text" + (pushFormat, \case + RawInline fmt _ -> Actual fmt + _ -> Absent) + (peekFormat, \case + RawInline _ txt -> Actual . (`RawInline` txt) + _ -> const Absent) + + , possibleProperty "mathtype" "math rendering method" + (pushMathType, \case + Math mt _ -> Actual mt + _ -> Absent) + (peekMathType, \case + Math _ txt -> Actual . (`Math` txt) + _ -> const Absent) + + , possibleProperty "quotetype" "type of quotes (single or double)" + (pushQuoteType, \case + Quoted qt _ -> Actual qt + _ -> Absent) + (peekQuoteType, \case + Quoted _ inlns -> Actual . (`Quoted` inlns) + _ -> const Absent) + + , possibleProperty "src" "image source" + (pushText, \case + Image _ _ (src, _) -> Actual src + _ -> Absent) + (peekText, \case + Image attr capt (_, title) -> Actual . Image attr capt . (,title) + _ -> const Absent) + + , possibleProperty "target" "link target URL" + (pushText, \case + Link _ _ (tgt, _) -> Actual tgt + _ -> Absent) + (peekText, \case + Link attr capt (_, title) -> Actual . Link attr capt . (,title) + _ -> const Absent) + , possibleProperty "title" "title text" + (pushText, \case + Image _ _ (_, tit) -> Actual tit + Link _ _ (_, tit) -> Actual tit + _ -> Absent) + (peekText, \case + Image attr capt (src, _) -> Actual . Image attr capt . (src,) + Link attr capt (src, _) -> Actual . Link attr capt . (src,) + _ -> const Absent) + + , possibleProperty "text" "text contents" + (pushText, getInlineText) + (peekText, setInlineText) + + , readonly "tag" "type of Inline" + (pushString, showConstr . toConstr ) + + , alias "t" "tag" ["tag"] + , alias "c" "content" ["content"] + , alias "identifier" "element identifier" ["attr", "identifier"] + , alias "classes" "element classes" ["attr", "classes"] + , alias "attributes" "other element attributes" ["attr", "attributes"] + + , method $ defun "clone" + ### return + <#> parameter peekInline "inline" "Inline" "self" + =#> functionResult pushInline "Inline" "cloned Inline" + ] + +-- +-- Text +-- + +-- | Gets the text property of an Inline, if present. +getInlineText :: Inline -> Possible Text +getInlineText = \case + Code _ lst -> Actual lst + Math _ str -> Actual str + RawInline _ raw -> Actual raw + Str s -> Actual s + _ -> Absent + +-- | Sets the text property of an Inline, if present. +setInlineText :: Inline -> Text -> Possible Inline +setInlineText = \case + Code attr _ -> Actual . Code attr + Math mt _ -> Actual . Math mt + RawInline f _ -> Actual . RawInline f + Str _ -> Actual . Str + _ -> const Absent + +-- | Constructor functions for 'Inline' elements. +inlineConstructors :: LuaError e => [DocumentedFunction e] +inlineConstructors = + [ defun "Cite" + ### liftPure2 (flip Cite) + <#> parameter peekInlinesFuzzy "content" "Inline" "placeholder content" + <#> parameter (peekList peekCitation) "citations" "list of Citations" "" + =#> functionResult pushInline "Inline" "cite element" + , defun "Code" + ### liftPure2 (\text mattr -> Code (fromMaybe nullAttr mattr) text) + <#> parameter peekText "code" "string" "code string" + <#> optionalParameter peekAttr "attr" "Attr" "additional attributes" + =#> functionResult pushInline "Inline" "code element" + , mkInlinesConstr "Emph" Emph + , defun "Image" + ### liftPure4 (\caption src mtitle mattr -> + let attr = fromMaybe nullAttr mattr + title = fromMaybe mempty mtitle + in Image attr caption (src, title)) + <#> parameter peekInlinesFuzzy "Inlines" "caption" "image caption / alt" + <#> parameter peekText "string" "src" "path/URL of the image file" + <#> optionalParameter peekText "string" "title" "brief image description" + <#> optionalParameter peekAttr "Attr" "attr" "image attributes" + =#> functionResult pushInline "Inline" "image element" + , defun "LineBreak" + ### return LineBreak + =#> functionResult pushInline "Inline" "line break" + , defun "Link" + ### liftPure4 (\content target mtitle mattr -> + let attr = fromMaybe nullAttr mattr + title = fromMaybe mempty mtitle + in Link attr content (target, title)) + <#> parameter peekInlinesFuzzy "Inlines" "content" "text for this link" + <#> parameter peekText "string" "target" "the link target" + <#> optionalParameter peekText "string" "title" "brief link description" + <#> optionalParameter peekAttr "Attr" "attr" "link attributes" + =#> functionResult pushInline "Inline" "link element" + , defun "Math" + ### liftPure2 Math + <#> parameter peekMathType "quotetype" "Math" "rendering method" + <#> parameter peekText "text" "string" "math content" + =#> functionResult pushInline "Inline" "math element" + , defun "Note" + ### liftPure Note + <#> parameter peekBlocksFuzzy "content" "Blocks" "note content" + =#> functionResult pushInline "Inline" "note" + , defun "Quoted" + ### liftPure2 Quoted + <#> parameter peekQuoteType "quotetype" "QuoteType" "type of quotes" + <#> parameter peekInlinesFuzzy "content" "Inlines" "inlines in quotes" + =#> functionResult pushInline "Inline" "quoted element" + , defun "RawInline" + ### liftPure2 RawInline + <#> parameter peekFormat "format" "Format" "format of content" + <#> parameter peekText "text" "string" "string content" + =#> functionResult pushInline "Inline" "raw inline element" + , mkInlinesConstr "SmallCaps" SmallCaps + , defun "SoftBreak" + ### return SoftBreak + =#> functionResult pushInline "Inline" "soft break" + , defun "Space" + ### return Space + =#> functionResult pushInline "Inline" "new space" + , defun "Span" + ### liftPure2 (\inlns mattr -> Span (fromMaybe nullAttr mattr) inlns) + <#> parameter peekInlinesFuzzy "content" "Inlines" "inline content" + <#> optionalParameter peekAttr "attr" "Attr" "additional attributes" + =#> functionResult pushInline "Inline" "span element" + , defun "Str" + ### liftPure Str + <#> parameter peekText "text" "string" "" + =#> functionResult pushInline "Inline" "new Str object" + , mkInlinesConstr "Strong" Strong + , mkInlinesConstr "Strikeout" Strikeout + , mkInlinesConstr "Subscript" Subscript + , mkInlinesConstr "Superscript" Superscript + , mkInlinesConstr "Underline" Underline + ] + where + mkInlinesConstr name constr = defun name + ### liftPure (\x -> x `seq` constr x) + <#> parameter peekInlinesFuzzy "Inlines" "content" "" + =#> functionResult pushInline "Inline" "new object" + +-- | Constructor for a list of `Inline` values. +mkInlines :: LuaError e => DocumentedFunction e +mkInlines = defun "Inlines" + ### liftPure id + <#> parameter peekInlinesFuzzy "Inlines" "inlines" "inline elements" + =#> functionResult pushInlines "Inlines" "list of inline elements" diff --git a/src/Text/Pandoc/Lua/Marshal/Inline.hs-boot b/src/Text/Pandoc/Lua/Marshal/Inline.hs-boot new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Inline.hs-boot @@ -0,0 +1,11 @@ +module Text.Pandoc.Lua.Marshal.Inline + ( peekInlinesFuzzy + , pushInlines + ) +where + +import HsLua +import Text.Pandoc.Definition (Inline) + +peekInlinesFuzzy :: LuaError e => Peeker e [Inline] +pushInlines :: LuaError e => Pusher e [Inline] diff --git a/src/Text/Pandoc/Lua/Marshal/List.hs b/src/Text/Pandoc/Lua/Marshal/List.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/List.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions and constructor for 'ListAttributes' +values. +-} +module Text.Pandoc.Lua.Marshal.List + ( pushPandocList + , luaopen_list_ptr + , pushListModule + , newListMetatable + ) where + +import Data.ByteString (useAsCString) +import Foreign.C +import HsLua + +-- | 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/src/Text/Pandoc/Lua/Marshal/ListAttributes.hs b/src/Text/Pandoc/Lua/Marshal/ListAttributes.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/ListAttributes.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions and constructor for 'ListAttributes' +values. +-} +module Text.Pandoc.Lua.Marshal.ListAttributes + ( typeListAttributes + , peekListAttributes + , pushListAttributes + , mkListAttributes + , peekListNumberDelim + , pushListNumberDelim + , peekListNumberStyle + , pushListNumberStyle + ) where + +import Data.Maybe (fromMaybe) +import HsLua +import Text.Pandoc.Definition + ( ListAttributes, ListNumberStyle (..), ListNumberDelim (..)) + +-- | 'ListAttributes' Lua object type. +typeListAttributes :: LuaError e => DocumentedType e ListAttributes +typeListAttributes = deftype "ListAttributes" + [ operation Eq $ lambda + ### liftPure2 (==) + <#> parameter peekListAttributes "a" "ListAttributes" "" + <#> parameter peekListAttributes "b" "ListAttributes" "" + =#> functionResult pushBool "boolean" "whether the two are equal" + ] + [ property "start" "number of the first list item" + (pushIntegral, \(start,_,_) -> start) + (peekIntegral, \(_,style,delim) -> (,style,delim)) + , property "style" "style used for list numbering" + (pushListNumberStyle, \(_,style,_) -> style) + (peekListNumberStyle, \(start,_,delim) -> (start,,delim)) + , property "delimiter" "delimiter of list numbers" + (pushListNumberDelim, \(_,_,delim) -> delim) + (peekListNumberDelim, \(start,style,_) -> (start,style,)) + , method $ defun "clone" + ### return + <#> udparam typeListAttributes "a" "" + =#> functionResult (pushUD typeListAttributes) "ListAttributes" + "cloned ListAttributes value" + ] + +-- | Pushes a 'ListAttributes' value as userdata object. +pushListAttributes :: LuaError e => Pusher e ListAttributes +pushListAttributes = pushUD typeListAttributes + +-- | Retrieve a 'ListAttributes' triple, either from userdata or from a +-- Lua tuple. +peekListAttributes :: LuaError e => Peeker e ListAttributes +peekListAttributes = retrieving "ListAttributes" . choice + [ peekUD typeListAttributes + , peekTriple peekIntegral peekRead peekRead + ] + +-- | Constructor for a new 'ListAttributes' value. +mkListAttributes :: LuaError e => DocumentedFunction e +mkListAttributes = defun "ListAttributes" + ### liftPure3 (\mstart mstyle mdelim -> + ( fromMaybe 1 mstart + , fromMaybe DefaultStyle mstyle + , fromMaybe DefaultDelim mdelim + )) + <#> optionalParameter peekIntegral "integer" "start" "number of first item" + <#> optionalParameter peekRead "string" "style" "list numbering style" + <#> optionalParameter peekRead "string" "delimiter" "list number delimiter" + =#> functionResult pushListAttributes "ListAttributes" "new ListAttributes" + #? "Creates a new ListAttributes object." + +-- | Pushes a 'ListNumberDelim' value as string. +pushListNumberDelim :: Pusher e ListNumberDelim +pushListNumberDelim = pushString . show +{-# INLINE pushListNumberDelim #-} + +-- | Retrieves a 'ListNumberDelim' value from a string. +peekListNumberDelim :: Peeker e ListNumberDelim +peekListNumberDelim = peekRead +{-# INLINE peekListNumberDelim #-} + +-- | Pushes a 'ListNumberStyle' value as string. +pushListNumberStyle :: Pusher e ListNumberStyle +pushListNumberStyle = pushString . show +{-# INLINE pushListNumberStyle #-} + +-- | Retrieves a 'ListNumberStyle' value from a string. +peekListNumberStyle :: Peeker e ListNumberStyle +peekListNumberStyle = peekRead +{-# INLINE peekListNumberStyle #-} diff --git a/src/Text/Pandoc/Lua/Marshal/MathType.hs b/src/Text/Pandoc/Lua/Marshal/MathType.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/MathType.hs @@ -0,0 +1,22 @@ +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions of 'MathType' values. +-} +module Text.Pandoc.Lua.Marshal.MathType + ( peekMathType + , pushMathType + ) where + +import HsLua +import Text.Pandoc.Definition (MathType) + +-- | Retrieves a 'MathType' value from a string. +peekMathType :: Peeker e MathType +peekMathType = peekRead + +-- | Pushes a 'MathType' value as a string. +pushMathType :: Pusher e MathType +pushMathType = pushString . show diff --git a/src/Text/Pandoc/Lua/Marshal/MetaValue.hs b/src/Text/Pandoc/Lua/Marshal/MetaValue.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/MetaValue.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions of 'MetaValue' elements. +-} +module Text.Pandoc.Lua.Marshal.MetaValue + ( peekMetaValue + , pushMetaValue + , metaValueConstructors + ) where + +import Control.Applicative ((<|>), optional) +import Control.Monad ((<$!>)) +import HsLua +import Text.Pandoc.Lua.Marshal.Block + ( peekBlock, peekBlocks, peekBlocksFuzzy, pushBlocks ) +import Text.Pandoc.Lua.Marshal.Inline + ( peekInline, peekInlines, peekInlinesFuzzy, pushInlines ) +import Text.Pandoc.Lua.Marshal.List (pushPandocList) +import Text.Pandoc.Definition (MetaValue (..)) + +-- | Push a 'MetaValue' element to the top of the Lua stack. +pushMetaValue :: LuaError e => Pusher e MetaValue +pushMetaValue = \case + MetaBlocks blcks -> pushBlocks blcks + MetaBool bool -> pushBool bool + MetaInlines inlns -> pushInlines inlns + MetaList metalist -> pushPandocList pushMetaValue metalist + MetaMap metamap -> pushMap pushText pushMetaValue metamap + MetaString t -> pushText t + +-- | Retrieves the value at the given stack index as 'MetaValue'. +peekMetaValue :: forall e. LuaError e => Peeker e MetaValue +peekMetaValue = retrieving "MetaValue" . \idx -> do + -- Get the contents of an AST element. + + liftLua (ltype idx) >>= \case + TypeBoolean -> MetaBool <$!> peekBool idx + + TypeString -> MetaString <$!> peekText idx + + TypeUserdata -> -- Allow singleton Inline or Block elements + (MetaInlines . (:[]) <$!> peekInline idx) <|> + (MetaBlocks . (:[]) <$!> peekBlock idx) + + TypeTable -> optional (getName idx) >>= \case + Just "Inlines" -> MetaInlines <$!> peekInlinesFuzzy idx + Just "Blocks" -> MetaBlocks <$!> peekBlocksFuzzy idx + Just "List" -> MetaList <$!> peekList peekMetaValue idx + _ -> do + -- no meta value tag given, try to guess. + len <- liftLua $ rawlen idx + if len <= 0 + then MetaMap <$!> peekMap peekText peekMetaValue idx + else (MetaInlines <$!> peekInlines idx) + <|> (MetaBlocks <$!> peekBlocks idx) + <|> (MetaList <$!> peekList peekMetaValue idx) + + _ -> failPeek "could not get meta value" + + where + getName idx = liftLua (getmetafield idx "__name") >>= \case + TypeNil -> failPeek "no name" + _ -> peekName idx `lastly` pop 1 + + +-- | Constructor functions for 'MetaValue' elements. +metaValueConstructors :: LuaError e => [DocumentedFunction e] +metaValueConstructors = + [ defun "MetaBlocks" + ### liftPure MetaBlocks + <#> parameter peekBlocksFuzzy "Blocks" "content" "block content" + =#> functionResult pushMetaValue "Blocks" "list of Block elements" + + , defun "MetaBool" + ### liftPure MetaBool + <#> parameter peekBool "boolean" "bool" "true or false" + =#> functionResult pushMetaValue "boolean" "input, unchanged" + + , defun "MetaInlines" + ### liftPure MetaInlines + <#> parameter peekInlinesFuzzy "Inlines" "inlines" "inline elements" + =#> functionResult pushMetaValue "Inlines" "list of Inline elements" + + , defun "MetaList" + ### liftPure MetaList + <#> parameter (peekList peekMetaValue) "MetaValue|{MetaValue,...}" + "values" "value, or list of values" + =#> functionResult pushMetaValue "List" "list of meta values" + + , defun "MetaMap" + ### liftPure MetaMap + <#> parameter (peekMap peekText peekMetaValue) "table" "map" + "string-indexed table" + =#> functionResult pushMetaValue "table" "map of meta values" + + , defun "MetaString" + ### liftPure MetaString + <#> parameter peekText "string" "s" "string value" + =#> functionResult pushMetaValue "string" "unchanged input" + ] diff --git a/src/Text/Pandoc/Lua/Marshal/Pandoc.hs b/src/Text/Pandoc/Lua/Marshal/Pandoc.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Pandoc.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions of 'Pandoc' values. +-} +module Text.Pandoc.Lua.Marshal.Pandoc + ( -- * Pandoc + peekPandoc + , pushPandoc + , mkPandoc + -- * Meta + , peekMeta + , pushMeta + , mkMeta + ) where + +import Control.Applicative (optional) +import Control.Monad ((<$!>)) +import Data.Maybe (fromMaybe) +import HsLua +import Text.Pandoc.Lua.Marshal.Block (peekBlocksFuzzy, pushBlocks) +import Text.Pandoc.Lua.Marshal.MetaValue (peekMetaValue, pushMetaValue) +import Text.Pandoc.Definition (Pandoc (..), Meta (..), nullMeta) + +-- | Pushes a 'Pandoc' value as userdata. +pushPandoc :: LuaError e => Pusher e Pandoc +pushPandoc = pushUD typePandoc + +-- | Retrieves a 'Pandoc' document from a userdata value. +peekPandoc :: LuaError e => Peeker e Pandoc +peekPandoc = retrieving "Pandoc" . peekUD typePandoc + +-- | Pandoc object type. +typePandoc :: LuaError e => DocumentedType e Pandoc +typePandoc = deftype "Pandoc" + [ operation Eq $ defun "__eq" + ### liftPure2 (==) + <#> parameter (optional . peekPandoc) "doc1" "pandoc" "" + <#> parameter (optional . peekPandoc) "doc2" "pandoc" "" + =#> functionResult pushBool "boolean" "true iff the two values are equal" + , operation Tostring $ lambda + ### liftPure show + <#> parameter peekPandoc "Pandoc" "doc" "" + =#> functionResult pushString "string" "native Haskell representation" + ] + [ property "blocks" "list of blocks" + (pushBlocks, \(Pandoc _ blks) -> blks) + (peekBlocksFuzzy, \(Pandoc m _) blks -> Pandoc m blks) + , property "meta" "document metadata" + (pushMeta, \(Pandoc meta _) -> meta) + (peekMeta, \(Pandoc _ blks) meta -> Pandoc meta blks) + ] + +-- | Pushes a 'Meta' value as a string-indexed table. +pushMeta :: LuaError e => Pusher e Meta +pushMeta (Meta mmap) = do + pushMap pushText pushMetaValue mmap + _ <- newmetatable "Meta" + setmetatable (nth 2) + +-- | Retrieves a 'Meta' value from a string-indexed table. +peekMeta :: LuaError e => Peeker e Meta +peekMeta idx = retrieving "Meta" $ + Meta <$!> peekMap peekText peekMetaValue idx + +-- | Constructor function for 'Pandoc' values. +mkPandoc :: LuaError e => DocumentedFunction e +mkPandoc = defun "Pandoc" + ### liftPure2 (\blocks mMeta -> Pandoc (fromMaybe nullMeta mMeta) blocks) + <#> parameter peekBlocksFuzzy "Blocks" "blocks" "document contents" + <#> optionalParameter peekMeta "Meta" "meta" "document metadata" + =#> functionResult pushPandoc "Pandoc" "new Pandoc document" + +-- | Constructor for 'Meta' values. +mkMeta :: LuaError e => DocumentedFunction e +mkMeta = defun "Meta" + ### liftPure id + <#> parameter peekMeta "table" "meta" "table containing meta information" + =#> functionResult pushMeta "table" "new Meta table" diff --git a/src/Text/Pandoc/Lua/Marshal/QuoteType.hs b/src/Text/Pandoc/Lua/Marshal/QuoteType.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/QuoteType.hs @@ -0,0 +1,22 @@ +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions of 'QuoteType' values. +-} +module Text.Pandoc.Lua.Marshal.QuoteType + ( peekQuoteType + , pushQuoteType + ) where + +import HsLua +import Text.Pandoc.Definition (QuoteType) + +-- | Retrieves a 'QuoteType' value from a string. +peekQuoteType :: Peeker e QuoteType +peekQuoteType = peekRead + +-- | Pushes a 'QuoteType' value as a string. +pushQuoteType :: Pusher e QuoteType +pushQuoteType = pushString . show diff --git a/src/Text/Pandoc/Lua/Marshal/SimpleTable.hs b/src/Text/Pandoc/Lua/Marshal/SimpleTable.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/SimpleTable.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{- | +Copyright : © 2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Definition and marshaling of the 'SimpleTable' data type used as a +convenience type when dealing with tables. +-} +module Text.Pandoc.Lua.Marshal.SimpleTable + ( SimpleTable (..) + , peekSimpleTable + , pushSimpleTable + , mkSimpleTable + ) + where + +import HsLua as Lua +import Text.Pandoc.Lua.Marshal.Alignment (peekAlignment, pushAlignment) +import Text.Pandoc.Lua.Marshal.Block (peekBlocksFuzzy, pushBlocks) +import Text.Pandoc.Lua.Marshal.Inline (peekInlinesFuzzy, pushInlines) +import Text.Pandoc.Lua.Marshal.List (pushPandocList) +import Text.Pandoc.Definition + +-- | A simple (legacy-style) table. +data SimpleTable = SimpleTable + { simpleTableCaption :: [Inline] + , simpleTableAlignments :: [Alignment] + , simpleTableColumnWidths :: [Double] + , simpleTableHeader :: [[Block]] + , simpleTableBody :: [[[Block]]] + } deriving stock (Eq, Show) + +typeSimpleTable :: LuaError e => DocumentedType e SimpleTable +typeSimpleTable = deftype "SimpleTable" + [ operation Eq $ lambda + ### liftPure2 (==) + <#> udparam typeSimpleTable "a" "" + <#> udparam typeSimpleTable "b" "" + =#> functionResult pushBool "boolean" "whether the two objects are equal" + , operation Tostring $ lambda + ### liftPure show + <#> udparam typeSimpleTable "self" "" + =#> functionResult pushString "string" "Haskell string representation" + ] + [ property "caption" "table caption" + (pushInlines, simpleTableCaption) + (peekInlinesFuzzy, \t capt -> t {simpleTableCaption = capt}) + , property "aligns" "column alignments" + (pushPandocList pushAlignment, simpleTableAlignments) + (peekList peekAlignment, \t aligns -> t{simpleTableAlignments = aligns}) + , property "widths" "relative column widths" + (pushPandocList pushRealFloat, simpleTableColumnWidths) + (peekList peekRealFloat, \t ws -> t{simpleTableColumnWidths = ws}) + , property "headers" "table header" + (pushRow, simpleTableHeader) + (peekRow, \t h -> t{simpleTableHeader = h}) + , property "rows" "table body rows" + (pushPandocList pushRow, simpleTableBody) + (peekList peekRow, \t bs -> t{simpleTableBody = bs}) + + , readonly "t" "type tag (always 'SimpleTable')" + (pushText, const "SimpleTable") + + , alias "header" "alias for `headers`" ["headers"] + ] + where + pushRow = pushPandocList pushBlocks + +peekRow :: LuaError e => Peeker e [[Block]] +peekRow = peekList peekBlocksFuzzy + +-- | Push a simple table to the stack by calling the +-- @pandoc.SimpleTable@ constructor. +pushSimpleTable :: forall e. LuaError e => SimpleTable -> LuaE e () +pushSimpleTable = pushUD typeSimpleTable + +-- | Retrieve a simple table from the stack. +peekSimpleTable :: forall e. LuaError e => Peeker e SimpleTable +peekSimpleTable = retrieving "SimpleTable" . peekUD typeSimpleTable + +-- | Constructor for the 'SimpleTable' type. +mkSimpleTable :: LuaError e => DocumentedFunction e +mkSimpleTable = defun "SimpleTable" + ### liftPure5 SimpleTable + <#> parameter peekInlinesFuzzy "Inlines" "caption" + "table caption" + <#> parameter (peekList peekAlignment) "{Alignment,...}" "align" + "column alignments" + <#> parameter (peekList peekRealFloat) "{number,...}" "widths" + "relative column widths" + <#> parameter peekRow "{Blocks,...}" "header" + "table header row" + <#> parameter (peekList peekRow) "{{Blocks,...},...}" "body" + "table body rows" + =#> functionResult pushSimpleTable "SimpleTable" "new SimpleTable object" diff --git a/src/Text/Pandoc/Lua/Marshal/TableParts.hs b/src/Text/Pandoc/Lua/Marshal/TableParts.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/TableParts.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{- | +Copyright : © 2021 Albert Krewinkel +SPDX-License-Identifier : MIT +Maintainer : Albert Krewinkel + +Marshaling/unmarshaling functions of types that are used exclusively +with tables. +-} +module Text.Pandoc.Lua.Marshal.TableParts + ( peekCaption + , pushCaption + , peekColSpec + , pushColSpec + , peekRow + , pushRow + , peekTableBody + , pushTableBody + , peekTableFoot + , pushTableFoot + , peekTableHead + , pushTableHead + ) where + +import Control.Applicative (optional) +import Control.Monad ((<$!>)) +import HsLua +import Text.Pandoc.Lua.Marshal.Alignment (peekAlignment, pushAlignment) +import Text.Pandoc.Lua.Marshal.Attr (peekAttr, pushAttr) +import {-# SOURCE #-} Text.Pandoc.Lua.Marshal.Block + ( peekBlocksFuzzy, pushBlocks ) +import Text.Pandoc.Lua.Marshal.Cell (peekCell, pushCell) +import {-# SOURCE #-} Text.Pandoc.Lua.Marshal.Inline + ( peekInlinesFuzzy, pushInlines ) +import Text.Pandoc.Lua.Marshal.List (pushPandocList) +import Text.Pandoc.Definition + +-- | Push Caption element +pushCaption :: LuaError e => Caption -> LuaE e () +pushCaption (Caption shortCaption longCaption) = do + newtable + addField "short" (maybe pushnil pushInlines shortCaption) + addField "long" (pushBlocks longCaption) + +-- | Peek Caption element +peekCaption :: LuaError e => Peeker e Caption +peekCaption = retrieving "Caption" . \idx -> do + short <- optional $ peekFieldRaw peekInlinesFuzzy "short" idx + long <- peekFieldRaw peekBlocksFuzzy "long" idx + return $! Caption short long + +-- | Push a ColSpec value as a pair of Alignment and ColWidth. +pushColSpec :: LuaError e => Pusher e ColSpec +pushColSpec = pushPair pushAlignment pushColWidth + +-- | Peek a ColSpec value as a pair of Alignment and ColWidth. +peekColSpec :: LuaError e => Peeker e ColSpec +peekColSpec = peekPair peekAlignment peekColWidth + +peekColWidth :: Peeker e ColWidth +peekColWidth = retrieving "ColWidth" . \idx -> do + maybe ColWidthDefault ColWidth <$!> optional (peekRealFloat idx) + +-- | Push a ColWidth value by pushing the width as a plain number, or +-- @nil@ for ColWidthDefault. +pushColWidth :: LuaError e => Pusher e ColWidth +pushColWidth = \case + (ColWidth w) -> push w + ColWidthDefault -> pushnil + +-- | Push a table row as a pair of attr and the list of cells. +pushRow :: LuaError e => Pusher e Row +pushRow (Row attr cells) = + pushPair pushAttr (pushPandocList pushCell) (attr, cells) + +-- | Push a table row from a pair of attr and the list of cells. +peekRow :: LuaError e => Peeker e Row +peekRow = (uncurry Row <$!>) + . retrieving "Row" + . peekPair peekAttr (peekList peekCell) + +-- | Pushes a 'TableBody' value as a Lua table with fields @attr@, +-- @row_head_columns@, @head@, and @body@. +pushTableBody :: LuaError e => Pusher e TableBody +pushTableBody (TableBody attr (RowHeadColumns rowHeadColumns) head' body) = do + newtable + addField "attr" (pushAttr attr) + addField "row_head_columns" (pushIntegral rowHeadColumns) + addField "head" (pushPandocList pushRow head') + addField "body" (pushPandocList pushRow body) + +-- | Retrieves a 'TableBody' value from a Lua table with fields @attr@, +-- @row_head_columns@, @head@, and @body@. +peekTableBody :: LuaError e => Peeker e TableBody +peekTableBody = fmap (retrieving "TableBody") + . typeChecked "table" istable + $ \idx -> TableBody + <$!> peekFieldRaw peekAttr "attr" idx + <*> peekFieldRaw (fmap RowHeadColumns . peekIntegral) "row_head_columns" idx + <*> peekFieldRaw (peekList peekRow) "head" idx + <*> peekFieldRaw (peekList peekRow) "body" idx + +-- | Push a table head value as the pair of its Attr and rows. +pushTableHead :: LuaError e => Pusher e TableHead +pushTableHead (TableHead attr rows) = + pushPair pushAttr (pushPandocList pushRow) (attr, rows) + +-- | Peek a table head value from a pair of Attr and rows. +peekTableHead :: LuaError e => Peeker e TableHead +peekTableHead = (uncurry TableHead <$!>) + . retrieving "TableHead" + . peekPair peekAttr (peekList peekRow) + +-- | Pushes a 'TableFoot' value as a pair of the Attr value and the list +-- of table rows. +pushTableFoot :: LuaError e => Pusher e TableFoot +pushTableFoot (TableFoot attr rows) = + pushPair pushAttr (pushPandocList pushRow) (attr, rows) + +-- | Retrieves a 'TableFoot' value from a pair containing an Attr value +-- and a list of table rows. +peekTableFoot :: LuaError e => Peeker e TableFoot +peekTableFoot = (uncurry TableFoot <$!>) + . retrieving "TableFoot" + . peekPair peekAttr (peekList peekRow) + +-- | Add a value to the table at the top of the stack at a string-index. +addField :: LuaError e => Name -> LuaE e () -> LuaE e () +addField key pushValue = do + pushName key + pushValue + rawset (nth 3) diff --git a/test/test-attr.lua b/test/test-attr.lua new file mode 100644 --- /dev/null +++ b/test/test-attr.lua @@ -0,0 +1,144 @@ +local tasty = require 'tasty' + +local test = tasty.test_case +local group = tasty.test_group +local assert = tasty.assert + +return { + group 'Attr' { + group 'Constructor' { + test('Attr is a function', function () + assert.are_equal(type(Attr), 'function') + end), + test('returns null-Attr if no arguments are given', function () + local attr = Attr() + assert.are_equal(attr.identifier, '') + assert.are_same(attr.classes, {}) + assert.are_same(#attr.attributes, 0) + end), + test( + 'accepts string-indexed table or list of pairs as attributes', + function () + local attributes_list = {{'one', '1'}, {'two', '2'}} + local attr_from_list = Attr('', {}, attributes_list) + + assert.are_equal(attr_from_list.attributes.one, '1') + assert.are_equal(attr_from_list.attributes.two, '2') + + local attributes_table = {one = '1', two = '2'} + local attr_from_table = Attr('', {}, attributes_table) + assert.are_equal( + attr_from_table.attributes, + AttributeList(attributes_table) + ) + assert.are_equal(attr_from_table.attributes.one, '1') + assert.are_equal(attr_from_table.attributes.two, '2') + end + ) + }, + group 'Properties' { + test('has t and tag property', function () + local attr = Attr('') + assert.are_equal(attr.t, 'Attr') + assert.are_equal(attr.tag, 'Attr') + end), + test('has field `identifier`', function () + local attr = Attr 'test' + assert.are_equal(attr.identifier, 'test') + end), + test('can be modified through field `identifier`', function () + local attr = Attr 'test' + attr.identifier = 'new' + assert.are_equal(attr, Attr 'new') + end), + group 'field classes' { + test('can be read', function () + local attr = Attr('', {'one'}) + assert.are_same(attr.classes, {'one'}) + end), + test('can be set', function () + local attr = Attr() + attr.classes = {'two'} + assert.are_equal(attr, Attr('', {'two'})) + end), + test('contains a pandoc List', function () + assert.are_equal(getmetatable(Attr().classes), List) + end), + } + }, + group 'AttributeList' { + test('allows access via fields', function () + local attributes = Attr('', {}, {{'a', '1'}, {'b', '2'}}).attributes + assert.are_equal(attributes.a, '1') + assert.are_equal(attributes.b, '2') + end), + test('allows access to pairs via numerical indexing', function () + local attributes = Attr('', {}, {{'a', '1'}, {'b', '2'}}).attributes + assert.are_same(attributes[1], {'a', '1'}) + assert.are_same(attributes[2], {'b', '2'}) + end), + test('allows replacing a pair', function () + local attributes = AttributeList{{'a', '1'}, {'b', '2'}} + attributes[1] = {'t','five'} + assert.are_same(attributes[1], {'t', 'five'}) + assert.are_same(attributes[2], {'b', '2'}) + end), + test('allows to remove a pair', function () + local attributes = AttributeList{{'a', '1'}, {'b', '2'}} + attributes[1] = nil + assert.are_equal(#attributes, 1) + end), + test('adds entries by field name', function () + local attributes = Attr('',{}, {{'c', '1'}, {'d', '2'}}).attributes + attributes.e = '3' + assert.are_same( + attributes, + -- checking the full AttributeList would "duplicate" entries + AttributeList{{'c', '1'}, {'d', '2'}, {'e', '3'}} + ) + end), + test('deletes entries by field name', function () + local attributes = Attr('',{}, {a = '1', b = '2'}).attributes + attributes.a = nil + assert.is_nil(attributes.a) + assert.are_same(attributes, AttributeList{{'b', '2'}}) + end), + test('remains unchanged if deleted key did not exist', function () + local assoc_list = List:new {{'alpha', 'x'}, {'beta', 'y'}} + local attributes = Attr('', {}, assoc_list).attributes + attributes.a = nil + local new_assoc_list = List() + for k, v in pairs(attributes) do + new_assoc_list:insert({k, v}) + end + assert.are_same(new_assoc_list, assoc_list) + end), + test('gives key-value pairs when iterated-over', function () + local attributes = {width = '11', height = '22', name = 'test'} + local attr = Attr('', {}, attributes) + local count = 0 + for k, v in pairs(attr.attributes) do + assert.are_equal(attributes[k], v) + count = count + 1 + end + assert.are_equal(count, 3) + end) + }, + group 'HTML-like attribute tables' { + test('in element constructor', function () + local html_attributes = { + id = 'the-id', + class = 'class1 class2', + width = '11', + height = '12' + } + local attr = Attr(html_attributes) + assert.are_equal(attr.identifier, 'the-id') + assert.are_equal(attr.classes[1], 'class1') + assert.are_equal(attr.classes[2], 'class2') + assert.are_equal(attr.attributes.width, '11') + assert.are_equal(attr.attributes.height, '12') + end), + } + } +} diff --git a/test/test-block.lua b/test/test-block.lua new file mode 100644 --- /dev/null +++ b/test/test-block.lua @@ -0,0 +1,346 @@ +local tasty = require 'tasty' + +local test = tasty.test_case +local group = tasty.test_group +local assert = tasty.assert + +return { + group "Block" { + group 'BlockQuote' { + test('access content via property `content`', function () + local elem = BlockQuote{'word'} + assert.are_same(elem.content, {Plain 'word'}) + assert.are_equal(type(elem.content), 'table') + + elem.content = { + Para{Str 'one'}, + Para{Str 'two'} + } + assert.are_equal( + BlockQuote{ + Para 'one', + Para 'two' + }, + elem + ) + end), + }, + group 'BulletList' { + test('access items via property `content`', function () + local para = Para 'one' + local blist = BulletList{{para}} + assert.are_same({{para}}, blist.content) + end), + test('property `content` uses fuzzy marshalling', function () + local old = Plain 'old' + local new = Plain 'new' + local blist = BulletList{{old}} + blist.content = {{new}} + assert.are_same({{new}}, blist:clone().content) + blist.content = new + assert.are_same({{new}}, blist:clone().content) + end), + }, + group 'CodeBlock' { + test('access code via property `text`', function () + local cb = CodeBlock('return true') + assert.are_equal(cb.text, 'return true') + assert.are_equal(type(cb.text), 'string') + + cb.text = 'return nil' + assert.are_equal(cb, CodeBlock('return nil')) + end), + test('access Attr via property `attr`', function () + local cb = CodeBlock('true', {'my-code', {'lua'}}) + assert.are_equal(cb.attr, Attr{'my-code', {'lua'}}) + assert.are_equal(type(cb.attr), 'userdata') + + cb.attr = Attr{'my-other-code', {'java'}} + assert.are_equal( + CodeBlock('true', {'my-other-code', {'java'}}), + cb + ) + end) + }, + group 'DefinitionList' { + test('access items via property `content`', function () + local deflist = DefinitionList{ + {'apple', {{Plain 'fruit'}, {Plain 'company'}}}, + {Str 'coffee', 'Best when hot.'} + } + assert.are_equal(#deflist.content, 2) + assert.are_same(deflist.content[1][1], {Str 'apple'}) + assert.are_same(deflist.content[1][2][2], + {Plain{Str 'company'}}) + assert.are_same(deflist.content[2][2], + {{Plain{ + Str 'Best', Space(), + Str 'when', Space(), + Str 'hot.'}}}) + end), + test('modify items via property `content`', function () + local deflist = DefinitionList{ + {'apple', {{{'fruit'}}, {{'company'}}}} + } + deflist.content[1][1] = Str 'orange' + deflist.content[1][2][1] = {Plain 'tasty fruit'} + local newlist = DefinitionList{ + { {Str 'orange'}, + {{Plain 'tasty fruit'}, {Plain 'company'}} + } + } + assert.are_equal(deflist, newlist) + end), + }, + group 'Div' { + test('access content via property `content`', function () + local elem = Div{BlockQuote{Plain 'word'}} + assert.are_same(elem.content, {BlockQuote{'word'}}) + assert.are_equal(type(elem.content), 'table') + + elem.content = { + Para{Str 'one'}, + Para{Str 'two'} + } + assert.are_equal( + Div{ + Para 'one', + Para 'two' + }, + elem + ) + end), + test('access Attr via property `attr`', function () + local div = Div('word', {'my-div', {'sample'}}) + assert.are_equal(div.attr, Attr{'my-div', {'sample'}}) + assert.are_equal(type(div.attr), 'userdata') + + div.attr = Attr{'my-other-div', {'example'}} + assert.are_equal( + Div('word', {'my-other-div', {'example'}}), + div + ) + end) + }, + group 'Header' { + test('access inlines via property `content`', function () + local header = Header(1, 'test') + assert.are_same(header.content, {Str 'test'}) + + header.content = {'new text'} + assert.are_equal(header, Header(1, {'new text'})) + end), + test('access Attr via property `attr`', function () + local header = Header(1, 'test', {'my-test'}) + assert.are_same(header.attr, Attr{'my-test'}) + + header.attr = 'second-test' + assert.are_equal(header, Header(1, 'test', 'second-test')) + end), + test('access level via property `level`', function () + local header = Header(3, 'test') + assert.are_same(header.level, 3) + + header.level = 2 + assert.are_equal(header, Header(2, 'test')) + end), + }, + group 'LineBlock' { + test('access lines via property `content`', function () + local spc = Space() + local lineblock = LineBlock{ + {'200', spc, 'Main', spc, 'St.'}, + {'Berkeley', spc, 'CA', spc, '94718'} + } + assert.are_equal(#lineblock.content, 2) -- has two lines + assert.are_same(lineblock.content[2][1], Str 'Berkeley') + end), + test('modifying `content` alter the element', function () + local spc = Space() + local lineblock = LineBlock{ + {'200', spc, 'Main', spc, 'St.'}, + {'Berkeley', spc, 'CA', spc, '94718'} + } + lineblock.content[1][1] = '404' + assert.are_same( + lineblock:clone().content[1], + {Str '404', spc, Str 'Main', spc, Str 'St.'} + ) + + lineblock.content = {{'line1'}, {'line2'}} + assert.are_same( + lineblock:clone(), + LineBlock{ + {Str 'line1'}, + {Str 'line2'} + } + ) + end) + }, + group 'Null' { + test('Can be constructed', function () + assert.are_equal(Null().t, 'Null') + end) + }, + group 'OrderedList' { + test('access items via property `content`', function () + local para = Plain 'one' + local olist = OrderedList{{para}} + assert.are_same({{para}}, olist.content) + end), + test('forgiving constructor', function () + local plain = Plain 'old' + local olist = OrderedList({plain}, {3, 'Example', 'Period'}) + local listAttribs = ListAttributes(3, 'Example', 'Period') + assert.are_same(olist.listAttributes, listAttribs) + end), + test('has list attribute aliases', function () + local olist = OrderedList({}, {4, 'Decimal', 'OneParen'}) + assert.are_equal(olist.start, 4) + assert.are_equal(olist.style, 'Decimal') + assert.are_equal(olist.delimiter, 'OneParen') + end) + }, + group 'Para' { + test('access inline via property `content`', function () + local para = Para{'Moin, ', Space(), 'Sylt!'} + assert.are_same( + para.content, + {Str 'Moin, ', Space(), Str 'Sylt!'} + ) + end), + test('modifying `content` changes the element', function () + local para = Para{'Moin, ', Space(), Str 'Sylt!'} + + para.content[3] = 'Hamburg!' + assert.are_same( + para:clone().content, + {Str 'Moin, ', Space(), Str 'Hamburg!'} + ) + + para.content = 'Huh' + assert.are_same( + para:clone().content, + {Str 'Huh'} + ) + end), + }, + group 'RawBlock' { + test('access raw content via property `text`', function () + local raw = RawBlock('markdown', '- one') + assert.are_equal(type(raw.text), 'string') + assert.are_equal(raw.text, '- one') + + raw.text = '+ one' + assert.are_equal(raw, RawBlock('markdown', '+ one')) + end), + test('access Format via property `format`', function () + local raw = RawBlock('markdown', '* hi') + assert.are_equal(type(raw.format), 'string') + assert.are_equal(raw.format, 'markdown') + + raw.format = 'org' + assert.are_equal(RawBlock('org', '* hi'), raw) + end) + }, + group 'Table' { + test('access Attr via property `attr`', function () + local caption = {long = {Plain 'cap'}} + local tbl = Table(caption, {}, {{}, {}}, {}, {{}, {}}, + {'my-tbl', {'a'}}) + assert.are_equal(tbl.attr, Attr{'my-tbl', {'a'}}) + + tbl.attr = Attr{'my-other-tbl', {'b'}} + assert.are_equal( + Table(caption, {}, {{}, {}}, {}, {{}, {}}, + {'my-other-tbl', {'b'}}), + tbl + ) + end), + test('access caption via property `caption`', function () + local caption = {long = {Plain 'cap'}} + local tbl = Table(caption, {}, {{}, {}}, {}, {{}, {}}) + assert.are_same(tbl.caption, {long = {Plain 'cap'}}) + + tbl.caption.short = 'brief' + tbl.caption.long = {Plain 'extended'} + + local new_caption = { + short = 'brief', + long = {Plain 'extended'} + } + assert.are_equal( + Table(new_caption, {}, {{}, {}}, {}, {{}, {}}), + tbl + ) + end), + test('access column specifiers via property `colspecs`', function () + local colspecs = {{AlignCenter, 1}} + local tbl = Table({long = {}}, colspecs, {{}, {}}, {}, {{}, {}}) + assert.are_same(tbl.colspecs, colspecs) + + tbl.colspecs[1][1] = AlignRight + tbl.colspecs[1][2] = nil + + local new_colspecs = {{AlignRight}} + assert.are_equal( + Table({long = {}}, new_colspecs, {{}, {}}, {}, {{}, {}}), + tbl + ) + end), + test('access table head via property `head`', function () + local head = {Attr{'tbl-head'}, {}} + local tbl = Table({long = {}}, {}, head, {}, {{}, {}}) + assert.are_same(tbl.head, head) + + tbl.head[1] = Attr{'table-head'} + + local new_head = {'table-head', {}} + assert.are_equal( + Table({long = {}}, {}, new_head, {}, {{}, {}}), + tbl + ) + end), + test('access table head via property `head`', function () + local foot = {{id = 'tbl-foot'}, {}} + local tbl = Table({long = {}}, {}, {{}, {}}, {}, foot) + assert.are_same(tbl.foot, {Attr('tbl-foot'), {}}) + + tbl.foot[1] = Attr{'table-foot'} + + local new_foot = {'table-foot', {}} + assert.are_equal( + Table({long = {}}, {}, {{}, {}}, {}, new_foot), + tbl + ) + end) + }, + }, + group "Blocks" { + test('splits a string into words', function () + assert.are_same( + Blocks 'Absolute Giganten', + {Plain {Str 'Absolute', Space(), Str 'Giganten'}} + ) + end), + test('converts single Block into List', function () + assert.are_same( + Blocks(CodeBlock('return true')), + {CodeBlock('return true')} + ) + end), + test('converts elements in a list into Blocks', function () + assert.are_same( + Blocks{'Berlin', 'Berkeley', Plain 'Zürich'}, + {Plain{Str 'Berlin'}, Plain{Str 'Berkeley'}, Plain{Str 'Zürich'}} + ) + end), + test('can be mapped over', function () + local words = Blocks{Header(1, 'Program'), CodeBlock 'pandoc'} + assert.are_same( + words:map(function (x) return x.t end), + {'Header', 'CodeBlock'} + ) + end), + }, +} diff --git a/test/test-citation.lua b/test/test-citation.lua new file mode 100644 --- /dev/null +++ b/test/test-citation.lua @@ -0,0 +1,111 @@ +-- +-- Tests for the pandoc types module +-- +local tasty = require 'tasty' + +local group = tasty.test_group +local test = tasty.test_case +local assert = tasty.assert + +return { + group 'Citation' { + test('can be cloned', function () + local cit = Citation('leibniz', AuthorInText) + local cloned = cit:clone() + cit.id = 'newton' + assert.are_same(cloned.id, 'leibniz') + assert.are_same(cit.id, 'newton') + assert.are_same(cit.mode, cloned.mode) + end), + group 'field `id`' { + test('can be read', function () + assert.are_equal( + Citation('einstein1905', 'NormalCitation').id, + 'einstein1905' + ) + end), + test('can be set', function () + local c = Citation('einstein1905', 'NormalCitation') + c.id = 'Poincaré1905' + assert.are_equal(c, Citation('Poincaré1905', 'NormalCitation')) + end) + }, + group 'field `mode`' { + test('can be read', function () + assert.are_equal( + Citation('einstein1905', 'NormalCitation').mode, + 'NormalCitation' + ) + end), + test('can be set', function () + local c = Citation('Poincaré1905', 'NormalCitation') + c.mode = 'AuthorInText' + assert.are_equal(c, Citation('Poincaré1905', 'AuthorInText')) + end) + }, + group 'field `prefix`' { + test('can be read', function () + assert.are_same( + Citation('einstein1905', 'NormalCitation', {'x'}).prefix, + {Str 'x'} + ) + end), + test('can be set', function () + local c = Citation('Poincaré1905', 'NormalCitation') + c.prefix = {'y'} + assert.are_equal( + c, + Citation('Poincaré1905', 'NormalCitation', {'y'}) + ) + end), + }, + group 'field `suffix`' { + test('can be read', function () + assert.are_same( + Citation('einstein1905', 'NormalCitation', {}, 'is great').suffix, + {Str 'is', Space(), Str 'great'} + ) + end), + test('can be set', function () + local c = Citation('Poincaré1905', 'NormalCitation') + c.suffix = {'why'} + assert.are_equal( + c, + Citation('Poincaré1905', 'NormalCitation', {}, {'why'}) + ) + end), + }, + group 'field `note_num`' { + test('can be read', function () + assert.are_equal( + Citation('einstein1905', 'NormalCitation', {}, {}, 7).note_num, + 7 + ) + end), + test('can be set', function () + local c = Citation('Poincaré1905', 'NormalCitation') + c.note_num = 23 + assert.are_equal( + c, + Citation('Poincaré1905', 'NormalCitation', {}, {}, 23) + ) + end), + }, + group 'field `hash`' { + test('can be read', function () + assert.are_equal( + Citation('einstein1905', 'NormalCitation', {}, {}, 0, 5).hash, + 5 + ) + end), + test('can be set', function () + local c = Citation('Poincaré1905', 'NormalCitation') + c.hash = 23 + assert.are_equal( + c, + Citation('Poincaré1905', 'NormalCitation', {}, {}, 0, 23) + ) + end) + } + } +} diff --git a/test/test-inline.lua b/test/test-inline.lua new file mode 100644 --- /dev/null +++ b/test/test-inline.lua @@ -0,0 +1,300 @@ +local tasty = require 'tasty' + +local test = tasty.test_case +local group = tasty.test_group +local assert = tasty.assert + +return { + group "Inline" { + group 'Cite' { + test('has property `content`', function () + local cite = Cite({Emph 'important'}, {}) + assert.are_same(cite.content, {Emph {Str 'important'}}) + + cite.content = 'boring' + assert.are_equal(cite, Cite({Str 'boring'}, {})) + end), + test('has list of citations in property `cite`', function () + local citations = { + Citation('einstein1905', 'NormalCitation') + } + local cite = Cite('relativity', citations) + assert.are_same(cite.citations, citations) + + local new_citations = { + citations[1], + Citation('Poincaré1905', 'NormalCitation') + } + cite.citations = new_citations + assert.are_equal(cite, Cite({'relativity'}, new_citations)) + end), + }, + group 'Code' { + test('has property `attr`', function () + local code = Code('true', {id='true', foo='bar'}) + assert.are_equal(code.attr, Attr('true', {}, {{'foo', 'bar'}})) + + code.attr = {id='t', fubar='quux'} + assert.are_equal( + Code('true', Attr('t', {}, {{'fubar', 'quux'}})), + code + ) + end), + test('has property `text`', function () + local code = Code('true') + assert.are_equal(code.text, 'true') + + code.text = '1 + 1' + assert.are_equal(Code('1 + 1'), code) + end), + }, + group 'Emph' { + test('has property `content`', function () + local elem = Emph{'two', Space(), 'words'} + assert.are_same( + elem.content, + {Str 'two', Space(), Str 'words'} + ) + elem.content = {'word'} + assert.are_equal(elem, Emph{'word'}) + end) + }, + group 'Image' { + test('has property `caption`', function () + local img = Image('example', 'a.png') + assert.are_same(img.caption, {Str 'example'}) + + img.caption = 'A' + assert.are_equal(img, Image({'A'}, 'a.png')) + end), + test('has property `src`', function () + local img = Image('example', 'sample.png') + assert.are_same(img.src, 'sample.png') + + img.src = 'example.svg' + assert.are_equal(img, Image('example', 'example.svg')) + end), + test('has property `title`', function () + local img = Image('here', 'img.gif', 'example') + assert.are_same(img.title, 'example') + + img.title = 'a' + assert.are_equal(img, Image('here', 'img.gif', 'a')) + end), + test('has property `attr`', function () + local img = Image('up', 'upwards.png', '', {'up', {'point'}}) + assert.are_same(img.attr, Attr {'up', {'point'}}) + + img.attr = Attr {'up', {'point', 'button'}} + assert.are_equal( + Image('up', 'upwards.png', nil, {'up', {'point', 'button'}}), + img + ) + end) + }, + group 'Link' { + test('has property `content`', function () + local link = Link('example', 'https://example.org') + assert.are_same(link.content, {Str 'example'}) + + link.content = 'commercial' + link.target = 'https://example.com' + assert.are_equal(link, Link('commercial', 'https://example.com')) + end), + test('has property `target`', function () + local link = Link('example', 'https://example.org') + assert.are_same(link.content, {Str 'example'}) + + link.target = 'https://example.com' + assert.are_equal(link, Link('example', 'https://example.com')) + end), + test('has property `title`', function () + local link = Link('here', 'https://example.org', 'example') + assert.are_same(link.title, 'example') + + link.title = 'a' + assert.are_equal(link, Link('here', 'https://example.org', 'a')) + end), + test('has property `attr`', function () + local link = Link('up', '../index.html', '', {'up', {'nav'}}) + assert.are_same(link.attr, Attr {'up', {'nav'}}) + + link.attr = Attr {'up', {'nav', 'button'}} + assert.are_equal( + Link('up', '../index.html', nil, {'up', {'nav', 'button'}}), + link + ) + end) + }, + group 'Math' { + test('has property `text`', function () + local elem = Math(InlineMath, 'x^2') + assert.are_same(elem.text, 'x^2') + elem.text = 'a + b' + assert.are_equal(elem, Math(InlineMath, 'a + b')) + end), + test('has property `mathtype`', function () + local elem = Math(InlineMath, 'x^2') + assert.are_same(elem.mathtype, 'InlineMath') + elem.mathtype = DisplayMath + assert.are_equal(elem, Math(DisplayMath, 'x^2')) + end), + }, + group 'Note' { + -- FIXME: waiting for Block support + -- test('has property `content`', function () + -- local elem = Note{Para {'two', Space(), 'words'}} + -- assert.are_same( + -- elem.content, + -- {Para {Str 'two', Space(), Str 'words'}} + -- ) + -- elem.content = Plain 'word' + -- assert.are_equal(elem, Note{'word'}) + -- end) + }, + group 'Quoted' { + test('has property `content`', function () + local elem = Quoted('SingleQuote', Emph{'emph'}) + assert.are_same( + elem.content, + {Emph{Str 'emph'}} + ) + elem.content = {'word'} + assert.are_equal(elem, Quoted(SingleQuote, {'word'})) + end), + test('has property `quotetype`', function () + local elem = Quoted('SingleQuote', 'a') + assert.are_same(elem.quotetype, SingleQuote) + elem.quotetype = 'DoubleQuote' + assert.are_equal(elem, Quoted(DoubleQuote, {'a'})) + end) + }, + group 'SmallCaps' { + test('has property `content`', function () + local elem = SmallCaps{'two', Space(), 'words'} + assert.are_same( + elem.content, + {Str 'two', Space(), Str 'words'} + ) + elem.content = {'word'} + assert.are_equal(elem, SmallCaps{'word'}) + end) + }, + group 'SoftBreak' { + test('can be constructed', function () + local sb = SoftBreak() + assert.are_equal(sb.t, 'SoftBreak') + end) + }, + group 'Span' { + test('has property `attr`', function () + local elem = Span('one', {'', {'number'}}) + assert.are_same( + elem.attr, + Attr('', {'number'}) + ) + elem.attr = {'', {}, {{'a', 'b'}}} + assert.are_equal(elem, Span({'one'}, {a='b'})) + end), + test('has property `content`', function () + local elem = Span{'two', Space(), 'words'} + assert.are_same( + elem.content, + {Str 'two', Space(), Str 'words'} + ) + elem.content = {'word'} + assert.are_equal(elem, Span{'word'}) + end) + }, + group 'Str' { + test('has property `text`', function () + local elem = Str 'nein' + assert.are_same(elem.text, 'nein') + elem.text = 'doch' + assert.are_equal(elem, Str 'doch') + end) + }, + group 'Strikeout' { + test('has property `content`', function () + local elem = Strikeout{'two', Space(), 'words'} + assert.are_same( + elem.content, + {Str 'two', Space(), Str 'words'} + ) + elem.content = {'word'} + assert.are_equal(elem, Strikeout{'word'}) + end) + }, + group 'Strong' { + test('has property `content`', function () + local elem = Strong{'two', Space(), 'words'} + assert.are_same( + elem.content, + {Str 'two', Space(), Str 'words'} + ) + elem.content = {'word'} + assert.are_equal(elem, Strong{'word'}) + end) + }, + group 'Subscript' { + test('has property `content`', function () + local elem = Subscript{'two', Space(), 'words'} + assert.are_same( + elem.content, + {Str 'two', Space(), Str 'words'} + ) + elem.content = {'word'} + assert.are_equal(elem, Subscript{'word'}) + end) + }, + group 'Superscript' { + test('has property `content`', function () + local elem = Superscript{'two', Space(), 'words'} + assert.are_same( + elem.content, + {Str 'two', Space(), Str 'words'} + ) + elem.content = {'word'} + assert.are_equal(elem, Superscript{'word'}) + end) + }, + group 'Underline' { + test('has property `content`', function () + local elem = Underline{'two', Space(), 'words'} + assert.are_same( + elem.content, + {Str 'two', Space(), Str 'words'} + ) + elem.content = {'word'} + assert.are_equal(elem, Underline{'word'}) + end) + }, + }, + group "Inlines" { + test('splits a string into words', function () + assert.are_same( + Inlines 'Absolute Giganten', + {Str 'Absolute', Space(), Str 'Giganten'} + ) + end), + test('converts single Inline into List', function () + assert.are_same( + Inlines(Emph{Str'Important'}), + {Emph{Str'Important'}} + ) + end), + test('converts elements in a list into Inlines', function () + assert.are_same( + Inlines{'Molecular', Space(), 'Biology'}, + {Str 'Molecular', Space(), Str 'Biology'} + ) + end), + test('can be mapped over', function () + local words = Inlines 'good idea' + assert.are_same( + words:map(function (x) return x.t end), + {'Str', 'Space', 'Str'} + ) + end) + }, +} diff --git a/test/test-list.lua b/test/test-list.lua new file mode 100644 --- /dev/null +++ b/test/test-list.lua @@ -0,0 +1,215 @@ +-- +-- Tests for the pandoc types module +-- +local tasty = require 'tasty' + +local group = tasty.test_group +local test = tasty.test_case +local assert = tasty.assert + +return { + group 'List' { + test('is a table', function () + assert.are_equal(type(List), 'table') + end), + group 'constructor' { + test('returns a new list if called without args', function () + assert.are_same(List(), {}) + end), + }, + + group 'clone' { + test('changing the clone does not affect original', function () + local orig = List:new {23, 42} + local copy = orig:clone() + copy[1] = 5 + assert.are_same({23, 42}, orig) + assert.are_same({5, 42}, copy) + end), + test('result is a list', function () + local orig = List:new {23, 42} + assert.are_equal(List, getmetatable(orig:clone())) + end), + }, + + group 'extend' { + test('extends list with other list', function () + local primes = List:new {2, 3, 5, 7} + primes:extend {11, 13, 17} + assert.are_same({2, 3, 5, 7, 11, 13, 17}, primes) + end) + }, + + group 'filter' { + test('keep elements for which property is truthy', function () + local is_small_prime = function (x) + return x == 2 or x == 3 or x == 5 or x == 7 + end + local numbers = List:new {4, 7, 2, 9, 5, 11} + assert.are_same(List{7, 2, 5}, numbers:filter(is_small_prime)) + end), + test('predecate function gets current index as second arg', function () + local args = List() + local collect_args = function (...) + args[#args+1] = {...} + return false + end + (List{0, 1, 1, 2, 3, 5, 8}):filter(collect_args) + assert.are_same( + args, + List{{0, 1}, {1, 2}, {1, 3}, {2, 4}, {3, 5}, {5, 6}, {8, 7}} + ) + end) + }, + + group 'find' { + test('returns element and index if found', function () + local list = List:new {5, 23, 71} + local elem, idx = list:find(71) + assert.are_same(71, elem) + assert.are_same(3, idx) + end), + test('respects start index', function () + local list = List:new {19, 23, 29, 71} + assert.are_equal(23, list:find(23, 1)) + assert.are_equal(23, list:find(23, 2)) + assert.is_nil(list:find(23, 3)) + end), + test('returns nil if element not found', function () + assert.is_nil((List:new {18, 20, 22, 0, 24}):find('0')) + end), + }, + + group 'find_if' { + test('returns element and index if found', function () + local perm_prime = List:new {2, 3, 5, 7, 11, 13, 17, 31, 37, 71} + local elem, idx = perm_prime:find_if(function (x) return x >= 10 end) + assert.are_same(11, elem) + assert.are_same(5, idx) + end), + test('gets current index as second arg', function () + assert.are_equal( + 5, + (List{9, 8, 7, 6, 5, 4, 3, 2, 1}):find_if( + function (x, i) return x == i end + ) + ) + end), + test('returns nil if element not found', function () + local is_zero = function (n) return n == 0 end + assert.is_nil((List:new {18, 20, 22, 24, 27}):find_if(is_zero)) + end), + }, + + group 'includes' { + test('finds elements in list', function () + local lst = List:new {'one', 'two', 'three'} + assert.is_truthy(lst:includes('one')) + assert.is_truthy(lst:includes('two')) + assert.is_truthy(lst:includes('three')) + assert.is_falsy(lst:includes('four')) + end) + }, + + group 'insert' { + test('is a function', function () + assert.are_equal(type(List.insert), 'function') + end), + test('insert value at end of list.', function () + local count_norsk = List {'en', 'to', 'tre'} + count_norsk:insert('fire') + assert.are_same({'en', 'to', 'tre', 'fire'}, count_norsk) + end), + test('insert value in the middle of list.', function () + local count_norsk = List {'fem', 'syv'} + count_norsk:insert(2, 'seks') + assert.are_same({'fem', 'seks', 'syv'}, count_norsk) + end) + }, + + group 'map' { + test('applies function to elements', function () + local primes = List:new {2, 3, 5, 7} + local squares = primes:map(function (x) return x^2 end) + assert.are_same({4, 9, 25, 49}, squares) + end), + test('leaves original list unchanged', function () + local primes = List:new {2, 3, 5, 7} + local squares = primes:map(function (x) return x^2 end) + assert.are_same({2, 3, 5, 7}, primes) + end), + test('map function gets index as second argument', function () + local primes = List:new {2, 3, 5, 7} + local indices = primes:map(function (x, i) return i end) + assert.are_same(List{1, 2, 3, 4}, indices) + end) + }, + + group 'new' { + test('keeps elements in list', function () + local test = {1, 1, 2, 3, 5} + assert.are_same(List:new(test), test) + end), + test('return empty list if no argument is given', function () + assert.are_same({}, List:new()) + end), + test('metatable of result is pandoc.List', function () + local test = List:new{5} + assert.are_equal(List, getmetatable(test)) + end) + }, + + group 'remove' { + test('is a function', function () + assert.are_equal(type(List.remove), 'function') + end), + test('remove value at end of list.', function () + local understand = List {'jeg', 'forstår', 'ikke'} + local norsk_not = understand:remove() + assert.are_same({'jeg', 'forstår'}, understand) + assert.are_equal('ikke', norsk_not) + end), + test('remove value at beginning of list.', function () + local count_norsk = List {'en', 'to', 'tre'} + count_norsk:remove(1) + assert.are_same({'to', 'tre'}, count_norsk) + end) + }, + + group 'sort' { + test('is a function', function () + assert.are_equal(type(List.sort), 'function') + end), + test('sort numeric list', function () + local numbers = List {71, 5, -1, 42, 23, 0, 1} + numbers:sort() + assert.are_same({-1, 0, 1, 5, 23, 42, 71}, numbers) + end), + test('reverse-sort numeric', function () + local numbers = List {71, 5, -1, 42, 23, 0, 1} + numbers:sort(function (x, y) return x > y end) + assert.are_same({71, 42, 23, 5, 1, 0, -1}, numbers) + end) + }, + }, + group 'Operations' { + group 'concatenation' { + test('yields a concatenated list', function () + assert.are_same(List {3, 4, 5, 6}, List{3, 4} .. List {5, 6}) + end), + test('does not modify its operands', function () + local a = List {54, 74} + local b = List {90, 2014} + local result = a .. b + assert.are_same(a, List{54, 74}) + assert.are_same(b, List{90, 2014}) + end), + test('sets metatable of first operand on result', function () + local result = {1, 4} .. List{9, 16} + assert.are_equal(nil, getmetatable(result)) + result = List{1, 4} .. {9, 16} + assert.are_equal(List, getmetatable(result)) + end), + } + }, +} diff --git a/test/test-listattributes.lua b/test/test-listattributes.lua new file mode 100644 --- /dev/null +++ b/test/test-listattributes.lua @@ -0,0 +1,65 @@ +local tasty = require 'tasty' + +local test = tasty.test_case +local group = tasty.test_group +local assert = tasty.assert + +return { + group 'ListAttributes' { + test('has field `start`', function () + local la = ListAttributes(7, DefaultStyle, Period) + assert.are_equal(la.start, 7) + end), + test('has field `style`', function () + local la = ListAttributes(1, Example, Period) + assert.are_equal(la.style, 'Example') + end), + test('has field `delimiter`', function () + local la = ListAttributes(1, Example, Period) + assert.are_equal(la.delimiter, 'Period') + end), + test('can be compared on equality', function () + assert.are_equal( + ListAttributes(2, DefaultStyle, Period), + ListAttributes(2, DefaultStyle, Period) + ) + assert.is_falsy( + ListAttributes(2, DefaultStyle, Period) == + ListAttributes(4, DefaultStyle, Period) + ) + end), + test('can be modified through `start`', function () + local la = ListAttributes(3, Decimal, OneParen) + la.start = 20 + assert.are_equal(la, ListAttributes(20, Decimal, OneParen)) + end), + test('can be modified through `style`', function () + local la = ListAttributes(3, Decimal, OneParen) + la.style = LowerRoman + assert.are_equal(la, ListAttributes(3, LowerRoman, OneParen)) + end), + test('can be modified through `delimiter`', function () + local la = ListAttributes(5, UpperAlpha, DefaultDelim) + la.delimiter = TwoParens + assert.are_equal(la, ListAttributes(5, UpperAlpha, TwoParens)) + end), + test('can be cloned', function () + local la = ListAttributes(2, DefaultStyle, Period) + local cloned = la:clone() + assert.are_equal(la, cloned) + la.start = 9 + assert.are_same(cloned.start, 2) + end), + group 'Constructor' { + test('omitting a start numer sets it to 1', function () + assert.are_equal(ListAttributes().start, 1) + end), + test('omitting a style sets it to DefaultStyle', function () + assert.are_equal(ListAttributes(0).style, DefaultStyle) + end), + test('omitting a delimiter sets it to DefaultDelim', function () + assert.are_equal(ListAttributes(0, UpperRoman).delimiter, DefaultDelim) + end) + } + }, +} diff --git a/test/test-metavalue.lua b/test/test-metavalue.lua new file mode 100644 --- /dev/null +++ b/test/test-metavalue.lua @@ -0,0 +1,15 @@ +local tasty = require 'tasty' + +local test = tasty.test_case +local group = tasty.test_group +local assert = tasty.assert + +return { + group 'MetaValue elements' { + test('MetaList elements behave like lists', function () + local metalist = MetaList{} + assert.are_equal(type(metalist.insert), 'function') + assert.are_equal(type(metalist.remove), 'function') + end), + } +} diff --git a/test/test-pandoc-lua-marshal.hs b/test/test-pandoc-lua-marshal.hs new file mode 100644 --- /dev/null +++ b/test/test-pandoc-lua-marshal.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : Main +Copyright : © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Tests for the pandoc types handling in Lua. +-} +module Main (main) where + +import Control.Monad (forM_, when) +import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr) +import Data.Proxy (Proxy (Proxy)) +import Data.String (fromString) +import HsLua as Lua +import Test.Tasty.QuickCheck (ioProperty, testProperty) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.Lua (translateResultsFromFile) +import Text.Pandoc.Arbitrary () +import Text.Pandoc.Definition +import Text.Pandoc.Lua.Marshal.AST + +main :: IO () +main = do + listTests <- run @Lua.Exception $ do + openlibs + pushListModule *> setglobal "List" + translateResultsFromFile "test/test-list.lua" + + listAttributeTests <- run @Lua.Exception $ do + openlibs + register' mkListAttributes + registerConstants (Proxy @ListNumberStyle) + registerConstants (Proxy @ListNumberDelim) + translateResultsFromFile "test/test-listattributes.lua" + + attrTests <- run @Lua.Exception $ do + openlibs + pushListModule *> setglobal "List" + register' mkAttr + register' mkAttributeList + translateResultsFromFile "test/test-attr.lua" + + citationTests <- run @Lua.Exception $ do + openlibs + pushListModule *> setglobal "List" + register' mkCitation + registerConstants (Proxy @CitationMode) + forM_ inlineConstructors register' + translateResultsFromFile "test/test-citation.lua" + + inlineTests <- run @Lua.Exception $ do + openlibs + pushListModule *> setglobal "List" + register' mkAttr + register' mkCitation + register' mkInlines + registerConstants (Proxy @CitationMode) + registerConstants (Proxy @MathType) + registerConstants (Proxy @QuoteType) + forM_ inlineConstructors register' + translateResultsFromFile "test/test-inline.lua" + + blockTests <- run @Lua.Exception $ do + openlibs + pushListModule *> setglobal "List" + register' mkAttr + register' mkBlocks + register' mkListAttributes + registerConstants (Proxy @Alignment) + registerConstants (Proxy @ListNumberStyle) + registerConstants (Proxy @ListNumberStyle) + forM_ inlineConstructors register' + forM_ blockConstructors register' + translateResultsFromFile "test/test-block.lua" + + simpleTableTests <- run @Lua.Exception $ do + openlibs + pushListModule *> setglobal "List" + register' mkAttr + register' mkListAttributes + register' mkSimpleTable + registerConstants (Proxy @Alignment) + forM_ inlineConstructors register' + forM_ blockConstructors register' + translateResultsFromFile "test/test-simpletable.lua" + + metavalueTests <- run @Lua.Exception $ do + openlibs + pushListModule *> setglobal "List" + forM_ metaValueConstructors register' + translateResultsFromFile "test/test-metavalue.lua" + + pandocTests <- run @Lua.Exception $ do + openlibs + pushListModule *> setglobal "List" + register' mkMeta + register' mkPandoc + forM_ inlineConstructors register' + forM_ blockConstructors register' + translateResultsFromFile "test/test-pandoc.lua" + + defaultMain $ testGroup "pandoc-lua-marshal" + [ roundtrips + , listTests + , listAttributeTests + , attrTests + , citationTests + , inlineTests + , blockTests + , simpleTableTests + , metavalueTests + , pandocTests + ] + +register' :: LuaError e => DocumentedFunction e -> LuaE e () +register' f = do + pushDocumentedFunction f + setglobal (functionName f) + +registerConstants :: forall a e. (Data a, LuaError e) => Proxy a -> LuaE e () +registerConstants proxy = + forM_ (constructors proxy) $ \c -> do + pushString c + setglobal (fromString c) + +constructors :: forall a. Data a => Proxy a -> [String] +constructors _ = map showConstr . dataTypeConstrs . dataTypeOf @a $ undefined + +-- +-- Roundtrips +-- + +-- | Basic tests +roundtrips :: TestTree +roundtrips = testGroup "Roundtrip through Lua stack" + [ testProperty "Alignment" $ + ioProperty . roundtripEqual pushAlignment peekAlignment + + , testProperty "Block" $ + ioProperty . roundtripEqual pushBlock peekBlockFuzzy + + , testProperty "[Block]" $ + ioProperty . roundtripEqual pushBlocks peekBlocksFuzzy + + , testProperty "Caption" $ + ioProperty . roundtripEqual pushCaption peekCaption + + , testProperty "Cell" $ + ioProperty . roundtripEqual pushCell peekCell + + , testProperty "Citation" $ + ioProperty . roundtripEqual pushCitation peekCitation + + , testProperty "CitationMode" $ + ioProperty . roundtripEqual pushCitationMode peekCitationMode + + , testProperty "Inline" $ + ioProperty . roundtripEqual pushInline peekInlineFuzzy + + , testProperty "[Inline]" $ + ioProperty . roundtripEqual pushInlines peekInlinesFuzzy + + , testProperty "ListNumberStyle" $ + ioProperty . roundtripEqual pushListNumberStyle peekListNumberStyle + + , testProperty "ListNumberDelim" $ + ioProperty . roundtripEqual pushListNumberDelim peekListNumberDelim + + , testProperty "MathType" $ + ioProperty . roundtripEqual pushMathType peekMathType + + , testProperty "Meta" $ + ioProperty . roundtripEqual pushMeta peekMeta + + , testProperty "Pandoc" $ + ioProperty . roundtripEqual pushPandoc peekPandoc + + , testProperty "Row" $ + ioProperty . roundtripEqual pushRow peekRow + + , testProperty "QuoteType" $ + ioProperty . roundtripEqual pushQuoteType peekQuoteType + + , testProperty "TableBody" $ + ioProperty . roundtripEqual pushTableBody peekTableBody + + , testProperty "TableHead" $ + ioProperty . roundtripEqual pushTableHead peekTableHead + ] + +roundtripEqual :: forall a. Eq a + => Pusher Lua.Exception a -> Peeker Lua.Exception a + -> a -> IO Bool +roundtripEqual pushX peekX x = (x ==) <$> roundtripped + where + roundtripped :: IO a + roundtripped = run $ do + openlibs + pushListModule <* pop 1 + oldSize <- gettop + pushX x + size <- gettop + when (size - oldSize /= 1) $ + Prelude.error ("Only one value should have been pushed" ++ show size) + forcePeek $ peekX top diff --git a/test/test-pandoc.lua b/test/test-pandoc.lua new file mode 100644 --- /dev/null +++ b/test/test-pandoc.lua @@ -0,0 +1,26 @@ +local tasty = require 'tasty' + +local test = tasty.test_case +local group = tasty.test_group +local assert = tasty.assert + +return { + group 'Meta' { + test('inline list is treated as MetaInlines', function () + local meta = Pandoc({}, {test = {Emph 'check'}}).meta + assert.are_same(meta.test, {Emph{Str 'check'}}) + end), + test('inline element is treated as MetaInlines singleton', function () + local meta = Pandoc({}, {test = Emph 'check'}).meta + assert.are_same(meta.test, {Emph{Str 'check'}}) + end), + test('block list is treated as MetaBlocks', function () + local meta = Pandoc({}, {test = {Plain 'check'}}).meta + assert.are_same(meta.test, {Plain{Str 'check'}}) + end), + test('block element is treated as MetaBlocks singleton', function () + local meta = Pandoc({}, {test = Plain 'check'}).meta + assert.are_same(meta.test, {Plain{Str 'check'}}) + end), + }, +}