T.P.Writers.Shared: Export splitSentences as a Doc Text transform.

[API change]

Use this in man/ms.

3 files changed, 61 insertions, 16 deletions

diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs
index 89789d3c5..9514a1ce7 100644
--- a/src/Text/Pandoc/Writers/Man.hs
+++ b/src/Text/Pandoc/Writers/Man.hs
@@ -108,10 +108,10 @@ blockToMan :: PandocMonad m
            -> StateT WriterState m (Doc Text)
 blockToMan opts (Div _ bs) = blockListToMan opts bs
 blockToMan opts (Plain inlines) =
-  inlineListToMan opts inlines
+  splitSentences <$> inlineListToMan opts inlines
 blockToMan opts (Para inlines) = do
   contents <- inlineListToMan opts inlines
-  return $ text ".PP" $$ contents
+  return $ text ".PP" $$ splitSentences contents
 blockToMan opts (LineBlock lns) =
   blockToMan opts $ linesToPara lns
 blockToMan _ b@(RawBlock f str)
diff --git a/src/Text/Pandoc/Writers/Ms.hs b/src/Text/Pandoc/Writers/Ms.hs
index 719407ac1..332368a67 100644
--- a/src/Text/Pandoc/Writers/Ms.hs
+++ b/src/Text/Pandoc/Writers/Ms.hs
@@ -142,7 +142,7 @@ blockToMs opts (Div (ident,cls,kvs) bs) = do
        setFirstPara
        return $ anchor $$ res
 blockToMs opts (Plain inlines) =
