{- Copyright © 2012-2015 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.StackInstances Copyright : Copyright © 2017 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel Stability : alpha StackValue instances for pandoc types. -} module Text.Pandoc.Lua.StackInstances () where import Data.Aeson ( FromJSON(..), ToJSON(..), Result(..), Value, fromJSON ) import Scripting.Lua ( LuaState, StackValue(..), newtable, pop, rawget, rawset ) import Scripting.Lua.Aeson () import Text.Pandoc.Definition ( Block(..), Inline(..), Meta(..), Pandoc(..) ) import qualified Scripting.Lua as Lua import qualified Text.Pandoc.UTF8 as UTF8 maybeFromJson :: (FromJSON a) => Maybe Value -> Maybe a maybeFromJson mv = fromJSON <$> mv >>= \case Success x -> Just x _ -> Nothing instance StackValue Pandoc where push lua (Pandoc meta blocks) = do newtable lua setField lua (-1) "blocks" blocks setField lua (-1) "meta" meta peek lua idx = do blocks <- getField lua idx "blocks" meta <- getField lua idx "meta" return $ Pandoc <$> meta <*> blocks valuetype _ = Lua.TTABLE instance StackValue Meta where push lua = push lua . toJSON peek lua = fmap maybeFromJson . peek lua valuetype _ = Lua.TTABLE instance StackValue Block where push lua = \case BlockQuote blcks -> pushTagged lua "BlockQuote" blcks BulletList items -> pushTagged lua "BulletList" items HorizontalRule -> pushTagged' lua "HorizontalRule" LineBlock blcks -> pushTagged lua "LineBlock" blcks Null -> pushTagged' lua "Null" Para blcks -> pushTagged lua "Para" blcks Plain blcks -> pushTagged lua "Plain" blcks -- fall back to conversion via aeson's Value x -> push lua (toJSON x) peek lua i = peekBlock lua i valuetype _ = Lua.TTABLE instance StackValue Inline where push lua = \case Emph inlns -> pushTagged lua "Emph" inlns LineBreak -> pushTagged' lua "LineBreak" Note blcks -> pushTagged lua "Note" blcks SmallCaps inlns -> pushTagged lua "SmallCaps" inlns SoftBreak -> pushTagged' lua "SoftBreak" Space -> pushTagged' lua "Space" Str s -> pushTagged lua "Str" s Strikeout inlns -> pushTagged lua "Strikeout" inlns Strong inlns -> pushTagged lua "Strong" inlns Subscript inlns -> pushTagged lua "Subscript" inlns Superscript inlns -> pushTagged lua "Superscript" inlns x -> push lua (toJSON x) peek = peekInline valuetype _ = Lua.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 _ = Lua.TSTRING -- | Push a value to the lua stack, tagged with a given string. This currently -- creates a structure equivalent to what the JSONified value would look like -- when pushed to lua. pushTagged :: StackValue a => LuaState -> String -> a -> IO () pushTagged lua tag value = do newtable lua setField lua (-1) "t" tag setField lua (-1) "c" value pushTagged' :: LuaState -> String -> IO () pushTagged' lua tag = do newtable lua push lua "t" push lua tag rawset lua (-3) -- | Return the value at the given index as inline if possible. peekInline :: LuaState -> Int -> IO (Maybe Inline) peekInline lua idx = do tag <- getField lua idx "t" case tag of Nothing -> return Nothing Just t -> case t of "Emph" -> fmap Emph <$> elementContent "LineBreak" -> return (Just LineBreak) "Note" -> fmap Note <$> elementContent "SmallCaps" -> fmap SmallCaps <$> elementContent "SoftBreak" -> return (Just SoftBreak) "Space" -> return (Just Space) "Str" -> fmap Str <$> elementContent "Strikeout" -> fmap Strikeout <$> elementContent "Strong" -> fmap Strong <$> elementContent "Subscript" -> fmap Subscript <$> elementContent "Superscript"-> fmap Superscript <$> elementContent -- fall back to construction via aeson's Value _ -> maybeFromJson <$> peek lua idx where -- Get the contents of an AST element. elementContent :: StackValue a => IO (Maybe a) elementContent = getField lua idx "c" -- | Return the value at the given index as block if possible. peekBlock :: LuaState -> Int -> IO (Maybe Block) peekBlock lua idx = do tag <- getField lua idx "t" case tag of Nothing -> return Nothing Just t -> case t of "BlockQuote" -> fmap BlockQuote <$> elementContent "BulletList" -> fmap BulletList <$> elementContent "HorizontalRule" -> return (Just HorizontalRule) "LineBlock" -> fmap LineBlock <$> elementContent "Null" -> return (Just Null) "Para" -> fmap Para <$> elementContent "Plain" -> fmap Plain <$> elementContent -- fall back to construction via aeson's Value _ -> maybeFromJson <$> peek lua idx where -- Get the contents of an AST element. elementContent :: StackValue a => IO (Maybe a) elementContent = getField lua idx "c" -- | Adjust the stack index, assuming that @n@ new elements have been pushed on -- the stack. adjustIndexBy :: Int -> Int -> Int adjustIndexBy idx n = if idx < 0 then idx - n else idx -- | Get value behind key from table at given index. getField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> IO (Maybe b) getField lua idx key = do push lua key rawget lua (idx `adjustIndexBy` 1) peek lua (-1) <* pop lua 1 -- | Set value for key for table at the given index setField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO () setField lua idx key value = do push lua key push lua value rawset lua (idx `adjustIndexBy` 2)