From 0add4253e6dc5c3cdca894c5bb312428fe3d31b3 Mon Sep 17 00:00:00 2001 From: Albert Krewinkel Date: Fri, 14 Apr 2017 19:07:55 +0200 Subject: Avoid repeating StackValue instances definitions 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. --- pandoc.cabal | 1 + src/Text/Pandoc/Lua/SharedInstances.hs | 106 +++++++++++++++++++++++++++ src/Text/Pandoc/Lua/StackInstances.hs | 128 +-------------------------------- src/Text/Pandoc/Lua/Util.hs | 56 ++++++++++++++- src/Text/Pandoc/Writers/Custom.hs | 31 +------- 5 files changed, 166 insertions(+), 156 deletions(-) create mode 100644 src/Text/Pandoc/Lua/SharedInstances.hs diff --git a/pandoc.cabal b/pandoc.cabal index 255a4ab65..f8cc78c64 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -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, diff --git a/src/Text/Pandoc/Lua/SharedInstances.hs b/src/Text/Pandoc/Lua/SharedInstances.hs new file mode 100644 index 000000000..02438b93b --- /dev/null +++ b/src/Text/Pandoc/Lua/SharedInstances.hs @@ -0,0 +1,106 @@ +{- +Copyright © 2012-2016 John MacFarlane + 2017 Albert Krewinkel + +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 + 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 diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs index 8e26ece55..8af7f78c0 100644 --- a/src/Text/Pandoc/Lua/StackInstances.hs +++ b/src/Text/Pandoc/Lua/StackInstances.hs @@ -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 diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs index 9c5625c3c..f0b87c231 100644 --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -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) diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index b06dd0c8a..ce90e4834 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -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 -- cgit v1.2.3