diff options
author | David Lazar <lazar6@illinois.edu> | 2013-03-28 14:53:10 -0700 |
---|---|---|
committer | David Lazar <lazar6@illinois.edu> | 2013-03-28 14:53:10 -0700 |
commit | 18459b95bab91b2a1d59e888045d555494d94bc8 (patch) | |
tree | 1974f9b339f37f9bdb90e309388ef5a436f7bcfe /src/Text/Pandoc/Readers/Haddock/Parse.y | |
parent | ee0fc19bc54208c5d8828eab872e3bbe303c47bf (diff) | |
download | pandoc-18459b95bab91b2a1d59e888045d555494d94bc8.tar.gz |
Add reader for Haddock markup based on Haddock's own lexer/parser.
Diffstat (limited to 'src/Text/Pandoc/Readers/Haddock/Parse.y')
-rw-r--r-- | src/Text/Pandoc/Readers/Haddock/Parse.y | 179 |
1 files changed, 179 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Readers/Haddock/Parse.y b/src/Text/Pandoc/Readers/Haddock/Parse.y new file mode 100644 index 000000000..065b9997f --- /dev/null +++ b/src/Text/Pandoc/Readers/Haddock/Parse.y @@ -0,0 +1,179 @@ +-- This code was copied from the 'haddock' package, modified, and integrated +-- into Pandoc by David Lazar. +{ +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module Text.Pandoc.Readers.Haddock.Parse (parseString, parseParas) where + +import Text.Pandoc.Readers.Haddock.Lex +import Text.Pandoc.Builder +import Data.Generics (everywhere, mkT) +import Data.Char (isSpace) +import Data.Maybe (fromMaybe) +import Data.List (stripPrefix) +import Data.Monoid (mempty) +} + +%expect 0 + +%tokentype { LToken } + +%token + '/' { (TokSpecial '/',_) } + '@' { (TokSpecial '@',_) } + '[' { (TokDefStart,_) } + ']' { (TokDefEnd,_) } + DQUO { (TokSpecial '\"',_) } + URL { (TokURL $$,_) } + PIC { (TokPic $$,_) } + ANAME { (TokAName $$,_) } + '/../' { (TokEmphasis $$,_) } + '-' { (TokBullet,_) } + '(n)' { (TokNumber,_) } + '>..' { (TokBirdTrack $$,_) } + PROP { (TokProperty $$,_) } + PROMPT { (TokExamplePrompt $$,_) } + RESULT { (TokExampleResult $$,_) } + EXP { (TokExampleExpression $$,_) } + IDENT { (TokIdent $$,_) } + PARA { (TokPara,_) } + STRING { (TokString $$,_) } + +%monad { Maybe } + +%name parseParas doc +%name parseString seq + +%% + +doc :: { Blocks } + : apara PARA doc { $1 <> $3 } + | PARA doc { $2 } + | apara { $1 } + | {- empty -} { mempty } + +apara :: { Blocks } + : ulpara { bulletList [$1] } + | olpara { orderedList [$1] } + | defpara { definitionList [$1] } + | para { $1 } + +ulpara :: { Blocks } + : '-' para { $2 } + +olpara :: { Blocks } + : '(n)' para { $2 } + +defpara :: { (Inlines, [Blocks]) } + : '[' seq ']' seq { ($2, [plain $4]) } + +para :: { Blocks } + : seq { para $1 } + | codepara { codeBlock $1 } + | property { $1 } + | examples { $1 } + +codepara :: { String } + : '>..' codepara { $1 ++ $2 } + | '>..' { $1 } + +property :: { Blocks } + : PROP { makeProperty $1 } + +examples :: { Blocks } + : example examples { $1 <> $2 } + | example { $1 } + +example :: { Blocks } + : PROMPT EXP result { makeExample $1 $2 (lines $3) } + | PROMPT EXP { makeExample $1 $2 [] } + +result :: { String } + : RESULT result { $1 ++ $2 } + | RESULT { $1 } + +seq :: { Inlines } + : elem seq { $1 <> $2 } + | elem { $1 } + +elem :: { Inlines } + : elem1 { $1 } + | '@' seq1 '@' { monospace $2 } + +seq1 :: { Inlines } + : PARA seq1 { linebreak <> $2 } + | elem1 seq1 { $1 <> $2 } + | elem1 { $1 } + +elem1 :: { Inlines } + : STRING { str $1 } + | '/../' { emph (str $1) } + | URL { makeHyperlink $1 } + | PIC { image $1 $1 mempty } + | ANAME { mempty } -- TODO + | IDENT { code $1 } + | DQUO strings DQUO { code $2 } + +strings :: { String } + : STRING { $1 } + | STRING strings { $1 ++ $2 } + +{ +happyError :: [LToken] -> Maybe a +happyError toks = Nothing + +monospace :: Inlines -> Inlines +monospace = everywhere (mkT go) + where + go (Str s) = Code nullAttr s + go Space = Code nullAttr " " + go x = x + +-- | Create a `Hyperlink` from given string. +-- +-- A hyperlink consists of a URL and an optional label. The label is separated +-- from the url by one or more whitespace characters. +makeHyperlink :: String -> Inlines +makeHyperlink input = case break isSpace $ strip input of + (url, "") -> link url url (str url) + (url, lb) -> link url url (str label) + where label = dropWhile isSpace lb + +makeProperty :: String -> Blocks +makeProperty s = case strip s of + 'p':'r':'o':'p':'>':xs -> + codeBlockWith ([], ["property"], []) (dropWhile isSpace xs) + xs -> + error $ "makeProperty: invalid input " ++ show xs + +-- | Create an 'Example', stripping superfluous characters as appropriate +makeExample :: String -> String -> [String] -> Blocks +makeExample prompt expression result = + para $ codeWith ([], ["expr"], []) (strip expression ++ "\n") + <> codeWith ([], ["result"], []) (unlines result') + where + -- 1. drop trailing whitespace from the prompt, remember the prefix + (prefix, _) = span isSpace prompt + + -- 2. drop, if possible, the exact same sequence of whitespace + -- characters from each result line + -- + -- 3. interpret lines that only contain the string "<BLANKLINE>" as an + -- empty line + result' = map (substituteBlankLine . tryStripPrefix prefix) result + where + tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys + + substituteBlankLine "<BLANKLINE>" = "" + substituteBlankLine line = line + +-- | Remove all leading and trailing whitespace +strip :: String -> String +strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse +} |