tokenisation

1 files changed, 175 insertions, 131 deletions

diff --git a/src/Text/Pandoc/Readers/Man.hs b/src/Text/Pandoc/Readers/Man.hs
index fe66bb61c..dfe1bcdc1 100644
--- a/src/Text/Pandoc/Readers/Man.hs
+++ b/src/Text/Pandoc/Readers/Man.hs
@@ -35,6 +35,7 @@ module Text.Pandoc.Readers.Man (readMan) where
 import Prelude
 import Control.Monad.Except (throwError)
 import Data.Default (Default)
+import Data.Functor.Identity (Identity)
 import Data.Map (insert)
 import Data.Maybe (isJust, fromMaybe)
 import Data.List (intersperse, intercalate)
@@ -46,11 +47,38 @@ import Text.Pandoc.Logging (LogMessage(..))
 import Text.Pandoc.Options
 import Text.Pandoc.Parsing
 import Text.Pandoc.Shared (crFilter)
-import Text.Parsec
+import Text.Parsec hiding (tokenPrim)
 import Text.Parsec.Char ()
+import Text.Parsec.Pos (updatePosString)
+
+--
+-- Data Types
+--
 
 data FontKind = Regular | Italic | Bold | ItalicBold deriving Show
 
+data MacroKind = KTitle
+               | KCodeBlStart
+               | KCodeBlEnd
+               | KTab
+               | KTabEnd
+               deriving Show
+
+data ManToken = MStr String FontKind
+              | MLine [(String, FontKind)]
+              | MLink String Target
+              | MEmptyLine
+              | MHeader Integer String
+              | MMacro MacroKind [String]
+              | MUnknownMacro String [String]
+              | MComment String
+              deriving Show
+
+data EscapeThing = EFont FontKind
+                 | EChar Char
+                 | ENothing
+                 deriving Show
+
 data RoffState = RoffState { inCodeBlock :: Bool
                            , fontKind :: FontKind
                            } deriving Show
@@ -60,48 +88,60 @@ instance Default RoffState where
 
 data ManState = ManState {pState :: ParserState, rState :: RoffState}
 
+type ManParser m = ParserT [Char] ManState m
+type ManCompiler m = ParserT [ManToken] ManState m
+
 instance HasLogMessages ManState where
   addLogMessage lm mst  = mst {pState = addLogMessage lm (pState mst)}
   getLogMessages mst = getLogMessages $ pState mst
 
+-- | Read man (troff) from an input string and return a Pandoc document.
+readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc
+readMan opts txt = do
+  let state = ManState { pState = def{ stateOptions = opts }, rState = def}
+  parsed <- readWithM parseMan state (T.unpack $ crFilter txt)
+  case parsed of
+    Right result -> return result
+    Left e       -> throwError e
+
+--
+-- String -> ManToken function
+--
+
+parseMan :: PandocMonad m => ManParser m Pandoc
+parseMan = do
+  tokens <- many (parseMacro <|> parseLine <|> parseEmptyLine)
+  let blocks = []
+  parserst <- pState <$> getState
+  return $ Pandoc (stateMeta parserst) blocks
+
 modifyRoffState :: PandocMonad m => (RoffState -> RoffState) -> ParsecT a ManState m ()
 modifyRoffState f = do
   mst <- getState
   setState mst { rState = f $ rState mst }
 
-type ManParser m = ParserT [Char] ManState m
-
-parseMacro :: PandocMonad m => ManParser m Block
+parseMacro :: PandocMonad m => ManParser m ManToken
 parseMacro = do
   char '.' <|> char '\''
   many space
   macroName <- many1 (letter <|> oneOf ['\\', '"'])
   args <- parseArgs
   let joinedArgs = concat $ intersperse " " args
-  ManState { rState = rst } <- getState
-  let toTextF transf = if inCodeBlock rst then [Code nullAttr joinedArgs] else transf [Str joinedArgs]
-  let toText = return . Plain . toTextF
-  let toBold       = toText (\s -> [Strong s])
-  let toItalic     = toText (\s -> [Emph s])
-  let toBoldItalic = toText (\s -> [Strong [Emph s]])
-  
-  case macroName of
-    "\\\"" -> return Null -- comment
-    "TH"   -> macroTitle (if null args then "" else head args) -- man-title
-    "TP"   -> return Null -- tab-indented paragraph
-    "PP"   -> return Null -- end of tab-indented paragraphs
-    "nf"   -> macroCodeBlock True >> return Null
-    "fi"   -> macroCodeBlock False >> return Null
-    "B"    -> toBold
-    "BR"   -> return $ macroBR joinedArgs (inCodeBlock rst)
-    "BI"   -> toBoldItalic
-    "IB"   -> toBoldItalic
-    "I"    -> toItalic
-    "IR"   -> toItalic
-    "RI"   -> toItalic
-    "SH"   -> return $ Header 2 nullAttr [Str joinedArgs]
-    "sp"   -> return $ if inCodeBlock rst then Null else Plain [LineBreak]
-    _      -> unkownMacro macroName
+
+  let tok = case macroName of
+              x | x `elem` ["\\\"", "\\#"] -> MComment joinedArgs
+              "TH"   -> MMacro KTitle args
+              "TP"   -> MMacro KTab []
+              "PP"   -> MMacro KTabEnd []
+              "nf"   -> MMacro KCodeBlStart []
+              "fi"   -> MMacro KCodeBlEnd []
+              x | x `elem` ["B", "BR"]    -> MStr joinedArgs Bold -- "BR" is often used as a link to another man
+              x | x `elem` ["BI", "IB"] -> MStr joinedArgs ItalicBold
+              x | x `elem` ["I", "IR", "RI"]  -> MStr joinedArgs Italic
+              "SH"   -> MHeader 2 joinedArgs
+              "sp"   -> MEmptyLine
+              _      -> MUnknownMacro macroName args
+  return tok
 
   where
 
