module IHaskell.Eval.Parser (
parseString,
CodeBlock(..),
StringLoc(..),
DirectiveType(..),
LineNumber,
ColumnNumber,
ErrMsg,
layoutChunks,
parseDirective,
getModuleName,
Located(..),
) where
import ClassyPrelude hiding (head, tail, liftIO, unlines, maximumBy)
import Data.List (findIndex, maximumBy, maximum, inits)
import Data.String.Utils (startswith, strip, split)
import Data.List.Utils (subIndex)
import Prelude (init, last, head, tail)
import Bag
import ErrUtils hiding (ErrMsg)
import FastString
import GHC hiding (Located)
import GhcMonad
import Lexer
import OrdList
import Outputable hiding ((<>))
import SrcLoc hiding (Located)
import StringBuffer
import Language.Haskell.GHC.Parser
import IHaskell.Eval.Util
data CodeBlock
= Expression String
| Declaration String
| Statement String
| Import String
| TypeSignature String
| Directive DirectiveType String
| Module String
| ParseError StringLoc ErrMsg
deriving (Show, Eq)
data DirectiveType
= GetType
| GetInfo
| SetDynFlag
| LoadFile
| SetOption
| SetExtension
| ShellCmd
| GetHelp
| SearchHoogle
| GetDoc
| GetKind
deriving (Show, Eq)
parseString :: String -> Ghc [Located CodeBlock]
parseString codeString = do
flags <- getSessionDynFlags
let output = runParser flags parserModule codeString
case output of
Parsed {} -> return [Located 1 $ Module codeString]
Failure {} -> do
let chunks = layoutChunks $ removeComments codeString
result <- joinFunctions <$> processChunks [] chunks
setSessionDynFlags flags
return result
where
parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)
parseChunk chunk line = Located line <$>
if isDirective chunk
then return $ parseDirective chunk line
else parseCodeChunk chunk line
processChunks :: GhcMonad m => [Located CodeBlock] -> [Located String] -> m [Located CodeBlock]
processChunks accum remaining =
case remaining of
[] -> return $ reverse accum
Located line chunk:remaining -> do
block <- parseChunk chunk line
activateParsingExtensions $ unloc block
processChunks (block : accum) remaining
isDirective :: String -> Bool
isDirective = startswith ":" . strip
nlines :: String -> Int
nlines = length . lines
activateParsingExtensions :: GhcMonad m => CodeBlock -> m ()
activateParsingExtensions (Directive SetExtension ext) = void $ setExtension ext
activateParsingExtensions (Directive SetDynFlag flags) =
case stripPrefix "-X" flags of
Just ext -> void $ setExtension ext
Nothing -> return ()
activateParsingExtensions _ = return ()
parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock
parseCodeChunk code startLine = do
flags <- getSessionDynFlags
let
rawResults = map (tryParser code) (parsers flags)
results = map (statementToExpression flags) rawResults in
case successes results of
[] -> return $ bestError $ failures results
result:_ -> return result
where
successes :: [ParseOutput a] -> [a]
successes [] = []
successes (Parsed a:rest) = a : successes rest
successes (_:rest) = successes rest
failures :: [ParseOutput a] -> [(ErrMsg, LineNumber, ColumnNumber)]
failures [] = []
failures (Failure msg (Loc line col):rest) = (msg, line, col) : failures rest
failures (_:rest) = failures rest
bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock
bestError errors = ParseError (Loc (line + startLine 1) col) msg
where
(msg, line, col) = maximumBy compareLoc errors
compareLoc (_, line1, col1) (_, line2, col2) = compare line1 line2 <> compare col1 col2
statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
statementToExpression flags (Parsed (Statement stmt)) = Parsed result
where result = if isExpr flags stmt
then Expression stmt
else Statement stmt
statementToExpression _ other = other
isExpr :: DynFlags -> String -> Bool
isExpr flags str = case runParser flags parserExpression str of
Parsed {} -> True
_ -> False
tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock
tryParser string (blockType, parser) = case parser string of
Parsed res -> Parsed (blockType res)
Failure err loc -> Failure err loc
parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)]
parsers flags =
[ (Import, unparser parserImport)
, (TypeSignature, unparser parserTypeSignature)
, (Statement, unparser parserStatement)
, (Declaration, unparser parserDeclaration)
]
where
unparser :: Parser a -> String -> ParseOutput String
unparser parser code =
case runParser flags parser code of
Parsed out -> Parsed code
Partial out strs -> Partial code strs
Failure err loc -> Failure err loc
joinFunctions :: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions [] = []
joinFunctions blocks =
if signatureOrDecl $ unloc $ head blocks
then Located lnum (conjoin $ map unloc decls) : joinFunctions rest
else head blocks : joinFunctions (tail blocks)
where
decls = takeWhile (signatureOrDecl . unloc) blocks
rest = drop (length decls) blocks
lnum = line $ head decls
signatureOrDecl (Declaration _) = True
signatureOrDecl (TypeSignature _) = True
signatureOrDecl _ = False
str (Declaration s) = s
str (TypeSignature s) = s
str _ = error "Expected declaration or signature"
conjoin :: [CodeBlock] -> CodeBlock
conjoin = Declaration . intercalate "\n" . map str
parseDirective :: String
-> Int
-> CodeBlock
parseDirective (':':'!':directive) line = Directive ShellCmd $ '!':directive
parseDirective (':':directive) line = case find rightDirective directives of
Just (directiveType, _) -> Directive directiveType arg
where arg = unwords restLine
_:restLine = words directive
Nothing ->
let directiveStart = case words directive of
[] -> ""
first:_ -> first in
ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'."
where
rightDirective (_, dirname) = case words directive of
[] -> False
dir:_ -> dir `elem` tail (inits dirname)
directives =
[ (GetType, "type")
, (GetKind, "kind")
, (GetInfo, "info")
, (SearchHoogle, "hoogle")
, (GetDoc, "documentation")
, (SetDynFlag, "set")
, (LoadFile, "load")
, (SetOption, "option")
, (SetExtension, "extension")
, (GetHelp, "?")
, (GetHelp, "help")
]
parseDirective _ _ = error "Directive must start with colon!"
getModuleName :: GhcMonad m => String -> m [String]
getModuleName moduleSrc = do
flags <- getSessionDynFlags
let output = runParser flags parserModule moduleSrc
case output of
Failure {} -> error "Module parsing failed."
Parsed mod ->
case unLoc <$> hsmodName (unLoc mod) of
Nothing -> error "Module must have a name."
Just name -> return $ split "." $ moduleNameString name
joinLines :: [String] -> String
joinLines = intercalate "\n"