path: root/src/Text/Pandoc/Lua/StackInstances.hs

{-
Copyright © 2012-2017 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 FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
   Module      : Text.Pandoc.Lua.StackInstances
   Copyright   : © 2012-2017 John MacFarlane
                 © 2017 Albert Krewinkel
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
   Stability   : alpha

StackValue instances for pandoc types.
-}
module Text.Pandoc.Lua.StackInstances () where

import Control.Applicative ((<|>))
import Scripting.Lua (LTYPE (..), LuaState, StackValue (..), ltype, newtable,
                      objlen)
import Text.Pandoc.Definition
import Text.Pandoc.Lua.SharedInstances ()
import Text.Pandoc.Lua.Util (addValue, getTable, pushViaConstructor)
import Text.Pandoc.Shared (safeRead)

instance StackValue Pandoc where
  push lua (Pandoc meta blocks) = do
    newtable lua
    addValue lua "blocks" blocks
    addValue lua "meta"   meta
  peek lua idx = do
    blocks <- getTable lua idx "blocks"
    meta   <- getTable lua idx "meta"
    return $ Pandoc <$> meta <*> blocks
  valuetype _ = TTABLE

instance StackValue Meta where
  push lua (Meta mmap) = push lua mmap
  peek lua idx = fmap Meta <$> peek lua idx
  valuetype _ = TTABLE

instance StackValue MetaValue where
  push = pushMetaValue
  peek = peekMetaValue
  valuetype = \case
    MetaBlocks _  -> TTABLE
    MetaBool _    -> TBOOLEAN
    MetaInlines _ -> TTABLE
    MetaList _    -> TTABLE
    MetaMap _     -> TTABLE
    MetaString _  -> TSTRING

instance StackValue Block where
  push = pushBlock
  peek = peekBlock
  valuetype _ = TTABLE

instance StackValue Inline where
  push = pushInline
  peek = peekInline
  valuetype _ = TTABLE

instance StackValue Citation where
  push lua (Citation cid prefix suffix mode noteNum hash) =
    pushViaConstructor lua "Citation" cid mode prefix suffix noteNum hash
  peek lua idx = do
    id' <- getTable lua idx "citationId"
    prefix <- getTable lua idx "citationPrefix"
    suffix <- getTable lua idx "citationSuffix"
    mode <- getTable lua idx "citationMode"
    num <- getTable lua idx "citationNoteNum"
    hash <- getTable lua idx "citationHash"
    return $ Citation <$> id' <*> prefix <*> suffix <*> mode <*> num <*> hash
  valuetype _ = TTABLE

instance StackValue Alignment where
  push lua = push lua . show
  peek lua idx = (>>= safeRead) <$> peek lua idx
  valuetype _ = TSTRING

instance StackValue CitationMode where
  push lua = push lua . show
  peek lua idx = (>>= safeRead) <$> peek lua idx
  valuetype _ = TSTRING

instance StackValue Format where
  push lua (Format f) = push lua f
  peek lua idx = fmap Format <$> peek lua idx
  valuetype _ = TSTRING

instance StackValue ListNumberDelim where
  push lua = push lua . show
  peek lua idx = (>>= safeRead) <$> peek lua idx
  valuetype _ = TSTRING

instance StackValue ListNumberStyle where
  push lua = push lua . show
  peek lua idx = (>>= safeRead) <$> peek lua idx
  valuetype _ = TSTRING

instance StackValue MathType where
  push lua = push lua . show
  peek lua idx = (>>= safeRead) <$> peek lua idx
  valuetype _ = TSTRING

instance StackValue QuoteType where
  push lua = push lua . show
  peek lua idx = (>>= safeRead) <$> peek lua idx
  valuetype _ = TSTRING

-- | Push an meta value element to the top of the lua stack.
pushMetaValue :: LuaState -> MetaValue -> IO ()
pushMetaValue lua = \case
  MetaBlocks blcks  -> pushViaConstructor lua "MetaBlocks" blcks
  MetaBool bool     -> push lua bool
  MetaInlines inlns -> pushViaConstructor lua "MetaInlines" inlns
  MetaList metalist -> pushViaConstructor lua "MetaList" metalist
  MetaMap metamap   -> pushViaConstructor lua "MetaMap" metamap
  MetaString str    -> push lua str

