9e3eba6 · typeable/pandoc

86instance Default RoffState where

87 def = RoffState {fontKind = Regular}

88

89−type ManParser m = ParserT [Char] RoffState m

89+type ManLexer m = ParserT [Char] RoffState m

90−type ManCompiler m = ParserT [ManToken] ParserState m

90+type ManParser m = ParserT [ManToken] ParserState m

91

92----

93-- testStrr :: [Char] -> Either PandocError Pandoc

115-- | Read man (troff) from an input string and return a Pandoc document.

116readMan :: PandocMonad m => ReaderOptions -> T.Text -> m Pandoc

117readMan opts txt = do

118− eithertokens <- readWithM parseMan def (T.unpack $ crFilter txt)

118+ eithertokens <- readWithM lexMan def (T.unpack $ crFilter txt)

119 case eithertokens of

120 Right tokenz -> do

121 let state = def {stateOptions = opts} :: ParserState

122− eitherdoc <- readWithMTokens compileMan state tokenz

122+ eitherdoc <- readWithMTokens parseMan state tokenz

123 case eitherdoc of

124 Right doc -> return doc

125 Left e -> throwError e

143-- String -> ManToken function

144--

145

146−parseMan :: PandocMonad m => ManParser m [ManToken]

146+lexMan :: PandocMonad m => ManLexer m [ManToken]

147−parseMan = many (parseMacro <|> parseLine <|> parseEmptyLine)

147+lexMan = many (lexMacro <|> lexLine <|> lexEmptyLine)

148

149−compileMan :: PandocMonad m => ManCompiler m Pandoc

149+parseMan :: PandocMonad m => ManParser m Pandoc

150−compileMan = do

150+parseMan = do

151− let compilers = [compileTitle, compilePara, compileSkippedContent

151+ let parsers = [parseTitle, parsePara, parseSkippedContent

152− , compileCodeBlock, compileHeader, compileSkipMacro]

152+ , parseCodeBlock, parseHeader, parseSkipMacro]

153− blocks <- many $ choice compilers

153+ blocks <- many $ choice parsers

154 parserst <- getState

155 return $ Pandoc (stateMeta parserst) (filter (not . isNull) blocks)

156

159 isNull Null = True

160 isNull _ = False

161

162−parseMacro :: PandocMonad m => ManParser m ManToken

162+lexMacro :: PandocMonad m => ManLexer m ManToken

163−parseMacro = do

163+lexMacro = do

164 char '.' <|> char '\''

165 many space

166 macroName <- many1 (letter <|> oneOf ['\\', '"'])

167− args <- parseArgs

167+ args <- lexArgs

168 let joinedArgs = concat $ intersperse " " args

169

170 let tok = case macroName of

200 let manurl pagename section = "../"++section++"/"++pagename++"."++section

201 return $ Link nullAttr [Str txt] (manurl mpage [mansect], mpage)

202

203− parseArgs :: PandocMonad m => ManParser m [String]

203+ lexArgs :: PandocMonad m => ManLexer m [String]

204− parseArgs = do

204+ lexArgs = do

205 eolOpt <- optionMaybe $ char '\n'

206 if isJust eolOpt

207 then return []

208 else do

209 many1 space

210 arg <- try quotedArg <|> plainArg

211− otherargs <- parseArgs

211+ otherargs <- lexArgs

212 return $ arg : otherargs

213

214 where

215

216− plainArg :: PandocMonad m => ManParser m String

216+ plainArg :: PandocMonad m => ManLexer m String

217 plainArg = many1 $ noneOf " \t\n"

218

219− quotedArg :: PandocMonad m => ManParser m String

219+ quotedArg :: PandocMonad m => ManLexer m String

220 quotedArg = do

221 char '"'

222 val <- many1 quotedChar

223 char '"'

224 return val

225

226− quotedChar :: PandocMonad m => ManParser m Char

226+ quotedChar :: PandocMonad m => ManLexer m Char

227 quotedChar = noneOf "\"\n" <|> try (string "\"\"" >> return '"')

228

229−escapeParser :: PandocMonad m => ManParser m EscapeThing

