Propagate source positions from Lex.x to Parse.y

5 files changed, 51 insertions, 44 deletions

diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 89440139..02fd4bc7 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -44,7 +44,7 @@ lexParseRnHaddockComment :: HaddockCommentType ->
     GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
 lexParseRnHaddockComment hty gre (HsDocString fs) = do
    let str = unpackFS fs
-   let toks = tokenise str
+   let toks = tokenise str (0,0) -- TODO: real position
    let parse = case hty of
          NormalHaddockComment -> parseParas
          DocSectionComment -> parseString
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index dc701f36..2bdd30a7 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -46,13 +46,15 @@ parseModuleHeader str0 =
       description1 :: Either String (Maybe (Doc RdrName))
       description1 = case descriptionOpt of
          Nothing -> Right Nothing
-         Just description -> case parseString . tokenise $ description of
+         -- TODO: pass real file position
+         Just description -> case parseString $ tokenise description (0,0) of
             Nothing -> Left ("Cannot parse Description: " ++ description)
             Just doc -> Right (Just doc)
    in
       case description1 of
          Left mess -> Left mess
-         Right docOpt -> case parseParas . tokenise $ str8 of
+         -- TODO: pass real file position
+         Right docOpt -> case parseParas $ tokenise str8 (0,0) of
            Nothing -> Left "Cannot parse header documentation paragraphs"
            Just doc -> Right (HaddockModInfo {
             hmi_description = docOpt,
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index 40ffbe92..14843aa3 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -17,6 +17,7 @@
 
 module Haddock.Lex (
 	Token(..),
+  LToken,
 	tokenise
  ) where
 
@@ -32,6 +33,8 @@ import Numeric
 import System.IO.Unsafe
 }
 
+%wrapper "posn"
+
 $ws    = $white # \n
 $digit = [0-9]
 $hexdigit = [0-9a-fA-F]
@@ -105,6 +108,9 @@ $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
 }
 
 {
+-- | A located token
+type LToken = (Token, AlexPosn)
+
 data Token
   = TokPara
   | TokNumber
@@ -124,55 +130,54 @@ data Token
   | TokExampleResult String
 --  deriving Show
 
+tokenPos :: LToken -> (Int, Int)
+tokenPos t = let AlexPn _ line col = snd t in (line, col)
+
 -- -----------------------------------------------------------------------------
 -- Alex support stuff
 
 type StartCode = Int
-type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
-
-type AlexInput = (Char,String)
-
-alexGetChar (_, [])   = Nothing
-alexGetChar (_, c:cs) = Just (c, (c,cs))
+type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> [LToken]
 
-alexInputPrevChar (c,_) = c
+tokenise :: String -> (Int, Int) -> [LToken]
+tokenise str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks
+  where
+    posn = AlexPn 0 line col
 
-tokenise :: String -> [Token]
-tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
-  where go inp@(_,str) sc =
+    go inp@(pos, _, str) sc =
 	  case alexScan inp sc of
 		AlexEOF -> []
 		AlexError _ -> error "lexical error"
 		AlexSkip  inp' _       -> go inp' sc
-		AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
+		AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc)
 
 -- NB. we add a final \n to the string, (see comment in the beginning of line
 -- production above).
 eofHack str = str++"\n"
 
 andBegin  :: Action -> StartCode -> Action
-andBegin act new_sc = \str _ cont -> act str new_sc cont
+andBegin act new_sc = \pos str _ cont -> act pos str new_sc cont
 
 token :: Token -> Action
-token t = \_ sc cont -> t : cont sc
+token t = \pos _ sc cont -> (t, pos) : cont sc
 
 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
+strtoken t = \pos str sc cont -> (t str, pos) : cont sc
+strtokenNL t = \pos str sc cont -> (t (filter (/= '\r') str), pos) : 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 = \_ _ cont -> cont sc
+begin sc = \_ _ _ cont -> cont sc
 
 -- -----------------------------------------------------------------------------
 -- Lex a string as a Haskell identifier
 
 ident :: Action
-ident str sc cont = 
+ident pos str sc cont = 
   case strToHsQNames id of
-	Just names -> TokIdent names : cont sc
-	Nothing -> TokString str : cont sc
+	Just names -> (TokIdent names, pos) : cont sc
+	Nothing -> (TokString str, pos) : cont sc
  where id = init (tail str)
 
 strToHsQNames :: String -> Maybe [RdrName]
diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y
index d1146da3..1aad3a18 100644
--- a/src/Haddock/Parse.y
+++ b/src/Haddock/Parse.y
@@ -20,26 +20,26 @@ import Data.List  (stripPrefix)
 
 %expect 0
 
-%tokentype { Token }
-
-%token	'/'	{ TokSpecial '/' }
-	'@'	{ TokSpecial '@' }
-	'['     { TokDefStart }
-	']'     { TokDefEnd }
-	DQUO 	{ TokSpecial '\"' }
-	URL	{ TokURL $$ }
-	PIC     { TokPic $$ }
-	ANAME	{ TokAName $$ }
-	'/../'  { TokEmphasis $$ }
-	'-'	{ TokBullet }
-	'(n)'	{ TokNumber }
-	'>..'	{ TokBirdTrack $$ }
-	PROMPT	{ TokExamplePrompt $$ }
-	RESULT	{ TokExampleResult $$ }
-	EXP	{ TokExampleExpression $$ }
-	IDENT   { TokIdent $$ }
-	PARA    { TokPara }
-	STRING	{ TokString $$ }
+%tokentype { LToken }
+
+%token	'/'	{ (TokSpecial '/',_) }
+	'@'	{ (TokSpecial '@',_) }
+	'['     { (TokDefStart,_) }
+	']'     { (TokDefEnd,_) }
+	DQUO 	{ (TokSpecial '\"',_) }
+	URL	{ (TokURL $$,_) }
+	PIC     { (TokPic $$,_) }
+	ANAME	{ (TokAName $$,_) }
+	'/../'  { (TokEmphasis $$,_) }
+	'-'	{ (TokBullet,_) }
+	'(n)'	{ (TokNumber,_) }
+	'>..'	{ (TokBirdTrack $$,_) }
+	PROMPT	{ (TokExamplePrompt $$,_) }
+	RESULT	{ (TokExampleResult $$,_) }
+	EXP	{ (TokExampleExpression $$,_) }
+	IDENT   { (TokIdent $$,_) }
+	PARA    { (TokPara,_) }
+	STRING	{ (TokString $$,_) }
 
 %monad { Maybe }
 
@@ -117,7 +117,7 @@ strings  :: { String }
 	| STRING strings	{ $1 ++ $2 }
 
 {
-happyError :: [Token] -> Maybe a
+happyError :: [LToken] -> Maybe a
 happyError toks = Nothing
 
 -- | Create an 'Example', stripping superfluous characters as appropriate
diff --git a/src/Main.hs b/src/Main.hs
index 9a7aa47f..571cb25e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -408,7 +408,7 @@ getPrologue flags =
     [] -> return Nothing
     [filename] -> do
       str <- readFile filename
-      case parseParas (tokenise str) of
+      case parseParas (tokenise str (0,0) {- TODO: real position -}) of
         Nothing -> throwE "parsing haddock prologue failed"
         Just doc -> return (Just doc)
     _otherwise -> throwE "multiple -p/--prologue options"