module Language.Haskell.HBB.Internal.Lexer (
getVariableIdUsingLexerAt,
LexingFailReason(..),
IncludeQualified(..)
) where
import Language.Haskell.HBB.Internal.SrcSpan
import StringBuffer
import FastString (unpackFS,mkFastString)
import GhcMonad (liftIO,GhcMonad)
import SrcLoc
import Lexer (lexTokenStream,ParseResult(..),Token(..))
import GHC (getSessionDynFlags)
data LexingFailReason = LexingFailed
| VarNotFound
data IncludeQualified = IncludeQualifiedVars
| ExcludeQualifiedVars
deriving (Eq)
getVariableIdUsingLexerAt :: GhcMonad m => (FilePath,BufLoc) -> IncludeQualified -> m (Either LexingFailReason (String,RealSrcSpan))
getVariableIdUsingLexerAt (filename,loc) behaviour = do
let wholeFileLoc :: RealSrcLoc
wholeFileLoc = mkRealSrcLoc (mkFastString filename) 1 1
ghcDynFlags <- getSessionDynFlags
fileContent <- liftIO $ hGetStringBuffer filename
let isRelevantToken :: Token -> Bool
isRelevantToken (ITvarid _) = True
isRelevantToken (ITqvarid _) | (behaviour == IncludeQualifiedVars) = True
isRelevantToken _ = False
token2Result :: Token -> String
token2Result (ITvarid s ) = unpackFS s
token2Result (ITqvarid (_,s)) = unpackFS s
token2Result _ = error "Internal error (unexected wrong token type)"
case lexTokenStream fileContent wholeFileLoc ghcDynFlags of
POk _ xs -> let relevantByLoc = [ tok | tok@(L (RealSrcSpan s) _) <- xs
, (toBufLoc $ realSrcSpanStart s) <= loc
, (toBufLoc $ realSrcSpanEnd s) > loc ]
relevant = [ (token2Result t,r) | (L (RealSrcSpan r) t) <- relevantByLoc , isRelevantToken t ]
in case relevant of [x] -> return $ Right x
[] -> return $ Left VarNotFound
_ -> error "internal error (too many tokens)"
PFailed _ _ -> return $ Left LexingFailed