module Language.Haskell.GHC.Parser (
runParser,
LineNumber,
ColumnNumber,
ErrMsg,
StringLoc(..),
ParseOutput(..),
Parser,
Located(..),
parserStatement,
parserImport,
parserDeclaration,
parserTypeSignature,
parserModule,
parserExpression,
removeComments,
layoutChunks,
) where
import Data.List (intercalate, findIndex)
import Bag
import ErrUtils hiding (ErrMsg)
import FastString
import GHC hiding (Located)
import Lexer
import OrdList
import Outputable hiding ((<>))
import SrcLoc hiding (Located)
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 Located a = Located {
line :: LineNumber,
unloc :: a
} deriving (Eq, Show, Functor)
data Parser a = Parser (P a)
parserStatement = Parser Parse.fullStatement
parserImport = Parser Parse.fullImport
parserDeclaration = Parser Parse.fullDeclaration
parserExpression = Parser Parse.fullExpression
parserTypeSignature = Parser Parse.fullTypeSignature
parserModule = Parser Parse.fullModule
runParser :: DynFlags -> Parser a -> String -> ParseOutput a
runParser flags (Parser 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 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"
layoutChunks :: String -> [Located String]
layoutChunks = go 1
where
go :: LineNumber -> String -> [Located String]
go line = filter (not . null . unloc) . map (fmap strip) . layoutLines line . lines
strip = dropRight . dropLeft
where
dropLeft = dropWhile (`elem` whitespace)
dropRight = reverse . dropWhile (`elem` whitespace) . reverse
whitespace = " \t\n"
layoutLines :: LineNumber -> [String] -> [Located String]
layoutLines _ [] = []
layoutLines lineIdx all@(firstLine:rest) =
let firstIndent = indentLevel firstLine
blockEnded line = indentLevel line <= firstIndent in
case findIndex blockEnded rest of
Nothing -> [Located lineIdx $ intercalate "\n" all]
Just idx ->
let (before, after) = splitAt idx rest in
Located lineIdx (joinLines $ firstLine:before) : go (lineIdx + idx + 1) (joinLines after)
indentLevel :: String -> Int
indentLevel (' ':str) = 1 + indentLevel str
indentLevel ('\t':str) = 2 + indentLevel str
indentLevel "" = 100000
indentLevel _ = 0
removeComments :: String -> String
removeComments = removeOneLineComments . removeMultilineComments 0 0
where
removeOneLineComments str =
case str of
':':'!':remaining ->":!" ++ takeLine remaining ++ dropLine remaining
'"':remaining ->
let quoted = takeString remaining
len = length quoted in
'"':quoted ++ removeOneLineComments (drop len remaining)
'-':'-':remaining -> dropLine remaining
x:xs -> x:removeOneLineComments xs
[] -> []
where
dropLine = removeOneLineComments . dropWhile (/= '\n')
removeMultilineComments nesting pragmaNesting str =
case str of
':':'!':remaining ->":!" ++ takeLine remaining ++
removeMultilineComments nesting pragmaNesting (dropWhile (/= '\n') remaining)
'"':remaining ->
if nesting == 0
then
let quoted = takeString remaining
len = length quoted in
'"':quoted ++ removeMultilineComments nesting pragmaNesting (drop len remaining)
else
removeMultilineComments nesting pragmaNesting remaining
'{':'-':'#':remaining ->
if nesting == 0
then "{-#" ++ removeMultilineComments nesting (pragmaNesting + 1) remaining
else removeMultilineComments nesting pragmaNesting remaining
'#':'-':'}':remaining ->
if nesting == 0
then if pragmaNesting > 0
then '#':'-':'}':removeMultilineComments nesting (pragmaNesting 1) remaining
else '#':'-':'}':removeMultilineComments nesting pragmaNesting remaining
else removeMultilineComments nesting pragmaNesting remaining
'{':'-':remaining -> removeMultilineComments (nesting + 1) pragmaNesting remaining
'-':'}':remaining ->
if nesting > 0
then removeMultilineComments (nesting 1) pragmaNesting remaining
else '-':'}':removeMultilineComments nesting pragmaNesting remaining
x:xs ->
if nesting > 0
then removeMultilineComments nesting pragmaNesting xs
else x:removeMultilineComments nesting pragmaNesting xs
[] -> []
takeLine = takeWhile (/= '\n')
takeString str = case str of
escaped@('\\':'"':rest) -> escaped
'"':rest -> "\""
x:xs -> x:takeString xs
[] -> []