packages feed

fmark 0.1.0 → 0.1.1

raw patch · 10 files changed

+705/−3 lines, 10 files

Files

fmark.cabal view
@@ -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 <jabolopes@gmail.com>+maintainer:          José Lopes <jabolopes AT gmail DOT com> 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.*,
+ src/Backend/Latex.hs view
@@ -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 {} = ""
+ src/Backend/Xml.hs view
@@ -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" ["<xml>", str, "</xml>"]+    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 ("</" ++ tag ++ ">")]++          xmlLongTag attrs tag m =+              do pre <- getPrefix+                 if pre then+                     concat <$> sequence [xmlIndent (return ("<" ++ tag ++ xmlAttributes attrs ++ ">\n")),+                                          withIdn m,+                                          return "\n",+                                          xmlIndent (return ("</" ++ tag ++ ">"))]+                 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
+ src/Data/Document.hs view
@@ -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)
+ src/Data/Text.hs view
@@ -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
+ src/Data/Token.hs view
@@ -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)
+ src/Fmark.hs view
@@ -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
+ src/Parser.hs view
@@ -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"
+ src/Utils.hs view
@@ -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
+ src/Weaver.hs view
@@ -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])