parser sets extension flags earlier now, closes #98

This commit is contained in:
Andrew Gibiansky 2014-01-08 15:24:33 -05:00
parent ce80fe6d86
commit 1d011463b0
4 changed files with 66 additions and 31 deletions

View File

@ -93,6 +93,7 @@ library
IHaskell.Eval.Stdin
IHaskell.Eval.Hoogle
IHaskell.Eval.ParseShell
IHaskell.Eval.Util
IHaskell.IPython
IHaskell.Message.Parser
IHaskell.Message.UUID
@ -118,6 +119,7 @@ executable IHaskell
IHaskell.Eval.Stdin
IHaskell.Eval.Hoogle
IHaskell.Eval.ParseShell
IHaskell.Eval.Util
IHaskell.IPython
IHaskell.Message.Parser
IHaskell.Message.UUID

View File

@ -65,6 +65,7 @@ import IHaskell.Eval.Parser
import IHaskell.Eval.Lint
import IHaskell.Display
import qualified IHaskell.Eval.Hoogle as Hoogle
import IHaskell.Eval.Util
import Paths_ihaskell (version)
import Data.Version (versionBranch)
@ -369,34 +370,6 @@ evalCommand _ (Directive SetExtension exts) state = wrapExecution state $ do
case catMaybes results of
[] -> return []
errors -> return $ displayError $ intercalate "\n" errors
where
-- Set an extension and update flags.
-- Return Nothing on success. On failure, return an error message.
setExtension :: String -> Interpreter (Maybe ErrMsg)
setExtension ext = do
flags <- getSessionDynFlags
-- First, try to check if this flag matches any extension name.
let newFlags =
case find (flagMatches ext) xFlags of
Just (_, flag, _) -> Just $ xopt_set flags flag
-- If it doesn't match an extension name, try matching against
-- disabling an extension.
Nothing ->
case find (flagMatchesNo ext) xFlags of
Just (_, flag, _) -> Just $ xopt_unset flags flag
Nothing -> Nothing
-- Set the flag if we need to.
case newFlags of
Just flags -> setSessionDynFlags flags >> return Nothing
Nothing -> return $ Just $ "Could not parse extension name: " ++ ext
-- Check if a FlagSpec matches an extension name.
flagMatches ext (name, _, _) = ext == name
-- Check if a FlagSpec matches "No<ExtensionName>".
-- In that case, we disable the extension.
flagMatchesNo ext (name, _, _) = ext == "No" ++ name
evalCommand _ (Directive GetType expr) state = wrapExecution state $ do
write $ "Type: " ++ expr

View File

@ -33,6 +33,7 @@ import SrcLoc hiding (Located)
import StringBuffer
import Language.Haskell.GHC.Parser
import IHaskell.Eval.Util
-- | A block of code to be evaluated.
-- Each block contains a single element - one declaration, statement,
@ -84,10 +85,16 @@ parseString codeString = do
let output = runParser flags parserModule codeString
case output of
Parsed {} -> return [Located 1 $ Module codeString]
Failure {} ->
Failure {} -> do
-- Split input into chunks based on indentation.
let chunks = layoutChunks $ dropComments codeString in
joinFunctions <$> processChunks [] chunks
let chunks = layoutChunks $ dropComments codeString
result <- joinFunctions <$> processChunks [] chunks
-- Return to previous flags. When parsing, flags can be set to make
-- sure parsing works properly. But we don't want those flags to be
-- set during evaluation until the right time.
setSessionDynFlags flags
return result
where
parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)
parseChunk chunk line = Located line <$>
@ -104,6 +111,7 @@ parseString codeString = do
-- If we have more remaining, parse the current chunk and recurse.
Located line chunk:remaining -> do
block <- parseChunk chunk line
activateParsingExtensions $ unloc block
processChunks (block : accum) remaining
-- Test wither a given chunk is a directive.
@ -114,6 +122,10 @@ parseString codeString = do
nlines :: String -> Int
nlines = length . lines
activateParsingExtensions :: GhcMonad m => CodeBlock -> m ()
activateParsingExtensions (Directive SetExtension ext) = void $ setExtension ext
activateParsingExtensions _ = return ()
-- | Parse a single chunk of code, as indicated by the layout of the code.
parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock
parseCodeChunk code startLine = do

48
src/IHaskell/Eval/Util.hs Normal file
View File

@ -0,0 +1,48 @@
module IHaskell.Eval.Util (
extensionFlag, setExtension,
ExtFlag(..),
) where
-- GHC imports.
import GHC
import GhcMonad
import DynFlags
import Data.List (find)
data ExtFlag
= SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
extensionFlag :: String -> Maybe ExtFlag
extensionFlag ext =
case find (flagMatches ext) xFlags of
Just (_, flag, _) -> Just $ SetFlag flag
-- If it doesn't match an extension name, try matching against
-- disabling an extension.
Nothing ->
case find (flagMatchesNo ext) xFlags of
Just (_, flag, _) -> Just $ UnsetFlag flag
Nothing -> Nothing
where
-- Check if a FlagSpec matches an extension name.
flagMatches ext (name, _, _) = ext == name
-- Check if a FlagSpec matches "No<ExtensionName>".
-- In that case, we disable the extension.
flagMatchesNo ext (name, _, _) = ext == "No" ++ name
-- Set an extension and update flags.
-- Return Nothing on success. On failure, return an error message.
setExtension :: GhcMonad m => String -> m (Maybe String)
setExtension ext = do
flags <- getSessionDynFlags
case extensionFlag ext of
Nothing -> return $ Just $ "Could not parse extension name: " ++ ext
Just flag -> do
setSessionDynFlags $
case flag of
SetFlag ghcFlag -> xopt_set flags ghcFlag
UnsetFlag ghcFlag -> xopt_unset flags ghcFlag
return Nothing