diff --git a/IHaskell.cabal b/IHaskell.cabal index 8ef35480..30bc204a 100644 --- a/IHaskell.cabal +++ b/IHaskell.cabal @@ -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 diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index d5b61bc3..3c9d3934 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -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". - -- In that case, we disable the extension. - flagMatchesNo ext (name, _, _) = ext == "No" ++ name evalCommand _ (Directive GetType expr) state = wrapExecution state $ do write $ "Type: " ++ expr diff --git a/src/IHaskell/Eval/Parser.hs b/src/IHaskell/Eval/Parser.hs index f4196501..d44d8107 100644 --- a/src/IHaskell/Eval/Parser.hs +++ b/src/IHaskell/Eval/Parser.hs @@ -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 diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs new file mode 100644 index 00000000..9b4d138d --- /dev/null +++ b/src/IHaskell/Eval/Util.hs @@ -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". + -- 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