mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-19 12:56:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

removed pattern guards

Browse Source
This commit is contained in:
Andrew Gibiansky 2014-01-25 16:12:12 -08:00
parent f6716a5cb6
commit 720603989c
3 changed files with 89 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
notebooks/Test.ipynb
View File

@ -47,20 +47,17 @@
"cell_type": "code",
"collapsed": false,
"input": [
"f True"
":info IHaskellDisplay"
],
"language": "python",
"metadata": {},
"outputs": [
{
"metadata": {},
"output_type": "display_data",
"text": [
"True"
]
"output_type": "display_data"
}
],
"prompt_number": 15
"prompt_number": 6
},
{
"cell_type": "code",
@ -89,7 +86,7 @@
"language": "python",
"metadata": {},
"outputs": [],
"prompt_number": 3
"prompt_number": 4
},
{
"cell_type": "code",
@ -225,7 +222,7 @@
"</symbol>\n",
"</g>\n",
"</defs>\n",
"<g id=\"surface44\">\n",
"<g id=\"surface56\">\n",
"<rect x=\"0\" y=\"0\" width=\"450\" height=\"300\" style=\"fill:rgb(100%,100%,100%);fill-opacity:1;stroke:none;\"/>\n",
"<g style=\"fill:rgb(0%,0%,0%);fill-opacity:1;\">\n",
" <use xlink:href=\"#glyph0-1\" x=\"156.476562\" y=\"16.550781\"/>\n",
@ -310,7 +307,7 @@
]
}
],
"prompt_number": 4
"prompt_number": 5
},
{
"cell_type": "code",

107
src/IHaskell/Eval/Evaluate.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, PatternGuards #-}
{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances #-}
{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
a statement, declaration, import, or directive.
@ -72,7 +72,7 @@ import IHaskell.Eval.Util
import Paths_ihaskell (version)
import Data.Version (versionBranch)
data ErrorOccurred = Success | Failure deriving (Show, Eq, Ord)
data ErrorOccurred = Success | Failure deriving (Show, Eq)
debug :: Bool
debug = False
@ -323,20 +323,26 @@ wrapExecution state exec = safely state $ exec >>= \res ->
-- | Set dynamic flags.
--
-- adapted from GHC's InteractiveUI.hs (newDynFlags)
setDynFlags :: [String] -> Interpreter [ErrMsg]
-- This was adapted from GHC's InteractiveUI.hs (newDynFlags).
setDynFlags :: [String] -- ^ Flags to set.
-> Interpreter [ErrMsg] -- ^ Errors from trying to set flags.
setDynFlags ext = do
-- Try to parse flags.
flags <- getSessionDynFlags
(flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
let restorePkg x = x { packageFlags = packageFlags flags }
-- First, try to check if this flag matches any extension name.
new_pkgs <- GHC.setProgramDynFlags (restorePkg flags')
GHC.setInteractiveDynFlags (restorePkg flags')
return $ map (("Could not parse: " ++) . unLoc) unrecognized ++
map ("Warning: " ++)
(map unLoc warnings ++
[ "-package not supported yet"
| packageFlags flags /= packageFlags flags' ])
let restorePkg x = x { packageFlags = packageFlags flags }
let restoredPkgs = flags' { packageFlags = packageFlags flags}
GHC.setProgramDynFlags restoredPkgs
GHC.setInteractiveDynFlags restoredPkgs
-- Create the parse errors.
let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized
allWarns = map unLoc warnings ++
["-package not supported yet" | packageFlags flags /= packageFlags flags']
warnErrs = map ("Warning: " ++) allWarns
return $ noParseErrs ++ warnErrs
-- | Return the display data for this command, as well as whether it
-- resulted in an error.
@ -405,38 +411,59 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
-- Since nothing prevents loading the module, compile and load it.
Nothing -> doLoadModule modName modName
evalCommand a (Directive SetDynFlag flags) state
| let f o = case filter (elem o . getSetName) kernelOpts of
[] -> Right o
[z] | s:_ <- getOptionName z -> Left s
| otherwise -> error ("evalCommand Directive SetDynFlag impossible")
ds -> error ("kernelOpts has duplicate:"++ show (map getSetName ds)),
(optionFlags,oo) <- partitionEithers $ map f (words flags),
not (null optionFlags) = do
eo1 <- evalCommand a (Directive SetOption (unwords optionFlags)) state
eo2 <- evalCommand a (Directive SetDynFlag (unwords oo)) (evalState eo1)
return $ EvalOut {
evalStatus = max (evalStatus eo1) (evalStatus eo2),
evalResult = evalResult eo1 ++ evalResult eo2,
evalState = evalState eo2,
evalPager = evalPager eo1 ++ evalPager eo2
}
evalCommand _ (Directive SetDynFlag flags) state = wrapExecution state $ do
write $ "DynFlag: " ++ flags
errs <- setDynFlags (words flags)
return $ case errs of
[] -> mempty
_ -> displayError $ intercalate "\n" errs
-- | Directives set via `:set`.
evalCommand output (Directive SetDynFlag flags) state =
case words flags of
-- For a single flag.
[flag] -> do
write $ "DynFlags: " ++ flags
evalCommand a (Directive SetExtension opts) state = do
-- Check if this is setting kernel options.
case find (elem flag . getSetName) kernelOpts of
-- If this is a kernel option, just set it.
Just (KernelOpt _ _ updater) ->
return EvalOut {
evalStatus = Success,
evalResult = mempty,
evalState = updater state,
evalPager = ""
}
-- If not a kernel option, must be a dyn flag.
Nothing -> do
errs <- setDynFlags [flag]
let display = case errs of
[] -> mempty
_ -> displayError $ intercalate "\n" errs
return EvalOut {
evalStatus = Success,
evalResult = display,
evalState = state,
evalPager = ""
}
-- Apply many flags.
flag:manyFlags -> do
firstEval <- evalCommand output (Directive SetDynFlag flags) state
case evalStatus firstEval of
Failure -> return firstEval
Success -> do
let newState = evalState firstEval
results = evalResult firstEval
restEval <- evalCommand output (Directive SetDynFlag $ unwords manyFlags) newState
return restEval {
evalResult = results ++ evalResult restEval
}
evalCommand output (Directive SetExtension opts) state = do
write $ "Extension: " ++ opts
evalCommand a (Directive SetDynFlag (concatMap (" -X"++) (words opts))) state
let set = concatMap (" -X" ++) $ words opts
evalCommand output (Directive SetDynFlag set) state
evalCommand a (Directive SetOption opts) state = do
write $ "Option: " ++ opts
let (lost, found) = partitionEithers
[ case filter (any (w==) . getOptionName) kernelOpts of
[ case filter (elem w . getOptionName) kernelOpts of
[x] -> Right (getUpdateKernelState x)
[] -> Left w
ds -> error ("kernelOpts has duplicate:" ++ show (map getOptionName ds))
@ -485,7 +512,7 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
if exists
then do
setCurrentDirectory directory
return $ mempty
return mempty
else
return $ displayError $ printf "No such directory: '%s'" directory
cmd -> do
@ -740,7 +767,7 @@ evalCommand output (Expression expr) state = do
Just bytestring ->
case Serialize.decode bytestring of
Left err -> error err
Right display -> do
Right display ->
return $
if useSvg state
then display

31
src/IHaskell/Types.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, PatternGuards #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
-- | Description : All message type definitions.
module IHaskell.Types (
Message (..),
@ -105,22 +104,24 @@ data FrontendType
| IPythonNotebook
deriving (Show, Eq, Read)
-- | names the ways to update the IHaskell 'KernelState' by `:set`
-- ('getSetName') and `:option` ('getOptionName') directives
data KernelOpt = KernelOpt
{ getOptionName, getSetName :: [String],
getUpdateKernelState :: KernelState -> KernelState }
-- | Kernel options to be set via `:set` and `:option`.
data KernelOpt = KernelOpt {
getOptionName :: [String], -- ^ Ways to set this option via `:option`
getSetName :: [String], -- ^ Ways to set this option via `:set`
getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state.
}
kernelOpts :: [KernelOpt]
kernelOpts =
[KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn },
KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff },
KernelOpt ["svg"] [] $ \state -> state { useSvg = True },
KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False },
KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True },
KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False },
KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True },
KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }]
[ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }
, KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }
, KernelOpt ["svg"] [] $ \state -> state { useSvg = True }
, KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }
, KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }
, KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }
, KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }
, KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }
]
-- | Initialization information for the kernel.
data InitInfo = InitInfo {