diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,22 @@ +## Changelog + +`hslua-packaging` uses [PVP Versioning](https://pvp.haskell.org). + +### hslua-packaging 2.0.0 + +Release pending. + +- Initially created. Contains modules previously found in the + modules `Foreign.Lua.Call` and `Foreign.Lua.Module` from + `hslua-1.3`. + +- Moved module hierarchy from Foreign.Lua to HsLua. + +- Added support for a "since" tag on documented functions; allows + to mark the library version when a function was introduced in + its present form. + +- Improved syntax for the creation of documented functions. + +- Documentation for functions is now stored in Lua; a method to + access it is available as a HaskellFunction. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright © 2019-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,91 @@ +# hslua-packaging + +[![Build status][GitHub Actions badge]][GitHub Actions] +[![AppVeyor Status]](https://ci.appveyor.com/project/tarleb/hslua-r2y18) +[![Hackage]](https://hackage.haskell.org/package/hslua-packaging) + +Utilities to package up Haskell functions and values into a Lua +module. + +[GitHub Actions badge]: https://img.shields.io/github/workflow/status/hslua/hslua/CI.svg?logo=github +[GitHub Actions]: https://github.com/hslua/hslua/actions +[AppVeyor Status]: https://ci.appveyor.com/api/projects/status/ldutrilgxhpcau94/branch/main?svg=true +[Hackage]: https://img.shields.io/hackage/v/hslua-packaging.svg + +This package is part of [HsLua], a Haskell framework built around +the embeddable scripting language [Lua]. + +[HsLua]: https://hslua.org/ +[Lua]: https://lua.org/ + +## Functions + +It is rarely enough to just expose Haskell functions to Lua, they +must also be documented. This library allows to combine both into +one step, as one would do in source files. + +Functions can be exposed to Lua if they follow the type + + a_0 -> a_1 -> ... -> a_n -> LuaE e b + +where each a~i~, 0 ≤ i ≤ n can be retrieved from the Lua stack. + +Let's look at an example: we want to expose the *factorial* +function, making use of Haskell's arbitrary size integers. Below +is how we would document and expose it to Lua. + +``` haskell +-- | Calculate the factorial of a number. +factorial :: DocumentedFunction Lua.Exception +factorial = defun "factorial" + ### liftPure (\n -> product [1..n]) + <#> n + =#> productOfNumbers + #? "Calculates the factorial of a positive integer." + `since` makeVersion [1,0,0] + where + n :: Parameter Lua.Exception Integer + n = parameter peekIntegral "integer" + "n" + "number for which the factorial is computed" + + productOfNumbers :: FunctionResults Lua.Exception Integer + productOfNumbers = + functionResult pushIntegral "integer" + "produce of all numbers from 1 upto n" +``` + +This produces a value which can be pushed to Lua as a function + +``` haskell +pushDocumentedFunction factorial +setglobal "factorial" +``` + +and can then be called from Lua + +``` lua +> factorial(4) +24 +> factorial(23) +"25852016738884976640000" +``` + +The documentation can be rendered as Markdown with `renderFunction`: + +``` +factorial (n) + +Calculates the factorial of a positive integer. + +*Since: 1.0.0* + +Parameters: + +n +: number for which the factorial is computed (integer) + +Returns: + + - product of all integers from 1 upto n (integer) +``` diff --git a/hslua-packaging.cabal b/hslua-packaging.cabal new file mode 100644 --- /dev/null +++ b/hslua-packaging.cabal @@ -0,0 +1,86 @@ +cabal-version: 2.2 +name: hslua-packaging +version: 2.0.0 +synopsis: Utilities to build Lua modules. +description: Utilities to package up Haskell functions and + values into a Lua module. + . + This package is part of HsLua, a Haskell framework + built around the embeddable scripting language + . +homepage: https://hslua.org/ +bug-reports: https://github.com/hslua/hslua/issues +license: MIT +license-file: LICENSE +author: Albert Krewinkel +maintainer: albert+hslua@zeitkraut.de +copyright: © 2019-2021 Albert Krewinkel +category: Foreign +extra-source-files: README.md + , CHANGELOG.md +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.3 + , GHC == 9.0.1 + +source-repository head + type: git + location: https://github.com/hslua/hslua.git + subdir: hslua-packaging + +common common-options + default-language: Haskell2010 + build-depends: base >= 4.8 && < 5 + , hslua-core >= 2.0 && < 2.1 + , hslua-marshalling >= 2.0 && < 2.1 + , hslua-objectorientation >= 2.0 && < 2.1 + , mtl >= 2.2 && < 2.3 + , text >= 1.0 && < 1.3 + ghc-options: -Wall + -Wincomplete-record-updates + -Wnoncanonical-monad-instances + -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -Wcpp-undef + -Werror=missing-home-modules + if impl(ghc >= 8.4) + ghc-options: -Widentities + -Wincomplete-uni-patterns + -Wpartial-fields + -fhide-source-paths + +library + import: common-options + exposed-modules: HsLua.Packaging + , HsLua.Packaging.Function + , HsLua.Packaging.Module + , HsLua.Packaging.Rendering + , HsLua.Packaging.Types + , HsLua.Packaging.UDType + hs-source-dirs: src + default-extensions: LambdaCase + other-extensions: DeriveFunctor + , OverloadedStrings + build-depends: containers >= 0.5.9 && < 0.7 + +test-suite test-hslua-packaging + import: common-options + type: exitcode-stdio-1.0 + main-is: test-hslua-packaging.hs + hs-source-dirs: test + ghc-options: -threaded + other-modules: HsLua.PackagingTests + , HsLua.Packaging.FunctionTests + , HsLua.Packaging.ModuleTests + , HsLua.Packaging.RenderingTests + , HsLua.Packaging.UDTypeTests + build-depends: hslua-packaging + , bytestring + , tasty-hslua + , tasty >= 0.11 + , tasty-hunit >= 0.9 + other-extensions: OverloadedStrings + , TypeApplications diff --git a/src/HsLua/Packaging.hs b/src/HsLua/Packaging.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Packaging.hs @@ -0,0 +1,25 @@ +{-| +Module : HsLua.Packaging +Copyright : © 2019-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Tools to create Lua modules. +-} +module HsLua.Packaging + ( -- * Modules + module HsLua.Packaging.Module + , module HsLua.Packaging.Function + -- * Object oriented marshalling + , module HsLua.Packaging.UDType + -- * Create documentation + , module HsLua.Packaging.Rendering + -- * Types + , module HsLua.Packaging.Types + ) where + +import HsLua.Packaging.Function +import HsLua.Packaging.Module +import HsLua.Packaging.Rendering +import HsLua.Packaging.UDType +import HsLua.Packaging.Types diff --git a/src/HsLua/Packaging/Function.hs b/src/HsLua/Packaging/Function.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Packaging/Function.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.Packaging.Function +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : alpha +Portability : Portable + +Marshaling and documenting Haskell functions. +-} +module HsLua.Packaging.Function + ( DocumentedFunction (..) + -- * Creating documented functions + , defun + , lambda + , applyParameter + , returnResult + , returnResultsOnStack + , liftPure + , liftPure2 + , liftPure3 + , liftPure4 + , liftPure5 + -- ** Types + , Parameter (..) + , FunctionResult (..) + , FunctionResults + -- ** Operators + , (###) + , (<#>) + , (=#>) + , (=?>) + , (#?) + -- * Modifying functions + , setName + , since + -- * Pushing to Lua + , pushDocumentedFunction + -- * Accessing documentation in Lua + , docsField + , pushDocumentation + -- * Convenience functions + , parameter + , optionalParameter + , functionResult + -- * Internal + , toHsFnPrecursor + ) where + +import Control.Applicative ((<|>)) +import Control.Monad.Except +import Data.Text (Text) +import Data.Version (Version) +import HsLua.Core +import HsLua.Marshalling +import HsLua.Packaging.Rendering (renderFunction) +import HsLua.Packaging.Types +import qualified HsLua.Core as Lua +import qualified HsLua.Core.Utf8 as Utf8 + +#if !MIN_VERSION_base(4,12,0) +import Data.Semigroup (Semigroup ((<>))) +#endif + +-- +-- Haskell function building +-- + +-- | Helper type used to create 'HaskellFunction's. +data HsFnPrecursor e a = HsFnPrecursor + { hsFnPrecursorAction :: Peek e a + , hsFnMaxParameterIdx :: StackIndex + , hsFnParameterDocs :: [ParameterDoc] + , hsFnName :: Name + } + deriving (Functor) + +-- | Result of a call to a Haskell function. +data FunctionResult e a + = FunctionResult + { fnResultPusher :: Pusher e a + , fnResultDoc :: ResultValueDoc + } + +-- | List of function results in the order in which they are +-- returned in Lua. +type FunctionResults e a = [FunctionResult e a] + +-- | Function parameter. +data Parameter e a = Parameter + { parameterPeeker :: Peeker e a + , parameterDoc :: ParameterDoc + } + + +-- | Begin wrapping a monadic Lua function such that it can be turned +-- into a documented function exposable to Lua. +defun :: Name -> a -> HsFnPrecursor e a +defun = toHsFnPrecursor (StackIndex 0) + +-- | Just like @defun@, but uses an empty name for the documented +-- function. Should be used when defining methods or operators. +lambda :: a -> HsFnPrecursor e a +lambda = defun (Name mempty) + +-- | Turns a pure function into a monadic Lua function. +-- +-- The resulting function is strict. +liftPure :: (a -> b) + -> (a -> LuaE e b) +liftPure f !a = return $! f a + +-- | Turns a binary function into a Lua function. +-- +-- The resulting function is strict in both its arguments. +liftPure2 :: (a -> b -> c) + -> (a -> b -> LuaE e c) +liftPure2 f !a !b = return $! f a b + +-- | Turns a ternary function into a Lua function. +-- +-- The resulting function is strict in all of its arguments. +liftPure3 :: (a -> b -> c -> d) + -> (a -> b -> c -> LuaE e d) +liftPure3 f !a !b !c = return $! f a b c + +-- | Turns a quarternary function into a Lua function. +-- +-- The resulting function is strict in all of its arguments. +liftPure4 :: (a -> b -> c -> d -> e) + -> (a -> b -> c -> d -> LuaE err e) +liftPure4 f !a !b !c !d = return $! f a b c d + +-- | Turns a quinary function into a Lua function. +-- +-- The resulting function is strict in all of its arguments. +liftPure5 :: (a -> b -> c -> d -> e -> f) + -> (a -> b -> c -> d -> e -> LuaE err f) +liftPure5 f !a !b !c !d !e = return $! f a b c d e + +-- | Create a HaskellFunction precursor from a monadic function, +-- selecting the stack index after which the first function parameter +-- will be placed. +toHsFnPrecursor :: StackIndex -> Name -> a -> HsFnPrecursor e a +toHsFnPrecursor idx name f = HsFnPrecursor + { hsFnPrecursorAction = return f + , hsFnMaxParameterIdx = idx + , hsFnParameterDocs = mempty + , hsFnName = name + } + +-- | Partially apply a parameter. +applyParameter :: HsFnPrecursor e (a -> b) + -> Parameter e a + -> HsFnPrecursor e b +applyParameter bldr param = do + let action = hsFnPrecursorAction bldr + let i = hsFnMaxParameterIdx bldr + 1 + let context = Name . Utf8.fromText $ "function argument " <> + (parameterName . parameterDoc) param + let nextAction f = withContext context $ do + !x <- parameterPeeker param i + return $ f x + bldr + { hsFnPrecursorAction = action >>= nextAction + , hsFnMaxParameterIdx = i + , hsFnParameterDocs = parameterDoc param : hsFnParameterDocs bldr + } + +-- | Take a 'HaskellFunction' precursor and convert it into a full +-- 'HaskellFunction', using the given 'FunctionResult's to return +-- the result to Lua. +returnResults :: HsFnPrecursor e (LuaE e a) + -> FunctionResults e a + -> DocumentedFunction e +returnResults bldr fnResults = DocumentedFunction + { callFunction = do + hsResult <- runPeek + . retrieving ("arguments for function " <> hsFnName bldr) + $ hsFnPrecursorAction bldr + case resultToEither hsResult of + Left err -> do + pushString err + Lua.error + Right x -> do + result <- x + forM_ fnResults $ \(FunctionResult push _) -> push result + return $! NumResults (fromIntegral $ length fnResults) + , functionName = hsFnName bldr + , functionDoc = FunctionDoc + { functionDescription = "" + , parameterDocs = reverse $ hsFnParameterDocs bldr + , functionResultsDocs = ResultsDocList $ map fnResultDoc fnResults + , functionSince = Nothing + } + } + +-- | Take a 'HaskellFunction' precursor and convert it into a full +-- 'HaskellFunction', using the given 'FunctionResult's to return +-- the result to Lua. +returnResultsOnStack :: HsFnPrecursor e (LuaE e NumResults) + -> Text + -> DocumentedFunction e +returnResultsOnStack bldr desc = DocumentedFunction + { callFunction = do + hsResult <- runPeek + . retrieving ("arguments for function " <> hsFnName bldr) + $ hsFnPrecursorAction bldr + case resultToEither hsResult of + Left err -> do + pushString err + Lua.error + Right x -> x + , functionName = hsFnName bldr + , functionDoc = FunctionDoc + { functionDescription = "" + , parameterDocs = reverse $ hsFnParameterDocs bldr + , functionResultsDocs = ResultsDocMult desc + , functionSince = Nothing + } + } + +-- | Like @'returnResult'@, but returns only a single result. +returnResult :: HsFnPrecursor e (LuaE e a) + -> FunctionResult e a + -> DocumentedFunction e +returnResult bldr = returnResults bldr . (:[]) + +-- | Updates the description of a Haskell function. Leaves the function +-- unchanged if it has no documentation. +updateFunctionDescription :: DocumentedFunction e + -> Text + -> DocumentedFunction e +updateFunctionDescription fn desc = + let fnDoc = functionDoc fn + in fn { functionDoc = fnDoc { functionDescription = desc} } + +-- | Renames a documented function. +setName :: Name -> DocumentedFunction e -> DocumentedFunction e +setName name fn = fn { functionName = name } + +-- | Sets the library version at which the function was introduced in its +-- current form. +since :: DocumentedFunction e -> Version -> DocumentedFunction e +since fn version = + let fnDoc = functionDoc fn + in fn { functionDoc = fnDoc { functionSince = Just version }} + +-- +-- Operators +-- + +infixl 8 ###, <#>, =#>, =?>, #?, `since` + +-- | Like '($)', but left associative. +(###) :: (a -> HsFnPrecursor e a) -> a -> HsFnPrecursor e a +(###) = ($) + +-- | Inline version of @'applyParameter'@. +(<#>) :: HsFnPrecursor e (a -> b) + -> Parameter e a + -> HsFnPrecursor e b +(<#>) = applyParameter + +-- | Inline version of @'returnResults'@. +(=#>) :: HsFnPrecursor e (LuaE e a) + -> FunctionResults e a + -> DocumentedFunction e +(=#>) = returnResults + +-- | Return a flexible number of results that have been pushed by the +-- function action. +(=?>) :: HsFnPrecursor e (LuaE e NumResults) + -> Text + -> DocumentedFunction e +(=?>) = returnResultsOnStack + +-- | Inline version of @'updateFunctionDescription'@. +(#?) :: DocumentedFunction e -> Text -> DocumentedFunction e +(#?) = updateFunctionDescription + +-- +-- Push to Lua +-- + +-- | Name of the registry field holding the documentation table. The +-- documentation table is indexed by the documented objects, like module +-- tables and functions, and contains documentation strings as values. +-- +-- The table is an ephemeron table, i.e., an entry gets garbage +-- collected if the key is no longer reachable. +docsField :: Name +docsField = "HsLua docs" + +-- | Pushes a documented Haskell function to the Lua stack, making it +-- usable as a normal function in Lua. At the same time, the function +-- docs are registered in the documentation table. +pushDocumentedFunction :: LuaError e + => DocumentedFunction e -> LuaE e () +pushDocumentedFunction fn = do + -- push function + Lua.pushHaskellFunction $ callFunction fn + + -- store documentation + Lua.getfield registryindex docsField >>= \case + TypeTable -> return () -- already have the documentation table + _ -> do + Lua.pop 1 -- pop non-table value + Lua.newtable -- create documentation table + Lua.pushstring "k" -- Make it an "ephemeron table" and.. + Lua.setfield (nth 2) "__mode" -- collect docs if function is GCed + Lua.pushvalue top -- add copy of table to registry + Lua.setfield registryindex docsField + Lua.pushvalue (nth 2) -- the function + pushText $ renderFunction fn + Lua.rawset (nth 3) + Lua.pop 1 -- pop doc table, leave function on stack + +-- | Pushes the documentation of the object at the given index to the +-- stack, or just *nil* if no documentation is available. +pushDocumentation :: LuaError e => StackIndex -> LuaE e NumResults +pushDocumentation idx = do + idx' <- Lua.absindex idx + Lua.getfield registryindex docsField >>= \case + TypeTable -> do + Lua.pushvalue idx' + Lua.rawget (nth 2) + _ -> do -- no documentation table available + Lua.pop 1 -- pop contents of docsField + Lua.pushnil + return (NumResults 1) + +-- +-- Convenience functions +-- + +-- | Creates a parameter. +parameter :: Peeker e a -- ^ method to retrieve value from Lua + -> Text -- ^ expected Lua type + -> Text -- ^ parameter name + -> Text -- ^ parameter description + -> Parameter e a +parameter peeker type_ name desc = Parameter + { parameterPeeker = peeker + , parameterDoc = ParameterDoc + { parameterName = name + , parameterDescription = desc + , parameterType = type_ + , parameterIsOptional = False + } + } + +-- | Creates an optional parameter. +optionalParameter :: Peeker e a -- ^ method to retrieve the value from Lua + -> Text -- ^ expected Lua type + -> Text -- ^ parameter name + -> Text -- ^ parameter description + -> Parameter e (Maybe a) +optionalParameter peeker type_ name desc = Parameter + { parameterPeeker = \idx -> (Nothing <$ peekNoneOrNil idx) + <|> (Just <$!> peeker idx) + , parameterDoc = ParameterDoc + { parameterName = name + , parameterDescription = desc + , parameterType = type_ + , parameterIsOptional = True + } + } + +-- | Creates a function result. +functionResult :: Pusher e a -- ^ method to push the Haskell result to Lua + -> Text -- ^ Lua type of result + -> Text -- ^ result description + -> FunctionResults e a +functionResult pusher type_ desc = (:[]) $ FunctionResult + { fnResultPusher = pusher + , fnResultDoc = ResultValueDoc + { resultValueType = type_ + , resultValueDescription = desc + } + } diff --git a/src/HsLua/Packaging/Module.hs b/src/HsLua/Packaging/Module.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Packaging/Module.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.Packaging.Module +Copyright : © 2019-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : alpha +Portability : Requires GHC 8 or later. + +Utility functions for HsLua modules. +-} +module HsLua.Packaging.Module + ( -- * Documented module + Module (..) + , Field (..) + , registerModule + , preloadModule + , preloadModuleWithName + , pushModule + , Operation (..) + ) +where + +import Control.Monad (forM_) +import HsLua.Core +import HsLua.Marshalling (pushName, pushText) +import HsLua.ObjectOrientation.Operation (Operation (..), metamethodName) +import HsLua.Packaging.Types +import qualified HsLua.Packaging.Function as Call + +-- | Create a new module (i.e., a Lua table). +create :: LuaE e () +create = newtable + +-- | Registers a 'Module'; leaves a copy of the module table on +-- the stack. +registerModule :: LuaError e => Module e -> LuaE e () +registerModule mdl = + requirehs (moduleName mdl) (pushModule mdl) + +-- | Add the module under a different name to the table of preloaded +-- packages. +preloadModuleWithName :: LuaError e => Module e -> Name -> LuaE e () +preloadModuleWithName documentedModule name = preloadModule $ + documentedModule { moduleName = name } + +-- | Preload self-documenting module using the module's default name. +preloadModule :: LuaError e => Module e -> LuaE e () +preloadModule mdl = + preloadhs (moduleName mdl) $ do + pushModule mdl + return (NumResults 1) + +-- | Pushes a documented module to the Lua stack. +pushModule :: LuaError e => Module e -> LuaE e () +pushModule mdl = do + create + forM_ (moduleFunctions mdl) $ \fn -> do + pushName (functionName fn) + Call.pushDocumentedFunction fn + rawset (nth 3) + forM_ (moduleFields mdl) $ \field -> do + pushText (fieldName field) + fieldPushValue field + rawset (nth 3) + case moduleOperations mdl of + [] -> pure () + ops -> do + -- create a metatable for this module and add operations + newtable + forM_ ops $ \(op, fn) -> do + pushName $ metamethodName op + Call.pushDocumentedFunction $ Call.setName "" fn + rawset (nth 3) + setmetatable (nth 2) diff --git a/src/HsLua/Packaging/Rendering.hs b/src/HsLua/Packaging/Rendering.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Packaging/Rendering.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.Packaging.Rendering +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : alpha +Portability : Portable + +Render function and module documentation. +-} +module HsLua.Packaging.Rendering + ( -- * Documentation + render + , renderModule + , renderFunction + ) where + +import Data.Text (Text) +import Data.Version (showVersion) +import HsLua.Core +import HsLua.Packaging.Types +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified HsLua.Core.Utf8 as Utf8 + +#if !MIN_VERSION_base(4,12,0) +import Data.Semigroup (Semigroup ((<>))) +#endif + +-- +-- Module documentation +-- + +-- | Alias for 'renderModule'. +render :: Module e -> Text +render = renderModule + +-- | Renders module documentation as Markdown. +renderModule :: Module e -> Text +renderModule mdl = + let fields = moduleFields mdl + in T.unlines + [ "# " <> T.decodeUtf8 (fromName $ moduleName mdl) + , "" + , moduleDescription mdl + , renderFields fields + , renderFunctions (moduleFunctions mdl) + ] + +-- | Renders the full function documentation section. +renderFunctions :: [DocumentedFunction e] -> Text +renderFunctions = \case + [] -> mempty + fs -> "\n## Functions\n\n" + <> T.intercalate "\n\n" (map (("### " <>) . renderFunction) fs) + +-- | Renders documentation of a function. +renderFunction :: DocumentedFunction e -- ^ function + -> Text -- ^ function docs +renderFunction fn = + let fnDoc = functionDoc fn + fnName = Utf8.toText $ fromName (functionName fn) + name = if T.null fnName + then "" + else fnName + in T.intercalate "\n" + [ name <> " (" <> renderFunctionParams fnDoc <> ")" + , "" + , renderFunctionDoc fnDoc + ] + +-- | Renders the parameter names of a function, separated by commas. +renderFunctionParams :: FunctionDoc -> Text +renderFunctionParams fd = + T.intercalate ", " + . map parameterName + $ parameterDocs fd + +-- | Render documentation for fields as Markdown. +renderFields :: [Field e] -> Text +renderFields fs = + if null fs + then mempty + else mconcat + [ "\n" + , T.intercalate "\n\n" (map (("### " <>) . renderField) fs) + ] + +-- | Renders documentation for a single field. +renderField :: Field e -> Text +renderField f = fieldName f <> "\n\n" <> fieldDescription f + +-- +-- Function documentation +-- + +-- | Renders the documentation of a function as Markdown. +renderFunctionDoc :: FunctionDoc -> Text +renderFunctionDoc (FunctionDoc desc paramDocs resultDoc mVersion) = + let sinceTag = case mVersion of + Nothing -> mempty + Just version -> T.pack $ "\n\n*Since: " <> showVersion version <> "*" + in (if T.null desc + then "" + else desc <> sinceTag <> "\n\n") <> + renderParamDocs paramDocs <> + renderResultsDoc resultDoc + +-- | Renders function parameter documentation as a Markdown blocks. +renderParamDocs :: [ParameterDoc] -> Text +renderParamDocs pds = "Parameters:\n\n" <> + T.intercalate "\n" (map renderParamDoc pds) + +-- | Renders the documentation of a function parameter as a Markdown +-- line. +renderParamDoc :: ParameterDoc -> Text +renderParamDoc pd = mconcat + [ parameterName pd + , "\n: " + , parameterDescription pd + , " (", parameterType pd, ")\n" + ] + +-- | Renders the documentation of a function result as a Markdown list +-- item. +renderResultsDoc :: ResultsDoc -> Text +renderResultsDoc = \case + ResultsDocList [] -> mempty + ResultsDocList rds -> + "\nReturns:\n\n" <> T.intercalate "\n" (map renderResultValueDoc rds) + ResultsDocMult txt -> " - " <> indent 4 txt + +-- | Renders the documentation of a function result as a Markdown list +-- item. +renderResultValueDoc :: ResultValueDoc -> Text +renderResultValueDoc rd = mconcat + [ " - " + , resultValueDescription rd + , " (", resultValueType rd, ")" + ] + +indent :: Int -> Text -> Text +indent n = T.replace "\n" (T.replicate n " ") diff --git a/src/HsLua/Packaging/Types.hs b/src/HsLua/Packaging/Types.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Packaging/Types.hs @@ -0,0 +1,91 @@ +{-| +Module : HsLua.Packaging.Types +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : alpha +Portability : Portable + +Marshaling and documenting Haskell functions. +-} +module HsLua.Packaging.Types + ( -- * Documented module + Module (..) + , Field (..) + -- * Documented functions + , DocumentedFunction (..) + -- ** Documentation types + , FunctionDoc (..) + , ParameterDoc (..) + , ResultsDoc (..) + , ResultValueDoc (..) + ) where + +import Data.Text (Text) +import Data.Version (Version) +import HsLua.Core (LuaE, Name, NumResults) +import HsLua.ObjectOrientation (Operation) + +-- | Named and documented Lua module. +data Module e = Module + { moduleName :: Name + , moduleDescription :: Text + , moduleFields :: [Field e] + , moduleFunctions :: [DocumentedFunction e] + , moduleOperations :: [(Operation, DocumentedFunction e)] + } + +-- | Self-documenting module field +data Field e = Field + { fieldName :: Text + , fieldDescription :: Text + , fieldPushValue :: LuaE e () + } + +-- +-- Function components +-- + +-- | Haskell equivallent to CFunction, i.e., function callable +-- from Lua. +data DocumentedFunction e = DocumentedFunction + { callFunction :: LuaE e NumResults + , functionName :: Name + , functionDoc :: FunctionDoc + } + +-- +-- Documentation types +-- + +-- | Documentation for a Haskell function +data FunctionDoc = FunctionDoc + { functionDescription :: Text + , parameterDocs :: [ParameterDoc] + , functionResultsDocs :: ResultsDoc + , functionSince :: Maybe Version -- ^ Version in which the function + -- was introduced. + } + deriving (Eq, Ord, Show) + +-- | Documentation for function parameters. +data ParameterDoc = ParameterDoc + { parameterName :: Text + , parameterType :: Text + , parameterDescription :: Text + , parameterIsOptional :: Bool + } + deriving (Eq, Ord, Show) + +-- | Documentation for the return values of a function. +data ResultsDoc + = ResultsDocList [ResultValueDoc] -- ^ List of individual results + | ResultsDocMult Text -- ^ Flexible results + deriving (Eq, Ord, Show) + +-- | Documentation for a single return value of a function. +data ResultValueDoc = ResultValueDoc + { resultValueType :: Text + , resultValueDescription :: Text + } + deriving (Eq, Ord, Show) diff --git a/src/HsLua/Packaging/UDType.hs b/src/HsLua/Packaging/UDType.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Packaging/UDType.hs @@ -0,0 +1,89 @@ +{-| +Module : HsLua.Packaging.UDType +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +This module provides types and functions to use Haskell values as +userdata objects in Lua. These objects wrap a Haskell value and provide +methods and properties to interact with the Haskell value. + +The terminology in this module refers to the userdata values as /UD +objects/, and to their type as /UD type/. +-} +module HsLua.Packaging.UDType + ( DocumentedType + , DocumentedTypeWithList + , deftype + , deftype' + , method + , property + , possibleProperty + , readonly + , alias + , operation + , peekUD + , pushUD + , udparam + -- * Helper types for building + , Member + , Operation (..) + , Property + , Possible (..) + ) where + +import Data.Text (Text) +import HsLua.Core +import HsLua.ObjectOrientation +import HsLua.ObjectOrientation.Operation (metamethodName) +import HsLua.Packaging.Function +import qualified HsLua.Core.Utf8 as Utf8 + +-- | Type definitions containing documented functions. +type DocumentedType e a = UDType e (DocumentedFunction e) a + +-- | A userdata type, capturing the behavior of Lua objects that wrap +-- Haskell values. The type name must be unique; once the type has been +-- used to push or retrieve a value, the behavior can no longer be +-- modified through this type. +type DocumentedTypeWithList e a itemtype = + UDTypeWithList e (DocumentedFunction e) a itemtype + +-- | Defines a new type, defining the behavior of objects in Lua. +-- Note that the type name must be unique. +deftype :: LuaError e + => Name -- ^ type name + -> [(Operation, DocumentedFunction e)] -- ^ operations + -> [Member e (DocumentedFunction e) a] -- ^ methods + -> DocumentedType e a +deftype = deftypeGeneric pushDocumentedFunction + +-- | Defines a new type that could also be treated as a list; defines +-- the behavior of objects in Lua. Note that the type name must be +-- unique. +deftype' :: LuaError e + => Name -- ^ type name + -> [(Operation, DocumentedFunction e)] -- ^ operations + -> [Member e (DocumentedFunction e) a] -- ^ methods + -> Maybe (ListSpec e a itemtype) -- ^ list access + -> DocumentedTypeWithList e a itemtype +deftype' = deftypeGeneric' pushDocumentedFunction + +-- | Use a documented function as an object method. +method :: DocumentedFunction e + -> Member e (DocumentedFunction e) a +method f = methodGeneric (functionName f) f + +-- | Declares a new object operation from a documented function. +operation :: Operation -- ^ the kind of operation + -> DocumentedFunction e -- ^ function used to perform the operation + -> (Operation, DocumentedFunction e) +operation op f = (,) op $ setName (metamethodName op) f + +-- | Defines a function parameter that takes the given type. +udparam :: LuaError e + => DocumentedTypeWithList e a itemtype -- ^ expected type + -> Text -- ^ parameter name + -> Text -- ^ parameter description + -> Parameter e a +udparam ty = parameter (peekUD ty) (Utf8.toText . fromName $ udName ty) diff --git a/test/HsLua/Packaging/FunctionTests.hs b/test/HsLua/Packaging/FunctionTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Packaging/FunctionTests.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Packaging.FunctionTests +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Tests for calling exposed Haskell functions. +-} +module HsLua.Packaging.FunctionTests (tests) where + +import Data.Maybe (fromMaybe) +import Data.Version (makeVersion) +import HsLua.Core (StackIndex, top) +import HsLua.Packaging.Function +import HsLua.Packaging.Types +import HsLua.Marshalling + ( forcePeek, peekIntegral, peekRealFloat, peekText + , pushIntegral, pushRealFloat) +import Test.Tasty.HsLua ((=:), shouldBeResultOf, shouldHoldForResultOf) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@=?)) + +import qualified Data.Text as T +import qualified HsLua.Core as Lua + +-- | Calling Haskell functions from Lua. +tests :: TestTree +tests = testGroup "Call" + [ testGroup "push Haskell function" + [ "DocumentedFunction building" =: + 720 + `shouldBeResultOf` do + factLua <- factLuaAtIndex <$> Lua.gettop + Lua.pushinteger 6 + _ <- callFunction factLua + forcePeek $ peekIntegral @Integer Lua.top + + , "error message" =: + mconcat [ "Integral expected, got boolean\n" + , "\twhile retrieving function argument n\n" + , "\twhile retrieving arguments for function factorial"] + `shouldBeResultOf` do + factLua <- factLuaAtIndex <$> Lua.gettop + Lua.pushboolean True + _ <- callFunction factLua + forcePeek $ peekText Lua.top + ] + , testGroup "use as C function" + [ "push factorial" =: + Lua.TypeFunction + `shouldBeResultOf` do + pushDocumentedFunction $ factLuaAtIndex 0 + Lua.ltype Lua.top + , "call factorial" =: + 120 + `shouldBeResultOf` do + pushDocumentedFunction $ factLuaAtIndex 0 + Lua.pushinteger 5 + Lua.call 1 1 + forcePeek $ peekIntegral @Integer Lua.top + , "use from Lua" =: + 24 + `shouldBeResultOf` do + pushDocumentedFunction $ factLuaAtIndex 0 + Lua.setglobal "factorial" + Lua.loadstring "return factorial(4)" *> Lua.call 0 1 + forcePeek $ peekIntegral @Integer Lua.top + + , "with setting an optional param" =: + 8 + `shouldBeResultOf` do + pushDocumentedFunction nroot + Lua.setglobal "nroot" + Lua.loadstring "return nroot(64)" *> Lua.call 0 1 + forcePeek $ peekRealFloat @Double Lua.top + , "with setting an optional param" =: + 2 + `shouldBeResultOf` do + pushDocumentedFunction nroot + Lua.setglobal "nroot" + Lua.loadstring "return nroot(64, 6)" *> Lua.call 0 1 + forcePeek $ peekRealFloat @Double Lua.top + ] + + , testGroup "documentation access" + [ "pushDocumentation" =: + ("factorial (n)\n" `T.isPrefixOf`) `shouldHoldForResultOf` do + pushDocumentedFunction (factLuaAtIndex 0) + numres <- pushDocumentation top + Lua.liftIO $ numres @=? Lua.NumResults 1 + forcePeek $ peekText top + + , "undocumented value" =: + Lua.TypeNil `shouldBeResultOf` do + Lua.pushboolean True + numres <- pushDocumentation top + Lua.liftIO $ numres @=? Lua.NumResults 1 + Lua.ltype top + ] + + , testGroup "helpers" + [ "parameter doc" =: + ( ParameterDoc + { parameterName = "test" + , parameterDescription = "test param" + , parameterType = "string" + , parameterIsOptional = False + } + @=? + parameterDoc + (parameter @Lua.Exception peekText "string" "test" "test param") + ) + , "optionalParameter doc" =: + ( ParameterDoc + { parameterName = "test" + , parameterDescription = "test param" + , parameterType = "string" + , parameterIsOptional = True + } + @=? + parameterDoc + (optionalParameter @Lua.Exception peekText "string" "test" "test param") + ) + , "functionResult doc" =: + ( [ ResultValueDoc + { resultValueDescription = "int result" + , resultValueType = "integer" + } + ] + @=? + fnResultDoc <$> + functionResult (pushIntegral @Int) "integer" "int result" + ) + ] + ] + +factLuaAtIndex :: StackIndex -> DocumentedFunction Lua.Exception +factLuaAtIndex idx = + toHsFnPrecursor idx "factorial" (liftPure factorial) + <#> factorialParam + =#> factorialResult + #? "Calculates the factorial of a positive integer." + `since` makeVersion [1,0,0] + +-- | Calculate the factorial of a number. +factorial :: Integer -> Integer +factorial n = product [1..n] + +factorialParam :: Parameter Lua.Exception Integer +factorialParam = Parameter + { parameterDoc = ParameterDoc + { parameterName = "n" + , parameterType = "integer" + , parameterDescription = "number for which the factorial is computed" + , parameterIsOptional = False + } + , parameterPeeker = peekIntegral @Integer + } + +factorialResult :: FunctionResults Lua.Exception Integer +factorialResult = (:[]) $ FunctionResult + (pushIntegral @Integer) + (ResultValueDoc "integer" "factorial") + +-- | Calculate the nth root of a number. Defaults to square root. +nroot :: DocumentedFunction Lua.Exception +nroot = defun "nroot" + ### liftPure2 nroot' + <#> parameter (peekRealFloat @Double) "number" "x" "" + <#> optionalParameter (peekIntegral @Int) "integer" "n" "" + =#> functionResult pushRealFloat "number" "nth root" + where + nroot' :: Double -> Maybe Int -> Double + nroot' x nOpt = + let n = fromMaybe 2 nOpt + in x ** (1 / fromIntegral n) diff --git a/test/HsLua/Packaging/ModuleTests.hs b/test/HsLua/Packaging/ModuleTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Packaging/ModuleTests.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Packaging.ModuleTests +Copyright : © 2019-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : alpha +Portability : Requires GHC 8 or later. + +Tests creating and loading of modules with Haskell. +-} +module HsLua.Packaging.ModuleTests (tests) where + +import HsLua.Marshalling + (Result (Success), peekIntegral, peekString, pushIntegral, pushText, runPeek) +import HsLua.Packaging.Function +import HsLua.Packaging.Module +import Test.Tasty.HsLua ((=:), pushLuaExpr, shouldBeResultOf) +import Test.Tasty (TestTree, testGroup) + +import qualified HsLua.Core as Lua + +-- | Specifications for Attributes parsing functions. +tests :: TestTree +tests = testGroup "Module" + [ testGroup "requirehs" + [ "pushes module to stack" =: + 1 `shouldBeResultOf` do + Lua.openlibs + old <- Lua.gettop + Lua.requirehs "foo" (Lua.pushnumber 5.0) + new <- Lua.gettop + return (new - old) + + , "module can be loaded with `require`" =: + let testModule = "string as a module" + in Just testModule `shouldBeResultOf` do + Lua.openlibs + Lua.requirehs "test.module" (Lua.pushstring testModule) + pushLuaExpr "require 'test.module'" + Lua.tostring Lua.top + ] + + , testGroup "preloadhs" + [ "does not modify the stack" =: + 0 `shouldBeResultOf` do + Lua.openlibs + old <- Lua.gettop + Lua.preloadhs "foo" (1 <$ Lua.pushnumber 5.0) + new <- Lua.gettop + return (new - old) + + , "module can be loaded with `require`" =: + let testModule = "string as a module" + in Just testModule `shouldBeResultOf` do + Lua.openlibs + Lua.preloadhs "test.module" (1 <$ Lua.pushstring testModule) + pushLuaExpr "require 'test.module'" + Lua.tostring Lua.top + ] + + , testGroup "creation helpers" + [ "create produces a table" =: + Lua.TypeTable `shouldBeResultOf` do + Lua.newtable + Lua.ltype Lua.top + ] + , testGroup "module type" + [ "register module" =: + 1 `shouldBeResultOf` do + Lua.openlibs + old <- Lua.gettop + registerModule mymath + new <- Lua.gettop + return (new - old) + + , "call module function" =: + Success 24 `shouldBeResultOf` do + Lua.openlibs + registerModule mymath + _ <- Lua.dostring $ mconcat + [ "local mymath = require 'mymath'\n" + , "return mymath.factorial(4)" + ] + runPeek $ peekIntegral @Integer Lua.top + + , "call module as function" =: + Success "call me maybe" `shouldBeResultOf` do + Lua.openlibs + registerModule mymath + _ <- Lua.dostring "return (require 'mymath')()" + runPeek $ peekString Lua.top + + ] + ] + +mymath :: Module Lua.Exception +mymath = Module + { moduleName = "mymath" + , moduleDescription = "A math module." + , moduleFields = [] + , moduleFunctions = [factorial] + , moduleOperations = + [ (,) Call $ lambda + ### (1 <$ pushText "call me maybe") + =?> "call result" + ] + } + +factorial :: DocumentedFunction Lua.Exception +factorial = + defun "factorial" + ### liftPure (\n -> product [1..n]) + <#> factorialParam + =#> factorialResult + +factorialParam :: Parameter Lua.Exception Integer +factorialParam = + parameter (peekIntegral @Integer) "integer" + "n" + "number for which the factorial is computed" + +factorialResult :: FunctionResults Lua.Exception Integer +factorialResult = + functionResult (pushIntegral @Integer) "integer" "factorial" diff --git a/test/HsLua/Packaging/RenderingTests.hs b/test/HsLua/Packaging/RenderingTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Packaging/RenderingTests.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Packaging.RenderingTests +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Tests for calling exposed Haskell functions. +-} +module HsLua.Packaging.RenderingTests (tests) where + +import Data.Maybe (fromMaybe) +import Data.Version (makeVersion) +import HsLua.Packaging.Function +import HsLua.Packaging.Module +import HsLua.Packaging.Rendering +import HsLua.Marshalling + (peekIntegral, peekRealFloat, pushIntegral, pushRealFloat) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@=?), testCase) + +import qualified Data.Text as T +import qualified HsLua.Core as Lua + +-- | Calling Haskell functions from Lua. +tests :: TestTree +tests = testGroup "Rendering" $ + let factorialDocs = T.intercalate "\n" + [ "factorial (n)" + , "" + , "Calculates the factorial of a positive integer." + , "" + , "*Since: 1.0.0*" + , "" + , "Parameters:" + , "" + , "n" + , ": number for which the factorial is computed (integer)" + , "" + , "Returns:" + , "" + , " - factorial (integer)" + ] + nrootDocs = T.intercalate "\n" + [ "nroot (x, n)" + , "" + , "Parameters:" + , "" + , "x" + , ": (number)" + , "" + , "n" + , ": (integer)" + , "" + , "Returns:" + , "" + , " - nth root (number)" + ] + eulerDocs = T.intercalate "\n" + [ "euler_mascheroni" + , "" + , "Euler-Mascheroni constant" + ] + in + [ testGroup "Function" + [ testCase "rendered docs" $ + factorialDocs @=? + renderFunction factorial + ] + , testGroup "Module" + [ testCase "module docs" + (T.unlines + [ "# mymath" + , "" + , "A math module." + , "" + , "### " `T.append` eulerDocs + , "" + , "## Functions" + , "" + , "### " `T.append` factorialDocs + , "" + , "### " `T.append` nrootDocs + ] @=? + render mymath) + ] + ] + +-- | Calculate the nth root of a number. Defaults to square root. +nroot :: DocumentedFunction Lua.Exception +nroot = defun "nroot" (liftPure2 nroot') + <#> parameter (peekRealFloat @Double) "number" "x" "" + <#> optionalParameter (peekIntegral @Int) "integer" "n" "" + =#> functionResult pushRealFloat "number" "nth root" + where + nroot' :: Double -> Maybe Int -> Double + nroot' x nOpt = + let n = fromMaybe 2 nOpt + in x ** (1 / fromIntegral n) + +mymath :: Module Lua.Exception +mymath = Module + { moduleName = "mymath" + , moduleDescription = "A math module." + , moduleFields = [euler_mascheroni] + , moduleFunctions = [ factorial, nroot ] + , moduleOperations = [] + } + +-- | Euler-Mascheroni constant +euler_mascheroni :: Field Lua.Exception +euler_mascheroni = Field + { fieldName = "euler_mascheroni" + , fieldDescription = "Euler-Mascheroni constant" + , fieldPushValue = pushRealFloat @Double + 0.57721566490153286060651209008240243 + } + +-- | Calculate the factorial of a number. +factorial :: DocumentedFunction Lua.Exception +factorial = defun "factorial" + ### liftPure (\n -> product [1..n]) + <#> factorialParam + =#> factorialResult + #? "Calculates the factorial of a positive integer." + `since` makeVersion [1,0,0] + +factorialParam :: Parameter Lua.Exception Integer +factorialParam = + parameter peekIntegral "integer" + "n" + "number for which the factorial is computed" + +factorialResult :: FunctionResults Lua.Exception Integer +factorialResult = + functionResult pushIntegral "integer" "factorial" diff --git a/test/HsLua/Packaging/UDTypeTests.hs b/test/HsLua/Packaging/UDTypeTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Packaging/UDTypeTests.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Packaging.UDTypeTests +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Tests for calling exposed Haskell functions. +-} +module HsLua.Packaging.UDTypeTests (tests) where + +import HsLua.Core +import HsLua.Packaging.Function +import HsLua.Packaging.UDType +import HsLua.Marshalling +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HsLua ((=:), shouldBeResultOf) +import qualified Data.ByteString.Char8 as Char8 + +-- | Calling Haskell functions from Lua. +tests :: TestTree +tests = testGroup "DocumentedType" + [ testGroup "Foo type" + [ "show" =: + "Foo 5 \"five\"" `shouldBeResultOf` do + openlibs + pushUD typeFoo $ Foo 5 "five" + setglobal "foo" + _ <- dostring "return foo:show()" + forcePeek $ peekText top + + , "pairs iterates over properties" =: + ["num", "5", "str", "echo", "show", "function"] `shouldBeResultOf` do + openlibs + pushUD typeFoo $ Foo 5 "echo" + setglobal "echo" + OK <- dostring $ Char8.unlines + [ "local result = {}" + , "for k, v in pairs(echo) do" + , " table.insert(result, k)" + , " table.insert(" + , " result," + , " type(v) == 'function' and 'function' or tostring(v)" + , " )" + , "end" + , "return result" + ] + forcePeek $ peekList peekText top + ] + + , testGroup "Sum type" + [ "tostring Quux" =: + "Quux 11 \"eleven\"" `shouldBeResultOf` do + openlibs + pushUD typeQux $ Quux 11 "eleven" + setglobal "quux" + _ <- dostring "return tostring(quux)" + forcePeek $ peekText top + , "show Quux" =: + "Quux 11 \"eleven\"" `shouldBeResultOf` do + openlibs + pushUD typeQux $ Quux 11 "eleven" + setglobal "quux" + _ <- dostring "return quux:show()" + forcePeek $ peekText top + ] + ] + +-- +-- Sample types +-- + +data Foo = Foo Int String + deriving (Eq, Show) + +show' :: LuaError e => DocumentedFunction e +show' = defun "show" + ### liftPure (show @Foo) + <#> udparam typeFoo "foo" "Object" + =#> functionResult pushString "string" "stringified foo" + +typeFoo :: LuaError e => DocumentedType e Foo +typeFoo = deftype "Foo" + [ operation Tostring show' + ] + [ property "num" "some number" + (pushIntegral, \(Foo n _) -> n) + (peekIntegral, \(Foo _ s) n -> Foo n s) + , readonly "str" "some string" (pushString, \(Foo _ s) -> s) + , method show' + ] + +-- +-- Sum Type +-- +data Qux + = Quux Int String + | Quuz Point Int + deriving (Eq, Show) + +data Point = Point Double Double + deriving (Eq, Show) + +pushPoint :: LuaError e => Pusher e Point +pushPoint (Point x y) = do + newtable + pushName "x" *> pushRealFloat x *> rawset (nth 3) + pushName "y" *> pushRealFloat y *> rawset (nth 3) + +peekPoint :: LuaError e => Peeker e Point +peekPoint idx = do + x <- peekFieldRaw peekRealFloat "x" idx + y <- peekFieldRaw peekRealFloat "y" idx + return $ x `seq` y `seq` Point x y + +showQux :: LuaError e => DocumentedFunction e +showQux = defun "show" + ### liftPure (show @Qux) + <#> parameter peekQux "qux" "qux" "Object" + =#> functionResult pushString "string" "stringified Qux" + +peekQux :: LuaError e => Peeker e Qux +peekQux = peekUD typeQux + +typeQux :: LuaError e => DocumentedType e Qux +typeQux = deftype "Qux" + [ operation Tostring showQux ] + [ method showQux + , property "num" "some number" + (pushIntegral, \case + Quux n _ -> n + Quuz _ n -> n) + (peekIntegral, \case + Quux _ s -> (`Quux` s) + Quuz d _ -> Quuz d) + + , possibleProperty "str" "a string in Quux" + (pushString, \case + Quux _ s -> Actual s + Quuz {} -> Absent) + (peekString, \case + Quux n _ -> Actual . Quux n + Quuz {} -> const Absent) + + , possibleProperty "point" "a point in Quuz" + (pushPoint, \case + Quuz p _ -> Actual p + Quux {} -> Absent) + (peekPoint, \case + Quuz _ n -> Actual . (`Quuz` n) + Quux {} -> const Absent) + + , alias "x" "The x coordinate of a point in Quuz" ["point", "x"] + ] diff --git a/test/HsLua/PackagingTests.hs b/test/HsLua/PackagingTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/PackagingTests.hs @@ -0,0 +1,24 @@ +{-| +Module : HsLua.PackagingTests +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Test packaging +-} +module HsLua.PackagingTests (tests) where + +import Test.Tasty (TestTree, testGroup) +import qualified HsLua.Packaging.FunctionTests +import qualified HsLua.Packaging.ModuleTests +import qualified HsLua.Packaging.RenderingTests +import qualified HsLua.Packaging.UDTypeTests + +-- | Tests for package creation. +tests :: TestTree +tests = testGroup "Packaging" + [ HsLua.Packaging.FunctionTests.tests + , HsLua.Packaging.ModuleTests.tests + , HsLua.Packaging.RenderingTests.tests + , HsLua.Packaging.UDTypeTests.tests + ] diff --git a/test/test-hslua-packaging.hs b/test/test-hslua-packaging.hs new file mode 100644 --- /dev/null +++ b/test/test-hslua-packaging.hs @@ -0,0 +1,18 @@ +{-| +Module : Main +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Tests for hslua-packaging. +-} +import Test.Tasty (TestTree, defaultMain, testGroup) + +import qualified HsLua.PackagingTests + +main :: IO () +main = defaultMain tests + +-- | Lua module packaging tests. +tests :: TestTree +tests = testGroup "Packaging" [HsLua.PackagingTests.tests]