X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FHaddockLex.x;h=da6dbd37065f2f8e5c2aff30c9fd8feb1118a711;hp=f395976d0badfed679d77366234886d9484666bb;hb=1e50fd4185479a62e02d987bdfcb1c62712859ca;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4

diff --git a/compiler/parser/HaddockLex.x b/compiler/parser/HaddockLex.x
index f395976..da6dbd3 100644
--- a/compiler/parser/HaddockLex.x
+++ b/compiler/parser/HaddockLex.x
@@ -7,7 +7,7 @@
 --
 
 {
-{-# OPTIONS -w #-}
+{-# 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
@@ -26,7 +26,7 @@ import RdrName
 import SrcLoc
 import DynFlags
 
-import Char
+import Data.Char
 import Numeric
 import System.IO.Unsafe
 }
@@ -34,7 +34,7 @@ import System.IO.Unsafe
 $ws    = $white # \n
 $digit = [0-9]
 $hexdigit = [0-9a-fA-F]
-$special =  [\"\@\/]
+$special =  [\"\@]
 $alphanum = [A-Za-z0-9]
 $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
 
@@ -63,21 +63,23 @@ $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
   () 			{ begin string }
 }
 
-<birdtrack> .*	\n?	{ strtoken TokBirdTrack `andBegin` line }
+<birdtrack> .*	\n?	{ strtokenNL TokBirdTrack `andBegin` line }
 
 <string,def> {
   $special			{ strtoken $ \s -> TokSpecial (head s) }
+  \<\<.*\>\>                    { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) }
   \<.*\>			{ strtoken $ \s -> TokURL (init (tail s)) }
   \#.*\#			{ strtoken $ \s -> TokAName (init (tail s)) }
+  \/ [^\/]* \/                  { strtoken $ \s -> TokEmphasis (init (tail s)) }
   [\'\`] $ident+ [\'\`]		{ ident }
   \\ .				{ strtoken (TokString . tail) }
   "&#" $digit+ \;		{ strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
   "&#" [xX] $hexdigit+ \;	{ strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
   -- allow special characters through if they don't fit one of the previous
   -- patterns.
-  [\'\`\<\#\&\\]			{ strtoken TokString }
-  [^ $special \< \# \n \'\` \& \\ \]]* \n { strtoken TokString `andBegin` line }
-  [^ $special \< \# \n \'\` \& \\ \]]+    { strtoken TokString }
+  [\/\'\`\<\#\&\\]			{ strtoken TokString }
+  [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtokenNL TokString `andBegin` line }
+  [^ $special \/ \< \# \n \'\` \& \\ \]]+    { strtoken TokString }
 }
 
 <def> {
@@ -101,6 +103,8 @@ data Token
   | TokIdent [RdrName]
   | TokString String
   | TokURL String
+  | TokPic String
+  | TokEmphasis String
   | TokAName String
   | TokBirdTrack String
 --  deriving Show
@@ -124,7 +128,7 @@ tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} t
 	  case alexScan inp sc of
 		AlexEOF -> []
 		AlexError _ -> error "lexical error"
-		AlexSkip  inp' len     -> go inp' sc
+		AlexSkip  inp' _       -> go inp' sc
 		AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
 
 -- NB. we add a final \n to the string, (see comment in the beginning of line
@@ -132,16 +136,19 @@ tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} t
 eofHack str = str++"\n"
 
 andBegin  :: Action -> StartCode -> Action
-andBegin act new_sc = \str sc cont -> act str new_sc cont
+andBegin act new_sc = \str _ cont -> act str new_sc cont
 
 token :: Token -> Action
-token t = \str sc cont -> t : cont sc
+token t = \_ sc cont -> t : cont sc
 
-strtoken :: (String -> Token) -> Action
+strtoken, strtokenNL :: (String -> Token) -> Action
 strtoken t = \str sc cont -> t str : cont sc
+strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc
+-- ^ We only want LF line endings in our internal doc string format, so we
+-- filter out all CRs.
 
 begin :: StartCode -> Action
-begin sc = \str _ cont -> cont sc
+begin sc = \_ _ cont -> cont sc
 
 -- -----------------------------------------------------------------------------
 -- Lex a string as a Haskell identifier
@@ -157,7 +164,6 @@ strToHsQNames :: String -> Maybe [RdrName]
 strToHsQNames str0 = 
   let buffer = unsafePerformIO (stringToStringBuffer str0)
       pstate = mkPState buffer noSrcLoc defaultDynFlags
-      lex = lexer (\t -> return t)
       result = unP parseIdentifier pstate 
   in case result of 
        POk _ name -> Just [unLoc name]