aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Lua/Marshaling/Attr.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Lua/Marshaling/Attr.hs')
-rw-r--r--src/Text/Pandoc/Lua/Marshaling/Attr.hs237
1 files changed, 0 insertions, 237 deletions
diff --git a/src/Text/Pandoc/Lua/Marshaling/Attr.hs b/src/Text/Pandoc/Lua/Marshaling/Attr.hs
deleted file mode 100644
index 97e702e35..000000000
--- a/src/Text/Pandoc/Lua/Marshaling/Attr.hs
+++ /dev/null
@@ -1,237 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-{- |
-Module : Text.Pandoc.Lua.Marshaling.Attr
-Copyright : © 2012-2021 John MacFarlane
- © 2017-2021 Albert Krewinkel
-License : GNU GPL, version 2 or above
-
-Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
-Stability : alpha
-
-Marshaling/unmarshaling instances for document AST elements.
--}
-module Text.Pandoc.Lua.Marshaling.Attr
- ( typeAttr
- , peekAttr
- , pushAttr
- , mkAttr
- , mkAttributeList
- ) where
-
-import Control.Applicative ((<|>), optional)
-import Control.Monad ((<$!>))
-import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-import HsLua
-import HsLua.Marshalling.Peekers (peekIndexRaw)
-import Safe (atMay)
-import Text.Pandoc.Definition (Attr, nullAttr)
-import Text.Pandoc.Lua.Marshaling.List (pushPandocList)
-
-import qualified Data.Text as T
-
-typeAttr :: LuaError e => DocumentedType e Attr
-typeAttr = deftype "Attr"
- [ operation Eq $ lambda
- ### liftPure2 (==)
- <#> parameter peekAttr "a1" "Attr" ""
- <#> parameter peekAttr "a2" "Attr" ""
- =#> functionResult pushBool "boolean" "whether the two are equal"
- , operation Tostring $ lambda
- ### liftPure show
- <#> parameter peekAttr "Attr" "attr" ""
- =#> functionResult pushString "string" "native Haskell representation"
- ]
- [ property "identifier" "element identifier"
- (pushText, \(ident,_,_) -> ident)
- (peekText, \(_,cls,kv) -> (,cls,kv))
- , property "classes" "element classes"
- (pushPandocList pushText, \(_,classes,_) -> classes)
- (peekList peekText, \(ident,_,kv) -> (ident,,kv))
- , property "attributes" "various element attributes"
- (pushAttribs, \(_,_,attribs) -> attribs)
- (peekAttribs, \(ident,cls,_) -> (ident,cls,))
- , method $ defun "clone"
- ### return
- <#> parameter peekAttr "attr" "Attr" ""
- =#> functionResult pushAttr "Attr" "new Attr element"
- , readonly "tag" "element type tag (always 'Attr')"
- (pushText, const "Attr")
-
- , alias "t" "alias for `tag`" ["tag"]
- ]
-
-pushAttr :: LuaError e => Pusher e Attr
-pushAttr = pushUD typeAttr
-
-peekAttribs :: LuaError e => Peeker e [(Text,Text)]
-peekAttribs idx = liftLua (ltype idx) >>= \case
- TypeUserdata -> peekUD typeAttributeList idx
- TypeTable -> liftLua (rawlen idx) >>= \case
- 0 -> peekKeyValuePairs peekText peekText idx
- _ -> peekList (peekPair peekText peekText) idx
- _ -> failPeek "unsupported type"
-
-pushAttribs :: LuaError e => Pusher e [(Text, Text)]
-pushAttribs = pushUD typeAttributeList
-
-typeAttributeList :: LuaError e => DocumentedType e [(Text, Text)]
-typeAttributeList = deftype "AttributeList"
- [ operation Eq $ lambda
- ### liftPure2 (==)
- <#> parameter peekAttribs "a1" "AttributeList" ""
- <#> parameter peekAttribs "a2" "AttributeList" ""
- =#> functionResult pushBool "boolean" "whether the two are equal"
-
- , operation Index $ lambda
- ### liftPure2 lookupKey
- <#> udparam typeAttributeList "t" "attributes list"
- <#> parameter peekKey "string|integer" "key" "lookup key"
- =#> functionResult (maybe pushnil pushAttribute) "string|table"
- "attribute value"
-
- , operation Newindex $ lambda
- ### setKey
- <#> udparam typeAttributeList "t" "attributes list"
- <#> parameter peekKey "string|integer" "key" "lookup key"
- <#> optionalParameter peekAttribute "string|nil" "value" "new value"
- =#> []
-
- , operation Len $ lambda
- ### liftPure length
- <#> udparam typeAttributeList "t" "attributes list"
- =#> functionResult pushIntegral "integer" "number of attributes in list"
-
- , operation Pairs $ lambda
- ### pushIterator (\(k, v) -> 2 <$ pushText k <* pushText v)
- <#> udparam typeAttributeList "t" "attributes list"
- =?> "iterator triple"
-
- , operation Tostring $ lambda
- ### liftPure show
- <#> udparam typeAttributeList "t" "attributes list"
- =#> functionResult pushString "string" ""
- ]
- []
-
-data Key = StringKey Text | IntKey Int
-
-peekKey :: LuaError e => Peeker e (Maybe Key)
-peekKey idx = liftLua (ltype idx) >>= \case
- TypeNumber -> Just . IntKey <$!> peekIntegral idx
- TypeString -> Just . StringKey <$!> peekText idx
- _ -> return Nothing
-
-data Attribute
- = AttributePair (Text, Text)
- | AttributeValue Text
-
-pushAttribute :: LuaError e => Pusher e Attribute
-pushAttribute = \case
- (AttributePair kv) -> pushPair pushText pushText kv
- (AttributeValue v) -> pushText v
-
--- | Retrieve an 'Attribute'.
-peekAttribute :: LuaError e => Peeker e Attribute
-peekAttribute idx = (AttributeValue <$!> peekText idx)
- <|> (AttributePair <$!> peekPair peekText peekText idx)
-
-lookupKey :: [(Text,Text)] -> Maybe Key -> Maybe Attribute
-lookupKey !kvs = \case
- Just (StringKey str) -> AttributeValue <$!> lookup str kvs
- Just (IntKey n) -> AttributePair <$!> atMay kvs (n - 1)
- Nothing -> Nothing
-
-setKey :: forall e. LuaError e
- => [(Text, Text)] -> Maybe Key -> Maybe Attribute
- -> LuaE e ()
-setKey kvs mbKey mbValue = case mbKey of
- Just (StringKey str) ->
- case break ((== str) . fst) kvs of
- (prefix, _:suffix) -> case mbValue of
- Nothing -> setNew $ prefix ++ suffix
- Just (AttributeValue value) -> setNew $ prefix ++ (str, value):suffix
- _ -> failLua "invalid attribute value"
- _ -> case mbValue of
- Nothing -> return ()
- Just (AttributeValue value) -> setNew (kvs ++ [(str, value)])
- _ -> failLua "invalid attribute value"
- Just (IntKey idx) ->
- case splitAt (idx - 1) kvs of
- (prefix, (k,_):suffix) -> setNew $ case mbValue of
- Nothing -> prefix ++ suffix
- Just (AttributePair kv) -> prefix ++ kv : suffix
- Just (AttributeValue v) -> prefix ++ (k, v) : suffix
- (prefix, []) -> case mbValue of
- Nothing -> setNew prefix
- Just (AttributePair kv) -> setNew $ prefix ++ [kv]
- _ -> failLua $ "trying to set an attribute key-value pair, "
- ++ "but got a single string instead."
-
- _ -> failLua "invalid attribute key"
- where
- setNew :: [(Text, Text)] -> LuaE e ()
- setNew new =
- putuserdata (nthBottom 1) (udName @e typeAttributeList) new >>= \case
- True -> return ()
- False -> failLua "failed to modify attributes list"
-
-peekAttr :: LuaError e => Peeker e Attr
-peekAttr idx = retrieving "Attr" $ liftLua (ltype idx) >>= \case
- TypeString -> (,[],[]) <$!> peekText idx -- treat string as ID
- TypeUserdata -> peekUD typeAttr idx
- TypeTable -> peekAttrTable idx
- x -> liftLua . failLua $ "Cannot get Attr from " ++ show x
-
--- | Helper function which gets an Attr from a Lua table.
-peekAttrTable :: LuaError e => Peeker e Attr
-peekAttrTable idx = do
- len' <- liftLua $ rawlen idx
- let peekClasses = peekList peekText
- if len' > 0
- then do
- ident <- peekIndexRaw 1 peekText idx
- classes <- fromMaybe [] <$!> optional (peekIndexRaw 2 peekClasses idx)
- attribs <- fromMaybe [] <$!> optional (peekIndexRaw 3 peekAttribs idx)
- return $ ident `seq` classes `seq` attribs `seq`
- (ident, classes, attribs)
- else retrieving "HTML-like attributes" $ do
- kvs <- peekKeyValuePairs peekText peekText idx
- let ident = fromMaybe "" $ lookup "id" kvs
- let classes = maybe [] T.words $ lookup "class" kvs
- let attribs = filter ((`notElem` ["id", "class"]) . fst) kvs
- return $ ident `seq` classes `seq` attribs `seq`
- (ident, classes, attribs)
-
--- | Constructor for 'Attr'.
-mkAttr :: LuaError e => DocumentedFunction e
-mkAttr = defun "Attr"
- ### (ltype (nthBottom 1) >>= \case
- TypeString -> forcePeek $ do
- mident <- optional (peekText (nthBottom 1))
- mclass <- optional (peekList peekText (nthBottom 2))
- mattribs <- optional (peekAttribs (nthBottom 3))
- return ( fromMaybe "" mident
- , fromMaybe [] mclass
- , fromMaybe [] mattribs)
- TypeTable -> forcePeek $ peekAttrTable (nthBottom 1)
- TypeUserdata -> forcePeek $ peekUD typeAttr (nthBottom 1) <|> do
- attrList <- peekUD typeAttributeList (nthBottom 1)
- return ("", [], attrList)
- TypeNil -> pure nullAttr
- TypeNone -> pure nullAttr
- x -> failLua $ "Cannot create Attr from " ++ show x)
- =#> functionResult pushAttr "Attr" "new Attr object"
-
--- | Constructor for 'AttributeList'.
-mkAttributeList :: LuaError e => DocumentedFunction e
-mkAttributeList = defun "AttributeList"
- ### return
- <#> parameter peekAttribs "table|AttributeList" "attribs" "an attribute list"
- =#> functionResult (pushUD typeAttributeList) "AttributeList"
- "new AttributeList object"
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-17 11:33:37 +0000