compiler/parser/HaddockLex.x

   1 --
   2 -- Haddock - A Haskell Documentation Tool
   3 --
   4 -- (c) Simon Marlow 2002
   5 --
   6 -- This file was modified and integrated into GHC by David Waern 2006
   7 --
   8
   9 {
  10 {-# OPTIONS -Wwarn -w #-}
  11 -- The above warning supression flag is a temporary kludge.
  12 -- While working on this module you are encouraged to remove it and fix
  13 -- any warnings in the module. See
  14 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  15 -- for details
  16
  17 module HaddockLex (
  18         Token(..),
  19         tokenise
  20  ) where
  21
  22 import Lexer hiding (Token)
  23 import Parser ( parseIdentifier )
  24 import StringBuffer
  25 import RdrName
  26 import SrcLoc
  27 import DynFlags
  28
  29 import Char
  30 import Numeric
  31 import System.IO.Unsafe
  32 }
  33
  34 $ws    = $white # \n
  35 $digit = [0-9]
  36 $hexdigit = [0-9a-fA-F]
  37 $special =  [\"\@]
  38 $alphanum = [A-Za-z0-9]
  39 $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
  40
  41 :-
  42
  43 -- beginning of a paragraph
  44 <0,para> {
  45  $ws* \n                ;
  46  $ws* \>                { begin birdtrack }
  47  $ws* [\*\-]            { token TokBullet `andBegin` string }
  48  $ws* \[                { token TokDefStart `andBegin` def }
  49  $ws* \( $digit+ \)     { token TokNumber `andBegin` string }
  50  $ws*                   { begin string }
  51 }
  52
  53 -- beginning of a line
  54 <line> {
  55   $ws* \>               { begin birdtrack }
  56   $ws* \n               { token TokPara `andBegin` para }
  57   -- Here, we really want to be able to say
  58   -- $ws* (\n | <eof>)  { token TokPara `andBegin` para}
  59   -- because otherwise a trailing line of whitespace will result in
  60   -- a spurious TokString at the end of a docstring.  We don't have <eof>,
  61   -- though (NOW I realise what it was for :-).  To get around this, we always
  62   -- append \n to the end of a docstring.
  63   ()                    { begin string }
  64 }
  65
  66 <birdtrack> .*  \n?     { strtokenNL TokBirdTrack `andBegin` line }
  67
  68 <string,def> {
  69   $special                      { strtoken $ \s -> TokSpecial (head s) }
  70   \<\<.*\>\>                    { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) }
  71   \<.*\>                        { strtoken $ \s -> TokURL (init (tail s)) }
  72   \#.*\#                        { strtoken $ \s -> TokAName (init (tail s)) }
  73   \/ [^\/]* \/                  { strtoken $ \s -> TokEmphasis (init (tail s)) }
  74   [\'\`] $ident+ [\'\`]         { ident }
  75   \\ .                          { strtoken (TokString . tail) }
  76   "&#" $digit+ \;               { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
  77   "&#" [xX] $hexdigit+ \;       { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
  78   -- allow special characters through if they don't fit one of the previous
  79   -- patterns.
  80   [\/\'\`\<\#\&\\]                      { strtoken TokString }
  81   [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtokenNL TokString `andBegin` line }
  82   [^ $special \/ \< \# \n \'\` \& \\ \]]+    { strtoken TokString }
  83 }
  84
  85 <def> {
  86   \]                            { token TokDefEnd `andBegin` string }
  87 }
  88
  89 -- ']' doesn't have any special meaning outside of the [...] at the beginning
  90 -- of a definition paragraph.
  91 <string> {
  92   \]                            { strtoken TokString }
  93 }
  94
  95 {
  96 data Token
  97   = TokPara
  98   | TokNumber
  99   | TokBullet
 100   | TokDefStart
 101   | TokDefEnd
 102   | TokSpecial Char
 103   | TokIdent [RdrName]
 104   | TokString String
 105   | TokURL String
 106   | TokPic String
 107   | TokEmphasis String
 108   | TokAName String
 109   | TokBirdTrack String
 110 --  deriving Show
 111
 112 -- -----------------------------------------------------------------------------
 113 -- Alex support stuff
 114
 115 type StartCode = Int
 116 type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
 117
 118 type AlexInput = (Char,String)
 119
 120 alexGetChar (_, [])   = Nothing
 121 alexGetChar (_, c:cs) = Just (c, (c,cs))
 122
 123 alexInputPrevChar (c,_) = c
 124
 125 tokenise :: String -> [Token]
 126 tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
 127   where go inp@(_,str) sc =
 128           case alexScan inp sc of
 129                 AlexEOF -> []
 130                 AlexError _ -> error "lexical error"
 131                 AlexSkip  inp' _       -> go inp' sc
 132                 AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
 133
 134 -- NB. we add a final \n to the string, (see comment in the beginning of line
 135 -- production above).
 136 eofHack str = str++"\n"
 137
 138 andBegin  :: Action -> StartCode -> Action
 139 andBegin act new_sc = \str _ cont -> act str new_sc cont
 140
 141 token :: Token -> Action
 142 token t = \_ sc cont -> t : cont sc
 143
 144 strtoken, strtokenNL :: (String -> Token) -> Action
 145 strtoken t = \str sc cont -> t str : cont sc
 146 strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc
 147 -- ^ We only want LF line endings in our internal doc string format, so we
 148 -- filter out all CRs.
 149
 150 begin :: StartCode -> Action
 151 begin sc = \_ _ cont -> cont sc
 152
 153 -- -----------------------------------------------------------------------------
 154 -- Lex a string as a Haskell identifier
 155
 156 ident :: Action
 157 ident str sc cont =
 158   case strToHsQNames id of
 159         Just names -> TokIdent names : cont sc
 160         Nothing -> TokString str : cont sc
 161  where id = init (tail str)
 162
 163 strToHsQNames :: String -> Maybe [RdrName]
 164 strToHsQNames str0 =
 165   let buffer = unsafePerformIO (stringToStringBuffer str0)
 166       pstate = mkPState buffer noSrcLoc defaultDynFlags
 167       result = unP parseIdentifier pstate
 168   in case result of
 169        POk _ name -> Just [unLoc name]
 170        _ -> Nothing
 171 }