Warning police
[ghc-hetmet.git] / 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 -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?     { strtoken TokBirdTrack `andBegin` line }
67
68 <string,def> {
69   $special                      { strtoken $ \s -> TokSpecial (head s) }
70   \<.*\>                        { strtoken $ \s -> TokURL (init (tail s)) }
71   \#.*\#                        { strtoken $ \s -> TokAName (init (tail s)) }
72   [\'\`] $ident+ [\'\`]         { ident }
73   \\ .                          { strtoken (TokString . tail) }
74   "&#" $digit+ \;               { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
75   "&#" [xX] $hexdigit+ \;       { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
76   -- allow special characters through if they don't fit one of the previous
77   -- patterns.
78   [\'\`\<\#\&\\]                        { strtoken TokString }
79   [^ $special \< \# \n \'\` \& \\ \]]* \n { strtoken TokString `andBegin` line }
80   [^ $special \< \# \n \'\` \& \\ \]]+    { strtoken TokString }
81 }
82
83 <def> {
84   \]                            { token TokDefEnd `andBegin` string }
85 }
86
87 -- ']' doesn't have any special meaning outside of the [...] at the beginning
88 -- of a definition paragraph.
89 <string> {
90   \]                            { strtoken TokString }
91 }
92
93 {
94 data Token
95   = TokPara
96   | TokNumber
97   | TokBullet
98   | TokDefStart
99   | TokDefEnd
100   | TokSpecial Char
101   | TokIdent [RdrName]
102   | TokString String
103   | TokURL String
104   | TokAName String
105   | TokBirdTrack String
106 --  deriving Show
107
108 -- -----------------------------------------------------------------------------
109 -- Alex support stuff
110
111 type StartCode = Int
112 type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
113
114 type AlexInput = (Char,String)
115
116 alexGetChar (_, [])   = Nothing
117 alexGetChar (_, c:cs) = Just (c, (c,cs))
118
119 alexInputPrevChar (c,_) = c
120
121 tokenise :: String -> [Token]
122 tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
123   where go inp@(_,str) sc =
124           case alexScan inp sc of
125                 AlexEOF -> []
126                 AlexError _ -> error "lexical error"
127                 AlexSkip  inp' len     -> go inp' sc
128                 AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
129
130 -- NB. we add a final \n to the string, (see comment in the beginning of line
131 -- production above).
132 eofHack str = str++"\n"
133
134 andBegin  :: Action -> StartCode -> Action
135 andBegin act new_sc = \str sc cont -> act str new_sc cont
136
137 token :: Token -> Action
138 token t = \str sc cont -> t : cont sc
139
140 strtoken :: (String -> Token) -> Action
141 strtoken t = \str sc cont -> t str : cont sc
142
143 begin :: StartCode -> Action
144 begin sc = \str _ cont -> cont sc
145
146 -- -----------------------------------------------------------------------------
147 -- Lex a string as a Haskell identifier
148
149 ident :: Action
150 ident str sc cont = 
151   case strToHsQNames id of
152         Just names -> TokIdent names : cont sc
153         Nothing -> TokString str : cont sc
154  where id = init (tail str)
155
156 strToHsQNames :: String -> Maybe [RdrName]
157 strToHsQNames str0 = 
158   let buffer = unsafePerformIO (stringToStringBuffer str0)
159       pstate = mkPState buffer noSrcLoc defaultDynFlags
160       lex = lexer (\t -> return t)
161       result = unP parseIdentifier pstate 
162   in case result of 
163        POk _ name -> Just [unLoc name] 
164        _ -> Nothing
165 }