diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog + +`hslua-module-version` uses [PVP Versioning](https://pvp.haskell.org). + +## 0.0.1 + +Release pending diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright © 1994-2020 Lua.org, PUC-Rio. +Copyright © 2007-2012 Gracjan Polak +Copyright © 2012-2015 Ömer Sinan Ağacan +Copyright © 2016-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,15 @@ +# hslua-module-version + +[![GitHub CI][CI badge]](https://github.com/hslua/hslua-module-version/actions) +[![Hackage][Hackage badge]](https://hackage.haskell.org/package/hslua-module-version) +[![Stackage Lts][Stackage Lts badge]](http://stackage.org/lts/package/hslua-module-version) +[![Stackage Nightly][Stackage Nightly badge]](http://stackage.org/nightly/package/hslua-module-version) +[![MIT license][License badge]](LICENSE) + +[CI badge]: https://github.com/hslua/hslua-module-version/workflows/CI/badge.svg +[Hackage badge]: https://img.shields.io/hackage/v/hslua-module-version.svg?logo=haskell +[Stackage Lts badge]: http://stackage.org/package/hslua-module-version/badge/lts +[Stackage Nightly badge]: http://stackage.org/package/hslua-module-version/badge/nightly +[License badge]: https://img.shields.io/badge/license-MIT-blue.svg + +Lua module to work with version specifiers. diff --git a/hslua-module-version.cabal b/hslua-module-version.cabal new file mode 100644 --- /dev/null +++ b/hslua-module-version.cabal @@ -0,0 +1,72 @@ +cabal-version: 2.2 +name: hslua-module-version +version: 1.0.0 +synopsis: Lua module to work with version specifiers. +description: Wrapper for the Data.Version.Version Haskell type. +homepage: https://github.com/hslua/hslua-module-version +bug-reports: https://github.com/hslua/hslua-module-version/issues +license: MIT +license-file: LICENSE +author: Albert Krewinkel +maintainer: Albert Krewinkel +copyright: © 2019-2021 Albert Krewinkel +category: Foreign +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +extra-source-files: test/test-version.lua +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.4 + , GHC == 9.0.1 + +source-repository head + type: git + location: https://github.com/hslua/hslua-module-version.git + +common common-options + build-depends: base >= 4.9.1 && < 5 + , filepath >= 1.4 && < 1.5 + , hslua >= 2.0 && < 2.1 + , hslua-marshalling >= 2.0 && < 2.1 + , hslua-packaging >= 2.0 && < 2.1 + , text >= 1.0 && < 1.3 + + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + + default-language: Haskell2010 + +library + import: common-options + hs-source-dirs: src + exposed-modules: HsLua.Module.Version + +test-suite hslua-module-version-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test-hslua-module-version.hs + build-depends: base + , hslua-module-version + , tasty + , tasty-hunit + , tasty-lua >= 1.0 && < 1.1 + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N diff --git a/src/HsLua/Module/Version.hs b/src/HsLua/Module/Version.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Module/Version.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.Module.Version +Copyright : © 2019-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Lua module to work with file paths. +-} +module HsLua.Module.Version ( + -- * Module + documentedModule + -- * Version objects + , typeVersion + , peekVersion + , pushVersion + , peekVersionFuzzy + ) +where + +import Prelude hiding (error) +import Data.Maybe (fromMaybe) +import Data.Version + ( Version, makeVersion, parseVersion, showVersion, versionBranch ) +import Data.List.NonEmpty as NonEmpty (last, nonEmpty) +#if !MIN_VERSION_base(4,12,0) +import Data.Semigroup (Semigroup ((<>))) +#endif +import Data.Text (Text) +import HsLua.Core + ( LuaError, Type (..) , call, dostring, error, ltype ) +import HsLua.Marshalling + ( Peeker, Pusher, failPeek, liftLua, peekIntegral, peekList, peekString + , pushBool, pushIntegral, pushIterator, pushString, retrieving ) +import HsLua.Packaging +import Text.ParserCombinators.ReadP (readP_to_S) + +import qualified HsLua.Core.Utf8 as UTF8 + +-- | The @path@ module specification. +documentedModule :: LuaError e => Module e +documentedModule = Module + { moduleName = "Version" + , moduleDescription = "Version specifier handling" + , moduleFields = [] + , moduleFunctions = [must_be_at_least] + , moduleOperations = + [ operation Call $ lambda + ### liftPure2 (\_ v -> v) + <#> parameter (const $ pure ()) "table" "module table" "ignored" + <#> versionParam "version" "version-like object" + =#> functionResult (pushUD typeVersion) "Version" "new Version object" + ] + } + +-- | Type definition of Lua Version values. +typeVersion :: LuaError e => DocumentedTypeWithList e Version Int +typeVersion = deftype' "Version" + [ operation Eq $ versionComparison (==) "true iff v1 == v2" + , operation Le $ versionComparison (<=) "true iff v1 <= v2" + , operation Lt $ versionComparison (<) "true iff v1 < v2" + , operation Len $ lambda + ### liftPure (length . versionBranch) + <#> versionParam "version" "" + =#> functionResult pushIntegral "integer" "number of version components" + , operation Pairs $ lambda + ### pushIterator (\(i, n) -> 2 <$ pushIntegral i <* pushIntegral n) + . zip [(1 :: Int) ..] . versionBranch + <#> versionParam "version" "" + =?> "iterator values" + , operation Tostring $ lambda + ### liftPure showVersion + <#> versionParam "version" "" + =#> functionResult pushString "string" "stringified version" + ] + [ method must_be_at_least ] + (Just (versionBranch, pushIntegral)) + where + versionComparison f descr = lambda + ### liftPure2 f + <#> versionParam "v1" "" + <#> versionParam "v2" "" + =#> functionResult pushBool "boolean" descr + +-- | Push a @'Version'@ element to the Lua stack. +pushVersion :: LuaError e => Pusher e Version +pushVersion = pushUD typeVersion + +-- | Retrieve a @'Version'@ object from the top of the stack. +peekVersion :: LuaError e => Peeker e Version +peekVersion = peekUD typeVersion + +-- | Retrieve a Version-like object from the top of the stack. +-- +-- This function uses these heuristics, depending on the Lua object +-- type. +-- +-- * string: object is parsed as a version specifier. +-- +-- * table: value is expected to be a list of integers, with each +-- index specifying a version branch. +-- +-- * userdata: assumes the value to be a Version userdata object. +-- +-- * number: parses the number as an integer value. +-- +-- Otherwise, or if the object fails to meet an expectation, peeking +-- fails. +peekVersionFuzzy :: LuaError e => Peeker e Version +peekVersionFuzzy idx = retrieving "Version" $ liftLua (ltype idx) >>= \case + TypeUserdata -> peekVersion idx + TypeString -> do + versionStr <- peekString idx + let parses = readP_to_S parseVersion versionStr + case NonEmpty.last <$> NonEmpty.nonEmpty parses of + Just (v, "") -> return v + _ -> failPeek $ + "could not parse as Version: " <> UTF8.fromString versionStr + TypeNumber -> makeVersion . (:[]) <$> peekIntegral idx + TypeTable -> makeVersion <$> peekList peekIntegral idx + _ -> + failPeek "could not peek Version" + +-- | Parameter that takes a Version-like object. +versionParam :: LuaError e => Text -> Text -> Parameter e Version +versionParam = parameter peekVersionFuzzy "Version" + +-- | Throw an error if this version is older than the given version. This +-- function currently the string library to be loaded. +must_be_at_least :: LuaError e => DocumentedFunction e +must_be_at_least = + defun "must_be_at_least" + ### (\actual expected mMsg -> do + -- Default error message when a version is too old. This + -- message is formatted in Lua with the expected and actual + -- versions as arguments. + let versionTooOldMessage = "expected version %s or newer, got %s" + let msg = fromMaybe versionTooOldMessage mMsg + if expected <= actual + then return 0 + else do + _ <- dostring "return string.format" + pushString msg + pushString (showVersion expected) + pushString (showVersion actual) + call 3 1 + error) + <#> versionParam "self" "version to check" + <#> versionParam "reference" "minimum version" + <#> optionalParameter peekString "string" "msg" "alternative message" + =?> mconcat [ "Returns no result, and throws an error if this " + , "version is older than `reference`." + ] diff --git a/test/test-hslua-module-version.hs b/test/test-hslua-module-version.hs new file mode 100644 --- /dev/null +++ b/test/test-hslua-module-version.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : Main +Copyright : © 2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Tests for the `version` Lua module. +-} +module Main (main) where + +import Control.Monad (void) +import HsLua (Lua) +import HsLua.Packaging.Module (preloadModule, preloadModuleWithName, pushModule) +import HsLua.Module.Version (documentedModule) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) +import Test.Tasty.Lua (translateResultsFromFile) + +import qualified HsLua as Lua + +main :: IO () +main = do + luaTestResults <- Lua.run @Lua.Exception $ do + Lua.openlibs + Lua.registerModule documentedModule + Lua.pop 1 + translateResultsFromFile "test/test-version.lua" + defaultMain $ testGroup "hslua-module-version" [tests, luaTestResults] + +-- | HSpec tests for the Lua 'version' module +tests :: TestTree +tests = testGroup "HsLua version module" + [ testCase "version module can be pushed to the stack" $ + Lua.run (void (pushModule documentedModule) :: Lua ()) + + , testCase "version module can be added to the preloader" . Lua.run $ do + Lua.openlibs + preloadModule documentedModule + assertEqual' "function not added to preloader" Lua.TypeFunction =<< do + Lua.getglobal' "package.preload.Version" + Lua.ltype (-1) + + , testCase "version module can be loaded as hsversion" . Lua.run $ do + Lua.openlibs + preloadModuleWithName documentedModule "hsversion" + assertEqual' "loading the module fails " Lua.OK =<< + Lua.dostring "require 'hsversion'" + ] + +assertEqual' :: (Show a, Eq a) => String -> a -> a -> Lua () +assertEqual' msg expected = Lua.liftIO . assertEqual msg expected diff --git a/test/test-version.lua b/test/test-version.lua new file mode 100644 --- /dev/null +++ b/test/test-version.lua @@ -0,0 +1,110 @@ +-- +-- Tests for the `version` module +-- +local Version = require 'Version' +local tasty = require 'tasty' + +local group = tasty.test_group +local test = tasty.test_case +local assert = tasty.assert + +return { + group 'constructor' { + test('has type `userdata`', function () + assert.are_same(type(Version {2}), 'userdata') + end), + test('accepts list of integers', function () + assert.are_same(type(Version {2, 7, 3}), 'userdata') + end), + test('accepts a single integer', function () + assert.are_same(Version(5), Version {5}) + end), + test('accepts version as string', function () + assert.are_same( + Version '4.45.1', + Version {4, 45, 1} + ) + end), + test('non-version string is rejected', function () + local success, msg = pcall(function () return Version '11friends' end) + assert.is_falsy(success) + assert.is_truthy(tostring(msg):match('11friends')) + end) + }, + + group 'comparison' { + test('smaller (equal) than', function () + assert.is_truthy(Version {2, 58, 3} < Version {2, 58, 4}) + assert.is_falsy(Version {2, 60, 1} < Version {2, 59, 2}) + assert.is_truthy(Version {0, 14, 3} < Version {0, 14, 3, 1}) + assert.is_truthy(Version {3, 58, 3} <= Version {4}) + assert.is_truthy(Version {0, 14, 3} <= Version {0, 14, 3, 1}) + end), + test('larger (equal) than', function () + assert.is_truthy(Version{2,58,3} > Version {2, 57, 4}) + assert.is_truthy(Version{2,58,3} > Version {2, 58, 2}) + assert.is_truthy(Version {0, 8} >= Version {0, 8}) + assert.is_falsy(Version {0, 8} >= Version {0, 8, 2}) + end), + test('equality', function () + assert.is_truthy(Version '8.8', Version {8, 8}) + end), + test('second argument can be a version string', function () + assert.is_truthy(Version '8' < '9.1') + assert.is_falsy(Version '8.8' < '8.7') + end), + }, + + group 'conversion to string' { + test('converting from and to string is a noop', function () + local version_string = '1.19.4' + assert.are_equal(tostring(Version(version_string)), version_string) + end) + }, + + group 'convenience functions' { + test('throws error if version is too old', function () + local actual = Version {2, 8} + local expected = Version {2, 9} + assert.error_matches( + function () actual:must_be_at_least(expected) end, + 'expected version 2.9 or newer, got 2.8' + ) + end), + test('does nothing if expected version is older than actual', function () + local actual = Version '2.9' + local expected = Version '2.8' + actual:must_be_at_least(expected) + end), + test('does nothing if expected version equals to actual', function () + local actual = Version '2.8' + local expected = Version '2.8' + actual:must_be_at_least(expected) + end) + }, + + group 'list-like behavior' { + test('can access version component numbers', function () + local version = Version '2.7.3' + assert.is_nil(version[0]) + assert.are_equal(version[1], 2) + assert.are_equal(version[2], 7) + assert.are_equal(version[3], 3) + end), + test('can be iterated over', function () + local version_list = {2, 7, 3} + local final_index = 0 + for i, v in pairs(Version(version_list)) do + assert.are_equal(v, version_list[i]) + final_index = i + end + assert.are_equal(final_index, 3) + end), + test('length is the number of components', function () + assert.are_equal(#(Version '0'), 1) + assert.are_equal(#(Version '1.6'), 2) + assert.are_equal(#(Version '8.7.5'), 3) + assert.are_equal(#(Version '2.9.1.5'), 4) + end) + } +}