From 331d6224a146f79a6f0a1bf6bff1f05b645641fb Mon Sep 17 00:00:00 2001 From: Albert Krewinkel Date: Sat, 16 Feb 2019 12:08:22 +0100 Subject: T.P.Lua: split StackInstances into smaller Marshaling modules --- src/Text/Pandoc/Lua.hs | 2 +- src/Text/Pandoc/Lua/Filter.hs | 2 +- src/Text/Pandoc/Lua/Global.hs | 2 +- src/Text/Pandoc/Lua/Marshaling.hs | 16 + src/Text/Pandoc/Lua/Marshaling/AST.hs | 312 ++++++++++++++++ src/Text/Pandoc/Lua/Marshaling/AnyValue.hs | 26 ++ src/Text/Pandoc/Lua/Marshaling/CommonState.hs | 102 +++++ src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs | 79 ++++ src/Text/Pandoc/Lua/Module/MediaBag.hs | 2 +- src/Text/Pandoc/Lua/Module/Pandoc.hs | 2 +- src/Text/Pandoc/Lua/Module/Utils.hs | 2 +- src/Text/Pandoc/Lua/StackInstances.hs | 474 ------------------------ 12 files changed, 541 insertions(+), 480 deletions(-) create mode 100644 src/Text/Pandoc/Lua/Marshaling.hs create mode 100644 src/Text/Pandoc/Lua/Marshaling/AST.hs create mode 100644 src/Text/Pandoc/Lua/Marshaling/AnyValue.hs create mode 100644 src/Text/Pandoc/Lua/Marshaling/CommonState.hs create mode 100644 src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs delete mode 100644 src/Text/Pandoc/Lua/StackInstances.hs (limited to 'src') diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index f7338b776..62278b5d2 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -39,5 +39,5 @@ module Text.Pandoc.Lua import Text.Pandoc.Lua.Filter (runFilterFile) import Text.Pandoc.Lua.Global (Global (..), setGlobals) import Text.Pandoc.Lua.Init (LuaException (..), runLua) -import Text.Pandoc.Lua.StackInstances () +import Text.Pandoc.Lua.Marshaling () diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs index cfd50876a..b2aeade74 100644 --- a/src/Text/Pandoc/Lua/Filter.hs +++ b/src/Text/Pandoc/Lua/Filter.hs @@ -48,7 +48,7 @@ import Data.Foldable (foldrM) import Data.Map (Map) import Foreign.Lua (Lua, Peekable, Pushable) import Text.Pandoc.Definition -import Text.Pandoc.Lua.StackInstances () +import Text.Pandoc.Lua.Marshaling () import Text.Pandoc.Walk (walkM, Walkable) import qualified Data.Map.Strict as Map diff --git a/src/Text/Pandoc/Lua/Global.hs b/src/Text/Pandoc/Lua/Global.hs index 445ce9e04..b7e8884f4 100644 --- a/src/Text/Pandoc/Lua/Global.hs +++ b/src/Text/Pandoc/Lua/Global.hs @@ -41,7 +41,7 @@ import Foreign.Lua.Userdata ( ensureUserdataMetatable, pushAnyWithMetatable import Paths_pandoc (version) import Text.Pandoc.Class (CommonState) import Text.Pandoc.Definition (Pandoc (Pandoc), pandocTypesVersion) -import Text.Pandoc.Lua.StackInstances () +import Text.Pandoc.Lua.Marshaling () import Text.Pandoc.Lua.Util (addFunction) import Text.Pandoc.Options (ReaderOptions) diff --git a/src/Text/Pandoc/Lua/Marshaling.hs b/src/Text/Pandoc/Lua/Marshaling.hs new file mode 100644 index 000000000..cc0451c09 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshaling.hs @@ -0,0 +1,16 @@ +{- | + Module : Text.Pandoc.Lua.Marshaling + Copyright : © 2012-2019 John MacFarlane + © 2017-2019 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel + Stability : alpha + +Lua marshaling (pushing) and unmarshaling (peeking) instances. +-} +module Text.Pandoc.Lua.Marshaling () where + +import Text.Pandoc.Lua.Marshaling.AST () +import Text.Pandoc.Lua.Marshaling.CommonState () +import Text.Pandoc.Lua.Marshaling.ReaderOptions () diff --git a/src/Text/Pandoc/Lua/Marshaling/AST.hs b/src/Text/Pandoc/Lua/Marshaling/AST.hs new file mode 100644 index 000000000..f18754ac2 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshaling/AST.hs @@ -0,0 +1,312 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{- | + Module : Text.Pandoc.Lua.Marshaling.AST + Copyright : © 2012-2019 John MacFarlane + © 2017-2019 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel + Stability : alpha + +Marshaling/unmarshaling instances for document AST elements. +-} +module Text.Pandoc.Lua.Marshaling.AST () where + +import Prelude +import Control.Applicative ((<|>)) +import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) +import Foreign.Lua.Userdata ( ensureUserdataMetatable, pushAnyWithMetatable + , metatableName) +import Text.Pandoc.Definition +import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor) +import Text.Pandoc.Lua.Marshaling.CommonState () +import Text.Pandoc.Shared (Element (Blk, Sec)) + +import qualified Foreign.Lua as Lua +import qualified Text.Pandoc.Lua.Util as LuaUtil + +instance Pushable Pandoc where + push (Pandoc meta blocks) = + pushViaConstructor "Pandoc" blocks meta + +instance Peekable Pandoc where + peek idx = defineHowTo "get Pandoc value" $ do + blocks <- LuaUtil.rawField idx "blocks" + meta <- LuaUtil.rawField idx "meta" + return $ Pandoc meta blocks + +instance Pushable Meta where + push (Meta mmap) = + pushViaConstructor "Meta" mmap +instance Peekable Meta where + peek idx = defineHowTo "get Meta value" $ + Meta <$> Lua.peek idx + +instance Pushable MetaValue where + push = pushMetaValue +instance Peekable MetaValue where + peek = peekMetaValue + +instance Pushable Block where + push = pushBlock + +instance Peekable Block where + peek = peekBlock + +-- Inline +instance Pushable Inline where + push = pushInline + +instance Peekable Inline where + peek = peekInline + +-- Citation +instance Pushable Citation where + push (Citation cid prefix suffix mode noteNum hash) = + pushViaConstructor "Citation" cid mode prefix suffix noteNum hash + +instance Peekable Citation where + peek idx = do + id' <- LuaUtil.rawField idx "id" + prefix <- LuaUtil.rawField idx "prefix" + suffix <- LuaUtil.rawField idx "suffix" + mode <- LuaUtil.rawField idx "mode" + num <- LuaUtil.rawField idx "note_num" + hash <- LuaUtil.rawField idx "hash" + return $ Citation id' prefix suffix mode num hash + +instance Pushable Alignment where + push = Lua.push . show +instance Peekable Alignment where + peek = Lua.peekRead + +instance Pushable CitationMode where + push = Lua.push . show +instance Peekable CitationMode where + peek = Lua.peekRead + +instance Pushable Format where + push (Format f) = Lua.push f +instance Peekable Format where + peek idx = Format <$> Lua.peek idx + +instance Pushable ListNumberDelim where + push = Lua.push . show +instance Peekable ListNumberDelim where + peek = Lua.peekRead + +instance Pushable ListNumberStyle where + push = Lua.push . show +instance Peekable ListNumberStyle where + peek = Lua.peekRead + +instance Pushable MathType where + push = Lua.push . show +instance Peekable MathType where + peek = Lua.peekRead + +instance Pushable QuoteType where + push = Lua.push . show +instance Peekable QuoteType where + peek = Lua.peekRead + +-- | Push an meta value element to the top of the lua stack. +pushMetaValue :: MetaValue -> Lua () +pushMetaValue = \case + MetaBlocks blcks -> pushViaConstructor "MetaBlocks" blcks + MetaBool bool -> Lua.push bool + MetaInlines inlns -> pushViaConstructor "MetaInlines" inlns + MetaList metalist -> pushViaConstructor "MetaList" metalist + MetaMap metamap -> pushViaConstructor "MetaMap" metamap + MetaString str -> Lua.push str + +-- | Interpret the value at the given stack index as meta value. +peekMetaValue :: StackIndex -> Lua MetaValue +peekMetaValue idx = defineHowTo "get MetaValue" $ do + -- Get the contents of an AST element. + let elementContent :: Peekable a => Lua a + elementContent = Lua.peek idx + luatype <- Lua.ltype idx + case luatype of + Lua.TypeBoolean -> MetaBool <$> Lua.peek idx + Lua.TypeString -> MetaString <$> Lua.peek idx + Lua.TypeTable -> do + tag <- Lua.try $ LuaUtil.getTag idx + case tag of + Right "MetaBlocks" -> MetaBlocks <$> elementContent + Right "MetaBool" -> MetaBool <$> elementContent + Right "MetaMap" -> MetaMap <$> elementContent + Right "MetaInlines" -> MetaInlines <$> elementContent + Right "MetaList" -> MetaList <$> elementContent + Right "MetaString" -> MetaString <$> elementContent + Right t -> Lua.throwException ("Unknown meta tag: " <> t) + Left _ -> do + -- no meta value tag given, try to guess. + len <- Lua.rawlen idx + if len <= 0 + then MetaMap <$> Lua.peek idx + else (MetaInlines <$> Lua.peek idx) + <|> (MetaBlocks <$> Lua.peek idx) + <|> (MetaList <$> Lua.peek idx) + _ -> Lua.throwException "could not get meta value" + +-- | Push an block element to the top of the lua stack. +pushBlock :: Block -> Lua () +pushBlock = \case + BlockQuote blcks -> pushViaConstructor "BlockQuote" blcks + BulletList items -> pushViaConstructor "BulletList" items + CodeBlock attr code -> pushViaConstructor "CodeBlock" code (LuaAttr attr) + DefinitionList items -> pushViaConstructor "DefinitionList" items + Div attr blcks -> pushViaConstructor "Div" blcks (LuaAttr attr) + Header lvl attr inlns -> pushViaConstructor "Header" lvl inlns (LuaAttr attr) + HorizontalRule -> pushViaConstructor "HorizontalRule" + LineBlock blcks -> pushViaConstructor "LineBlock" blcks + OrderedList lstAttr list -> pushViaConstructor "OrderedList" list + (LuaListAttributes lstAttr) + Null -> pushViaConstructor "Null" + Para blcks -> pushViaConstructor "Para" blcks + Plain blcks -> pushViaConstructor "Plain" blcks + RawBlock f cs -> pushViaConstructor "RawBlock" f cs + Table capt aligns widths headers rows -> + pushViaConstructor "Table" capt aligns widths headers rows + +-- | Return the value at the given index as block if possible. +peekBlock :: StackIndex -> Lua Block +peekBlock idx = defineHowTo "get Block value" $ do + tag <- LuaUtil.getTag idx + case tag of + "BlockQuote" -> BlockQuote <$> elementContent + "BulletList" -> BulletList <$> elementContent + "CodeBlock" -> withAttr CodeBlock <$> elementContent + "DefinitionList" -> DefinitionList <$> elementContent + "Div" -> withAttr Div <$> elementContent + "Header" -> (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst) + <$> elementContent + "HorizontalRule" -> return HorizontalRule + "LineBlock" -> LineBlock <$> elementContent + "OrderedList" -> (\(LuaListAttributes lstAttr, lst) -> + OrderedList lstAttr lst) + <$> elementContent + "Null" -> return Null + "Para" -> Para <$> elementContent + "Plain" -> Plain <$> elementContent + "RawBlock" -> uncurry RawBlock <$> elementContent + "Table" -> (\(capt, aligns, widths, headers, body) -> + Table capt aligns widths headers body) + <$> elementContent + _ -> Lua.throwException ("Unknown block type: " <> tag) + where + -- Get the contents of an AST element. + elementContent :: Peekable a => Lua a + elementContent = LuaUtil.rawField idx "c" + +-- | Push an inline element to the top of the lua stack. +pushInline :: Inline -> Lua () +pushInline = \case + Cite citations lst -> pushViaConstructor "Cite" lst citations + Code attr lst -> pushViaConstructor "Code" lst (LuaAttr attr) + Emph inlns -> pushViaConstructor "Emph" inlns + Image attr alt (src,tit) -> pushViaConstructor "Image" alt src tit (LuaAttr attr) + LineBreak -> pushViaConstructor "LineBreak" + Link attr lst (src,tit) -> pushViaConstructor "Link" lst src tit (LuaAttr attr) + Note blcks -> pushViaConstructor "Note" blcks + Math mty str -> pushViaConstructor "Math" mty str + Quoted qt inlns -> pushViaConstructor "Quoted" qt inlns + RawInline f cs -> pushViaConstructor "RawInline" f cs + SmallCaps inlns -> pushViaConstructor "SmallCaps" inlns + SoftBreak -> pushViaConstructor "SoftBreak" + Space -> pushViaConstructor "Space" + Span attr inlns -> pushViaConstructor "Span" inlns (LuaAttr attr) + Str str -> pushViaConstructor "Str" str + Strikeout inlns -> pushViaConstructor "Strikeout" inlns + Strong inlns -> pushViaConstructor "Strong" inlns + Subscript inlns -> pushViaConstructor "Subscript" inlns + Superscript inlns -> pushViaConstructor "Superscript" inlns + +-- | Return the value at the given index as inline if possible. +peekInline :: StackIndex -> Lua Inline +peekInline idx = defineHowTo "get Inline value" $ do + tag <- LuaUtil.getTag idx + case tag of + "Cite" -> uncurry Cite <$> elementContent + "Code" -> withAttr Code <$> elementContent + "Emph" -> Emph <$> elementContent + "Image" -> (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt) + <$> elementContent + "Link" -> (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt) + <$> elementContent + "LineBreak" -> return LineBreak + "Note" -> Note <$> elementContent + "Math" -> uncurry Math <$> elementContent + "Quoted" -> uncurry Quoted <$> elementContent + "RawInline" -> uncurry RawInline <$> elementContent + "SmallCaps" -> SmallCaps <$> elementContent + "SoftBreak" -> return SoftBreak + "Space" -> return Space + "Span" -> withAttr Span <$> elementContent + "Str" -> Str <$> elementContent + "Strikeout" -> Strikeout <$> elementContent + "Strong" -> Strong <$> elementContent + "Subscript" -> Subscript <$> elementContent + "Superscript"-> Superscript <$> elementContent + _ -> Lua.throwException ("Unknown inline type: " <> tag) + where + -- Get the contents of an AST element. + elementContent :: Peekable a => Lua a + elementContent = LuaUtil.rawField idx "c" + +withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b +withAttr f (attributes, x) = f (fromLuaAttr attributes) x + +-- | Wrapper for Attr +newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr } + +instance Pushable LuaAttr where + push (LuaAttr (id', classes, kv)) = + pushViaConstructor "Attr" id' classes kv + +instance Peekable LuaAttr where + peek idx = defineHowTo "get Attr value" (LuaAttr <$> Lua.peek idx) + +-- | Wrapper for ListAttributes +newtype LuaListAttributes = LuaListAttributes ListAttributes + +instance Pushable LuaListAttributes where + push (LuaListAttributes (start, style, delimiter)) = + pushViaConstructor "ListAttributes" start style delimiter + +instance Peekable LuaListAttributes where + peek = defineHowTo "get ListAttributes value" . + fmap LuaListAttributes . Lua.peek + +-- +-- Hierarchical elements +-- +instance Pushable Element where + push (Blk blk) = Lua.push blk + push sec = pushAnyWithMetatable pushElementMetatable sec + where + pushElementMetatable = ensureUserdataMetatable (metatableName sec) $ + LuaUtil.addFunction "__index" indexElement + +instance Peekable Element where + peek idx = Lua.ltype idx >>= \case + Lua.TypeUserdata -> Lua.peekAny idx + _ -> Blk <$> Lua.peek idx + +indexElement :: Element -> String -> Lua Lua.NumResults +indexElement = \case + (Blk _) -> const (1 <$ Lua.pushnil) -- this shouldn't happen + (Sec lvl num attr label contents) -> fmap (return 1) . \case + "level" -> Lua.push lvl + "numbering" -> Lua.push num + "attr" -> Lua.push (LuaAttr attr) + "label" -> Lua.push label + "contents" -> Lua.push contents + "tag" -> Lua.push "Sec" + "t" -> Lua.push "Sec" + _ -> Lua.pushnil diff --git a/src/Text/Pandoc/Lua/Marshaling/AnyValue.hs b/src/Text/Pandoc/Lua/Marshaling/AnyValue.hs new file mode 100644 index 000000000..a5ff3f2ba --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshaling/AnyValue.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | + Module : Text.Pandoc.Lua.Marshaling.AnyValue + Copyright : © 2017-2019 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel + Stability : alpha + +Helper type to work with raw Lua stack indices instead of unmarshaled +values. + +TODO: Most of this module should be abstracted, factored out, and go +into HsLua. +-} +module Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) where + +import Prelude +import Foreign.Lua (Peekable (peek), StackIndex) + +-- | Dummy type to allow values of arbitrary Lua type. This just wraps +-- stack indices, using it requires extra care. +newtype AnyValue = AnyValue StackIndex + +instance Peekable AnyValue where + peek = return . AnyValue diff --git a/src/Text/Pandoc/Lua/Marshaling/CommonState.hs b/src/Text/Pandoc/Lua/Marshaling/CommonState.hs new file mode 100644 index 000000000..eed1500ec --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshaling/CommonState.hs @@ -0,0 +1,102 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{- | + Module : Text.Pandoc.Lua.Marshaling.CommonState + Copyright : © 2012-2019 John MacFarlane + © 2017-2019 Albert Krewinkel + License : GNU GPL, version 2 or above + Maintainer : Albert Krewinkel + Stability : alpha + +Instances to marshal (push) and unmarshal (peek) the common state. +-} +module Text.Pandoc.Lua.Marshaling.CommonState () where + +import Prelude +import Foreign.Lua (Lua, Peekable, Pushable) +import Foreign.Lua.Types.Peekable (reportValueOnFailure) +import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable, + toAnyWithName) +import Text.Pandoc.Class (CommonState (..)) +import Text.Pandoc.Logging (LogMessage, showLogMessage) +import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) + +import qualified Data.Map as Map +import qualified Foreign.Lua as Lua +import qualified Text.Pandoc.Lua.Util as LuaUtil + +-- | Name used by Lua for the @CommonState@ type. +commonStateTypeName :: String +commonStateTypeName = "Pandoc CommonState" + +instance Peekable CommonState where + peek idx = reportValueOnFailure commonStateTypeName + (`toAnyWithName` commonStateTypeName) idx + +instance Pushable CommonState where + push st = pushAnyWithMetatable pushCommonStateMetatable st + where + pushCommonStateMetatable = ensureUserdataMetatable commonStateTypeName $ do + LuaUtil.addFunction "__index" indexCommonState + LuaUtil.addFunction "__pairs" pairsCommonState + +indexCommonState :: CommonState -> AnyValue -> Lua Lua.NumResults +indexCommonState st (AnyValue idx) = Lua.ltype idx >>= \case + Lua.TypeString -> 1 <$ (Lua.peek idx >>= pushField) + _ -> 1 <$ Lua.pushnil + where + pushField :: String -> Lua () + pushField name = case lookup name commonStateFields of + Just pushValue -> pushValue st + Nothing -> Lua.pushnil + +pairsCommonState :: CommonState -> Lua Lua.NumResults +pairsCommonState st = do + Lua.pushHaskellFunction nextFn + Lua.pushnil + Lua.pushnil + return 3 + where + nextFn :: AnyValue -> AnyValue -> Lua Lua.NumResults + nextFn _ (AnyValue idx) = + Lua.ltype idx >>= \case + Lua.TypeNil -> case commonStateFields of + [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) + (key, pushValue):_ -> 2 <$ (Lua.push key *> pushValue st) + Lua.TypeString -> do + key <- Lua.peek idx + case tail $ dropWhile ((/= key) . fst) commonStateFields of + [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) + (nextKey, pushValue):_ -> 2 <$ (Lua.push nextKey *> pushValue st) + _ -> 2 <$ (Lua.pushnil *> Lua.pushnil) + +commonStateFields :: [(String, CommonState -> Lua ())] +commonStateFields = + [ ("input_files", Lua.push . stInputFiles) + , ("output_file", Lua.push . Lua.Optional . stOutputFile) + , ("log", Lua.push . stLog) + , ("request_headers", Lua.push . Map.fromList . stRequestHeaders) + , ("resource_path", Lua.push . stResourcePath) + , ("source_url", Lua.push . Lua.Optional . stSourceURL) + , ("user_data_dir", Lua.push . Lua.Optional . stUserDataDir) + , ("trace", Lua.push . stTrace) + , ("verbosity", Lua.push . show . stVerbosity) + ] + +-- | Name used by Lua for the @CommonState@ type. +logMessageTypeName :: String +logMessageTypeName = "Pandoc LogMessage" + +instance Peekable LogMessage where + peek idx = reportValueOnFailure logMessageTypeName + (`toAnyWithName` logMessageTypeName) idx + +instance Pushable LogMessage where + push msg = pushAnyWithMetatable pushLogMessageMetatable msg + where + pushLogMessageMetatable = ensureUserdataMetatable logMessageTypeName $ + LuaUtil.addFunction "__tostring" tostringLogMessage + +tostringLogMessage :: LogMessage -> Lua String +tostringLogMessage = return . showLogMessage diff --git a/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs b/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs new file mode 100644 index 000000000..5395f6fc8 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | + Module : Text.Pandoc.Lua.Marshaling.ReaderOptions + Copyright : © 2012-2019 John MacFarlane + © 2017-2019 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel + Stability : alpha + +Marshaling instance for ReaderOptions and its components. +-} +module Text.Pandoc.Lua.Marshaling.ReaderOptions () where + +import Prelude +import Data.Data (showConstr, toConstr) +import Foreign.Lua (Lua, Pushable) +import Text.Pandoc.Extensions (Extensions) +import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) +import Text.Pandoc.Lua.Marshaling.CommonState () +import Text.Pandoc.Options (ReaderOptions (..), TrackChanges) + +import qualified Data.Set as Set +import qualified Foreign.Lua as Lua +import qualified Text.Pandoc.Lua.Util as LuaUtil + +-- +-- Reader Options +-- +instance Pushable Extensions where + push exts = Lua.push (show exts) + +instance Pushable TrackChanges where + push = Lua.push . showConstr . toConstr + +instance Pushable ReaderOptions where + push ro = do + let ReaderOptions + (extensions :: Extensions) + (standalone :: Bool) + (columns :: Int) + (tabStop :: Int) + (indentedCodeClasses :: [String]) + (abbreviations :: Set.Set String) + (defaultImageExtension :: String) + (trackChanges :: TrackChanges) + (stripComments :: Bool) + = ro + Lua.newtable + LuaUtil.addField "extensions" extensions + LuaUtil.addField "standalone" standalone + LuaUtil.addField "columns" columns + LuaUtil.addField "tab_stop" tabStop + LuaUtil.addField "indented_code_classes" indentedCodeClasses + LuaUtil.addField "abbreviations" abbreviations + LuaUtil.addField "default_image_extension" defaultImageExtension + LuaUtil.addField "track_changes" trackChanges + LuaUtil.addField "strip_comments" stripComments + + -- add metatable + let indexReaderOptions :: AnyValue -> AnyValue -> Lua Lua.NumResults + indexReaderOptions _tbl (AnyValue key) = do + Lua.ltype key >>= \case + Lua.TypeString -> Lua.peek key >>= \case + "defaultImageExtension" -> Lua.push defaultImageExtension + "indentedCodeClasses" -> Lua.push indentedCodeClasses + "stripComments" -> Lua.push stripComments + "tabStop" -> Lua.push tabStop + "trackChanges" -> Lua.push trackChanges + _ -> Lua.pushnil + _ -> Lua.pushnil + return 1 + Lua.newtable + LuaUtil.addFunction "__index" indexReaderOptions + Lua.setmetatable (Lua.nthFromTop 2) diff --git a/src/Text/Pandoc/Lua/Module/MediaBag.hs b/src/Text/Pandoc/Lua/Module/MediaBag.hs index eabab11ed..a9813b958 100644 --- a/src/Text/Pandoc/Lua/Module/MediaBag.hs +++ b/src/Text/Pandoc/Lua/Module/MediaBag.hs @@ -36,7 +36,7 @@ import Data.Maybe (fromMaybe) import Foreign.Lua (Lua, NumResults, Optional, liftIO) import Text.Pandoc.Class (CommonState (..), fetchItem, putCommonState, runIOorExplode, setMediaBag) -import Text.Pandoc.Lua.StackInstances () +import Text.Pandoc.Lua.Marshaling () import Text.Pandoc.Lua.Util (addFunction) import Text.Pandoc.MIME (MimeType) diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs index 30e36af9d..b28b112d5 100644 --- a/src/Text/Pandoc/Lua/Module/Pandoc.hs +++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs @@ -41,7 +41,7 @@ import System.Exit (ExitCode (..)) import Text.Pandoc.Class (runIO) import Text.Pandoc.Definition (Block, Inline) import Text.Pandoc.Lua.Filter (walkInlines, walkBlocks, LuaFilter) -import Text.Pandoc.Lua.StackInstances () +import Text.Pandoc.Lua.Marshaling () import Text.Pandoc.Walk (Walkable) import Text.Pandoc.Options (ReaderOptions (readerExtensions)) import Text.Pandoc.Process (pipeProcess) diff --git a/src/Text/Pandoc/Lua/Module/Utils.hs b/src/Text/Pandoc/Lua/Module/Utils.hs index 101a33809..c9df996ac 100644 --- a/src/Text/Pandoc/Lua/Module/Utils.hs +++ b/src/Text/Pandoc/Lua/Module/Utils.hs @@ -38,7 +38,7 @@ import Foreign.Lua (Peekable, Lua, NumResults) import Text.Pandoc.Class (runIO, setUserDataDir) import Text.Pandoc.Definition ( Pandoc, Meta, MetaValue (..), Block, Inline , Citation, Attr, ListAttributes) -import Text.Pandoc.Lua.StackInstances () +import Text.Pandoc.Lua.Marshaling () import Text.Pandoc.Lua.Util (addFunction) import qualified Data.Digest.Pure.SHA as SHA diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs deleted file mode 100644 index cf75885af..000000000 --- a/src/Text/Pandoc/Lua/StackInstances.hs +++ /dev/null @@ -1,474 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- -Copyright © 2012-2019 John MacFarlane - 2017-2019 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 --} -{- | - Module : Text.Pandoc.Lua.StackInstances - Copyright : © 2012-2019 John MacFarlane - © 2017-2019 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 Prelude -import Control.Applicative ((<|>)) -import Data.Data (showConstr, toConstr) -import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) -import Foreign.Lua.Types.Peekable (reportValueOnFailure) -import Foreign.Lua.Userdata ( ensureUserdataMetatable, pushAnyWithMetatable - , toAnyWithName, metatableName) -import Text.Pandoc.Class (CommonState (..)) -import Text.Pandoc.Definition -import Text.Pandoc.Extensions (Extensions) -import Text.Pandoc.Logging (LogMessage, showLogMessage) -import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor) -import Text.Pandoc.Options (ReaderOptions (..), TrackChanges) -import Text.Pandoc.Shared (Element (Blk, Sec)) - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Foreign.Lua as Lua -import qualified Text.Pandoc.Lua.Util as LuaUtil - -instance Pushable Pandoc where - push (Pandoc meta blocks) = - pushViaConstructor "Pandoc" blocks meta - -instance Peekable Pandoc where - peek idx = defineHowTo "get Pandoc value" $ do - blocks <- LuaUtil.rawField idx "blocks" - meta <- LuaUtil.rawField idx "meta" - return $ Pandoc meta blocks - -instance Pushable Meta where - push (Meta mmap) = - pushViaConstructor "Meta" mmap -instance Peekable Meta where - peek idx = defineHowTo "get Meta value" $ - Meta <$> Lua.peek idx - -instance Pushable MetaValue where - push = pushMetaValue -instance Peekable MetaValue where - peek = peekMetaValue - -instance Pushable Block where - push = pushBlock - -instance Peekable Block where - peek = peekBlock - --- Inline -instance Pushable Inline where - push = pushInline - -instance Peekable Inline where - peek = peekInline - --- Citation -instance Pushable Citation where - push (Citation cid prefix suffix mode noteNum hash) = - pushViaConstructor "Citation" cid mode prefix suffix noteNum hash - -instance Peekable Citation where - peek idx = do - id' <- LuaUtil.rawField idx "id" - prefix <- LuaUtil.rawField idx "prefix" - suffix <- LuaUtil.rawField idx "suffix" - mode <- LuaUtil.rawField idx "mode" - num <- LuaUtil.rawField idx "note_num" - hash <- LuaUtil.rawField idx "hash" - return $ Citation id' prefix suffix mode num hash - -instance Pushable Alignment where - push = Lua.push . show -instance Peekable Alignment where - peek = Lua.peekRead - -instance Pushable CitationMode where - push = Lua.push . show -instance Peekable CitationMode where - peek = Lua.peekRead - -instance Pushable Format where - push (Format f) = Lua.push f -instance Peekable Format where - peek idx = Format <$> Lua.peek idx - -instance Pushable ListNumberDelim where - push = Lua.push . show -instance Peekable ListNumberDelim where - peek = Lua.peekRead - -instance Pushable ListNumberStyle where - push = Lua.push . show -instance Peekable ListNumberStyle where - peek = Lua.peekRead - -instance Pushable MathType where - push = Lua.push . show -instance Peekable MathType where - peek = Lua.peekRead - -instance Pushable QuoteType where - push = Lua.push . show -instance Peekable QuoteType where - peek = Lua.peekRead - --- | Push an meta value element to the top of the lua stack. -pushMetaValue :: MetaValue -> Lua () -pushMetaValue = \case - MetaBlocks blcks -> pushViaConstructor "MetaBlocks" blcks - MetaBool bool -> Lua.push bool - MetaInlines inlns -> pushViaConstructor "MetaInlines" inlns - MetaList metalist -> pushViaConstructor "MetaList" metalist - MetaMap metamap -> pushViaConstructor "MetaMap" metamap - MetaString str -> Lua.push str - --- | Interpret the value at the given stack index as meta value. -peekMetaValue :: StackIndex -> Lua MetaValue -peekMetaValue idx = defineHowTo "get MetaValue" $ do - -- Get the contents of an AST element. - let elementContent :: Peekable a => Lua a - elementContent = Lua.peek idx - luatype <- Lua.ltype idx - case luatype of - Lua.TypeBoolean -> MetaBool <$> Lua.peek idx - Lua.TypeString -> MetaString <$> Lua.peek idx - Lua.TypeTable -> do - tag <- Lua.try $ LuaUtil.getTag idx - case tag of - Right "MetaBlocks" -> MetaBlocks <$> elementContent - Right "MetaBool" -> MetaBool <$> elementContent - Right "MetaMap" -> MetaMap <$> elementContent - Right "MetaInlines" -> MetaInlines <$> elementContent - Right "MetaList" -> MetaList <$> elementContent - Right "MetaString" -> MetaString <$> elementContent - Right t -> Lua.throwException ("Unknown meta tag: " <> t) - Left _ -> do - -- no meta value tag given, try to guess. - len <- Lua.rawlen idx - if len <= 0 - then MetaMap <$> Lua.peek idx - else (MetaInlines <$> Lua.peek idx) - <|> (MetaBlocks <$> Lua.peek idx) - <|> (MetaList <$> Lua.peek idx) - _ -> Lua.throwException "could not get meta value" - --- | Push an block element to the top of the lua stack. -pushBlock :: Block -> Lua () -pushBlock = \case - BlockQuote blcks -> pushViaConstructor "BlockQuote" blcks - BulletList items -> pushViaConstructor "BulletList" items - CodeBlock attr code -> pushViaConstructor "CodeBlock" code (LuaAttr attr) - DefinitionList items -> pushViaConstructor "DefinitionList" items - Div attr blcks -> pushViaConstructor "Div" blcks (LuaAttr attr) - Header lvl attr inlns -> pushViaConstructor "Header" lvl inlns (LuaAttr attr) - HorizontalRule -> pushViaConstructor "HorizontalRule" - LineBlock blcks -> pushViaConstructor "LineBlock" blcks - OrderedList lstAttr list -> pushViaConstructor "OrderedList" list - (LuaListAttributes lstAttr) - Null -> pushViaConstructor "Null" - Para blcks -> pushViaConstructor "Para" blcks - Plain blcks -> pushViaConstructor "Plain" blcks - RawBlock f cs -> pushViaConstructor "RawBlock" f cs - Table capt aligns widths headers rows -> - pushViaConstructor "Table" capt aligns widths headers rows - --- | Return the value at the given index as block if possible. -peekBlock :: StackIndex -> Lua Block -peekBlock idx = defineHowTo "get Block value" $ do - tag <- LuaUtil.getTag idx - case tag of - "BlockQuote" -> BlockQuote <$> elementContent - "BulletList" -> BulletList <$> elementContent - "CodeBlock" -> withAttr CodeBlock <$> elementContent - "DefinitionList" -> DefinitionList <$> elementContent - "Div" -> withAttr Div <$> elementContent - "Header" -> (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst) - <$> elementContent - "HorizontalRule" -> return HorizontalRule - "LineBlock" -> LineBlock <$> elementContent - "OrderedList" -> (\(LuaListAttributes lstAttr, lst) -> - OrderedList lstAttr lst) - <$> elementContent - "Null" -> return Null - "Para" -> Para <$> elementContent - "Plain" -> Plain <$> elementContent - "RawBlock" -> uncurry RawBlock <$> elementContent - "Table" -> (\(capt, aligns, widths, headers, body) -> - Table capt aligns widths headers body) - <$> elementContent - _ -> Lua.throwException ("Unknown block type: " <> tag) - where - -- Get the contents of an AST element. - elementContent :: Peekable a => Lua a - elementContent = LuaUtil.rawField idx "c" - --- | Push an inline element to the top of the lua stack. -pushInline :: Inline -> Lua () -pushInline = \case - Cite citations lst -> pushViaConstructor "Cite" lst citations - Code attr lst -> pushViaConstructor "Code" lst (LuaAttr attr) - Emph inlns -> pushViaConstructor "Emph" inlns - Image attr alt (src,tit) -> pushViaConstructor "Image" alt src tit (LuaAttr attr) - LineBreak -> pushViaConstructor "LineBreak" - Link attr lst (src,tit) -> pushViaConstructor "Link" lst src tit (LuaAttr attr) - Note blcks -> pushViaConstructor "Note" blcks - Math mty str -> pushViaConstructor "Math" mty str - Quoted qt inlns -> pushViaConstructor "Quoted" qt inlns - RawInline f cs -> pushViaConstructor "RawInline" f cs - SmallCaps inlns -> pushViaConstructor "SmallCaps" inlns - SoftBreak -> pushViaConstructor "SoftBreak" - Space -> pushViaConstructor "Space" - Span attr inlns -> pushViaConstructor "Span" inlns (LuaAttr attr) - Str str -> pushViaConstructor "Str" str - Strikeout inlns -> pushViaConstructor "Strikeout" inlns - Strong inlns -> pushViaConstructor "Strong" inlns - Subscript inlns -> pushViaConstructor "Subscript" inlns - Superscript inlns -> pushViaConstructor "Superscript" inlns - --- | Return the value at the given index as inline if possible. -peekInline :: StackIndex -> Lua Inline -peekInline idx = defineHowTo "get Inline value" $ do - tag <- LuaUtil.getTag idx - case tag of - "Cite" -> uncurry Cite <$> elementContent - "Code" -> withAttr Code <$> elementContent - "Emph" -> Emph <$> elementContent - "Image" -> (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt) - <$> elementContent - "Link" -> (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt) - <$> elementContent - "LineBreak" -> return LineBreak - "Note" -> Note <$> elementContent - "Math" -> uncurry Math <$> elementContent - "Quoted" -> uncurry Quoted <$> elementContent - "RawInline" -> uncurry RawInline <$> elementContent - "SmallCaps" -> SmallCaps <$> elementContent - "SoftBreak" -> return SoftBreak - "Space" -> return Space - "Span" -> withAttr Span <$> elementContent - "Str" -> Str <$> elementContent - "Strikeout" -> Strikeout <$> elementContent - "Strong" -> Strong <$> elementContent - "Subscript" -> Subscript <$> elementContent - "Superscript"-> Superscript <$> elementContent - _ -> Lua.throwException ("Unknown inline type: " <> tag) - where - -- Get the contents of an AST element. - elementContent :: Peekable a => Lua a - elementContent = LuaUtil.rawField idx "c" - -withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b -withAttr f (attributes, x) = f (fromLuaAttr attributes) x - --- | Wrapper for Attr -newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr } - -instance Pushable LuaAttr where - push (LuaAttr (id', classes, kv)) = - pushViaConstructor "Attr" id' classes kv - -instance Peekable LuaAttr where - peek idx = defineHowTo "get Attr value" (LuaAttr <$> Lua.peek idx) - --- | Wrapper for ListAttributes -newtype LuaListAttributes = LuaListAttributes ListAttributes - -instance Pushable LuaListAttributes where - push (LuaListAttributes (start, style, delimiter)) = - pushViaConstructor "ListAttributes" start style delimiter - -instance Peekable LuaListAttributes where - peek = defineHowTo "get ListAttributes value" . - fmap LuaListAttributes . Lua.peek - --- --- Hierarchical elements --- -instance Pushable Element where - push (Blk blk) = Lua.push blk - push sec = pushAnyWithMetatable pushElementMetatable sec - where - pushElementMetatable = ensureUserdataMetatable (metatableName sec) $ - LuaUtil.addFunction "__index" indexElement - -instance Peekable Element where - peek idx = Lua.ltype idx >>= \case - Lua.TypeUserdata -> Lua.peekAny idx - _ -> Blk <$> Lua.peek idx - -indexElement :: Element -> String -> Lua Lua.NumResults -indexElement = \case - (Blk _) -> const (1 <$ Lua.pushnil) -- this shouldn't happen - (Sec lvl num attr label contents) -> fmap (return 1) . \case - "level" -> Lua.push lvl - "numbering" -> Lua.push num - "attr" -> Lua.push (LuaAttr attr) - "label" -> Lua.push label - "contents" -> Lua.push contents - "tag" -> Lua.push "Sec" - "t" -> Lua.push "Sec" - _ -> Lua.pushnil - - --- --- Reader Options --- -instance Pushable Extensions where - push exts = Lua.push (show exts) - -instance Pushable TrackChanges where - push = Lua.push . showConstr . toConstr - -instance Pushable ReaderOptions where - push ro = do - let ReaderOptions - (extensions :: Extensions) - (standalone :: Bool) - (columns :: Int) - (tabStop :: Int) - (indentedCodeClasses :: [String]) - (abbreviations :: Set.Set String) - (defaultImageExtension :: String) - (trackChanges :: TrackChanges) - (stripComments :: Bool) - = ro - Lua.newtable - LuaUtil.addField "extensions" extensions - LuaUtil.addField "standalone" standalone - LuaUtil.addField "columns" columns - LuaUtil.addField "tab_stop" tabStop - LuaUtil.addField "indented_code_classes" indentedCodeClasses - LuaUtil.addField "abbreviations" abbreviations - LuaUtil.addField "default_image_extension" defaultImageExtension - LuaUtil.addField "track_changes" trackChanges - LuaUtil.addField "strip_comments" stripComments - - -- add metatable - let indexReaderOptions :: AnyValue -> AnyValue -> Lua Lua.NumResults - indexReaderOptions _tbl (AnyValue key) = do - Lua.ltype key >>= \case - Lua.TypeString -> Lua.peek key >>= \case - "defaultImageExtension" -> Lua.push defaultImageExtension - "indentedCodeClasses" -> Lua.push indentedCodeClasses - "stripComments" -> Lua.push stripComments - "tabStop" -> Lua.push tabStop - "trackChanges" -> Lua.push trackChanges - _ -> Lua.pushnil - _ -> Lua.pushnil - return 1 - Lua.newtable - LuaUtil.addFunction "__index" indexReaderOptions - Lua.setmetatable (Lua.nthFromTop 2) - --- | Dummy type to allow values of arbitrary Lua type. -newtype AnyValue = AnyValue StackIndex - --- --- TODO: Much of the following should be abstracted, factored out --- and go into HsLua. --- - -instance Peekable AnyValue where - peek = return . AnyValue - --- | Name used by Lua for the @CommonState@ type. -commonStateTypeName :: String -commonStateTypeName = "Pandoc CommonState" - -instance Peekable CommonState where - peek idx = reportValueOnFailure commonStateTypeName - (`toAnyWithName` commonStateTypeName) idx - -instance Pushable CommonState where - push st = pushAnyWithMetatable pushCommonStateMetatable st - where - pushCommonStateMetatable = ensureUserdataMetatable commonStateTypeName $ do - LuaUtil.addFunction "__index" indexCommonState - LuaUtil.addFunction "__pairs" pairsCommonState - -indexCommonState :: CommonState -> AnyValue -> Lua Lua.NumResults -indexCommonState st (AnyValue idx) = Lua.ltype idx >>= \case - Lua.TypeString -> 1 <$ (Lua.peek idx >>= pushField) - _ -> 1 <$ Lua.pushnil - where - pushField :: String -> Lua () - pushField name = case lookup name commonStateFields of - Just pushValue -> pushValue st - Nothing -> Lua.pushnil - -pairsCommonState :: CommonState -> Lua Lua.NumResults -pairsCommonState st = do - Lua.pushHaskellFunction nextFn - Lua.pushnil - Lua.pushnil - return 3 - where - nextFn :: AnyValue -> AnyValue -> Lua Lua.NumResults - nextFn _ (AnyValue idx) = - Lua.ltype idx >>= \case - Lua.TypeNil -> case commonStateFields of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - (key, pushValue):_ -> 2 <$ (Lua.push key *> pushValue st) - Lua.TypeString -> do - key <- Lua.peek idx - case tail $ dropWhile ((/= key) . fst) commonStateFields of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - (nextKey, pushValue):_ -> 2 <$ (Lua.push nextKey *> pushValue st) - _ -> 2 <$ (Lua.pushnil *> Lua.pushnil) - -commonStateFields :: [(String, CommonState -> Lua ())] -commonStateFields = - [ ("input_files", Lua.push . stInputFiles) - , ("output_file", Lua.push . Lua.Optional . stOutputFile) - , ("log", Lua.push . stLog) - , ("request_headers", Lua.push . Map.fromList . stRequestHeaders) - , ("resource_path", Lua.push . stResourcePath) - , ("source_url", Lua.push . Lua.Optional . stSourceURL) - , ("user_data_dir", Lua.push . Lua.Optional . stUserDataDir) - , ("trace", Lua.push . stTrace) - , ("verbosity", Lua.push . show . stVerbosity) - ] - --- | Name used by Lua for the @CommonState@ type. -logMessageTypeName :: String -logMessageTypeName = "Pandoc LogMessage" - -instance Peekable LogMessage where - peek idx = reportValueOnFailure logMessageTypeName - (`toAnyWithName` logMessageTypeName) idx - -instance Pushable LogMessage where - push msg = pushAnyWithMetatable pushLogMessageMetatable msg - where - pushLogMessageMetatable = ensureUserdataMetatable logMessageTypeName $ - LuaUtil.addFunction "__tostring" tostringLogMessage - -tostringLogMessage :: LogMessage -> Lua String -tostringLogMessage = return . showLogMessage -- cgit v1.2.3