-- | Interpret the value at the given stack index as meta value.
peekMetaValue :: LuaState -> Int -> IO (Maybe MetaValue)
peekMetaValue lua idx = do
  -- Get the contents of an AST element.
  let elementContent :: StackValue a => IO (Maybe a)
      elementContent = peek lua idx
  luatype <- ltype lua idx
  case luatype of
    TBOOLEAN -> fmap MetaBool <$> peek lua idx
    TSTRING  -> fmap MetaString <$> peek lua idx
    TTABLE   -> do
      tag <- getTable lua idx "t"
      case tag of
        Just "MetaBlocks"  -> fmap MetaBlocks  <$> elementContent
        Just "MetaBool"    -> fmap MetaBool    <$> elementContent
        Just "MetaMap"     -> fmap MetaMap     <$> elementContent
        Just "MetaInlines" -> fmap MetaInlines <$> elementContent
        Just "MetaList"    -> fmap MetaList    <$> elementContent
        Just "MetaString"  -> fmap MetaString  <$> elementContent
        Nothing -> do
          -- no meta value tag given, try to guess.
          len <- objlen lua idx
          if len <= 0
            then fmap MetaMap <$> peek lua idx
            else  (fmap MetaInlines <$> peek lua idx)
                  <|> (fmap MetaBlocks <$> peek lua idx)
                  <|> (fmap MetaList <$> peek lua idx)
        _        -> return Nothing
    _        -> return Nothing

-- | Push an block element to the top of the lua stack.
pushBlock :: LuaState -> Block -> IO ()
pushBlock lua = \case
  BlockQuote blcks         -> pushViaConstructor lua "BlockQuote" blcks
  BulletList items         -> pushViaConstructor lua "BulletList" items
  CodeBlock attr code      -> pushViaConstructor lua "CodeBlock" code (LuaAttr attr)
  DefinitionList items     -> pushViaConstructor lua "DefinitionList" items
  Div attr blcks           -> pushViaConstructor lua "Div" blcks (LuaAttr attr)
  Header lvl attr inlns    -> pushViaConstructor lua "Header" lvl inlns (LuaAttr attr)
  HorizontalRule           -> pushViaConstructor lua "HorizontalRule"
  LineBlock blcks          -> pushViaConstructor lua "LineBlock" blcks
  OrderedList lstAttr list -> pushViaConstructor lua "OrderedList" list lstAttr
  Null                     -> pushViaConstructor lua "Null"
  Para blcks               -> pushViaConstructor lua "Para" blcks
  Plain blcks              -> pushViaConstructor lua "Plain" blcks
  RawBlock f cs            -> pushViaConstructor lua "RawBlock" f cs
  Table capt aligns widths headers rows ->
    pushViaConstructor lua "Table" capt aligns widths headers rows

-- | Return the value at the given index as block if possible.
peekBlock :: LuaState -> Int -> IO (Maybe Block)
peekBlock lua idx = do
  tag <- getTable lua idx "t"
  case tag of
    Nothing -> return Nothing
    Just t -> case t of
      "BlockQuote"     -> fmap BlockQuote <$> elementContent
      "BulletList"     -> fmap BulletList <$> elementContent
      "CodeBlock"      -> fmap (withAttr CodeBlock) <$> elementContent
      "DefinitionList" -> fmap DefinitionList <$> elementContent
      "Div"            -> fmap (withAttr Div) <$> elementContent
      "Header"         -> fmap (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst)
                          <$> elementContent
      "HorizontalRule" -> return (Just HorizontalRule)
      "LineBlock"      -> fmap LineBlock <$> elementContent
      "OrderedList"    -> fmap (uncurry OrderedList) <$> elementContent
      "Null"           -> return (Just Null)
      "Para"           -> fmap Para <$> elementContent
      "Plain"          -> fmap Plain <$> elementContent
      "RawBlock"       -> fmap (uncurry RawBlock) <$> elementContent
      "Table"          -> fmap (\(capt, aligns, widths, headers, body) ->
                                  Table capt aligns widths headers body)
                          <$> elementContent
      _ -> return Nothing
 where
   -- Get the contents of an AST element.
   elementContent :: StackValue a => IO (Maybe a)
   elementContent = getTable lua idx "c"