229+escapeLexer :: PandocMonad m => ManLexer m EscapeThing

230−escapeParser = do

230+escapeLexer = do

231 char '\\'

232 choice [escChar, escFont]

233 where

234

235− escChar :: PandocMonad m => ManParser m EscapeThing

235+ escChar :: PandocMonad m => ManLexer m EscapeThing

236 escChar = choice [ char '-' >> return (EChar '-')

237 , oneOf ['%', '{', '}'] >> return ENothing

238 ]

239

240− escFont :: PandocMonad m => ManParser m EscapeThing

240+ escFont :: PandocMonad m => ManLexer m EscapeThing

241 escFont = do

242 char 'f'

243 font <- choice [ char 'B' >> return Bold

250 modifyState (\r -> r {fontKind = font})

251 return $ EFont font

252

253−parseLine :: PandocMonad m => ManParser m ManToken

253+lexLine :: PandocMonad m => ManLexer m ManToken

254−parseLine = do

254+lexLine = do

255 lnparts <- many1 (esc <|> linePart)

256 newline

257 return $ MLine $ catMaybes lnparts

258 where

259

260− esc :: PandocMonad m => ManParser m (Maybe (String, FontKind))

260+ esc :: PandocMonad m => ManLexer m (Maybe (String, FontKind))

261 esc = do

262− someesc <- escapeParser

262+ someesc <- escapeLexer

263 font <- currentFont

264 let rv = case someesc of

265 EChar c -> Just ([c], font)

266 _ -> Nothing

267 return rv

268

269− linePart :: PandocMonad m => ManParser m (Maybe (String, FontKind))

269+ linePart :: PandocMonad m => ManLexer m (Maybe (String, FontKind))

270 linePart = do

271 lnpart <- many1 $ noneOf "\n\\"

272 font <- currentFont

273 return $ Just (lnpart, font)

274

275− currentFont :: PandocMonad m => ManParser m FontKind

275+ currentFont :: PandocMonad m => ManLexer m FontKind

276 currentFont = do

277 RoffState {fontKind = fk} <- getState

278 return fk

279

280

281−parseEmptyLine :: PandocMonad m => ManParser m ManToken

281+lexEmptyLine :: PandocMonad m => ManLexer m ManToken

282−parseEmptyLine = char '\n' >> return MEmptyLine

282+lexEmptyLine = char '\n' >> return MEmptyLine

283

284--

285-- ManToken parsec functions

291 testTok t = if predic t then Just t else Nothing

292 nextPos pos x _xs = updatePosString pos (show x)

293

294−mstr :: PandocMonad m => ManCompiler m ManToken

294+mstr :: PandocMonad m => ManParser m ManToken

295mstr = msatisfy isMStr where

296 isMStr (MStr _ _) = True

297 isMStr _ = False

298

299−mline :: PandocMonad m => ManCompiler m ManToken

299+mline :: PandocMonad m => ManParser m ManToken

300mline = msatisfy isMLine where

301 isMLine (MLine _) = True

302 isMLine _ = False

303

304−mlink :: PandocMonad m => ManCompiler m ManToken

304+mlink :: PandocMonad m => ManParser m ManToken

305mlink = msatisfy isMLink where

306 isMLink (MLink _ _) = True

307 isMLink _ = False

308

309−memplyLine :: PandocMonad m => ManCompiler m ManToken

309+memplyLine :: PandocMonad m => ManParser m ManToken

310memplyLine = msatisfy isMEmptyLine where

311 isMEmptyLine MEmptyLine = True

312 isMEmptyLine _ = False

313

314−mheader :: PandocMonad m => ManCompiler m ManToken

314+mheader :: PandocMonad m => ManParser m ManToken

315mheader = msatisfy isMHeader where

316 isMHeader (MHeader _ _) = True

317 isMHeader _ = False

318

319−mmacro :: PandocMonad m => MacroKind -> ManCompiler m ManToken

319+mmacro :: PandocMonad m => MacroKind -> ManParser m ManToken

320mmacro mk = msatisfy isMMacro where

321 isMMacro (MMacro mk' _) | mk == mk' = True

322 | otherwise = False

323 isMMacro _ = False

324

325−mmacroAny :: PandocMonad m => ManCompiler m ManToken

325+mmacroAny :: PandocMonad m => ManParser m ManToken

326mmacroAny = msatisfy isMMacro where

327 isMMacro (MMacro _ _) = True

328 isMMacro _ = False

329

330−munknownMacro :: PandocMonad m => ManCompiler m ManToken

330+munknownMacro :: PandocMonad m => ManParser m ManToken

331munknownMacro = msatisfy isMUnknownMacro where

332 isMUnknownMacro (MUnknownMacro _ _) = True

333 isMUnknownMacro _ = False

334

335−mcomment :: PandocMonad m => ManCompiler m ManToken

335+mcomment :: PandocMonad m => ManParser m ManToken

336mcomment = msatisfy isMComment where

337 isMComment (MComment _) = True

338 isMComment _ = False

341-- ManToken -> Block functions

342--

343

344−compileTitle :: PandocMonad m => ManCompiler m Block

344+parseTitle :: PandocMonad m => ManParser m Block

345−compileTitle = do

345+parseTitle = do

346 (MMacro _ args) <- mmacro KTitle

347 if null args

348 then return Null

357 in

358 pst {stateMeta = metaUp}

359

360−compileSkippedContent :: PandocMonad m => ManCompiler m Block

360+parseSkippedContent :: PandocMonad m => ManParser m Block

361−compileSkippedContent = do

361+parseSkippedContent = do

362 tok <- munknownMacro <|> mcomment <|> memplyLine

363 onToken tok

364 return Null

365

366 where

367

368− onToken :: PandocMonad m => ManToken -> ManCompiler m ()

368+ onToken :: PandocMonad m => ManToken -> ManParser m ()

369 onToken (MUnknownMacro mname _) = do

370 pos <- getPosition

371 logMessage $ SkippedContent ("Unknown macro: " ++ mname) pos

377strToInline s Bold = Strong [Str s]

378strToInline s ItalicBold = Strong [Emph [Str s]]

379

380−compilePara :: PandocMonad m => ManCompiler m Block

380+parsePara :: PandocMonad m => ManParser m Block

381−compilePara = do

381+parsePara = do

382 inls <- many1 (strInl <|> lineInl <|> comment)

383 let withspaces = intersperse [Str " "] inls

384 return $ Para (concat withspaces)

385

386 where

387

388− strInl :: PandocMonad m => ManCompiler m [Inline]

388+ strInl :: PandocMonad m => ManParser m [Inline]

389 strInl = do

390 (MStr str fk) <- mstr

391 return [strToInline str fk]

392

393− lineInl :: PandocMonad m => ManCompiler m [Inline]

393+ lineInl :: PandocMonad m => ManParser m [Inline]

394 lineInl = do

395 (MLine fragments) <- mline

396 return $ fmap (\(s,f) -> strToInline s f) fragments

397

398− comment :: PandocMonad m => ManCompiler m [Inline]

398+ comment :: PandocMonad m => ManParser m [Inline]

399 comment = mcomment >> return []

400

401

402−compileCodeBlock :: PandocMonad m => ManCompiler m Block

402+parseCodeBlock :: PandocMonad m => ManParser m Block

403−compileCodeBlock = do

403+parseCodeBlock = do

404 mmacro KCodeBlStart

406 mmacro KCodeBlEnd

415 extractText MEmptyLine = Just "" -- string are intercalated with '\n', this prevents double '\n'

416 extractText _ = Nothing

417

418−compileHeader :: PandocMonad m => ManCompiler m Block

418+parseHeader :: PandocMonad m => ManParser m Block

419−compileHeader = do

419+parseHeader = do

420 (MHeader lvl s) <- mheader

421 return $ Header lvl nullAttr [Str s]

422

423−compileSkipMacro :: PandocMonad m => ManCompiler m Block

423+parseSkipMacro :: PandocMonad m => ManParser m Block

424−compileSkipMacro = mmacroAny >> return Null

424+parseSkipMacro = mmacroAny >> return Null