@@ -174,111 +214,115 @@ parseMacro = do
     quotedChar :: PandocMonad m => ManParser m Char
     quotedChar = noneOf "\"\n" <|> try (string "\"\"" >> return '"')
 
-roffInline :: RoffState -> String -> [Inline]
-roffInline rst str
-  | null str && (not $ inCodeBlock rst) = []
-  | inCodeBlock rst = [Code nullAttr str]
-  | otherwise       = case fontKind rst of
-    Regular    -> [Str str]
-    Italic     -> [Emph [Str str]]
-    Bold       -> [Strong [Str str]]
-    ItalicBold -> [Emph [Strong [Str str]]]
-
-parseLine :: PandocMonad m => ManParser m Block
+escapeParser :: PandocMonad m => ManParser m EscapeThing
+escapeParser = do
+  char '\\'
+  choice [escChar, escFont]
+  where
+
+  escChar :: PandocMonad m => ManParser m EscapeThing
+  escChar = choice [ char '-' >> return (EChar '-')
+                  , oneOf ['%', '{', '}'] >> return ENothing
+                  ]
+
+  escFont :: PandocMonad m => ManParser m EscapeThing
+  escFont = do
+    char 'f'
+    font <- choice [ char 'B' >> return Bold
+          , char 'I' >> return Italic
+          , (char 'P' <|> anyChar) >> return Regular
+          , char '(' >> anyChar >> anyChar >> return Regular
+          , string "[]"  >> return Regular
+          , char '[' >> many1 letter >> char ']'  >> return Regular
+          ]
+    modifyRoffState (\r -> RoffState {fontKind = font})
+    return $ EFont font
+
+parseLine :: PandocMonad m => ManParser m ManToken
 parseLine = do
-  parts <- parseLineParts
-  newline
-  return $ if null parts
-    then Null
-    else Plain parts
+  lnparts <- many1 (esc <|> linePart)
+  return $ MLine lnparts
   where
-    parseLineParts :: PandocMonad m => ManParser m [Inline]
-    parseLineParts = do
-      lnpart <- many $ noneOf "\n\\"
-      ManState {rState = roffSt} <- getState
-      let inls = roffInline roffSt lnpart
-      others <- backSlash <|> return []
-      return $ inls ++ others
+
+  esc :: PandocMonad m => ManParser m (String, FontKind)
+  esc = do
+    someesc <- escapeParser
+    font <- currentFont
+    let rv = case someesc of
+               EChar c -> ([c], font)
+               _ -> ("", font)
+    return rv
+
+  linePart :: PandocMonad m => ManParser m (String, FontKind)
+  linePart = do
+    lnpart <- many1 $ noneOf "\n\\"
+    font <- currentFont
+    return (lnpart, font)
+  
+  currentFont :: PandocMonad m => ManParser m FontKind
+  currentFont = do
+    RoffState {fontKind = fk} <- rState <$> getState
+    return fk
+
     