-- | Push an inline element to the top of the lua stack.
pushInline :: LuaState -> Inline -> IO ()
pushInline lua = \case
  Cite citations lst       -> pushViaConstructor lua "Cite" lst citations
  Code attr lst            -> pushViaConstructor lua "Code" lst (LuaAttr attr)
  Emph inlns               -> pushViaConstructor lua "Emph" inlns
  Image attr alt (src,tit) -> pushViaConstructor lua "Image" alt src tit (LuaAttr attr)
  LineBreak                -> pushViaConstructor lua "LineBreak"
  Link attr lst (src,tit)  -> pushViaConstructor lua "Link" lst src tit (LuaAttr attr)
  Note blcks               -> pushViaConstructor lua "Note" blcks
  Math mty str             -> pushViaConstructor lua "Math" mty str
  Quoted qt inlns          -> pushViaConstructor lua "Quoted" qt inlns
  RawInline f cs           -> pushViaConstructor lua "RawInline" f cs
  SmallCaps inlns          -> pushViaConstructor lua "SmallCaps" inlns
  SoftBreak                -> pushViaConstructor lua "SoftBreak"
  Space                    -> pushViaConstructor lua "Space"
  Span attr inlns          -> pushViaConstructor lua "Span" inlns (LuaAttr attr)
  Str str                  -> pushViaConstructor lua "Str" str
  Strikeout inlns          -> pushViaConstructor lua "Strikeout" inlns
  Strong inlns             -> pushViaConstructor lua "Strong" inlns
  Subscript inlns          -> pushViaConstructor lua "Subscript" inlns
  Superscript inlns        -> pushViaConstructor lua "Superscript" inlns

-- | Return the value at the given index as inline if possible.
peekInline :: LuaState -> Int -> IO (Maybe Inline)
peekInline lua idx = do
  tag <- getTable lua idx "t"
  case tag of
    Nothing -> return Nothing
    Just t -> case t of
      "Cite"       -> fmap (uncurry Cite) <$> elementContent
      "Code"       -> fmap (withAttr Code) <$> elementContent
      "Emph"       -> fmap Emph <$> elementContent
      "Image"      -> fmap (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt)
                      <$> elementContent
      "Link"       -> fmap (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt)
                      <$> elementContent
      "LineBreak"  -> return (Just LineBreak)
      "Note"       -> fmap Note <$> elementContent
      "Math"       -> fmap (uncurry Math) <$> elementContent
      "Quoted"     -> fmap (uncurry Quoted) <$> elementContent
      "RawInline"  -> fmap (uncurry RawInline) <$> elementContent
      "SmallCaps"  -> fmap SmallCaps <$> elementContent
      "SoftBreak"  -> return (Just SoftBreak)
      "Space"      -> return (Just Space)
      "Span"       -> fmap (withAttr Span) <$> elementContent
      "Str"        -> fmap Str <$> elementContent
      "Strikeout"  -> fmap Strikeout <$> elementContent
      "Strong"     -> fmap Strong <$> elementContent
      "Subscript"  -> fmap Subscript <$> elementContent
      "Superscript"-> fmap Superscript <$> elementContent
      _ -> return Nothing
 where
   -- Get the contents of an AST element.
   elementContent :: StackValue a => IO (Maybe a)
   elementContent = getTable lua 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 StackValue LuaAttr where
  push lua (LuaAttr (id', classes, kv)) =
    pushViaConstructor lua "Attr" id' classes kv
  peek lua idx = fmap LuaAttr <$> peek lua idx
  valuetype _ = TTABLE