-  inlineListToMs' opts inlines
+  splitSentences <$> inlineListToMs' opts inlines
 blockToMs opts (Para [Image attr alt (src,_tit)])
   | let ext = takeExtension (T.unpack src) in (ext == ".ps" || ext == ".eps") = do
   let (mbW,mbH) = (inPoints opts <$> dimension Width attr,
@@ -155,7 +155,7 @@ blockToMs opts (Para [Image attr alt (src,_tit)])
                               space <>
                               doubleQuotes (literal (tshow (floor hp :: Int)))
                        _ -> empty
-  capt <- inlineListToMs' opts alt
+  capt <- splitSentences <$> inlineListToMs' opts alt
   return $ nowrap (literal ".PSPIC -C " <>
              doubleQuotes (literal (escapeStr opts src)) <>
              sizeAttrs) $$
@@ -166,7 +166,8 @@ blockToMs opts (Para inlines) = do
   firstPara <- gets stFirstPara
   resetFirstPara
   contents <- inlineListToMs' opts inlines
-  return $ literal (if firstPara then ".LP" else ".PP") $$ contents
+  return $ literal (if firstPara then ".LP" else ".PP") $$
+           splitSentences contents
 blockToMs _ b@(RawBlock f str)
   | f == Format "ms" = return $ literal str
   | otherwise        = do
diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs
index 0b7c6bee0..34c4ebfba 100644
--- a/src/Text/Pandoc/Writers/Shared.hs
+++ b/src/Text/Pandoc/Writers/Shared.hs
@@ -36,6 +36,8 @@ module Text.Pandoc.Writers.Shared (
                      , toTableOfContents
                      , endsWithPlain
                      , toLegacyTable
+                     , breakable
+                     , splitSentences
                      )
 where
 import Safe (lastMay)
@@ -49,6 +51,7 @@ import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
 import Data.Text.Conversions (FromText(..))
 import qualified Data.Map as M
 import qualified Data.Text as T
+import Data.Text (Text)
 import qualified Text.Pandoc.Builder as Builder
 import Text.Pandoc.Definition
 import Text.Pandoc.Options
@@ -119,13 +122,13 @@ metaValueToVal _ inlineWriter (MetaInlines is) = SimpleVal <$> inlineWriter is
 
 
 -- | Retrieve a field value from a template context.
-getField   :: FromContext a b => T.Text -> Context a -> Maybe b
+getField   :: FromContext a b => Text -> Context a -> Maybe b
 getField field (Context m) = M.lookup field m >>= fromVal
 
 -- | Set a field of a template context.  If the field already has a value,
 -- convert it into a list with the new value appended to the old value(s).
 -- This is a utility function to be used in preparing template contexts.
-setField   :: ToContext a b => T.Text -> b -> Context a -> Context a
+setField   :: ToContext a b => Text -> b -> Context a -> Context a
 setField field val (Context m) =
   Context $ M.insertWith combine field (toVal val) m
  where
@@ -135,21 +138,21 @@ setField field val (Context m) =
 -- | Reset a field of a template context.  If the field already has a
 -- value, the new value replaces it.
 -- This is a utility function to be used in preparing template contexts.
-resetField :: ToContext a b => T.Text -> b -> Context a -> Context a
+resetField :: ToContext a b => Text -> b -> Context a -> Context a
 resetField field val (Context m) =
   Context (M.insert field (toVal val) m)
 
 -- | Set a field of a template context if it currently has no value.
 -- If it has a value, do nothing.
 -- This is a utility function to be used in preparing template contexts.
-defField   :: ToContext a b => T.Text -> b -> Context a -> Context a
+defField   :: ToContext a b => Text -> b -> Context a -> Context a
 defField field val (Context m) =
   Context (M.insertWith f field (toVal val) m)
   where
     f _newval oldval = oldval
 
 -- | Get the contents of the `lang` metadata field or variable.
-getLang :: WriterOptions -> Meta -> Maybe T.Text
+getLang :: WriterOptions -> Meta -> Maybe Text
 getLang opts meta =
   case lookupContext "lang" (writerVariables opts) of
         Just s -> Just s
@@ -162,7 +165,7 @@ getLang opts meta =
                _                                 -> Nothing
 
 -- | Produce an HTML tag with the given pandoc attributes.
-tagWithAttrs :: HasChars a => T.Text -> Attr -> Doc a
+tagWithAttrs :: HasChars a => Text -> Attr -> Doc a
 tagWithAttrs tag (ident,classes,kvs) = hsep
   ["<" <> text (T.unpack tag)
   ,if T.null ident
@@ -213,7 +216,7 @@ fixDisplayMath x = x
 
 -- | Converts a Unicode character into the ASCII sequence used to
 -- represent the character in "smart" Markdown.
-unsmartify :: WriterOptions -> T.Text -> T.Text
+unsmartify :: WriterOptions -> Text -> Text
 unsmartify opts = T.concatMap $ \c -> case c of
   '\8217' -> "'"
   '\8230' -> "..."
@@ -345,7 +348,7 @@ gridTable opts blocksToDoc headless aligns widths headers rows = do
 
 -- | Retrieve the metadata value for a given @key@
 -- and convert to Bool.
-lookupMetaBool :: T.Text -> Meta -> Bool
+lookupMetaBool :: Text -> Meta -> Bool
 lookupMetaBool key meta =
   case lookupMeta key meta of
       Just (MetaBlocks _)  -> True
@@ -356,7 +359,7 @@ lookupMetaBool key meta =
 
 -- | Retrieve the metadata value for a given @key@
 -- and extract blocks.
-lookupMetaBlocks :: T.Text -> Meta -> [Block]
+lookupMetaBlocks :: Text -> Meta -> [Block]
 lookupMetaBlocks key meta =
   case lookupMeta key meta of
          Just (MetaBlocks bs)   -> bs
@@ -366,7 +369,7 @@ lookupMetaBlocks key meta =
 
 -- | Retrieve the metadata value for a given @key@
 -- and extract inlines.
-lookupMetaInlines :: T.Text -> Meta -> [Inline]
+lookupMetaInlines :: Text -> Meta -> [Inline]
 lookupMetaInlines key meta =
   case lookupMeta key meta of
          Just (MetaString s)           -> [Str s]
@@ -377,7 +380,7 @@ lookupMetaInlines key meta =
 
 -- | Retrieve the metadata value for a given @key@
 -- and convert to String.
-lookupMetaString :: T.Text -> Meta -> T.Text
+lookupMetaString :: Text -> Meta -> Text
 lookupMetaString key meta =
   case lookupMeta key meta of
          Just (MetaString s)    -> s
@@ -519,3 +522,44 @@ toLegacyTable (Caption _ cbody) specs thead tbodies tfoot
 
     getComponents (Cell _ _ (RowSpan h) (ColSpan w) body)
       = (h, w, body)
+
+-- | Create a breakable 'Doc' from a text.  Only regular spaces
+-- are break points (not tabs or nonbreaking spaces).
+breakable :: Text -> Doc Text
+breakable t
+  | T.any (== ' ') t = mconcat $ foldr go mempty (T.split (==' ') t)
+  | otherwise = Text (realLength t) t
+ where
+  go "" xs =
+   case xs of
+     BreakingSpace : _ -> xs
+     _ -> BreakingSpace : xs
+  go t' xs = Text (realLength t') t' :
+    case xs of
+      [] -> xs
+      BreakingSpace : _ -> xs
+      _ -> BreakingSpace : xs
+
+splitSentences :: Doc Text -> Doc Text
+splitSentences = go . toList
+ where
+  go [] = mempty
+  go (Text len t : BreakingSpace : xs) =
+     if isSentenceEnding t
+        then Text len t <> NewLine <> go xs
+        else Text len t <> BreakingSpace <> go xs
+  go (x:xs) = x <> go xs
+
+  toList (Concat (Concat a b) c) = toList (Concat a (Concat b c))
+  toList (Concat a b) = a : toList b
+  toList x = [x]
+
+  isSentenceEnding t =
+    case T.unsnoc t of
+      Just (t',c)
+        | c == '.' || c == '!' || c == '?' -> True
+        | c == ')' || c == ']' || c == '"' || c == '\x201D' ->
+           case T.unsnoc t' of
+             Just (_,d) -> d == '.' || d == '!' || d == '?'
+             _ -> False
+      _ -> False