Cleanup

1 files changed, 0 insertions, 713 deletions

diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs
deleted file mode 100644
index 93baa6aa..00000000
--- a/src/HsLexer.lhs
+++ /dev/null
@@ -1,713 +0,0 @@
------------------------------------------------------------------------------
--- $Id: HsLexer.lhs,v 1.18 2005/03/09 08:28:39 wolfgang Exp $
---
--- (c) The GHC Team, 1997-2000
---
--- Lexer for Haskell.
---
------------------------------------------------------------------------------
-
-ToDo: Parsing floats is a *real* hack...
-ToDo: Introduce different tokens for decimal, octal and hexadecimal (?)
-ToDo: FloatTok should have three parts (integer part, fraction, exponent)
-ToDo: Use a lexical analyser generator (lx?)
-
-\begin{code}
-module HsLexer (Token(..), lexer, parseError,isSymbol) where
-
-import HsParseMonad
-import HsParseUtils
-import HsSyn2
-
-import Numeric	( readHex, readOct )
-import Char
-import List     ( isPrefixOf )
-\end{code}
-
-\begin{code}
-data Token 
-        = VarId String
-	| IPVarId String
-        | QVarId (String,String)
-	| ConId String
-        | QConId (String,String)
-        | VarSym String
-        | ConSym String
-        | QVarSym (String,String)
-        | QConSym (String,String)
-
--- Literals
-
-	| IntTok     Integer
-        | FloatTok   String
-	| Character  Char
-        | StringTok  String
-	| PrimChar   Char		-- GHC extension
-	| PrimInt    Integer		-- GHC extension
-        | PrimString String		-- GHC extension
-	| PrimFloat  String		-- GHC extension
-	| PrimDouble String		-- GHC extension
-
--- Symbols
-
-	| LeftParen
-	| RightParen
-	| SemiColon
-        | LeftCurly
-        | RightCurly
-        | VRightCurly			-- a virtual close brace
-        | LeftSquare
-        | RightSquare
-	| Comma
-        | Underscore
-        | BackQuote
-	| LeftUT			-- GHC Extension: (#
-	| RightUT			-- GHC Extension: #)
-	
--- Documentation annotations
-
-	| DocCommentNext  String	-- something beginning '-- |'
-	| DocCommentPrev  String	-- something beginning '-- ^'
-	| DocCommentNamed String	-- something beginning '-- $'
-	| DocSection      Int String	-- a section heading
-	| DocOptions      String	-- attributes '-- #'
-
--- Reserved operators
-
-	| Dot				-- GHC extension
-	| DotDot
-	| DoubleColon
-	| Equals
-	| Backslash
-	| Bar
-	| LeftArrow
-	| RightArrow
-	| At
-	| Tilde
-	| DoubleArrow
-	| Minus
-	| Exclamation
-
--- Reserved Ids
-
-	| KW_As
-	| KW_Case
-	| KW_CCall
-	| KW_Class
-	| KW_Data
-	| KW_Default
-	| KW_Deriving
-	| KW_Do
-	| KW_DotNet
-	| KW_Else
-	| KW_Export
-	| KW_Forall
-	| KW_Foreign
-        | KW_Hiding
-	| KW_If
-	| KW_Import
-	| KW_In
-	| KW_Infix
-	| KW_InfixL
-	| KW_InfixR
-	| KW_Instance
-	| KW_Let
-	| KW_Module
-	| KW_NewType
-	| KW_Of
-	| KW_Safe
-	| KW_StdCall
-	| KW_Then
-	| KW_ThreadSafe
-	| KW_Type
-	| KW_Unsafe
-	| KW_Where    
-	| KW_Qualified
-
-        | EOF
-        deriving (Eq,Show)
-
-reserved_ops :: [(String,Token)]
-reserved_ops = [
- ( ".",  Dot ),				-- GHC extension
- ( "..", DotDot ),    
- ( "::", DoubleColon ),
- ( "=",  Equals ),    
- ( "\\", Backslash ), 
- ( "|",  Bar ),       
- ( "<-", LeftArrow ), 
- ( "->", RightArrow ),
- ( "@",  At ),        
- ( "~",  Tilde ),     
- ( "=>", DoubleArrow ),
- ( "-",  Minus ),			--ToDo: shouldn't be here
- ( "!",  Exclamation )		--ditto
- ]
-
-reserved_ids :: [(String,Token)]
-reserved_ids = [
- ( "_",         Underscore ),
- ( "case",      KW_Case ),     
- ( "ccall",     KW_CCall ),
- ( "class",     KW_Class ),    
- ( "data",      KW_Data ),     
- ( "default",   KW_Default ),  
- ( "deriving",  KW_Deriving ), 
- ( "do",        KW_Do ),       
- ( "dotnet",    KW_DotNet ),       
- ( "else",      KW_Else ),     
- ( "export",    KW_Export ),     
- ( "forall",    KW_Forall ),     
- ( "foreign",   KW_Foreign ),     
- ( "if",    	KW_If ),       
- ( "import",    KW_Import ),   
- ( "in", 	KW_In ),       
- ( "infix", 	KW_Infix ),    
- ( "infixl", 	KW_InfixL ),   
- ( "infixr", 	KW_InfixR ),   
- ( "instance",  KW_Instance ), 
- ( "let", 	KW_Let ),      
- ( "mdo",       KW_Do ),       -- pretend mdo is do, for now.
- ( "module", 	KW_Module ),   
- ( "newtype",   KW_NewType ),  
- ( "of", 	KW_Of ),       
- ( "safe", 	KW_Safe ),     
- ( "then", 	KW_Then ),     
- ( "threadsafe",KW_ThreadSafe ),     
- ( "type", 	KW_Type ),     
- ( "unsafe", 	KW_Unsafe ),
- ( "where", 	KW_Where ),    
- ( "as", 	KW_As ),       
- ( "qualified", KW_Qualified ),
- ( "hiding", 	KW_Hiding ),
- ( "stdcall",   KW_StdCall )
- ]
-
-specialIds = [
-  KW_As,
-  KW_Unsafe,
-  KW_Safe,
-  KW_ThreadSafe,
-  KW_Qualified,
-  KW_Hiding,
-  KW_Export,
-  KW_StdCall,
-  KW_CCall,
-  KW_DotNet
-  ]
-
-isIdent, isSymbol, isWhite :: Char -> Bool
-isIdent  c = isAlpha c || isDigit c || c == '\'' || c == '_'
-isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~"
-isWhite  c = elem c " \n\r\t\v\f"
-
-isIdentInitial :: Char -> Bool
-isIdentInitial ch = isLower ch || ch == '_'
-
-tAB_LENGTH :: Int
-tAB_LENGTH = 8
-
--- The source location, (y,x), is the coordinates of the previous token.
--- col is the current column in the source file.  If col is 0, we are
--- somewhere at the beginning of the line before the first token.
-
--- Setting col to 0 is used in two places: just after emitting a virtual
--- close brace due to layout, so that next time through we check whether
--- we also need to emit a semi-colon, and at the beginning of the file,
--- to kick off the lexer.
-
-
-lexer :: (Token -> P a) -> P a
-lexer cont input (SrcLoc _ x0 _) y0 col f =
-        if col == 0
-           then tab y0 x0  f True  input
-           else tab y0 col f False input -- throw away old x
-  where
-   	-- move past whitespace and comments
-        tab y x f _ [] = 
-        	cont EOF [] (SrcLoc y x f) y col f
-        tab y x f bol ('\t':s) =
-        	tab y (nextTab x) f bol s
-        tab y _ f _  ('\n':s) =
-                newLine cont s y f
-
-        tab y _ f True ('#':s)
-            | "pragma GCC set_debug_pwd" `isPrefixOf` s
-            = newLine cont (tail $ dropWhile (/= '\n') s) y f
-
-	tab y x f True ('#':' ':s@(d:_))
-	    | isDigit d = parseLinePragma tab y f s
-
-	-- single-line comments
-        tab y x f bol s@('-':'-':' ':c:_) | doc c = 
-	 	is_a_token bol s y x f
-        tab y _ f _ ('-':'-':s) | null s || not (isSymbol (head (dropWhile (== '-') s)))  =
-        	newLine cont (drop 1 (dropWhile (/= '\n') s)) y f
-
-	-- multi-line nested comments and pragmas
-	tab y x f bol ('{':'-':'#':s) = pragma tab y (x+3) f bol s
-	tab y x f bol s@('{':'-':c:_) | doc c = 
-		is_a_token bol s y x f
-	tab y x f bol s@('{':'-':' ':c:_) | doc c = 
-		is_a_token bol s y x f
-        tab y x f bol ('{':'-':s) = nestedComment (\y x -> tab y x f) y (x+2) bol s
-
-        tab y x f bol (c:s)
-        	| isWhite c = tab y (x+1) f bol s
-        	| otherwise = is_a_token bol (c:s) y x f
-
- 	is_a_token bol s y x f
-	   | bol       = lexBOL   cont s (SrcLoc y x f) y x f
-	   | otherwise = lexToken cont s (SrcLoc y x f) y x f
-
-	newLine _ s y f =  tab (y+1) 1 f True s
-
-	doc '|' = True
-	doc '/' = True
-	doc '^' = True
-	doc '*' = True
-	doc '$' = True
-	doc '#' = True
-	doc _ = False
-
-nextTab :: Int -> Int
-nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH)
-
--- When we are lexing the first token of a line, check whether we need to
--- insert virtual semicolons or close braces due to layout.
-
-lexBOL :: (Token -> P a) -> P a
-lexBOL cont s loc y x f context =
-        if need_close_curly then 
-                -- trace "layout: inserting '}'\n" $
-        	-- Set col to 0, indicating that we're still at the
-        	-- beginning of the line, in case we need a semi-colon too.
-        	-- Also pop the context here, so that we don't insert
-        	-- another close brace before the parser can pop it.
-        	cont VRightCurly s loc y 0 f (tail context)
-        else if need_semi_colon then
-                --trace "layout: inserting ';'\n" $
-        	cont SemiColon s loc y x f context
-        else
-        	lexToken cont s loc y x f context
- where
-        need_close_curly =
-        	case context of
-        		[] -> False
-        		(i:_) -> case i of
-        			    NoLayout -> False
-        			    Layout n -> x < n
-        need_semi_colon =
-        	case context of
-        		[] -> False
-        		(i:_) -> case i of
-        			    NoLayout -> False
-        			    Layout n -> x == n
-
-lexToken :: (Token -> P a) -> P a
---lexToken _    [] loc _ _ =
---    error $ "Internal error: empty input in lexToken at " ++ show loc
-lexToken cont s0 loc y x f =
-   -- trace ("lexer: y="++show y++" x="++show x++"\n") $ 
-   case s0 of
-        []            -> error $ "Internal error: empty input in lexToken at "
-                                 ++ show loc
-	-- First the doc comments
-	'-':'-':' ':s -> do_doc s False
-	'{':'-':' ':s -> do_doc s True
-	'{':'-':s     -> do_doc s True
-
-        -- Next the special symbols
-        '(':'#':s -> forward 2 LeftUT s
-	'(':s 	  -> forward 1 LeftParen s
-	'#':')':s -> forward 2 RightUT s
-        ')':s     -> forward 1 RightParen s
-        ',':s     -> forward 1 Comma s
-        ';':s     -> forward 1 SemiColon s
-        '[':s     -> forward 1 LeftSquare s
-        ']':s     -> forward 1 RightSquare s
-        '`':s     -> forward 1 BackQuote s
-        '{':s     -> \ctxt  -> forward 1 LeftCurly s (NoLayout : ctxt)
-        '}':s     -> \ctxt0 -> case ctxt0 of
-                               (_:ctxt) -> forward 1 RightCurly s ctxt
-						-- pop context on '}'
-                               []       -> error "Internal error: empty context in lexToken"
-
-        '?':s:ss  
-	  | isIdentInitial s -> lexToken ( \ (VarId x) -> cont (IPVarId x)) (s:ss) loc y x f
-        '\'':s -> lexChar cont s loc y (x+1) f
-        '\"':s{-"-} -> lexString cont s loc y (x+1) f
-
-        '0':'x':c:s | isHexDigit c -> 
-	   let (num, rest) = span isHexDigit (c:s)
-	       [(i,_)] = readHex num
-	   in
-	   afterNum cont i rest loc y (x+length num) f
-        '0':'o':c:s | isOctDigit c -> 
-	   let (num, rest) = span isOctDigit (c:s)
-	       [(i,_)] = readOct num
-	   in
-	   afterNum cont i rest loc y (x+length num) f
-
-        c:s | isIdentInitial c ->
-        	let 
-        	    (idtail, rest) = slurpIdent s
-        	    id0 = c:idtail
-        	    l_id = 1 + length idtail
-        	in
-        	case lookup id0 reserved_ids of
-        		Just keyword -> forward l_id keyword rest
-        		Nothing      -> forward l_id (VarId id0) rest
-
-          | isUpper c -> lexCon "" cont (c:s) loc y x f
-          | isSymbol c ->
-        	let
-        	    (symtail, rest) = span isSymbol s
-        	    sym = c : symtail
-        	    l_sym = 1 + length symtail
-        	in
-        	case lookup sym reserved_ops of
-        	    Just t  -> forward l_sym t rest
-        	    Nothing -> case c of
-        			':' -> forward l_sym (ConSym sym) rest
-        			_   -> forward l_sym (VarSym sym) rest
-
-          | isDigit c -> lexNum cont c s loc y x f
-
-          | otherwise ->
-        	parseError ("illegal character \'" ++ show c ++ "\'\n") 
-        		  s loc y x f
-
-  where forward n t str = cont t str loc y (x+n) f
-
-	-- this is all terribly ugly, sorry :(
-	do_doc ('|':s) nested  = multi nested DocCommentNext  cont s loc y x f
-	do_doc ('/':s) nested  = multi nested DocCommentNext  cont s loc y x f
-	do_doc ('^':s) nested  = multi nested DocCommentPrev  cont s loc y x f
-	do_doc ('$':s) nested  = multi nested DocCommentNamed cont s loc y x f
-	do_doc ('#':s) nested  = multi nested DocOptions      cont s loc y x f
-	do_doc ('*':s) nested  = section 1 s
-	  where section n ('*':s1) = section (n+1) s1
-		section n s1 
-		 | nested    = nestedDocComment  (DocSection n) cont s1 loc y x f
-		 | otherwise = oneLineDocComment (DocSection n) cont s1 loc y x f
-	do_doc _       _ = error "Internal error: HsLexer.do_doc"
-        
-
-multi :: Bool -> ([Char] -> b)
-      -> (b -> [Char] -> c -> Int -> Int -> d)
-      -> [Char] -> c -> Int -> Int -> d
-multi True  = nestedDocComment
-multi False = multiLineDocComment
-
-afterNum :: Num a => (Token -> [Char] -> b -> c -> a -> d -> e)
-	 -> Integer -> [Char] -> b -> c -> a -> d -> e
-afterNum cont i ('#':s) loc y x f = cont (PrimInt i) s loc y (x+1) f
-afterNum cont i s loc y x f = cont (IntTok i) s loc y x f
-
-lexNum :: (Token -> [Char] -> a -> b -> Int -> c -> d)
-       -> Char -> [Char] -> a -> b -> Int -> c -> d
-lexNum cont c0 s0 loc y x fname = 
-  let (num, after_num) = span isDigit (c0:s0)
-  in
-  case after_num of
-    '.':c1:s1 | isDigit c1 ->
-	let (frac,after_frac) = span isDigit s1
-	in
-	let float = num ++ '.':frac
-	    (f, after_exp)
-		 = case after_frac of
-		    'E':s -> do_exponent s
-		    'e':s -> do_exponent s
-		    _     -> (float, after_frac)
-
-	    do_exponent s2 =
-		 case s2 of
-		  '-':c:s | isDigit c -> 
-			let (exp0,rest) = span isDigit (c:s) in
-			(float ++ 'e':'-':exp0, rest)
-		  '+':c:s | isDigit c -> 
-			let (exp0,rest) = span isDigit (c:s) in
-			(float ++ 'e':'+':exp0, rest)
-		  c:s | isDigit c -> 
-			let (exp0,rest) = span isDigit (c:s) in
-			(float ++ 'e':exp0, rest)
-		  _ -> (float, after_frac)
-
-	    x' = x + length f
-
-	in case after_exp of -- glasgow exts only
-		'#':'#':s -> cont (PrimDouble f) s loc y x' fname
-		'#':s     -> cont (PrimFloat f)  s loc y x' fname
-		s         -> cont (FloatTok f)   s loc y x' fname
-
-    _ -> afterNum cont (parseInteger 10 num) after_num loc y (x + length num) fname
-
-		
--- GHC extension: allow trailing '#'s in an identifier. 
-slurpIdent :: String -> (String, String)
-slurpIdent s = slurp' s []
- where
-  slurp' [] i = (reverse i, [])
-  slurp' (c:cs) i 
-    | isIdent c = slurp' cs (c:i)
-    | c == '#'  = slurphashes cs (c:i)
-  slurp' cs i = (reverse i, cs)
-
-slurphashes :: String -> String -> (String, String)
-slurphashes [] i = (reverse i, [])
-slurphashes ('#':cs) i = slurphashes cs ('#':i)
-slurphashes s i = (reverse i, s)
-
-lexCon :: [Char] -> (Token -> String -> a -> b -> Int -> c -> d)
-       -> String -> a -> b -> Int -> c -> d
-lexCon qual cont s0 loc y x f =
-  let
-    forward n t s = cont t s loc y (x+n) f
-
-    (con, rest) = slurpIdent s0
-    l_con = length con
-
-    just_a_conid 
-	| null qual = forward l_con (ConId con) rest
-	| otherwise = forward l_con (QConId (qual,con)) rest
-
-    qual' | null qual = con
-	  | otherwise = qual ++ '.':con
-  in
-  case rest of
-    '.':c1:s1 
-     | isIdentInitial c1 ->	-- qualified varid?
-	let
-	    (idtail, rest1) = slurpIdent s1
-	    id0 = c1:idtail
-	    l_id = 1 + length idtail
-	in
-	case lookup id0 reserved_ids of
-	   -- cannot qualify a reserved word
-	   Just id | id `notElem` specialIds  -> just_a_conid
-	   _ -> forward (l_con+1+l_id) (QVarId (qual', id0)) rest1
-
-     | isUpper c1 ->	-- qualified conid?
-	lexCon qual' cont (c1:s1) loc y (x+l_con+1) f
-
-     | isSymbol c1 ->	-- qualified symbol?
-	let
-	    (symtail, rest1) = span isSymbol s1
-	    sym = c1 : symtail
-	    l_sym = 1 + length symtail
-	in
-	case lookup sym reserved_ops of
-	    -- cannot qualify a reserved operator
-	    Just _  -> just_a_conid
-	    Nothing -> 
-		case c1 of
-		  ':' -> forward (l_con+1+l_sym) (QConSym (qual', sym)) rest1
-		  _   -> forward (l_con+1+l_sym) (QVarSym (qual', sym)) rest1
-
-    _ -> just_a_conid -- not a qualified thing
-
-
-lexChar :: (Token -> P a) -> P a
-lexChar cont s0 loc0 y x f = case s0 of
-                    '\\':s1 -> (escapeChar s1 `thenP` \(e,s,i) _ _ _ _ _ ->
-                               charEnd e s loc0 y (x+i) f) s1 loc0 y x f
-                    c:s     -> charEnd c s loc0 y (x+1) f
-                    []      -> char_err [] loc0 y x f
-
-  where charEnd c ('\'':'#':s) = \loc y0 x0 f0 -> cont (PrimChar c) s loc y0 (x0+2) f0
-	charEnd c ('\'':s) = \loc y0 x0 f0 -> cont (Character c) s loc y0 (x0+1) f0
-	charEnd c s = char_err s
-
-	char_err s = parseError "Improperly terminated character constant" s
-
-lexString :: (Token -> P a) -> P a
-lexString cont s0 loc y0 x0 f0 = loop "" s0 x0 y0 f0
-  where
-     loop e s1 x y f = case s1 of
-            '\\':'&':s  -> loop e s (x+2) y f
-            '\\':c:s | isSpace c -> stringGap e s (x+2) y f
-        	     | otherwise -> (escapeChar (c:s) `thenP` \(e',s2,i) _ _ _ _ ->
-        		             loop (e':e) s2 (x+i) y) s loc y x f
-            '\"':'#':s  -> cont (PrimString (reverse e)) s loc y (x+2) f
-            '\"':s{-"-} -> cont (StringTok (reverse e)) s loc y (x+1) f
-            c:s		-> loop (c:e) s (x+1) y f
-            []          -> parseError "Improperly terminated string" s1 loc y x f
-
-     stringGap e s1 x y = case s1 of
-        	'\n':s -> stringGap e s 1 (y+1)
-        	'\\':s -> loop e s (x+1) y
-        	c:s | isSpace c -> stringGap e s (x+1) y
-        	    | otherwise -> 
-        	       parseError "Illegal character in string gap" s1 loc y x
-                []     -> error "Internal error: stringGap"
-
--- ToDo: \o, \x, \<octal> things.
-
-escapeChar :: String -> P (Char,String,Int)
-escapeChar s0 = case s0 of
-
-  'x':c:s | isHexDigit c -> 
-	let (num,rest) = span isHexDigit (c:s) in
-	returnP (chr (fromIntegral (parseInteger 16 num)), rest, length num)
-
-  'o':c:s | isOctDigit c -> 
-	let (num,rest) = span isOctDigit (c:s) in
-	returnP (chr (fromIntegral (parseInteger 8 num)), rest, length num)
-
-  c:s | isDigit c -> let (num,rest) = span isDigit (c:s) in
-		     returnP (chr (read num), rest, length num)
-
--- Production charesc from section B.2 (Note: \& is handled by caller)
-
-  'a':s 	  -> returnP ('\a',s,2)
-  'b':s 	  -> returnP ('\b',s,2)
-  'f':s 	  -> returnP ('\f',s,2)
-  'n':s 	  -> returnP ('\n',s,2)
-  'r':s 	  -> returnP ('\r',s,2)
-  't':s 	  -> returnP ('\t',s,2)
-  'v':s 	  -> returnP ('\v',s,2)
-  '\\':s        -> returnP ('\\',s,2)
-  '"':s         -> returnP ('\"',s,2)
-  '\'':s        -> returnP ('\'',s,2)
-
--- Production ascii from section B.2
-
-  '^':x@(_:_)   -> cntrl x
-  'N':'U':'L':s -> returnP ('\NUL',s,4)
-  'S':'O':'H':s -> returnP ('\SOH',s,4)
-  'S':'T':'X':s -> returnP ('\STX',s,4)
-  'E':'T':'X':s -> returnP ('\ETX',s,4)
-  'E':'O':'T':s -> returnP ('\EOT',s,4)
-  'E':'N':'Q':s -> returnP ('\ENQ',s,4)
-  'A':'C':'K':s -> returnP ('\ACK',s,4)
-  'B':'E':'L':s -> returnP ('\BEL',s,4)
-  'B':'S':s     -> returnP ('\BS', s,3)
-  'H':'T':s  	  -> returnP ('\HT', s,3)
-  'L':'F':s 	  -> returnP ('\LF', s,3)
-  'V':'T':s 	  -> returnP ('\VT', s,3)
-  'F':'F':s 	  -> returnP ('\FF', s,3)
-  'C':'R':s 	  -> returnP ('\CR', s,3)
-  'S':'O':s 	  -> returnP ('\SO', s,3)
-  'S':'I':s 	  -> returnP ('\SI', s,3)
-  'D':'L':'E':s -> returnP ('\DLE',s,4)
-  'D':'C':'1':s -> returnP ('\DC1',s,4)
-  'D':'C':'2':s -> returnP ('\DC2',s,4)
-  'D':'C':'3':s -> returnP ('\DC3',s,4)
-  'D':'C':'4':s -> returnP ('\DC4',s,4)
-  'N':'A':'K':s -> returnP ('\NAK',s,4)
-  'S':'Y':'N':s -> returnP ('\SYN',s,4)
-  'E':'T':'B':s -> returnP ('\ETB',s,4)
-  'C':'A':'N':s -> returnP ('\CAN',s,4)
-  'E':'M':s     -> returnP ('\EM', s,3)
-  'S':'U':'B':s -> returnP ('\SUB',s,4)
-  'E':'S':'C':s -> returnP ('\ESC',s,4)
-  'F':'S':s     -> returnP ('\FS', s,3)
-  'G':'S':s     -> returnP ('\GS', s,3)
-  'R':'S':s     -> returnP ('\RS', s,3)
-  'U':'S':s     -> returnP ('\US', s,3)
-  'S':'P':s     -> returnP ('\SP', s,3)
-  'D':'E':'L':s -> returnP ('\DEL',s,4)
-
-  _             -> parseError "Illegal escape sequence"
-
-
--- Stolen from Hugs's Prelude
-parseInteger :: Integer -> String -> Integer
-parseInteger radix ds =
-	foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds)
-
--- Production cntrl from section B.2
-
-cntrl :: String -> P (Char,String,Int)
-cntrl (c:s) | c >= '@' && c <= '_' = returnP (chr (ord c - ord '@'), s,2)
-cntrl _                            = parseError "Illegal control character"
-
-
-pragma :: (Int -> Int -> FilePath -> Bool -> [Char] -> b)
-       -> Int -> Int -> FilePath -> Bool -> [Char] -> b
-pragma cont y x f bol s0 =
-   case span (==' ') s0 of
-      (_, 'L':'I':'N':'E':' ':s) -> parseLinePragma cont y f s
-      (_, 'l':'i':'n':'e':' ':s) -> parseLinePragma cont y f s
-      (sp,s) -> nestedComment (\y x -> cont y x f) y (x+length sp) bol s
-
-parseLinePragma :: (Int -> Int -> FilePath -> Bool -> [Char] -> b)
-                -> Int -> FilePath -> [Char] -> b
-parseLinePragma cont y fname s0 =
-		cont y' 1 fname' True (drop 1 (dropWhile (/= '\n') s0))
-
-  where  s1            = dropWhite s0
-         (lineStr, s2) = span isDigit s1
-         y'            = case reads lineStr of
-	                   ((y',_):_) -> y'
-			   _          -> y
-         s3            = dropWhite s2
-	 fnameStr      = takeWhile (\c -> c /= '"' && c/='\n') (tail s3)
-         fname'        | null s3 || head s3 /= '"' = fname
-                       -- try and get more sharing of file name strings
-                       | fnameStr == fname         = fname
-                       | otherwise                 = fnameStr
-         dropWhite = dropWhile (\c -> c == ' ' || c == '\t')
-
-nestedComment :: (Int -> Int -> Bool -> [Char] -> b)
-	      -> Int -> Int -> Bool -> [Char] -> b
-nestedComment cont y x bol s0 =
-   case s0 of
-      '-':'}':s -> cont y (x+2) bol s
-      '{':'-':s -> nestedComment (nestedComment cont) y (x+2) bol s
-      '\t':s    -> nestedComment cont y (nextTab x) bol s
-      '\n':s    -> nestedComment cont (y+1) 1 True s
-      _:s       -> nestedComment cont y (x+1) bol s
-      []        -> error "Internal error: nestedComment"
-
-nestedDocComment :: ([Char] -> b)
-		 -> (b -> [Char] -> c -> Int -> Int -> d)
-                 -> [Char] -> c -> Int -> Int -> d
-nestedDocComment f0 cont0 s0 loc y0 x0 = go f0 cont0 "" y0 x0 s0
- where
-  go f cont acc y1 x1 s1 = 
-   case s1 of
-      '-':'}':s -> cont (f (reverse acc)) s loc y1 (x1+2)
-      '{':'-':s -> nestedComment (\y x _ s2 -> go f cont acc y x s2) 
-			y1 (x1+2) False s
-      '\t':s    -> go f cont ('\t':acc) y1 (nextTab x1) s
-      '\n':s    -> go f cont ('\n':acc) (y1+1) 1 s
-      c:s       -> go f cont (c:acc) y1 (x1+1) s
-      []        -> error "Internal error: nestedComment"
-
-oneLineDocComment :: ([Char] -> a)
-		  -> (a -> [Char] -> b -> c -> d -> e)
-		  -> [Char] -> b -> c -> d -> e
-oneLineDocComment f cont s loc y x
-  = cont (f line) rest loc y x -- continue with the newline char
-  where (line, rest) = break (== '\n') s
-
-multiLineDocComment :: Num a => ([Char] -> b)
-		    -> (b -> [Char] -> c -> a -> d -> e)
-		    -> [Char] -> c -> a -> d -> e
-multiLineDocComment f cont s loc y x 
-  = cont (f comment) s' loc y' x -- continue with the newline char
-  where (s', comment, y') = slurpExtraCommentLines s [] y
-    
-slurpExtraCommentLines :: Num a => [Char] -> [[Char]] -> a 
-                       -> ([Char], [Char], a)
-slurpExtraCommentLines s0 lines0 y
-  = case rest of
-	'\n':nextline -> 
-		case dropWhile nonNewlineSpace nextline of 
-		  -- stop slurping if we see a string of more than two '-';
-		  -- strings of dashes are useful as separators but we don't
-		  -- want them in the doc.
-		  '-':'-':c:s | c /= '-'
-			 -> slurpExtraCommentLines (c:s)
-				((line++"\n"):lines0) (y+1)
-		  _ -> (rest, finished, y)
-	_ -> (rest, finished, y)
-  where
-	(line, rest) = break (== '\n') s0
-	finished = concat (reverse (line:lines0))
-
-nonNewlineSpace :: Char -> Bool
-nonNewlineSpace c = isSpace c && c /= '\n'
-\end{code}