diff --git a/fmark.cabal b/fmark.cabal --- a/fmark.cabal +++ b/fmark.cabal @@ -1,5 +1,5 @@ name: fmark -version: 0.1.0 +version: 0.1.1 homepage: http://github.com/jabolopes/fmark bug-reports: http://github.com/jabolopes/fmark/issues synopsis: A Friendly Markup language without syntax. @@ -9,7 +9,7 @@ license: BSD3 license-file: LICENSE author: José Lopes -maintainer: José Lopes +maintainer: José Lopes stability: Experimental category: Typography @@ -24,8 +24,18 @@ executable fmark main-is: Main.hs - extensions: DoAndIfThenElse + extensions: DoAndIfThenElse hs-source-dirs: src + other-modules: + Backend.Latex + Backend.Xml + Data.Document + Data.Text + Data.Token + Fmark + Parser + Utils + Weaver -- other-modules: build-depends: base == 4.5.*, diff --git a/src/Backend/Latex.hs b/src/Backend/Latex.hs new file mode 100644 --- /dev/null +++ b/src/Backend/Latex.hs @@ -0,0 +1,76 @@ +module Backend.Latex where + +import Data.Functor ((<$>)) +import Data.List (intercalate) + +import Utils (trim) +import Data.Document +import Data.Text + + +-- | 'docToLatex' @mstyle doc@ formats a styled 'Document' @doc@ into +-- a LaTeX 'String', where @mstyle@ specifies the style 'Document' +-- used to stylize @doc@. +docToLatex :: Maybe Document -> Document -> String +docToLatex mstyle doc = + let ps = properties doc + title = lookup "Title" ps + subtitle = lookup "Subtitle" ps + author = lookup "Author" ps + date = lookup "Date" ps + abstract = lookup "Abstract" ps + maketitle = case (title, author, date) of + (Just _, Just _, Just _) -> def "maketitle" + _ -> "" + in + seq [comArgs "documentclass" ["a4paper"] "article", + comArgs "usepackage" ["utf8"] "inputenc", + fulltitle title subtitle, + prop (com "author") author, + prop (com "date") date, + env "document" $ seq [maketitle, + prop (env "abstract") abstract, + loop 0 doc]] + where fulltitle Nothing Nothing = "" + fulltitle (Just t) Nothing = com "title" t + fulltitle Nothing (Just s) = com "title" $ com "large" s + fulltitle (Just t) (Just s) = com "title" $ nls $ t ++ "\n" ++ com "large" s + + properties (Heading _ _) = [] + properties (Paragraph _ _) = [] + properties (Content docs) = concatMap properties docs + properties (Section doc) = properties doc + properties (Style _ sty str) = [(sty, loopText str)] + + lit = concatMap lit' + where lit' '#' = "\\#" + lit' c = [c] + + nls = concatMap nls' + where nls' '\n' = "\\\\" + nls' c = [c] + + def id = '\\':lit id + com id str = "\\" ++ lit id ++ "{" ++ lit str ++ "}" + comArgs id args str = "\\" ++ lit id ++ "[" ++ intercalate "," (map lit args) ++ "]{" ++ lit str ++ "}" + env id str = "\\begin{" ++ lit id ++ "}\n" ++ lit str ++ "\n\\end{" ++ lit id ++ "}" + + prop fn = maybe "" $ fn . lit + + sec lvl str + | lvl < 3 = com (concat (replicate lvl "sub") ++ "section") $ nls str + | lvl == 3 = com "paragraph" $ nls str + | lvl == 4 = com "subparagraph" $ nls str + + par = lit + + seq = intercalate "\n" . filter (\ln -> trim ln /= "") + + loopText (Footnote str) = com "footnote" str + loopText (Plain str) = lit str + + loop lvl (Heading _ lns) = sec lvl $ intercalate "\n" [ concatMap loopText txts | txts <- lns ] + loop lvl (Paragraph _ txts) = concatMap loopText txts + loop lvl (Content docs) = seq $ map (loop lvl) docs + loop lvl (Section doc) = loop (lvl + 1) doc + loop lvl Style {} = "" diff --git a/src/Backend/Xml.hs b/src/Backend/Xml.hs new file mode 100644 --- /dev/null +++ b/src/Backend/Xml.hs @@ -0,0 +1,131 @@ +-- | 'Backend.Xml' is the XML generator backend for 'Document's. +module Backend.Xml where + +import Control.Monad.State (State, evalState, get, modify) +import Data.Functor ((<$>)) +import Data.List (intercalate) + +import Data.Document +import Data.Text + + +-- | 'XmlState' is the XML generator state that records the current +-- indentation level and a prefix values that decides whether XML tags +-- should be indented. +data XmlState = XmlState Int Bool + +-- | 'XmlM' is the type of the XML generator 'Monad'. +type XmlM a = State XmlState a + + +-- | 'getIdn' is a 'Monad' with the current indentation level. +getIdn :: XmlM Int +getIdn = + do XmlState idn _ <- get + return idn + + +-- | 'putIdn' @idn@ is a 'Monad' that modifies the current indentation +-- level. +putIdn :: Int -> XmlM () +putIdn idn = + modify $ \(XmlState _ pre) -> XmlState idn pre + + +-- | 'withIdn' @m@ is a 'Monad' that temporarily creates a deeper +-- indentation level for 'Monad' @m@. +withIdn :: XmlM a -> XmlM a +withIdn m = + do idn <- getIdn + putIdn $ idn + 2 + val <- m + putIdn idn + return val + + +-- | 'getPrefix' is a 'Monad' with the current prefix. +getPrefix :: XmlM Bool +getPrefix = + do XmlState _ pre <- get + return pre + + +-- | 'putPrefix' @pre@ is a 'Monad' that modified the current prefix. +putPrefix :: Bool -> XmlM () +putPrefix pre = + modify $ \(XmlState idn _) -> XmlState idn pre + + +-- | 'withPrefix' @pre m@ is a 'Monad' that modified the current +-- prefix for 'Monad' @m@. +withPrefix :: Bool -> XmlM a -> XmlM a +withPrefix pre m = + do pre' <- getPrefix + putPrefix pre + val <- m + putPrefix pre' + return val + + +-- | 'docToXml' @mstyle doc@ formats a styled 'Document' @doc@ into a +-- XML 'String', where @mstyle@ specifies the style 'Document' used to +-- stylize @doc@. +docToXml :: Maybe Document -> Document -> String +docToXml _ doc = + intercalate "\n" ["", str, ""] + where str = evalState (loop doc) (XmlState 2 True) + + xmlIndent :: XmlM String -> XmlM String + xmlIndent m = + do idn <- getIdn + pre <- getPrefix + if pre then + do str <- m + return $ replicate idn ' ' ++ str + else + m + + xmlAttribute Nothing = [] + xmlAttribute (Just val) = [("style", val)] + + xmlAttributes [] = "" + xmlAttributes attrs = ' ':unwords (map (\(id, val) -> id ++ "=\"" ++ val ++ "\"") attrs) + + xmlStr = xmlIndent + + xmlShortTag :: [(String, String)] -> String -> XmlM String -> XmlM String + xmlShortTag attrs tag m = + concat <$> sequence [xmlIndent (return ("<" ++ tag ++ xmlAttributes attrs ++ ">")), + withPrefix False m, + return ("")] + + xmlLongTag attrs tag m = + do pre <- getPrefix + if pre then + concat <$> sequence [xmlIndent (return ("<" ++ tag ++ xmlAttributes attrs ++ ">\n")), + withIdn m, + return "\n", + xmlIndent (return (""))] + else + xmlShortTag attrs tag m + + xmlLongTags :: [(String, String)] -> String -> [XmlM String] -> XmlM String + xmlLongTags attrs tag ms = + do pre <- getPrefix + if pre then + xmlLongTag attrs tag $ intercalate "\n" <$> sequence ms + else + xmlLongTag attrs tag $ concat <$> sequence ms + + loopText :: Text -> XmlM String + loopText (Footnote str) = withPrefix False $ xmlShortTag [] "footnote" $ return str + loopText (Plain str) = xmlStr $ return str + + loop :: Document -> XmlM String + loop (Heading _ [txts]) = xmlShortTag [] "heading" $ concat <$> mapM loopText txts + loop (Heading _ lns) = xmlLongTags [] "heading" [ concat <$> mapM loopText txts | txts <- lns ] + loop (Paragraph _ txts) = xmlShortTag [] "paragraph" $ concat <$> mapM loopText txts + loop (Content [doc]) = xmlShortTag [] "content" $ loop doc + loop (Content docs) = xmlLongTags [] "content" $ map loop docs + loop (Section doc) = xmlLongTag [] "section" $ loop doc + loop (Style _ sty txt) = xmlShortTag [] sty $ loopText txt diff --git a/src/Data/Document.hs b/src/Data/Document.hs new file mode 100644 --- /dev/null +++ b/src/Data/Document.hs @@ -0,0 +1,53 @@ +module Data.Document where + +import Data.Char (isPunctuation) +import Data.List (intercalate) + +import Data.Text + + +-- | 'Srcloc' represents an association between 'Document' parts and +-- 'Token' elements. +type Srcloc = (Int, String) + + +-- | 'Document' is a structured representation of the input. +data Document + -- | 'Heading' is a 'Document' part with a source location and + -- heading content. + = Heading Srcloc [[Text]] + -- | 'Paragraph' is a 'Document' part with a source location and + -- paragraph content. + | Paragraph Srcloc [Text] + -- | 'Content' is a 'Document' part that represents a sequence of + -- 'Document's. + | Content [Document] + -- | 'Section' is a 'Document' part that represents a subsection. + | Section Document + -- | 'Style' is a 'Document' part that represents a style 'Text' + -- element, with a source location and a style 'String'. + | Style Srcloc String Text + +instance Show Document where + show (Heading _ docs) = "Heading = " ++ show docs + show (Paragraph _ doc) = "Paragraph = " ++ show doc + show (Content docs) = intercalate "\n" $ map show docs + show (Section doc) = "begin\n" ++ show doc ++ "\nend" + show (Style _ sty str) = "(" ++ sty ++ ") = " ++ show str + + +-- | 'ensureDocument' @docs@ the first elements of @docs@ if @docs@ is +-- a singleton list, otherwise, it returns a 'Content docs' +ensureDocument :: [Document] -> Document +ensureDocument [doc] = doc +ensureDocument docs = Content docs + + +-- | 'rangeLoc' @doc@ returns the pair of surrounding 'Srcloc's of +-- @doc@ or its children. +rangeloc :: Document -> (Srcloc, Srcloc) +rangeloc (Heading loc _) = (loc, loc) +rangeloc (Paragraph loc _) = (loc, loc) +rangeloc (Content (doc:docs)) = (fst $ rangeloc doc, snd $ rangeloc $ last docs) +rangeloc (Section doc) = rangeloc doc +rangeloc (Style loc _ _) = (loc, loc) diff --git a/src/Data/Text.hs b/src/Data/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text.hs @@ -0,0 +1,13 @@ +module Data.Text where + + +-- | 'Text' represents predefined styled elements. +data Text + -- | 'Footnote' is a 'Text' element that represents a footnote. + = Footnote String + -- | 'Plain' is a 'Text' element without style. + | Plain String + +instance Show Text where + show (Footnote str) = "[" ++ str ++ "]" + show (Plain str) = str diff --git a/src/Data/Token.hs b/src/Data/Token.hs new file mode 100644 --- /dev/null +++ b/src/Data/Token.hs @@ -0,0 +1,16 @@ +module Data.Token where + + +-- | 'Token' is an unstructured representation of the input. +data Token + -- | 'Literal' corresponds to successive lines of text joined + -- together. + = Literal Int String + -- | 'BeginSection' represents the beginning of a new section, + -- i.e., increase in indentation or an unmatched decrease in + -- indentation. + | BeginSection + -- | 'EndSection' represents the end of a section, i.e., a + -- decrease in indentation. + | EndSection + deriving (Show) diff --git a/src/Fmark.hs b/src/Fmark.hs new file mode 100644 --- /dev/null +++ b/src/Fmark.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE ParallelListComp #-} +module Fmark where + +import Control.Monad ((>=>)) + +import System.Directory (copyFile) +import System.FilePath (addExtension, dropExtensions, combine) +import System.IO +import System.Process +import System.Unix.Directory (withTemporaryDirectory) + +import Backend.Latex +import Backend.Xml +import Data.Document +import Data.Text +import Data.Token +import Parser +import Utils +import Weaver + + +-- | 'pdflatex' @outFp contents@ executes the 'pdflatex' 'Process' +-- with @contents@ as input and @outFp@ as the 'FilePath' for the +-- output PDF. +pdflatex :: FilePath -> String -> IO () +pdflatex outFp contents = + withTemporaryDirectory "fmark" $ + \outDir -> withFile "/dev/null" WriteMode $ + \hNull -> do (Just hIn, _, _, h) <- createProcess + (proc "pdflatex" ["-output-directory=" ++ outDir, + "--jobname=" ++ outFname]) + { std_in = CreatePipe, + std_out = UseHandle hNull, + std_err = UseHandle hNull } + mapM_ (hPutStrLn hIn) $ filterLines $ lines contents + hClose hIn + waitForProcess h + copyFile (pdfFp outDir) (addExtension (dropExtensions outFp) "pdf") + where outFname = "texput" + pdfFp fp = combine fp $ addExtension outFname "pdf" + + +-- | 'Flag' represents the command line flags that specify output +-- format, display usage information, and 'Style' filename. +data Flag + -- | Output to 'stdout' in 'Document' format. + = OutputDoc + -- | Output to 'stdout' in LaTeX format. + | OutputLatex + -- | Output to a PDF file using LaTeX format and 'pdflatex'. + | OutputPdf + -- | Output to 'stdout' in XML format. + | OutputXml + -- | Display usage information. + | Help + | StyleName String + deriving (Eq, Show) + + +-- | 'formatFn' @fmt@ maps the output format @fmt@ into the +-- appropriate formatter function. +formatFn :: Flag -> Maybe Document -> Document -> String +formatFn OutputDoc = const show +formatFn OutputLatex = docToLatex +formatFn OutputPdf = formatFn OutputLatex +formatFn OutputXml = docToXml +formatFn fmt = error $ "unhandled case: " ++ show fmt + + +-- | 'formatH' @fmt eOut@ maps the output format @fmt@ and either an +-- output 'Handle' or a 'FilePath' into the appropriate 'IO' function. +formatH :: Flag -> Either Handle FilePath -> String -> IO () +formatH OutputPdf (Left _) = error "cannot use stdin with PDF output format" +formatH OutputPdf (Right fp) = pdflatex fp +formatH fmt (Left hOut) = hPutStrLn hOut +formatH fmt (Right fp) = \str -> withFile fp WriteMode $ \hOut -> formatH fmt (Left hOut) str + + +-- | 'fmark' @fmt contents mstring@ is the friendly markup algorithm, +-- using @fmt@ as output format, @contents@ as input and @mstyle@ as +-- an optional style input. 'fmark' return a formatted string +-- according to @fmt@ and a 'List' of warning messages. +fmark :: Flag -> String -> Maybe String -> (String, [String]) +fmark fmt contents Nothing = + (formatFn fmt Nothing $ docify $ classify contents, []) + +fmark fmt contents (Just style) = + let doc = docify $ classify contents in + let styleDoc = docify $ classify style in + let (doc', errs) = weave doc styleDoc in + (formatFn fmt (Just styleDoc) doc', errs) + + +-- | 'fmarkH' is an alternative version of 'fmark' that uses 'Handle's +-- instead of 'String's thus performing 'IO' directly for input and +-- output. +fmarkH :: Flag -> Handle -> Either Handle FilePath -> Maybe Handle -> IO () +fmarkH fmt hIn eOut mstyle = + do contents <- hGetContents hIn + mstyle <- maybe (return Nothing) + (hGetContents >=> (return . Just)) + mstyle + let (str, errs) = fmark fmt contents mstyle + formatH fmt eOut str + case errs of + [] -> return () + _ -> do hPutStrLn stderr "Style warnings:" + mapM_ (hPutStrLn stderr) errs diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,99 @@ +module Parser where + +import Data.Char (isPunctuation, isSpace) + +import Data.Document +import Data.Text +import Data.Token +import Utils + + +-- | 'isParagraph' @str@ decides whether @str@ is a paragraph or a +-- heading. +isParagraph :: String -> Bool +isParagraph str = + isPunctuation c && (not $ c `elem` "[]\"") + where c = last str + + +-- | 'section' @idns idn@ is the 'List' of 'BeginSection' and +-- 'EndSection' 'Token's issued according the indentation stack @idns@ +-- and current indentation @idn@. +section :: [Int] -> Int -> [Token] +section [] _ = error "section: idns is empty" +section (idn1:idns) idn2 = + case compare idn1 idn2 of + EQ -> [] + LT -> [BeginSection] + GT -> EndSection:section (dropWhile (> idn1) idns) idn2 + + +-- | 'reduce' @idns ln@ is the 'List' containing the 'Text' 'Token' +-- holding @ln@ preceeded by the appropriate section 'Token's as +-- issued by 'section' according to the indentation stack @idns@. +reduce :: [Int] -> Int -> String -> [Token] +reduce idns n ln = section idns (indentation ln) ++ [Literal n $ trim ln] + + +-- | 'classify' @str@ is the 'List' of 'Token's of @str@. +classify :: String -> [Token] +classify str = + classify' [0] $ zip [1..] $ lines str + where classify' _ [] = [] + classify' _ [(_, ln)] | all isSpace ln = [] + classify' idns ((_, ln1):lns) | all isSpace ln1 = classify' idns lns + classify' idns [(n, ln)] = reduce idns n ln + classify' idns ((n1, ln1):(n2, ln2):lns) + | all isSpace ln2 = reduce idns n1 ln1 ++ classify' (push idn1 (dropWhile (> idn1) idns)) lns + | idn1 < idn2 = reduce idns n1 ln1 ++ classify' (push idn1 (dropWhile (> idn1) idns)) ((n2, ln2):lns) + | idn1 > idn2 = reduce idns n1 ln1 ++ classify' (push idn1 idns) ((n2, ln2):lns) + | otherwise = classify' idns ((n1, join ln1 ln2):lns) + where idn1 = indentation ln1 + idn2 = indentation ln2 + + +-- | 'reconstruct' @str@ produces the 'List' of 'Text' elements for +-- 'String' @str@. +reconstructLine :: String -> [Text] +reconstructLine = loop + where loop [] = [] + loop ('[':str) = + case span (/= ']') str of + (hd, []) -> [Plain hd] + (hd, _:tl) -> Footnote hd:loop tl + loop str = + Plain hd:loop tl + where (hd, tl) = span (/= '[') str + + +-- | 'reconstructLines' @str@ produces the 'List' of 'Text' elements +-- for each line in @str@. +reconstructLines :: String -> [[Text]] +reconstructLines = map reconstructLine . lines + + +-- | 'docify' @tks@ parses the sequence of 'Token's @tks@ into a 'Document'. +docify :: [Token] -> Document +docify tks = + docify' tks [[]] + where docify' :: [Token] -> [[Document]] -> Document + -- edit: this 'ensureDocument' is interfering with style weaving + -- docify' [] [docs] = ensureDocument $ reverse docs + docify' [] [docs] = Content $ reverse docs + docify' [] st = docify' [EndSection] st + + docify' (Literal n str:tks) (top:st) = + docify' tks ((doc:top):st) + where doc | isParagraph str = Paragraph (n, str) $ reconstructLine $ replace ' ' str + | otherwise = Heading (n, str) $ reconstructLines str + + docify' (BeginSection:tks) st = + docify' tks ([]:st) + + docify' (EndSection:tks) (top:bot:st) = + docify' tks ((Section (ensureDocument $ reverse top):bot):st) + + docify' tks st = + error $ "\n\n\tdocify: docify': unhandled case" ++ + "\n\n\t tks = " ++ show tks ++ + "\n\n\t st = " ++ show st ++ "\n\n" diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ParallelListComp #-} +-- | 'Utils' is a module of assorted utilities. +module Utils where + +import Data.Char (isSpace) +import Data.List (dropWhileEnd) + + +-- | 'filterLines' @lns@ filters empty lines and lines containing only +-- space characters from @lns@. +-- +-- > filterLines ["hello", " \t ", "goodbye"] == ["hello","goodbye"] +filterLines :: [String] -> [String] +filterLines lns = [ ln | ln <- lns, trim ln /= "" ] + + +-- | 'replace' @c str@ replaces newlines in @str@ with @c@ +-- +-- > replace "hello\ngoodbye" == "hello,goodbye" +replace :: Char -> String -> String +replace c = + map loop + where loop '\n' = c + loop c = c + + +-- | 'indentation' @ln@ is the number of space characters at the +-- begining of @ln@. +-- +-- > indentation "\t hello" == 2 +indentation :: String -> Int +indentation ln = length $ takeWhile isSpace ln + + +-- | 'join' @str1 str2@ appends @str1@ and @str2@ ensuring that is +-- only a single newline space character between them. +-- +-- > join "hello \n" "\t goodbye" == "hello\ngoodbye" +join :: String -> String -> String +join str1 str2 = dropWhileEnd isSpace str1 ++ "\n" ++ dropWhile isSpace str2 + + +-- | 'prefix' @pre str@ prepends all lines in 'str' with 'pre'. +-- +-- > prefix "->" "hello\ngoodbye" == "->hello\n->goodbye" +prefix :: String -> String -> String +prefix pre str = + pre ++ prefix' str + where prefix' = + concatMap (\c -> case c of + '\n' -> '\n':pre + _ -> [c]) + + +-- | 'push' @x xs@ adds @x@ to @xs@ only if the first element in @xs@ +-- is different from @x@. +-- +-- > push 1 [2,3] == [1,2,3] +-- > push 1 [1,3] == [1,3] +push :: Eq a => a -> [a] -> [a] +push x (y:ys) | x /= y = x:y:ys +push _ xs = xs + + +-- | 'trim' @str@ removes leading and trailing space characters from +-- @str@. +-- +-- > trim "\t hello \n" == "hello" +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace diff --git a/src/Weaver.hs b/src/Weaver.hs new file mode 100644 --- /dev/null +++ b/src/Weaver.hs @@ -0,0 +1,126 @@ +-- | 'Weaver' combines content and style to produced styled +-- 'Document's. +module Weaver where + +import Control.Monad (zipWithM) +import Data.List (intercalate) + +import Data.Document +import Data.Text +import Parser +import Utils + + +-- | 'msgLine' @title cntLoc styLoc@ produces a warning message for a +-- given content and style 'Srcloc'. +msgLine :: String -> Srcloc -> String -> String +msgLine title (n, cnt) sty = + intercalate "\n" ["In line " ++ show n ++ ", " ++ title, + prefix " " cnt, + "does not match style", + prefix " " sty] + + +-- | 'msgLines' @title cntLoc1 cntLoc2 styLoc1 styLoc2@ produces a +-- warning message that spans multiple lines of content and style. +-- This warning message is adjusted to possibly equal ranges of +-- content and style lines. +msgLines :: String -> Srcloc -> Srcloc -> Srcloc -> Srcloc -> String +msgLines title (n1, cnt1) (n2, cnt2) (n1', sty1) (n2', sty2) = + let + pre | n1 == n2 = "In line " ++ show n1 + | otherwise = "In lines " ++ show n1 ++ "-" ++ show n2 + cnt | n1 == n2 = cnt1 + | otherwise = intercalate "\n" [cnt1, "...", cnt2] + sty | n1' == n2' = sty1 + | otherwise = intercalate "\n" [sty1, "...", sty2] + in + intercalate "\n" [pre ++ ", " ++ title, + prefix " " cnt, + "does not match style", + prefix " " sty] + + +-- | 'msgHeading' @cntLoc styLoc@ produces a suitable warning message +-- for a 'Heading' element given the 'Srcloc' of the content and the +-- 'Srcloc' of the style. +msgHeading :: Srcloc -> Srcloc -> String +msgHeading loc (_, styStr) = msgLine "heading" loc styStr + + +-- | 'msgPararaph' @cntLoc styLoc@ produces a suitable warning message +-- for a 'Paragraph' element given the 'Srcloc' of the content and the +-- 'Srcloc' of the style. +msgParagraph :: Srcloc -> Srcloc -> String +msgParagraph loc (_, styStr) = msgLine "paragraph" loc styStr + + +-- | 'weaveText' @loc txt1 txt2@ weaves 'Text' @txt1@ with style of +-- 'Text' @txt2@ where @loc@ is the 'Srloc' of the produced 'Style' +-- elements. 'Nothing' is returned if the style cannot be applied. +weaveText :: Srcloc -> Text -> Text -> Maybe Document +weaveText loc (Footnote cnt) (Footnote sty) = + Just $ Style loc (trim sty) $ Plain $ trim cnt + +weaveText loc text@(Plain cnt) (Plain sty) = + Just $ Style loc (trim sty') $ Plain $ trim cnt + where sty' | isParagraph sty = init sty + | otherwise = sty + +weaveText _ _ _ = Nothing + + +-- | 'weaveLine' @loc txts1 txts2@ weaves 'Text's @txts1@ with style +-- of @txts2@ where @loc@ is the 'Srcloc' of the produced 'Style' +-- elements. 'Nothing' is returned if the style cannot be applied. +weaveLine :: Srcloc -> [Text] -> [Text] -> Maybe [Document] +weaveLine _ txts1 txts2 | length txts1 /= length txts2 = Nothing +weaveLine loc txts1 txts2 = zipWithM (weaveText loc) txts1 txts2 + + +-- | 'weaveLines' @loc lns1 lns2@ weaves lines @lns1@ with style of +-- lines @lns2@ where @loc@ is the 'Srcloc' of the produced 'Style' +-- elements. 'Nothing' is returned if the style cannot be applied. +weaveLines :: Srcloc -> [[Text]] -> [[Text]] -> Maybe [[Document]] +weaveLines _ lns1 lns2 | length lns1 /= length lns2 = Nothing +weaveLines loc lns1 lns2 = zipWithM (weaveLine loc) lns1 lns2 + + +-- | 'weaveStyle' @doc style@ combines content 'Document' @doc@ and +-- style 'Document' @style@ in a single styled 'Document'. +weave :: Document -> Document -> (Document, [String]) +weave doc style = + let (docs, errs) = weave' doc style in (ensureDocument docs, errs) + where weave' cnt@(Heading loc1 lns1) (Heading loc2 lns2) = + case weaveLines loc1 lns1 lns2 of + Nothing -> ([cnt], [msgHeading loc1 loc2]) + Just docs -> (concat docs, []) + + weave' cnt@(Paragraph loc1 txts1) (Paragraph loc2 txts2) = + case weaveLine loc1 txts1 txts2 of + Nothing -> ([cnt], [msgParagraph loc1 loc2]) + Just docs -> (docs, []) + + weave' cnt@(Content docs1) sty@(Content docs2) | length docs1 < length docs2 = + let + (cntLoc1, cntLoc2) = rangeloc cnt + (styLoc1, styLoc2) = rangeloc sty + in + ([cnt], [msgLines "content" cntLoc1 cntLoc2 styLoc1 styLoc2]) + + weave' (Content docs1) (Content docs2) = + let + (matDocs, unmatDocs) = splitAt (length docs2) docs1 + (docss, errss) = unzip $ zipWith weave' matDocs docs2 + in ([Content (concat docss ++ unmatDocs)], concat errss) + + weave' (Section doc1) (Section doc2) = + let (doc', errs) = weave' doc1 doc2 in + ([Section $ ensureDocument doc'], errs) + + weave' cnt sty = + let + (cntLoc1, cntLoc2) = rangeloc cnt + (styLoc1, styLoc2) = rangeloc sty + in + ([cnt], [msgLines "document" cntLoc1 cntLoc2 styLoc1 styLoc2])