module CSPM.Parser.Monad (
ParseMonad, ParserState(..),
FileParserState(..), movePos,
setParserState, getParserState,
FilePosition(..), filePositionToSrcLoc,
modifyTopFileParserState, getTopFileParserState,
runParser, pushFile, pushFileContents,
getTokenizerPos, getFileName, getInput,
getPreviousChar, getCurrentStartCode, setCurrentStartCode,
getSequenceStack, setSequenceStack
)
where
import Control.Exception
import Control.Monad.State
import GHC.IO.Encoding
#if __GLASGOW_HASKELL__ < 705
import Prelude hiding (catch)
#endif
import System.FilePath
import System.IO
import CSPM.Parser.Exceptions
import Util.Annotated
data FilePosition = FilePosition !Int !Int !Int
deriving (Eq,Show)
startPos :: FilePosition
startPos = FilePosition 0 1 1
filePositionToSrcLoc :: String -> FilePosition -> SrcSpan
filePositionToSrcLoc filePath (FilePosition _ line col) =
SrcSpanPoint filePath line col
movePos :: FilePosition -> Char -> FilePosition
movePos (FilePosition a l _) '\n' = FilePosition (a+1) (l+1) 1
movePos (FilePosition a l c) _ = FilePosition (a+1) l (c+1)
data ParserState = ParserState {
rootDir :: !String,
fileStack :: ![FileParserState]
}
deriving Show
data FileParserState = FileParserState {
tokenizerPos :: !FilePosition,
fileName :: !String,
input :: String,
previousChar :: !Char,
currentStartCode :: !Int,
sequenceStack :: ![Int]
}
deriving Show
type ParseMonad = StateT ParserState IO
runParser :: ParseMonad a -> String -> IO a
runParser prog dirname =
runStateT prog (ParserState dirname [])
>>= return . fst
getTopFileParserState :: ParseMonad FileParserState
getTopFileParserState = gets (head . fileStack)
getParserState :: ParseMonad ParserState
getParserState = gets id
setParserState :: ParserState -> ParseMonad ()
setParserState st = modify (\ _ -> st)
modifyTopFileParserState :: (FileParserState -> FileParserState) -> ParseMonad ()
modifyTopFileParserState stf =
modify (\ st -> let fs:fss = fileStack st in
st { fileStack = (stf fs):fss })
pushFile :: String -> ParseMonad a -> ParseMonad a
pushFile fname prog = do
dirname <- gets rootDir
let
filename = combine dirname fname
handle :: IOException -> a
handle e = throwSourceError [fileAccessErrorMessage filename]
str <- liftIO $ catch (do
handle <- openFile filename ReadMode
hSetEncoding handle char8
hGetContents handle) handle
pushFileContents filename str
x <- prog
return x
pushFileContents :: String -> String -> ParseMonad ()
pushFileContents filename input =
modify (\ st -> let
fs = FileParserState startPos filename (input++" ") '\n' 0 [0]
in
st { fileStack = fs:(fileStack st) })
getTokenizerPos :: ParseMonad FilePosition
getTokenizerPos = getTopFileParserState >>= (return . tokenizerPos)
getFileName :: ParseMonad String
getFileName = getTopFileParserState >>= (return . fileName)
getInput :: ParseMonad String
getInput = getTopFileParserState >>= (return . input)
getPreviousChar :: ParseMonad Char
getPreviousChar = getTopFileParserState >>= (return . previousChar)
getCurrentStartCode :: ParseMonad Int
getCurrentStartCode = getTopFileParserState >>= (return . currentStartCode)
getSequenceStack :: ParseMonad [Int]
getSequenceStack = getTopFileParserState >>= (return . sequenceStack)
setCurrentStartCode :: Int -> ParseMonad ()
setCurrentStartCode sc =
modifyTopFileParserState (\ st -> st { currentStartCode = sc })
setSequenceStack :: [Int] -> ParseMonad ()
setSequenceStack st =
modifyTopFileParserState (\ s -> s { sequenceStack = st })