Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

Avoid repeating StackValue instances definitions

Browse source 
The lua filters and custom lua writer system defined very similar
StackValue instances for strings and tuples.  These instance definitions
are extracted to a separate module to enable sharing.
This commit is contained in:
Albert Krewinkel 2017-04-14 19:07:55 +02:00
parent feb1c1a930
commit 0add4253e6
No known key found for this signature in database
GPG key ID: 388DC0B21F631124
5 changed files with 166 additions and 156 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
pandoc.cabal
View file

@ -457,6 +457,7 @@ Library
Text.Pandoc.Readers.Org.Shared,
Text.Pandoc.Lua.Compat,
Text.Pandoc.Lua.PandocModule,
Text.Pandoc.Lua.SharedInstances,
Text.Pandoc.Lua.StackInstances,
Text.Pandoc.Lua.Util,
Text.Pandoc.CSS,

106
src/Text/Pandoc/Lua/SharedInstances.hs Normal file
View file

@ -0,0 +1,106 @@
{-
Copyright © 2012-2016 John MacFarlane <jgm@berkeley.edu>
2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
Module : Text.Pandoc.Lua.SharedInstances
Copyright : © 2012–2016 John MacFarlane,
© 2017 Albert Krewinkel
License : GNU GPL, version 2 or above
Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
Stability : alpha
Shared StackValue instances for pandoc and generic types.
-}
module Text.Pandoc.Lua.SharedInstances () where
import Scripting.Lua ( LTYPE(..), StackValue(..), newtable )
import Text.Pandoc.Lua.Util ( addRawInt, addValue, getRawInt, keyValuePairs )
import qualified Data.Map as M
import qualified Text.Pandoc.UTF8 as UTF8
#if MIN_VERSION_base(4,8,0)
instance {-# OVERLAPS #-} StackValue [Char] where
#else
instance StackValue [Char] where
#endif
push lua cs = push lua (UTF8.fromString cs)
peek lua i = fmap UTF8.toString <$> peek lua i
valuetype _ = TSTRING
instance (StackValue a, StackValue b) => StackValue (a, b) where
push lua (a, b) = do
newtable lua
addRawInt lua 1 a
addRawInt lua 2 b
peek lua idx = do
a <- getRawInt lua idx 1
b <- getRawInt lua idx 2
return $ (,) <$> a <*> b
valuetype _ = TTABLE
instance (StackValue a, StackValue b, StackValue c) =>
StackValue (a, b, c)
where
push lua (a, b, c) = do
newtable lua
addRawInt lua 1 a
addRawInt lua 2 b
addRawInt lua 3 c
peek lua idx = do
a <- getRawInt lua idx 1
b <- getRawInt lua idx 2
c <- getRawInt lua idx 3
return $ (,,) <$> a <*> b <*> c
valuetype _ = TTABLE
instance (StackValue a, StackValue b, StackValue c,
StackValue d, StackValue e) =>
StackValue (a, b, c, d, e)
where
push lua (a, b, c, d, e) = do
newtable lua
addRawInt lua 1 a
addRawInt lua 2 b
addRawInt lua 3 c
addRawInt lua 4 d
addRawInt lua 5 e
peek lua idx = do
a <- getRawInt lua idx 1
b <- getRawInt lua idx 2
c <- getRawInt lua idx 3
d <- getRawInt lua idx 4
e <- getRawInt lua idx 5
return $ (,,,,) <$> a <*> b <*> c <*> d <*> e
valuetype _ = TTABLE
instance (Ord a, StackValue a, StackValue b) =>
StackValue (M.Map a b) where
push lua m = do
newtable lua
mapM_ (uncurry $ addValue lua) $ M.toList m
peek lua idx = fmap M.fromList <$> keyValuePairs lua idx
valuetype _ = TTABLE

128
src/Text/Pandoc/Lua/StackInstances.hs
View file

@ -16,12 +16,8 @@ You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
Module : Text.Pandoc.Lua.StackInstances
@ -38,15 +34,10 @@ module Text.Pandoc.Lua.StackInstances () where
import Control.Applicative ( (<|>) )
import Scripting.Lua
( LTYPE(..), LuaState, StackValue(..)
, call, getglobal2, ltype, newtable, next, objlen, pop, pushnil
)
( LTYPE(..), LuaState, StackValue(..), getglobal2, ltype, newtable, objlen )
import Text.Pandoc.Definition
import Text.Pandoc.Lua.Util
( adjustIndexBy, addValue, getTable, addRawInt, getRawInt )
import qualified Data.Map as M
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.Lua.SharedInstances ()
import Text.Pandoc.Lua.Util ( addValue, getTable, pushViaConstructor )
instance StackValue Pandoc where
push lua (Pandoc meta blocks) = do
@ -261,119 +252,6 @@ instance StackValue QuoteType where
_ -> return Nothing
valuetype _ = TTABLE
#if MIN_VERSION_base(4,8,0)
instance {-# OVERLAPS #-} StackValue [Char] where
#else
instance StackValue [Char] where
#endif
push lua cs = push lua (UTF8.fromString cs)
peek lua i = fmap UTF8.toString <$> peek lua i
valuetype _ = TSTRING
instance (StackValue a, StackValue b) => StackValue (a, b) where
push lua (a, b) = do
newtable lua
addRawInt lua 1 a
addRawInt lua 2 b
peek lua idx = do
a <- getRawInt lua idx 1
b <- getRawInt lua idx 2
return $ (,) <$> a <*> b
valuetype _ = TTABLE
instance (StackValue a, StackValue b, StackValue c) =>
StackValue (a, b, c)
where
push lua (a, b, c) = do
newtable lua
addRawInt lua 1 a
addRawInt lua 2 b
addRawInt lua 3 c
peek lua idx = do
a <- getRawInt lua idx 1
b <- getRawInt lua idx 2
c <- getRawInt lua idx 3
return $ (,,) <$> a <*> b <*> c
valuetype _ = TTABLE
instance (StackValue a, StackValue b, StackValue c,
StackValue d, StackValue e) =>
StackValue (a, b, c, d, e)
where
push lua (a, b, c, d, e) = do
newtable lua
addRawInt lua 1 a
addRawInt lua 2 b
addRawInt lua 3 c
addRawInt lua 4 d
addRawInt lua 5 e
peek lua idx = do
a <- getRawInt lua idx 1
b <- getRawInt lua idx 2
c <- getRawInt lua idx 3
d <- getRawInt lua idx 4
e <- getRawInt lua idx 5
return $ (,,,,) <$> a <*> b <*> c <*> d <*> e
valuetype _ = TTABLE
instance (Ord a, StackValue a, StackValue b) =>
StackValue (M.Map a b) where
push lua m = do
newtable lua
mapM_ (uncurry $ addValue lua) $ M.toList m
peek lua idx = fmap M.fromList <$> keyValuePairs lua idx
valuetype _ = TTABLE
-- | Try reading the value under the given index as a list of key-value pairs.
keyValuePairs :: (StackValue a, StackValue b)
=> LuaState -> Int -> IO (Maybe [(a, b)])
keyValuePairs lua idx = do
pushnil lua
sequence <$> remainingPairs
where
remainingPairs = do
res <- nextPair
case res of
Nothing -> return []
Just a -> (a:) <$> remainingPairs
nextPair :: (StackValue a, StackValue b) => IO (Maybe (Maybe (a,b)))
nextPair = do
hasNext <- next lua (idx `adjustIndexBy` 1)
if hasNext
then do
val <- peek lua (-1)
key <- peek lua (-2)
pop lua 1 -- removes the value, keeps the key
return $ Just <$> ((,) <$> key <*> val)
else do
return Nothing
-- | Helper class for pushing a single value to the stack via a lua function.
-- See @pushViaCall@.
class PushViaCall a where
pushViaCall' :: LuaState -> String -> IO () -> Int -> a
instance PushViaCall (IO ()) where
pushViaCall' lua fn pushArgs num = do
getglobal2 lua fn
pushArgs
call lua num 1
instance (StackValue a, PushViaCall b) => PushViaCall (a -> b) where
pushViaCall' lua fn pushArgs num x =
pushViaCall' lua fn (pushArgs *> push lua x) (num + 1)
-- | Push an value to the stack via a lua function. The lua function is called
-- with all arguments that are passed to this function and is expected to return
-- a single value.
pushViaCall :: PushViaCall a => LuaState -> String -> a
pushViaCall lua fn = pushViaCall' lua fn (return ()) 0
-- | Call a pandoc element constructor within lua, passing all given arguments.
pushViaConstructor :: PushViaCall a => LuaState -> String -> a
pushViaConstructor lua pandocFn = pushViaCall lua ("pandoc." ++ pandocFn)
-- | Return the value at the given index as inline if possible.
peekInline :: LuaState -> Int -> IO (Maybe Inline)
peekInline lua idx = do

56
src/Text/Pandoc/Lua/Util.hs
View file

@ -16,6 +16,7 @@ You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-# LANGUAGE FlexibleInstances #-}
{- |
Module : Text.Pandoc.Lua.Util
Copyright : © 2012–2016 John MacFarlane,
@ -35,11 +36,15 @@ module Text.Pandoc.Lua.Util
, getRawInt
, setRawInt
, addRawInt
, keyValuePairs
, PushViaCall
, pushViaCall
, pushViaConstructor
) where
import Scripting.Lua
( LuaState, StackValue(..)
, gettable, pop, rawgeti, rawseti, settable
, call, getglobal2, gettable, next, pop, pushnil, rawgeti, rawseti, settable
)
-- | Adjust the stack index, assuming that @n@ new elements have been pushed on
@ -84,3 +89,52 @@ setRawInt lua idx key value = do
-- | Set numeric key/value in table at the top of the stack.
addRawInt :: StackValue a => LuaState -> Int -> a -> IO ()
addRawInt lua = setRawInt lua (-1)
-- | Try reading the table under the given index as a list of key-value pairs.
keyValuePairs :: (StackValue a, StackValue b)
=> LuaState -> Int -> IO (Maybe [(a, b)])
keyValuePairs lua idx = do
pushnil lua
sequence <$> remainingPairs
where
remainingPairs = do
res <- nextPair
case res of
Nothing -> return []
Just a -> (a:) <$> remainingPairs
nextPair :: (StackValue a, StackValue b) => IO (Maybe (Maybe (a,b)))
nextPair = do
hasNext <- next lua (idx `adjustIndexBy` 1)
if hasNext
then do
val <- peek lua (-1)
key <- peek lua (-2)
pop lua 1 -- removes the value, keeps the key
return $ Just <$> ((,) <$> key <*> val)
else do
return Nothing
-- | Helper class for pushing a single value to the stack via a lua function.
-- See @pushViaCall@.
class PushViaCall a where
pushViaCall' :: LuaState -> String -> IO () -> Int -> a
instance PushViaCall (IO ()) where
pushViaCall' lua fn pushArgs num = do
getglobal2 lua fn
pushArgs
call lua num 1
instance (StackValue a, PushViaCall b) => PushViaCall (a -> b) where
pushViaCall' lua fn pushArgs num x =
pushViaCall' lua fn (pushArgs *> push lua x) (num + 1)
-- | Push an value to the stack via a lua function. The lua function is called
-- with all arguments that are passed to this function and is expected to return
-- a single value.
pushViaCall :: PushViaCall a => LuaState -> String -> a
pushViaCall lua fn = pushViaCall' lua fn (return ()) 0
-- | Call a pandoc element constructor within lua, passing all given arguments.
pushViaConstructor :: PushViaCall a => LuaState -> String -> a
pushViaConstructor lua pandocFn = pushViaCall lua ("pandoc." ++ pandocFn)

31
src/Text/Pandoc/Writers/Custom.hs
View file

@ -47,6 +47,7 @@ import Scripting.Lua (LuaState, StackValue, callfunc)
import qualified Scripting.Lua as Lua
import Text.Pandoc.Lua.Compat ( loadstring )
import Text.Pandoc.Lua.Util ( addValue )
import Text.Pandoc.Lua.SharedInstances ()
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.Templates
@ -59,41 +60,11 @@ attrToMap (id',classes,keyvals) = M.fromList
: ("class", unwords classes)
: keyvals
#if MIN_VERSION_base(4,8,0)
instance {-# OVERLAPS #-} StackValue [Char] where
#else
instance StackValue [Char] where
#endif
push lua cs = Lua.push lua (UTF8.fromString cs)
peek lua i = do
res <- Lua.peek lua i
return $ UTF8.toString `fmap` res
valuetype _ = Lua.TSTRING
instance StackValue Format where
push lua (Format f) = Lua.push lua (map toLower f)
peek l n = fmap Format `fmap` Lua.peek l n
valuetype _ = Lua.TSTRING
instance (StackValue a, StackValue b) => StackValue (M.Map a b) where
push lua m = do
let xs = M.toList m
Lua.createtable lua (length xs + 1) 0
let addValue (k, v) = Lua.push lua k >> Lua.push lua v >>
Lua.rawset lua (-3)
mapM_ addValue xs
peek _ _ = undefined -- not needed for our purposes
valuetype _ = Lua.TTABLE
instance (StackValue a, StackValue b) => StackValue (a,b) where
push lua (k,v) = do
Lua.createtable lua 2 0
Lua.push lua k
Lua.push lua v
Lua.rawset lua (-3)
peek _ _ = undefined -- not needed for our purposes
valuetype _ = Lua.TTABLE
#if MIN_VERSION_base(4,8,0)
instance {-# OVERLAPS #-} StackValue [Inline] where
#else