-    backSlash :: PandocMonad m => ManParser m [Inline]
-    backSlash = do
-      char '\\'
-      esc <- choice [ char 'f' >> fEscape
-                    , char '-' >> return (Just '-')
-                    , char '%' >> return Nothing
-                    , Just <$> noneOf "\n"
-                    ]
-      ManState {rState = roffSt} <- getState
-      case esc of
-        Just c -> let inls = roffInline roffSt [c]
-                  in parseLineParts >>= (\oth -> return $ inls ++ oth)
-        Nothing -> parseLineParts
-      where
-      
-      fEscape :: PandocMonad m => ManParser m (Maybe Char)
-      fEscape = choice [ char 'B' >> modifyRoffState (\rst -> rst {fontKind = Bold})
-                       , char 'I' >> modifyRoffState (\rst -> rst {fontKind = Italic})
-                       , (char 'P' <|> anyChar) >> modifyRoffState (\rst -> rst {fontKind = Regular})
-                       ]
-                >> return Nothing
-
-finds :: (a -> Bool) -> [a] -> ([a], [a])
-finds predic els = let matched = finds' els
-  in (matched, drop (length matched) els) where
-  finds' [] = []
-  finds' (e:es) | predic e = e : finds' es
-                | otherwise = []
-
--- | return (matched, notmatched, others)
-findsBoth :: (a -> Bool) -> [a] -> ([a], [a], [a])
-findsBoth predic els =
-  let (matched, els')     = finds predic els
-      (notmatched, els'') = finds (not . predic) els'
-  in (matched, notmatched, els'')
-
-createParas :: [Block] -> [Block]
-createParas bs = inner bs [] where
-  inner :: [Block] -> [Inline] -> [Block]
-  inner [] inls = plainInlinesToPara inls
-  inner (Plain einls : oth) inls = inner oth (inls ++ joinCode einls)
-  inner (block : oth) inls = (plainInlinesToPara inls ++ [block]) ++ inner oth []
-
-  joinCode :: [Inline] -> [Inline]
-  joinCode inls =
-    let (codes, notcodes) = finds isCode inls
-        codeStr (Code _ s) = s
-        codeStr _          = ""
-        joined = Code nullAttr (concat $ codeStr <$> codes)
-    in if null codes
-         then notcodes
-         else joined : notcodes
-
-  plainInlinesToPara :: [Inline] -> [Block]
-  plainInlinesToPara []   = []
-  plainInlinesToPara inls =
-    let (cds, ncds, oth) = findsBoth isCode inls
-        codeToStr (Code _ s) = s
-        codeToStr _ = ""
-        cbs = if null cds
-                then []
-                else [CodeBlock nullAttr (intercalate "\n" $ codeToStr <$> cds)]
-        paras = [Para (intersperse (Str " ") ncds)]
-    in cbs ++ paras ++ plainInlinesToPara oth
-
-  isCode (Code _ _) = True
-  isCode _ = False
+parseEmptyLine :: PandocMonad m => ManParser m ManToken
+parseEmptyLine = char '\n' >> return MEmptyLine
 
-parseMan :: PandocMonad m => ManParser m Pandoc
-parseMan = do
-  blocks <- createParas <$> many (parseMacro <|> parseLine)
-  parserst <- pState <$> getState
-  return $ Pandoc (stateMeta parserst) blocks
+--
+-- ManToken parsec functions
+--
+
+msatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParserT s st m t
+msatisfy pred = tokenPrim show nextPos testTok
+  where
+    posFromTok (pos,t)  = pos
+    testTok t     = if pred t then Just t else Nothing
+    nextPos pos x xs  = updatePosString pos (show x)
+
+mstr :: PandocMonad m => ManCompiler m ManToken
+mstr = msatisfy isMStr where
+  isMStr (MStr _ _) = True
+  isMStr _ = False
+
+mline :: PandocMonad m => ManCompiler m ManToken
+mline = msatisfy isMLine where
+  isMLine (MLine _) = True
+  isMLine _ = False
+
+mlink :: PandocMonad m => ManCompiler m ManToken
+mlink = msatisfy isMLink where
+  isMLink (MLink _ _) = True
+  isMLink _ = False
+
+memplyLine :: PandocMonad m => ManCompiler m ManToken
+memplyLine = msatisfy isMEmptyLine where
+  isMEmptyLine MEmptyLine = True
+  isMEmptyLine _ = False
+
+mheader :: PandocMonad m => ManCompiler m ManToken
+mheader = msatisfy isMHeader where
+  isMHeader (MHeader _ _) = True
+  isMHeader _ = False
+
+mmacro :: PandocMonad m => ManCompiler m ManToken
+mmacro = msatisfy isMMacro where
+  isMMacro (MMacro _ _) = True
+  isMMacro _ = False
+
+munknownMacro :: PandocMonad m => ManCompiler m ManToken
+munknownMacro = msatisfy isMUnknownMacro where
+  isMUnknownMacro (MUnknownMacro _ _) = True
+  isMUnknownMacro _ = False
+
+mcomment :: PandocMonad m => ManCompiler m ManToken
+mcomment = msatisfy isMComment where
+  isMComment (MComment _) = True
+  isMComment _ = False
+
+--
+-- ManToken -> Block functions
+--
+
+compileHeader :: PandocMonad m => ManCompiler m Block
+compileHeader = undefined --do
 
--- | Read man (troff) from an input string and return a Pandoc document.
-readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc
-readMan opts txt = do
-  let state = ManState { pState = def{ stateOptions = opts }, rState = def}
-  parsed <- readWithM parseMan state (T.unpack $ crFilter txt)
-  case parsed of
-    Right result -> return result
-    Left e       -> throwError e