diff options
author | John MacFarlane <jgm@berkeley.edu> | 2019-05-29 12:05:04 -0400 |
---|---|---|
committer | GitHub <noreply@github.com> | 2019-05-29 12:05:04 -0400 |
commit | e871d65b67e2458c6146debddeaddb3c9773f67c (patch) | |
tree | 77665385be99be05e80f1cdbe5ea93c5e3f72baa /src/Text/Pandoc/Lua/Marshaling | |
parent | 1de7b20ebbb198362ec0b4717f72d275fb34dd9c (diff) | |
parent | 505f5bf5d951a5c4342f7acce9bea5f260dc9d78 (diff) | |
download | pandoc-e871d65b67e2458c6146debddeaddb3c9773f67c.tar.gz |
Merge pull request #5526 from tarleb/richer-version-type
Lua: add Version type to simplify comparisons
Diffstat (limited to 'src/Text/Pandoc/Lua/Marshaling')
-rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/Version.hs | 154 |
1 files changed, 154 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Lua/Marshaling/Version.hs b/src/Text/Pandoc/Lua/Marshaling/Version.hs new file mode 100644 index 000000000..3c667cbc4 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshaling/Version.hs @@ -0,0 +1,154 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{- | + Module : Text.Pandoc.Lua.Marshaling.Version + Copyright : © 2019 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> + Stability : alpha + +Marshaling of @'Version'@s. The marshaled elements can be compared using +default comparison operators (like @>@ and @<=@). +-} +module Text.Pandoc.Lua.Marshaling.Version + ( peekVersion + , pushVersion + ) + where + +import Prelude +import Data.Maybe (fromMaybe) +import Data.Version (Version (..), makeVersion, parseVersion, showVersion) +import Foreign.Lua (Lua, Optional (..), NumResults, + Peekable, Pushable, StackIndex) +import Foreign.Lua.Types.Peekable (reportValueOnFailure) +import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable, + toAnyWithName) +import Safe (atMay, lastMay) +import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) +import Text.ParserCombinators.ReadP (readP_to_S) + +import qualified Foreign.Lua as Lua +import qualified Text.Pandoc.Lua.Util as LuaUtil + +-- | Push a @'Version'@ element to the Lua stack. +pushVersion :: Version -> Lua () +pushVersion version = pushAnyWithMetatable pushVersionMT version + where + pushVersionMT = ensureUserdataMetatable versionTypeName $ do + LuaUtil.addFunction "__eq" __eq + LuaUtil.addFunction "__le" __le + LuaUtil.addFunction "__lt" __lt + LuaUtil.addFunction "__len" __len + LuaUtil.addFunction "__index" __index + LuaUtil.addFunction "__pairs" __pairs + LuaUtil.addFunction "__tostring" __tostring + +instance Pushable Version where + push = pushVersion + +peekVersion :: StackIndex -> Lua Version +peekVersion idx = Lua.ltype idx >>= \case + Lua.TypeString -> do + versionStr <- Lua.peek idx + let parses = readP_to_S parseVersion versionStr + case lastMay parses of + Just (v, "") -> return v + _ -> Lua.throwException $ "could not parse as Version: " ++ versionStr + + Lua.TypeUserdata -> + reportValueOnFailure versionTypeName + (`toAnyWithName` versionTypeName) + idx + Lua.TypeNumber -> do + n <- Lua.peek idx + return (makeVersion [n]) + + Lua.TypeTable -> + makeVersion <$> Lua.peek idx + + _ -> + Lua.throwException "could not peek Version" + +instance Peekable Version where + peek = peekVersion + +-- | Name used by Lua for the @CommonState@ type. +versionTypeName :: String +versionTypeName = "HsLua Version" + +__eq :: Version -> Version -> Lua Bool +__eq v1 v2 = return (v1 == v2) + +__le :: Version -> Version -> Lua Bool +__le v1 v2 = return (v1 <= v2) + +__lt :: Version -> Version -> Lua Bool +__lt v1 v2 = return (v1 < v2) + +-- | Get number of version components. +__len :: Version -> Lua Int +__len = return . length . versionBranch + +-- | Access fields. +__index :: Version -> AnyValue -> Lua NumResults +__index v (AnyValue k) = do + ty <- Lua.ltype k + case ty of + Lua.TypeNumber -> do + n <- Lua.peek k + let versionPart = atMay (versionBranch v) (n - 1) + Lua.push (Lua.Optional versionPart) + return 1 + Lua.TypeString -> do + str <- Lua.peek k + if str == "must_be_at_least" + then 1 <$ Lua.pushHaskellFunction must_be_at_least + else 1 <$ Lua.pushnil + _ -> 1 <$ Lua.pushnil + +-- | Create iterator. +__pairs :: Version -> Lua NumResults +__pairs v = do + Lua.pushHaskellFunction nextFn + Lua.pushnil + Lua.pushnil + return 3 + where + nextFn :: AnyValue -> Optional Int -> Lua Lua.NumResults + nextFn _ (Optional key) = + case key of + Nothing -> case versionBranch v of + [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) + n:_ -> 2 <$ (Lua.push (1 :: Int) *> Lua.push n) + Just n -> case atMay (versionBranch v) n of + Nothing -> 2 <$ (Lua.pushnil *> Lua.pushnil) + Just b -> 2 <$ (Lua.push (n + 1) *> Lua.push b) + +-- | Convert to string. +__tostring :: Version -> Lua String +__tostring v = return (showVersion v) + +-- | Default error message when a version is too old. This message is +-- formatted in Lua with the expected and actual versions as arguments. +versionTooOldMessage :: String +versionTooOldMessage = "version too old: expected version %s or newer, got %s" + +-- | Throw an error if this version is older than the given version. +-- FIXME: This function currently requires the string library to be +-- loaded. +must_be_at_least :: Version -> Version -> Optional String -> Lua NumResults +must_be_at_least actual expected optMsg = do + let msg = fromMaybe versionTooOldMessage (fromOptional optMsg) + if expected <= actual + then return 0 + else do + Lua.getglobal' "string.format" + Lua.push msg + Lua.push (showVersion expected) + Lua.push (showVersion actual) + Lua.call 3 1 + Lua.error + |