module Language.Haskell.GHC.Parser (
runParser,
LineNumber,
ColumnNumber,
ErrMsg,
StringLoc(..),
ParseOutput(..),
Parser,
parserStatement,
parserImport,
parserDeclaration,
parserTypeSignature,
parserModule,
parserExpression,
partialStatement,
partialImport,
partialDeclaration,
partialTypeSignature,
partialModule,
partialExpression,
) where
import Data.List (intercalate)
import Bag
import ErrUtils hiding (ErrMsg)
import FastString
import GHC
import Lexer
import OrdList
import Outputable hiding ((<>))
import SrcLoc
import StringBuffer
import qualified Language.Haskell.GHC.HappyParser as Parse
type LineNumber = Int
type ColumnNumber = Int
type ErrMsg = String
data StringLoc = Loc LineNumber ColumnNumber deriving (Show, Eq)
data ParseOutput a
= Failure ErrMsg StringLoc
| Parsed a
| Partial a (String, String)
deriving (Eq, Show)
data ParserType = FullParser | PartialParser
data Parser a = Parser ParserType (P a)
parserStatement = Parser FullParser Parse.fullStatement
parserImport = Parser FullParser Parse.fullImport
parserDeclaration = Parser FullParser Parse.fullDeclaration
parserExpression = Parser FullParser Parse.fullExpression
parserTypeSignature = Parser FullParser Parse.fullTypeSignature
parserModule = Parser FullParser Parse.fullModule
partialStatement = Parser PartialParser Parse.partialStatement
partialImport = Parser PartialParser Parse.partialImport
partialDeclaration = Parser PartialParser Parse.partialDeclaration
partialExpression = Parser PartialParser Parse.partialExpression
partialTypeSignature = Parser PartialParser Parse.partialTypeSignature
partialModule = Parser PartialParser Parse.partialModule
runParser :: DynFlags -> Parser a -> String -> ParseOutput a
runParser flags (Parser parserType parser) str =
let filename = "<interactive>"
location = mkRealSrcLoc (mkFastString filename) 1 1
buffer = stringToStringBuffer str
parseState = mkPState flags buffer location in
toParseOut $ unP parser parseState
where
toParseOut :: ParseResult a -> ParseOutput a
toParseOut (PFailed span@(RealSrcSpan realSpan) err) =
let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags span err
line = srcLocLine $ realSrcSpanStart realSpan
col = srcLocCol $ realSrcSpanStart realSpan
in Failure errMsg $ Loc line col
toParseOut (PFailed span err) =
let errMsg = printErrorBag $ unitBag $ mkPlainErrMsg flags span err
in Failure errMsg $ Loc 0 0
toParseOut (POk parseState result) =
let parseEnd = realSrcSpanStart $ last_loc parseState
endLine = srcLocLine parseEnd
endCol = srcLocCol parseEnd
(before, after) = splitAtLoc endLine endCol str in
case parserType of
PartialParser -> Partial result (before, after)
FullParser -> Parsed result
printErrorBag bag = joinLines . map show $ bagToList bag
splitAtLoc :: LineNumber -> ColumnNumber -> String -> (String, String)
splitAtLoc line col string =
if line > length (lines string)
then (string, "")
else (before, after)
where
(beforeLines, afterLines) = splitAt line $ lines string
theLine = last beforeLines
(beforeChars, afterChars) = splitAt (col 1) theLine
before = joinLines (init beforeLines) ++ '\n' : beforeChars
after = joinLines $ afterChars : afterLines
joinLines :: [String] -> String
joinLines = intercalate "\n"