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
+