@@ -0,0 +1,154 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE NoImplicitPrelude #-}
4+{- |
5+ Module : Text.Pandoc.Lua.Marshaling.Version
6+ Copyright : © 2019 Albert Krewinkel
7+ License : GNU GPL, version 2 or above
8+
9+ Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
10+ Stability : alpha
11+
12+Marshaling of @'Version'@s. The marshaled elements can be compared using
13+default comparison operators (like @>@ and @<=@).
14+-}
15+module Text.Pandoc.Lua.Marshaling.Version
16+ ( peekVersion
17+ , pushVersion
18+ )
19+ where
20+
21+import Prelude
22+import Data.Maybe (fromMaybe)
23+import Data.Version (Version (..), makeVersion, parseVersion, showVersion)
24+import Foreign.Lua (Lua, Optional (..), NumResults,
25+ Peekable, Pushable, StackIndex)
26+import Foreign.Lua.Types.Peekable (reportValueOnFailure)
27+import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable,
28+ toAnyWithName)
29+import Safe (atMay, lastMay)
30+import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..))
31+import Text.ParserCombinators.ReadP (readP_to_S)
32+
33+import qualified Foreign.Lua as Lua
34+import qualified Text.Pandoc.Lua.Util as LuaUtil
35+
36+-- | Push a @'Version'@ element to the Lua stack.
37+pushVersion :: Version -> Lua ()
38+pushVersion version = pushAnyWithMetatable pushVersionMT version
39+ where
40+ pushVersionMT = ensureUserdataMetatable versionTypeName $ do
41+ LuaUtil.addFunction "__eq" __eq
42+ LuaUtil.addFunction "__le" __le
43+ LuaUtil.addFunction "__lt" __lt
44+ LuaUtil.addFunction "__len" __len
45+ LuaUtil.addFunction "__index" __index
46+ LuaUtil.addFunction "__pairs" __pairs
47+ LuaUtil.addFunction "__tostring" __tostring
48+
49+instance Pushable Version where
50+ push = pushVersion
51+
52+peekVersion :: StackIndex -> Lua Version
53+peekVersion idx = Lua.ltype idx >>= \case
54+ Lua.TypeString -> do
55+ versionStr <- Lua.peek idx
56+ let parses = readP_to_S parseVersion versionStr
57+ case lastMay parses of
58+ Just (v, "") -> return v
59+ _ -> Lua.throwException $ "could not parse as Version: " ++ versionStr
60+
61+ Lua.TypeUserdata ->
62+ reportValueOnFailure versionTypeName
63+ (`toAnyWithName` versionTypeName)
64+ idx
65+ Lua.TypeNumber -> do
66+ n <- Lua.peek idx
67+ return (makeVersion [n])
68+
69+ Lua.TypeTable ->
70+ makeVersion <$> Lua.peek idx
71+
72+ _ ->
73+ Lua.throwException "could not peek Version"
74+
75+instance Peekable Version where
76+ peek = peekVersion
77+
78+-- | Name used by Lua for the @CommonState@ type.
79+versionTypeName :: String
80+versionTypeName = "HsLua Version"
81+
82+__eq :: Version -> Version -> Lua Bool
83+__eq v1 v2 = return (v1 == v2)
84+
85+__le :: Version -> Version -> Lua Bool
86+__le v1 v2 = return (v1 <= v2)
87+
88+__lt :: Version -> Version -> Lua Bool
89+__lt v1 v2 = return (v1 < v2)
90+
91+-- | Get number of version components.
92+__len :: Version -> Lua Int
93+__len = return . length . versionBranch
94+
95+-- | Access fields.
96+__index :: Version -> AnyValue -> Lua NumResults
97+__index v (AnyValue k) = do
98+ ty <- Lua.ltype k
99+ case ty of
100+ Lua.TypeNumber -> do
101+ n <- Lua.peek k
102+ let versionPart = atMay (versionBranch v) (n - 1)
103+ Lua.push (Lua.Optional versionPart)
104+ return 1
105+ Lua.TypeString -> do
106+ str <- Lua.peek k
107+ if str == "must_be_at_least"
108+ then 1 <$ Lua.pushHaskellFunction must_be_at_least
109+ else 1 <$ Lua.pushnil
110+ _ -> 1 <$ Lua.pushnil
111+
112+-- | Create iterator.
113+__pairs :: Version -> Lua NumResults
114+__pairs v = do
115+ Lua.pushHaskellFunction nextFn
116+ Lua.pushnil
117+ Lua.pushnil
118+ return 3
119+ where
120+ nextFn :: AnyValue -> Optional Int -> Lua Lua.NumResults
121+ nextFn _ (Optional key) =
122+ case key of
123+ Nothing -> case versionBranch v of
124+ [] -> 2 <$ (Lua.pushnil *> Lua.pushnil)
125+ n:_ -> 2 <$ (Lua.push (1 :: Int) *> Lua.push n)
126+ Just n -> case atMay (versionBranch v) n of
127+ Nothing -> 2 <$ (Lua.pushnil *> Lua.pushnil)
128+ Just b -> 2 <$ (Lua.push (n + 1) *> Lua.push b)
129+
130+-- | Convert to string.
131+__tostring :: Version -> Lua String
132+__tostring v = return (showVersion v)
133+
134+-- | Default error message when a version is too old. This message is
135+-- formatted in Lua with the expected and actual versions as arguments.
136+versionTooOldMessage :: String
137+versionTooOldMessage = "version too old: expected version %s or newer, got %s"
138+
139+-- | Throw an error if this version is older than the given version.
140+-- FIXME: This function currently requires the string library to be
141+-- loaded.
142+must_be_at_least :: Version -> Version -> Optional String -> Lua NumResults
143+must_be_at_least actual expected optMsg = do
144+ let msg = fromMaybe versionTooOldMessage (fromOptional optMsg)
145+ if expected <= actual
146+ then return 0
147+ else do
148+ Lua.getglobal' "string.format"
149+ Lua.push msg
150+ Lua.push (showVersion expected)
151+ Lua.push (showVersion actual)
152+ Lua.call 3 1
153+ Lua.error
154+