Removed an older version of selectStackFormat
[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 module HaddockLex (
11         Token(..),
12         tokenise
13  ) where
14
15 import Lexer hiding (Token)
16 import Parser ( parseIdentifier )
17 import StringBuffer
18 import RdrName
19 import SrcLoc
20 import DynFlags
21
22 import Char
23 import Numeric
24 import System.IO.Unsafe
25 }
26
27 $ws    = $white # \n
28 $digit = [0-9]
29 $hexdigit = [0-9a-fA-F]
30 $special =  [\"\@\/]
31 $alphanum = [A-Za-z0-9]
32 $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
33
34 :-
35
36 -- beginning of a paragraph
37 <0,para> {
38  $ws* \n                ;
39  $ws* \>                { begin birdtrack }
40  $ws* [\*\-]            { token TokBullet `andBegin` string }
41  $ws* \[                { token TokDefStart `andBegin` def }
42  $ws* \( $digit+ \)     { token TokNumber `andBegin` string }
43  $ws*                   { begin string }                
44 }
45
46 -- beginning of a line
47 <line> {
48   $ws* \>               { begin birdtrack }
49   $ws* \n               { token TokPara `andBegin` para }
50   -- Here, we really want to be able to say
51   -- $ws* (\n | <eof>)  { token TokPara `andBegin` para}
52   -- because otherwise a trailing line of whitespace will result in 
53   -- a spurious TokString at the end of a docstring.  We don't have <eof>,
54   -- though (NOW I realise what it was for :-).  To get around this, we always
55   -- append \n to the end of a docstring.
56   ()                    { begin string }
57 }
58
59 <birdtrack> .*  \n?     { strtoken TokBirdTrack `andBegin` line }
60
61 <string,def> {
62   $special                      { strtoken $ \s -> TokSpecial (head s) }
63   \<.*\>                        { strtoken $ \s -> TokURL (init (tail s)) }
64   \#.*\#                        { strtoken $ \s -> TokAName (init (tail s)) }
65   [\'\`] $ident+ [\'\`]         { ident }
66   \\ .                          { strtoken (TokString . tail) }
67   "&#" $digit+ \;               { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
68   "&#" [xX] $hexdigit+ \;       { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
69   -- allow special characters through if they don't fit one of the previous
70   -- patterns.
71   [\'\`\<\#\&\\]                        { strtoken TokString }
72   [^ $special \< \# \n \'\` \& \\ \]]* \n { strtoken TokString `andBegin` line }
73   [^ $special \< \# \n \'\` \& \\ \]]+    { strtoken TokString }
74 }
75
76 <def> {
77   \]                            { token TokDefEnd `andBegin` string }
78 }
79
80 -- ']' doesn't have any special meaning outside of the [...] at the beginning
81 -- of a definition paragraph.
82 <string> {
83   \]                            { strtoken TokString }
84 }
85
86 {
87 data Token
88   = TokPara
89   | TokNumber
90   | TokBullet
91   | TokDefStart
92   | TokDefEnd
93   | TokSpecial Char
94   | TokIdent [RdrName]
95   | TokString String
96   | TokURL String
97   | TokAName String
98   | TokBirdTrack String
99 --  deriving Show
100
101 -- -----------------------------------------------------------------------------
102 -- Alex support stuff
103
104 type StartCode = Int
105 type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
106
107 type AlexInput = (Char,String)
108
109 alexGetChar (_, [])   = Nothing
110 alexGetChar (_, c:cs) = Just (c, (c,cs))
111
112 alexInputPrevChar (c,_) = c
113
114 tokenise :: String -> [Token]
115 tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
116   where go inp@(_,str) sc =
117           case alexScan inp sc of
118                 AlexEOF -> []
119                 AlexError _ -> error "lexical error"
120                 AlexSkip  inp' len     -> go inp' sc
121                 AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
122
123 -- NB. we add a final \n to the string, (see comment in the beginning of line
124 -- production above).
125 eofHack str = str++"\n"
126
127 andBegin  :: Action -> StartCode -> Action
128 andBegin act new_sc = \str sc cont -> act str new_sc cont
129
130 token :: Token -> Action
131 token t = \str sc cont -> t : cont sc
132
133 strtoken :: (String -> Token) -> Action
134 strtoken t = \str sc cont -> t str : cont sc
135
136 begin :: StartCode -> Action
137 begin sc = \str _ cont -> cont sc
138
139 -- -----------------------------------------------------------------------------
140 -- Lex a string as a Haskell identifier
141
142 ident :: Action
143 ident str sc cont = 
144   case strToHsQNames id of
145         Just names -> TokIdent names : cont sc
146         Nothing -> TokString str : cont sc
147  where id = init (tail str)
148
149 strToHsQNames :: String -> Maybe [RdrName]
150 strToHsQNames str0 = 
151   let buffer = unsafePerformIO (stringToStringBuffer str0)
152       pstate = mkPState buffer noSrcLoc defaultDynFlags
153       lex = lexer (\t -> return t)
154       result = unP parseIdentifier pstate 
155   in case result of 
156        POk _ name -> Just [unLoc name] 
157        _ -> Nothing
158 }