mirror of
https://github.com/IHaskell/IHaskell.git
synced 2025-04-16 03:16:20 +00:00
parser sets extension flags earlier now, closes #98
This commit is contained in:
parent
ce80fe6d86
commit
1d011463b0
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
48
src/IHaskell/Eval/Util.hs
Normal 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
|
Loading…
x
Reference in New Issue
Block a user