pandoc-lua-marshal-0.1.1: test/test-pandoc-lua-marshal.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-|
Module      : Main
Copyright   : © 2017-2021 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <albert+hslua@zeitkraut.de>

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'
    forM_ blockConstructors 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"

  cellTests <- run @Lua.Exception $ do
    openlibs
    pushListModule *> setglobal "List"
    register' mkAttr
    register' mkBlocks
    register' mkCell
    register' mkListAttributes
    registerConstants (Proxy @Alignment)
    forM_ inlineConstructors register'
    forM_ blockConstructors register'
    translateResultsFromFile "test/test-cell.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
    , cellTests
    , 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