{ {-# 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 Haddock.Parse where import Haddock.Lex import Haddock.Types (Doc(..), Example(Example), Hyperlink(..)) import Haddock.Doc import HsSyn import RdrName import Data.Char (isSpace) import Data.Maybe (fromMaybe) import Data.List (stripPrefix) } %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 :: { Doc RdrName } : apara PARA doc { docAppend $1 $3 } | PARA doc { $2 } | apara { $1 } | {- empty -} { DocEmpty } apara :: { Doc RdrName } : ulpara { DocUnorderedList [$1] } | olpara { DocOrderedList [$1] } | defpara { DocDefList [$1] } | para { $1 } ulpara :: { Doc RdrName } : '-' para { $2 } olpara :: { Doc RdrName } : '(n)' para { $2 } defpara :: { (Doc RdrName, Doc RdrName) } : '[' seq ']' seq { ($2, $4) } para :: { Doc RdrName } : seq { docParagraph $1 } | codepara { DocCodeBlock $1 } | property { $1 } | examples { DocExamples $1 } codepara :: { Doc RdrName } : '>..' codepara { docAppend (DocString $1) $2 } | '>..' { DocString $1 } property :: { Doc RdrName } : PROP { makeProperty $1 } examples :: { [Example] } : example examples { $1 : $2 } | example { [$1] } example :: { Example } : PROMPT EXP result { makeExample $1 $2 (lines $3) } | PROMPT EXP { makeExample $1 $2 [] } result :: { String } : RESULT result { $1 ++ $2 } | RESULT { $1 } seq :: { Doc RdrName } : elem seq { docAppend $1 $2 } | elem { $1 } elem :: { Doc RdrName } : elem1 { $1 } | '@' seq1 '@' { DocMonospaced $2 } seq1 :: { Doc RdrName } : PARA seq1 { docAppend (DocString "\n") $2 } | elem1 seq1 { docAppend $1 $2 } | elem1 { $1 } elem1 :: { Doc RdrName } : STRING { DocString $1 } | '/../' { DocEmphasis (DocString $1) } | URL { DocHyperlink (makeHyperlink $1) } | PIC { DocPic $1 } | ANAME { DocAName $1 } | IDENT { DocIdentifier $1 } | DQUO strings DQUO { DocModule $2 } strings :: { String } : STRING { $1 } | STRING strings { $1 ++ $2 } { happyError :: [LToken] -> Maybe a happyError toks = Nothing -- | 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 -> Hyperlink makeHyperlink input = case break isSpace $ strip input of (url, "") -> Hyperlink url Nothing (url, label) -> Hyperlink url (Just . dropWhile isSpace $ label) makeProperty :: String -> Doc RdrName makeProperty s = case strip s of 'p':'r':'o':'p':'>':xs -> DocProperty (dropWhile isSpace xs) xs -> error $ "makeProperty: invalid input " ++ show xs -- | Create an 'Example', stripping superfluous characters as appropriate makeExample :: String -> String -> [String] -> Example makeExample prompt expression result = Example (strip expression) -- we do not care about leading and trailing -- whitespace in expressions, so drop them 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 }