ICML writer: changed type of writeICML.
API change: It is now `WriterOptions -> Pandoc -> IO String`. Also handle new image attributes. (mb21)
This commit is contained in:
John MacFarlane
mb21
parent
4391c5f34c
commit
9deb335ca5
2 changed files with 51 additions and 40 deletions
|
|
@ -273,7 +273,7 @@ writers = [
|
|||
,("html" , PureStringWriter writeHtmlString)
|
||||
,("html5" , PureStringWriter $ \o ->
|
||||
writeHtmlString o{ writerHtml5 = True })
|
||||
,("icml" , PureStringWriter writeICML)
|
||||
,("icml" , IOStringWriter writeICML)
|
||||
,("s5" , PureStringWriter $ \o ->
|
||||
writeHtmlString o{ writerSlideVariant = S5Slides
|
||||
, writerTableOfContents = False })
|
||||
|
|
|
|||
|
|
@ -17,15 +17,17 @@ module Text.Pandoc.Writers.ICML (writeICML) where
|
|||
import Text.Pandoc.Definition
|
||||
import Text.Pandoc.XML
|
||||
import Text.Pandoc.Writers.Shared
|
||||
import Text.Pandoc.Shared (splitBy)
|
||||
import Text.Pandoc.Shared (splitBy, fetchItem, warn)
|
||||
import Text.Pandoc.Options
|
||||
import Text.Pandoc.Templates (renderTemplate')
|
||||
import Text.Pandoc.Pretty
|
||||
import Text.Pandoc.ImageSize
|
||||
import Data.List (isPrefixOf, isInfixOf, stripPrefix)
|
||||
import Data.Text as Text (breakOnAll, pack)
|
||||
import Data.Monoid (mappend)
|
||||
import Control.Monad.State
|
||||
import Network.URI (isURI)
|
||||
import System.FilePath (pathSeparator)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
type Style = [String]
|
||||
|
|
@ -39,7 +41,7 @@ data WriterState = WriterState{
|
|||
, maxListDepth :: Int
|
||||
}
|
||||
|
||||
type WS a = State WriterState a
|
||||
type WS a = StateT WriterState IO a
|
||||
|
||||
defaultWriterState :: WriterState
|
||||
defaultWriterState = WriterState{
|
||||
|
|
@ -118,27 +120,27 @@ citeName = "Cite"
|
|||
|
||||
|
||||
-- | Convert Pandoc document to string in ICML format.
|
||||
writeICML :: WriterOptions -> Pandoc -> String
|
||||
writeICML opts (Pandoc meta blocks) =
|
||||
writeICML :: WriterOptions -> Pandoc -> IO String
|
||||
writeICML opts (Pandoc meta blocks) = do
|
||||
let colwidth = if writerWrapText opts
|
||||
then Just $ writerColumns opts
|
||||
else Nothing
|
||||
render' = render colwidth
|
||||
renderMeta f s = Just $ render' $ fst $ runState (f opts [] s) defaultWriterState
|
||||
Just metadata = metaToJSON opts
|
||||
(renderMeta blocksToICML)
|
||||
(renderMeta inlinesToICML)
|
||||
meta
|
||||
(doc, st) = runState (blocksToICML opts [] blocks) defaultWriterState
|
||||
main = render' doc
|
||||
renderMeta f s = liftM (render' . fst) $ runStateT (f opts [] s) defaultWriterState
|
||||
metadata <- metaToJSON opts
|
||||
(renderMeta blocksToICML)
|
||||
(renderMeta inlinesToICML)
|
||||
meta
|
||||
(doc, st) <- runStateT (blocksToICML opts [] blocks) defaultWriterState
|
||||
let main = render' doc
|
||||
context = defField "body" main
|
||||
$ defField "charStyles" (render' $ charStylesToDoc st)
|
||||
$ defField "parStyles" (render' $ parStylesToDoc st)
|
||||
$ defField "hyperlinks" (render' $ hyperlinksToDoc $ links st)
|
||||
$ metadata
|
||||
in if writerStandalone opts
|
||||
then renderTemplate' (writerTemplate opts) context
|
||||
else main
|
||||
return $ if writerStandalone opts
|
||||
then renderTemplate' (writerTemplate opts) context
|
||||
else main
|
||||
|
||||
-- | Auxilary functions for parStylesToDoc and charStylesToDoc.
|
||||
contains :: String -> (String, (String, String)) -> [(String, String)]
|
||||
|
|
@ -427,7 +429,7 @@ inlineToICML opts style (Link lst (url, title)) = do
|
|||
cont = inTags True "HyperlinkTextSource"
|
||||
[("Self","htss-"++show ident), ("Name",title), ("Hidden","false")] content
|
||||
in (cont, newst)
|
||||
inlineToICML opts style (Image alt target) = imageICML opts style alt target
|
||||
inlineToICML opts style (Image attr alt target) = imageICML opts style attr alt target
|
||||
inlineToICML opts style (Note lst) = footnoteToICML opts style lst
|
||||
inlineToICML opts style (Span _ lst) = inlinesToICML opts style lst
|
||||
|
||||
|
|
@ -500,39 +502,48 @@ styleToStrAttr style =
|
|||
in (stlStr, attrs)
|
||||
|
||||
-- | Assemble an ICML Image.
|
||||
imageICML :: WriterOptions -> Style -> [Inline] -> Target -> WS Doc
|
||||
imageICML _ style _ (linkURI, _) =
|
||||
let imgWidth = 300::Int --TODO: set width, height dynamically as in Docx.hs
|
||||
imgHeight = 200::Int
|
||||
scaleFact = show (1::Double) --TODO: set scaling factor so image is scaled exactly to imgWidth x imgHeight
|
||||
hw = show $ imgWidth `div` 2
|
||||
hh = show $ imgHeight `div` 2
|
||||
qw = show $ imgWidth `div` 4
|
||||
qh = show $ imgHeight `div` 4
|
||||
uriPrefix = if isURI linkURI then "" else "file:"
|
||||
imageICML :: WriterOptions -> Style -> Attr -> [Inline] -> Target -> WS Doc
|
||||
imageICML opts style attr _ (src, _) = do
|
||||
res <- liftIO $ fetchItem (writerSourceURL opts) src
|
||||
imgS <- case res of
|
||||
Left (_) -> do
|
||||
liftIO $ warn $ "Could not find image `" ++ src ++ "', skipping..."
|
||||
return def
|
||||
Right (img, _) -> do
|
||||
case imageSize img of
|
||||
Right size -> return size
|
||||
Left msg -> do
|
||||
return $ warn $ "Could not determine image size in `" ++
|
||||
src ++ "': " ++ msg
|
||||
return def
|
||||
let (ow, oh) = sizeInPoints imgS
|
||||
(imgWidth, imgHeight) = desiredSizeInPoints opts attr imgS
|
||||
hw = showFl $ ow / 2
|
||||
hh = showFl $ oh / 2
|
||||
scale = showFl (imgWidth / ow) ++ " 0 0 " ++ showFl (imgHeight / oh)
|
||||
src' = if isURI src then src else "file://." ++ pathSeparator : src
|
||||
(stlStr, attrs) = styleToStrAttr style
|
||||
props = inTags True "Properties" [] $ inTags True "PathGeometry" []
|
||||
$ inTags True "GeometryPathType" [("PathOpen","false")]
|
||||
$ inTags True "PathPointArray" []
|
||||
$ vcat [
|
||||
selfClosingTag "PathPointType" [("Anchor", "-"++qw++" -"++qh),
|
||||
("LeftDirection", "-"++qw++" -"++qh), ("RightDirection", "-"++qw++" -"++qh)]
|
||||
, selfClosingTag "PathPointType" [("Anchor", "-"++qw++" "++qh),
|
||||
("LeftDirection", "-"++qw++" "++qh), ("RightDirection", "-"++qw++" "++qh)]
|
||||
, selfClosingTag "PathPointType" [("Anchor", qw++" "++qh),
|
||||
("LeftDirection", qw++" "++qh), ("RightDirection", qw++" "++qh)]
|
||||
, selfClosingTag "PathPointType" [("Anchor", qw++" -"++qh),
|
||||
("LeftDirection", qw++" -"++qh), ("RightDirection", qw++" -"++qh)]
|
||||
selfClosingTag "PathPointType" [("Anchor", "-"++hw++" -"++hh),
|
||||
("LeftDirection", "-"++hw++" -"++hh), ("RightDirection", "-"++hw++" -"++hh)]
|
||||
, selfClosingTag "PathPointType" [("Anchor", "-"++hw++" "++hh),
|
||||
("LeftDirection", "-"++hw++" "++hh), ("RightDirection", "-"++hw++" "++hh)]
|
||||
, selfClosingTag "PathPointType" [("Anchor", hw++" "++hh),
|
||||
("LeftDirection", hw++" "++hh), ("RightDirection", hw++" "++hh)]
|
||||
, selfClosingTag "PathPointType" [("Anchor", hw++" -"++hh),
|
||||
("LeftDirection", hw++" -"++hh), ("RightDirection", hw++" -"++hh)]
|
||||
]
|
||||
image = inTags True "Image"
|
||||
[("Self","ue6"), ("ItemTransform", scaleFact++" 0 0 "++scaleFact++" -"++qw++" -"++qh)]
|
||||
[("Self","ue6"), ("ItemTransform", scale++" -"++hw++" -"++hh)]
|
||||
$ vcat [
|
||||
inTags True "Properties" [] $ inTags True "Profile" [("type","string")] $ text "$ID/Embedded"
|
||||
$$ selfClosingTag "GraphicBounds" [("Left","0"), ("Top","0"), ("Right", hw), ("Bottom", hh)]
|
||||
, selfClosingTag "Link" [("Self", "ueb"), ("LinkResourceURI", uriPrefix++linkURI)]
|
||||
, selfClosingTag "Link" [("Self", "ueb"), ("LinkResourceURI", src')]
|
||||
]
|
||||
doc = inTags True "CharacterStyleRange" attrs
|
||||
$ inTags True "Rectangle" [("Self","uec"), ("ItemTransform", "1 0 0 1 "++qw++" -"++qh)]
|
||||
$ inTags True "Rectangle" [("Self","uec"), ("StrokeWeight", "0"),
|
||||
("ItemTransform", scale++" "++hw++" -"++hh)]
|
||||
$ (props $$ image)
|
||||
in do
|
||||
state $ \st -> (doc, st{ inlineStyles = Set.insert stlStr $ inlineStyles st } )
|
||||
state $ \st -> (doc, st{ inlineStyles = Set.insert stlStr $ inlineStyles st } )
|
||||
|
|
|
|||
Loading…
Reference in a new issue