mirror of
https://github.com/IHaskell/IHaskell.git
synced 2025-04-16 03:16:20 +00:00
Switch warnings to -Wall and fix the rest
This commit is contained in:
Erik de Castro Lopo
parent
4c0b3d249b
commit
f43b91294c
@ -49,7 +49,7 @@ data-files:
|
||||
library
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wincomplete-patterns -Wmissing-signatures -Wunused-do-bind -Wunused-local-binds -Wunused-top-binds -Wunused-matches -Wunused-imports
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
aeson >=1.0,
|
||||
base >=4.9,
|
||||
@ -121,11 +121,10 @@ executable ihaskell
|
||||
other-modules:
|
||||
IHaskellPrelude
|
||||
Paths_ihaskell
|
||||
ghc-options: -threaded -rtsopts
|
||||
ghc-options: -threaded -rtsopts -Wall
|
||||
|
||||
-- Other library packages from which modules are imported.
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wincomplete-patterns -Wmissing-signatures -Wunused-do-bind -Wunused-local-binds -Wunused-top-binds -Wunused-matches -Wunused-imports
|
||||
build-depends:
|
||||
ihaskell -any,
|
||||
base >=4.9 && < 4.13,
|
||||
@ -143,7 +142,7 @@ executable ihaskell
|
||||
|
||||
Test-Suite hspec
|
||||
Type: exitcode-stdio-1.0
|
||||
Ghc-Options: -threaded
|
||||
Ghc-Options: -threaded -Wall
|
||||
Main-Is: Hspec.hs
|
||||
hs-source-dirs: src/tests
|
||||
other-modules:
|
||||
@ -152,7 +151,6 @@ Test-Suite hspec
|
||||
IHaskell.Test.Util
|
||||
IHaskell.Test.Parser
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wincomplete-patterns -Wmissing-signatures -Wunused-do-bind -Wunused-local-binds -Wunused-top-binds -Wunused-matches -Wunused-imports
|
||||
build-depends:
|
||||
base,
|
||||
ihaskell,
|
||||
|
||||
48
main/Main.hs
48
main/Main.hs
@ -47,7 +47,7 @@ main = do
|
||||
args <- parseFlags <$> getArgs
|
||||
case args of
|
||||
Left errorMessage -> hPutStrLn stderr errorMessage
|
||||
Right args -> ihaskell args
|
||||
Right xs -> ihaskell xs
|
||||
|
||||
ihaskell :: Args -> IO ()
|
||||
ihaskell (Args (ShowDefault helpStr) args) = showDefault helpStr args
|
||||
@ -101,10 +101,10 @@ parseKernelArgs = foldl' addFlag defaultKernelSpecOptions
|
||||
runKernel :: KernelSpecOptions -- ^ Various options from when the kernel was installed.
|
||||
-> String -- ^ File with kernel profile JSON (ports, etc).
|
||||
-> IO ()
|
||||
runKernel kernelOpts profileSrc = do
|
||||
let debug = kernelSpecDebug kernelOpts
|
||||
libdir = kernelSpecGhcLibdir kernelOpts
|
||||
useStack = kernelSpecUseStack kernelOpts
|
||||
runKernel kOpts profileSrc = do
|
||||
let debug = kernelSpecDebug kOpts
|
||||
libdir = kernelSpecGhcLibdir kOpts
|
||||
useStack = kernelSpecUseStack kOpts
|
||||
|
||||
-- Parse the profile file.
|
||||
let profileErr = error $ "ihaskell: "++profileSrc++": Failed to parse profile file"
|
||||
@ -155,10 +155,10 @@ runKernel kernelOpts profileSrc = do
|
||||
evaluator line = void $ do
|
||||
-- Create a new state each time.
|
||||
stateVar <- liftIO initialKernelState
|
||||
state <- liftIO $ takeMVar stateVar
|
||||
evaluate state line noPublish noWidget
|
||||
st <- liftIO $ takeMVar stateVar
|
||||
evaluate st line noPublish noWidget
|
||||
|
||||
confFile <- liftIO $ kernelSpecConfFile kernelOpts
|
||||
confFile <- liftIO $ kernelSpecConfFile kOpts
|
||||
case confFile of
|
||||
Just filename -> liftIO (readFile filename) >>= evaluator
|
||||
Nothing -> return ()
|
||||
@ -259,8 +259,8 @@ replyTo _ CommInfoRequest{} replyHeader state =
|
||||
|
||||
-- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
|
||||
-- let the frontend know shutdown is happening.
|
||||
replyTo interface ShutdownRequest { restartPending = restartPending } replyHeader _ = liftIO $ do
|
||||
writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending
|
||||
replyTo interface ShutdownRequest { restartPending = pending } replyHeader _ = liftIO $ do
|
||||
writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader pending
|
||||
exitSuccess
|
||||
|
||||
-- Reply to an execution request. The reply itself does not require computation, but this causes
|
||||
@ -285,7 +285,7 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
|
||||
-- re-display with the updated output.
|
||||
displayed <- liftIO $ newMVar []
|
||||
updateNeeded <- liftIO $ newMVar False
|
||||
pagerOutput <- liftIO $ newMVar []
|
||||
pOut <- liftIO $ newMVar []
|
||||
|
||||
let execCount = getExecutionCounter state
|
||||
-- Let all frontends know the execution count and code that's about to run
|
||||
@ -294,7 +294,7 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
|
||||
|
||||
-- Run code and publish to the frontend as we go.
|
||||
let widgetMessageHandler = widgetHandler send replyHeader
|
||||
publish = publishResult send replyHeader displayed updateNeeded pagerOutput (usePager state)
|
||||
publish = publishResult send replyHeader displayed updateNeeded pOut (usePager state)
|
||||
updatedState <- evaluate state (T.unpack code) publish widgetMessageHandler
|
||||
|
||||
-- Notify the frontend that we're done computing.
|
||||
@ -303,7 +303,7 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
|
||||
|
||||
-- Take pager output if we're using the pager.
|
||||
pager <- if usePager state
|
||||
then liftIO $ readMVar pagerOutput
|
||||
then liftIO $ readMVar pOut
|
||||
else return []
|
||||
return
|
||||
(updatedState, ExecuteReply
|
||||
@ -371,14 +371,14 @@ replyTo _ HistoryRequest{} replyHeader state = do
|
||||
--
|
||||
-- Sending the message only on the shell_reply channel doesn't work, so we send it as a comm message
|
||||
-- on the iopub channel and return the SendNothing message.
|
||||
replyTo interface open@CommOpen{} replyHeader state = do
|
||||
let send msg = liftIO $ writeChan (iopubChannel interface) msg
|
||||
replyTo interface ocomm@CommOpen{} replyHeader state = do
|
||||
let send = liftIO . writeChan (iopubChannel interface)
|
||||
|
||||
incomingUuid = commUuid open
|
||||
target = commTargetName open
|
||||
incomingUuid = commUuid ocomm
|
||||
target = commTargetName ocomm
|
||||
|
||||
targetMatches = target == "ipython.widget"
|
||||
valueMatches = commData open == object ["widget_class" .= "ipywidgets.CommInfo"]
|
||||
valueMatches = commData ocomm == object ["widget_class" .= ("ipywidgets.CommInfo" :: Text)]
|
||||
|
||||
commMap = openComms state
|
||||
uuidTargetPairs = map (second targetName) $ Map.toList commMap
|
||||
@ -387,11 +387,11 @@ replyTo interface open@CommOpen{} replyHeader state = do
|
||||
|
||||
currentComms = object $ map pairProcessor $ (incomingUuid, "comm") : uuidTargetPairs
|
||||
|
||||
replyValue = object [ "method" .= "custom"
|
||||
replyValue = object [ "method" .= ("custom" :: Text)
|
||||
, "content" .= object ["comms" .= currentComms]
|
||||
]
|
||||
|
||||
msg = CommData replyHeader (commUuid open) replyValue
|
||||
msg = CommData replyHeader (commUuid ocomm) replyValue
|
||||
|
||||
-- To the iopub channel you go
|
||||
when (targetMatches && valueMatches) $ send msg
|
||||
@ -409,7 +409,7 @@ handleComm send kernelState req replyHeader = do
|
||||
-- MVars to hold intermediate data during publishing
|
||||
displayed <- liftIO $ newMVar []
|
||||
updateNeeded <- liftIO $ newMVar False
|
||||
pagerOutput <- liftIO $ newMVar []
|
||||
pOut <- liftIO $ newMVar []
|
||||
|
||||
let widgets = openComms kernelState
|
||||
uuid = commUuid req
|
||||
@ -423,7 +423,7 @@ handleComm send kernelState req replyHeader = do
|
||||
-- a function that executes an IO action and publishes the output to
|
||||
-- the frontend simultaneously.
|
||||
let run = capturedIO publish kernelState
|
||||
publish = publishResult send replyHeader displayed updateNeeded pagerOutput toUsePager
|
||||
publish = publishResult send replyHeader displayed updateNeeded pOut toUsePager
|
||||
|
||||
-- Notify the frontend that the kernel is busy
|
||||
busyHeader <- liftIO $ dupHeader replyHeader StatusMessage
|
||||
@ -435,12 +435,12 @@ handleComm send kernelState req replyHeader = do
|
||||
case msgType $ header req of
|
||||
CommDataMessage -> do
|
||||
disp <- run $ comm widget dat communicate
|
||||
pgrOut <- liftIO $ readMVar pagerOutput
|
||||
pgrOut <- liftIO $ readMVar pOut
|
||||
liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) []
|
||||
return kernelState
|
||||
CommCloseMessage -> do
|
||||
disp <- run $ close widget dat
|
||||
pgrOut <- liftIO $ readMVar pagerOutput
|
||||
pgrOut <- liftIO $ readMVar pOut
|
||||
liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) []
|
||||
return kernelState { openComms = Map.delete uuid widgets }
|
||||
_ ->
|
||||
|
||||
@ -46,12 +46,12 @@ convCell _sty object
|
||||
= s
|
||||
convCell sty object
|
||||
| Just (String "code") <- lookup "cell_type" object,
|
||||
Just (Array i) <- lookup "source" object,
|
||||
Just (Array a) <- lookup "source" object,
|
||||
Just (Array o) <- lookup "outputs" object,
|
||||
~(Just i) <- concatWithPrefix (lhsCodePrefix sty) i,
|
||||
o <- fromMaybe mempty (convOutputs sty o)
|
||||
~(Just i) <- concatWithPrefix (lhsCodePrefix sty) a,
|
||||
o2 <- fromMaybe mempty (convOutputs sty o)
|
||||
= "\n" <>
|
||||
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
|
||||
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o2 <> "\n"
|
||||
convCell _ _ = "IHaskell.Convert.convCell: unknown cell"
|
||||
|
||||
convOutputs :: LhsStyle LT.Text
|
||||
|
||||
@ -95,12 +95,12 @@ boilerplate =
|
||||
|
||||
groupClassified :: [CellLine LText] -> [Cell [LText]]
|
||||
groupClassified (CodeLine a:x)
|
||||
| (c, x) <- List.span isCode x,
|
||||
(_, x) <- List.span isEmptyMD x,
|
||||
(o, x) <- List.span isOutput x
|
||||
= Code (a : map untag c) (map untag o) : groupClassified x
|
||||
| (c, x1) <- List.span isCode x,
|
||||
(_, x2) <- List.span isEmptyMD x1,
|
||||
(o, x3) <- List.span isOutput x2
|
||||
= Code (a : map untag c) (map untag o) : groupClassified x3
|
||||
groupClassified (MarkdownLine a:x)
|
||||
| (m, x) <- List.span isMD x = Markdown (a : map untag m) : groupClassified x
|
||||
| (m, x1) <- List.span isMD x = Markdown (a : map untag m) : groupClassified x1
|
||||
groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x
|
||||
groupClassified [] = []
|
||||
|
||||
|
||||
@ -42,7 +42,7 @@ module IHaskell.Display (
|
||||
-- ** Image and data encoding functions
|
||||
Width,
|
||||
Height,
|
||||
Base64(..),
|
||||
Base64,
|
||||
encode64,
|
||||
base64,
|
||||
|
||||
@ -76,28 +76,6 @@ import StringUtils (rstrip)
|
||||
|
||||
type Base64 = Text
|
||||
|
||||
-- | these instances cause the image, html etc. which look like:
|
||||
--
|
||||
-- > Display
|
||||
-- > [Display]
|
||||
-- > IO [Display]
|
||||
-- > IO (IO Display)
|
||||
--
|
||||
-- be run the IO and get rendered (if the frontend allows it) in the pretty form.
|
||||
instance IHaskellDisplay a => IHaskellDisplay (IO a) where
|
||||
display = (display =<<)
|
||||
|
||||
instance IHaskellDisplay Display where
|
||||
display = return
|
||||
|
||||
instance IHaskellDisplay DisplayData where
|
||||
display disp = return $ Display [disp]
|
||||
|
||||
instance IHaskellDisplay a => IHaskellDisplay [a] where
|
||||
display disps = do
|
||||
displays <- mapM display disps
|
||||
return $ ManyDisplay displays
|
||||
|
||||
-- | Encode many displays into a single one. All will be output.
|
||||
many :: [Display] -> Display
|
||||
many = ManyDisplay
|
||||
|
||||
@ -21,12 +21,8 @@ import qualified Data.List.Split as Split
|
||||
import qualified Data.List.Split.Internals as Split
|
||||
import System.Environment (getEnv)
|
||||
|
||||
import GHC hiding (Qualified)
|
||||
#if MIN_VERSION_ghc(8,2,0)
|
||||
import GHC
|
||||
import GHC.PackageDb
|
||||
#else
|
||||
import GHC.PackageDb (ExposedModule(exposedName))
|
||||
#endif
|
||||
import DynFlags
|
||||
import GhcMonad
|
||||
import Outputable (showPpr)
|
||||
@ -57,7 +53,7 @@ exposedName :: (a, b) -> a
|
||||
exposedName = fst
|
||||
#endif
|
||||
|
||||
extName (FlagSpec { flagSpecName = name }) = name
|
||||
extName :: FlagSpec flag -> String
|
||||
extName (FlagSpec { flagSpecName = name }) = name
|
||||
|
||||
complete :: String -> Int -> Interpreter (String, [String])
|
||||
@ -97,8 +93,8 @@ complete code posOffset = do
|
||||
Identifier candidate ->
|
||||
return $ filter (candidate `isPrefixOf`) unqualNames
|
||||
|
||||
Qualified moduleName candidate -> do
|
||||
let prefix = intercalate "." [moduleName, candidate]
|
||||
Qualified mName candidate -> do
|
||||
let prefix = intercalate "." [mName, candidate]
|
||||
completions = filter (prefix `isPrefixOf`) qualNames
|
||||
return completions
|
||||
|
||||
@ -200,7 +196,7 @@ completionType line loc target
|
||||
else []
|
||||
Left _ -> Empty
|
||||
|
||||
cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0
|
||||
cursorInString str lcn = nquotes (take lcn str) `mod` 2 /= (0 :: Int)
|
||||
|
||||
nquotes ('\\':'"':xs) = nquotes xs
|
||||
nquotes ('"':xs) = 1 + nquotes xs
|
||||
@ -214,12 +210,12 @@ completionType line loc target
|
||||
where
|
||||
go acc rest =
|
||||
case rest of
|
||||
'"':'\\':rem -> go ('"' : acc) rem
|
||||
'"':_ -> acc
|
||||
' ':'\\':rem -> go (' ' : acc) rem
|
||||
' ':_ -> acc
|
||||
x:rem -> go (x : acc) rem
|
||||
[] -> acc
|
||||
'"':'\\':xs -> go ('"' : acc) xs
|
||||
'"':_ -> acc
|
||||
' ':'\\':xs -> go (' ' : acc) xs
|
||||
' ':_ -> acc
|
||||
x:xs -> go (x : acc) xs
|
||||
[] -> acc
|
||||
|
||||
-- | Get the word under a given cursor location.
|
||||
completionTarget :: String -> Int -> [String]
|
||||
@ -277,8 +273,8 @@ completePath line = completePathFilter acceptAll acceptAll line ""
|
||||
acceptAll = const True
|
||||
|
||||
completePathWithExtensions :: [String] -> String -> Interpreter [String]
|
||||
completePathWithExtensions extensions line =
|
||||
completePathFilter (extensionIsOneOf extensions) acceptAll line ""
|
||||
completePathWithExtensions extns line =
|
||||
completePathFilter (extensionIsOneOf extns) acceptAll line ""
|
||||
where
|
||||
acceptAll = const True
|
||||
extensionIsOneOf exts str = any correctEnding exts
|
||||
|
||||
@ -44,13 +44,11 @@ import InteractiveEval
|
||||
import DynFlags
|
||||
import Exception (gtry)
|
||||
import HscTypes
|
||||
import HscMain
|
||||
import GhcMonad (liftIO)
|
||||
import GHC hiding (Stmt, TypeSig)
|
||||
import Exception hiding (evaluate)
|
||||
import Outputable hiding ((<>))
|
||||
import Packages
|
||||
import FastString
|
||||
import Bag
|
||||
import qualified ErrUtils
|
||||
|
||||
@ -64,6 +62,14 @@ import IHaskell.Eval.Util
|
||||
import IHaskell.BrokenPackages
|
||||
import StringUtils (replace, split, strip, rstrip)
|
||||
|
||||
#if MIN_VERSION_ghc(8,2,0)
|
||||
import FastString (unpackFS)
|
||||
#else
|
||||
import Paths_ihaskell (version)
|
||||
import Data.Version (versionBranch)
|
||||
#endif
|
||||
|
||||
|
||||
data ErrorOccurred = Success
|
||||
| Failure
|
||||
deriving (Show, Eq)
|
||||
@ -115,7 +121,7 @@ ihaskellGlobalImports =
|
||||
|
||||
-- | Interpreting function for testing.
|
||||
testInterpret :: Interpreter a -> IO a
|
||||
testInterpret val = interpret GHC.Paths.libdir False (const val)
|
||||
testInterpret v = interpret GHC.Paths.libdir False (const v)
|
||||
|
||||
-- | Evaluation function for testing.
|
||||
testEvaluate :: String -> IO ()
|
||||
@ -176,9 +182,9 @@ initializeImports = do
|
||||
-- version of the ihaskell library. Also verify that the packages we load are not broken.
|
||||
dflags <- getSessionDynFlags
|
||||
broken <- liftIO getBrokenPackages
|
||||
(dflags, _) <- liftIO $ initPackages dflags
|
||||
let db = getPackageConfigs dflags
|
||||
packageNames = map (packageIdString' dflags) db
|
||||
(dflgs, _) <- liftIO $ initPackages dflags
|
||||
let db = getPackageConfigs dflgs
|
||||
packageNames = map (packageIdString' dflgs) db
|
||||
|
||||
initStr = "ihaskell-"
|
||||
|
||||
@ -257,11 +263,11 @@ data EvalOut =
|
||||
}
|
||||
|
||||
cleanString :: String -> String
|
||||
cleanString x = if allBrackets
|
||||
cleanString istr = if allBrackets
|
||||
then clean
|
||||
else str
|
||||
else istr
|
||||
where
|
||||
str = strip x
|
||||
str = strip istr
|
||||
l = lines str
|
||||
allBrackets = all (fAny [isPrefixOf ">", null]) l
|
||||
fAny fs x = any ($ x) fs
|
||||
@ -296,7 +302,7 @@ evaluate kernelState code output widgetHandler = do
|
||||
|
||||
runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])
|
||||
-- Print all parse errors.
|
||||
errs -> do
|
||||
_ -> do
|
||||
forM_ errs $ \err -> do
|
||||
out <- evalCommand output err kernelState
|
||||
liftIO $ output $ FinalResult (evalResult out) [] []
|
||||
@ -331,8 +337,7 @@ evaluate kernelState code output widgetHandler = do
|
||||
Just disps -> evalResult evalOut <> disps
|
||||
|
||||
-- Output things only if they are non-empty.
|
||||
let empty = noResults result && null (evalPager evalOut)
|
||||
unless empty $
|
||||
unless (noResults result && null (evalPager evalOut)) $
|
||||
liftIO $ output $ FinalResult result (evalPager evalOut) []
|
||||
|
||||
let tempMsgs = evalMsgs evalOut
|
||||
@ -377,7 +382,7 @@ flushWidgetMessages :: KernelState
|
||||
-> [WidgetMsg]
|
||||
-> (KernelState -> [WidgetMsg] -> IO KernelState)
|
||||
-> Interpreter KernelState
|
||||
flushWidgetMessages state evalMsgs widgetHandler = do
|
||||
flushWidgetMessages state evalmsgs widgetHandler = do
|
||||
-- Capture all widget messages queued during code execution
|
||||
extracted <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages"
|
||||
liftIO $
|
||||
@ -390,7 +395,7 @@ flushWidgetMessages state evalMsgs widgetHandler = do
|
||||
messages <- messagesIO
|
||||
|
||||
-- Handle all the widget messages
|
||||
let commMessages = evalMsgs ++ messages
|
||||
let commMessages = evalmsgs ++ messages
|
||||
widgetHandler state commMessages
|
||||
|
||||
|
||||
@ -476,8 +481,8 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
|
||||
-- Return whether this module prevents the loading of the one we're trying to load. If a module B
|
||||
-- exist, we cannot load A.B. All modules must have unique last names (where A.B has last name B).
|
||||
-- However, we *can* just reload a module.
|
||||
preventsLoading mod =
|
||||
let pieces = moduleNameOf mod
|
||||
preventsLoading md =
|
||||
let pieces = moduleNameOf md
|
||||
in last namePieces == last pieces && namePieces /= pieces
|
||||
|
||||
-- If we've loaded anything with the same last name, we can't use this. Otherwise, GHC tries to load
|
||||
@ -511,14 +516,14 @@ evalCommand _output (Directive SetDynFlag flagsStr) state = safely state $ do
|
||||
|
||||
if null flags
|
||||
then do
|
||||
flags <- getSessionDynFlags
|
||||
flgs <- getSessionDynFlags
|
||||
return
|
||||
EvalOut
|
||||
{ evalStatus = Success
|
||||
, evalResult = Display
|
||||
[ plain $ showSDoc flags $ vcat
|
||||
[ pprDynFlags False flags
|
||||
, pprLanguages False flags
|
||||
[ plain $ showSDoc flgs $ vcat
|
||||
[ pprDynFlags False flgs
|
||||
, pprLanguages False flgs
|
||||
]
|
||||
]
|
||||
, evalState = state
|
||||
@ -529,7 +534,7 @@ evalCommand _output (Directive SetDynFlag flagsStr) state = safely state $ do
|
||||
-- Apply all IHaskell flag updaters to the state to get the new state
|
||||
let state' = foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags) state
|
||||
errs <- setFlags ghcFlags
|
||||
let display =
|
||||
let disp =
|
||||
case errs of
|
||||
[] -> mempty
|
||||
_ -> displayError $ intercalate "\n" errs
|
||||
@ -546,7 +551,7 @@ evalCommand _output (Directive SetDynFlag flagsStr) state = safely state $ do
|
||||
return
|
||||
EvalOut
|
||||
{ evalStatus = Success
|
||||
, evalResult = display
|
||||
, evalResult = disp
|
||||
, evalState = state'
|
||||
, evalPager = []
|
||||
, evalMsgs = []
|
||||
@ -632,8 +637,8 @@ evalCommand publish (Directive ShellCmd cmd) state = wrapExecution state $
|
||||
homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String))
|
||||
let home =
|
||||
case homeEither of
|
||||
Left _ -> "~"
|
||||
Right val -> val
|
||||
Left _ -> "~"
|
||||
Right v -> v
|
||||
|
||||
let directory = replace "~" home $ unwords dirs
|
||||
exists <- liftIO $ doesDirectoryExist directory
|
||||
@ -644,19 +649,19 @@ evalCommand publish (Directive ShellCmd cmd) state = wrapExecution state $
|
||||
liftIO $ setCurrentDirectory directory
|
||||
|
||||
-- Set the directory for user code.
|
||||
let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $
|
||||
let cmd1 = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $
|
||||
replace " " "\\ " $
|
||||
replace "\"" "\\\"" directory
|
||||
_ <- execStmt cmd execOptions
|
||||
_ <- execStmt cmd1 execOptions
|
||||
return mempty
|
||||
else return $ displayError $ printf "No such directory: '%s'" directory
|
||||
cmd -> liftIO $ do
|
||||
(pipe, handle) <- createPipe'
|
||||
let initProcSpec = shell $ unwords cmd
|
||||
cmd1 -> liftIO $ do
|
||||
(pipe, hdl) <- createPipe'
|
||||
let initProcSpec = shell $ unwords cmd1
|
||||
procSpec = initProcSpec
|
||||
{ std_in = Inherit
|
||||
, std_out = UseHandle handle
|
||||
, std_err = UseHandle handle
|
||||
, std_out = UseHandle hdl
|
||||
, std_err = UseHandle hdl
|
||||
}
|
||||
(_, _, _, process) <- createProcess procSpec
|
||||
|
||||
@ -688,8 +693,8 @@ evalCommand publish (Directive ShellCmd cmd) state = wrapExecution state $
|
||||
let computationDone = isJust exitCode
|
||||
|
||||
when computationDone $ do
|
||||
nextChunk <- readChars pipe "" maxSize
|
||||
modifyMVar_ outputAccum (return . (++ nextChunk))
|
||||
next <- readChars pipe "" maxSize
|
||||
modifyMVar_ outputAccum (return . (++ next))
|
||||
|
||||
if not computationDone
|
||||
then do
|
||||
@ -762,11 +767,11 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
|
||||
strings <- unlines <$> getDescription str
|
||||
|
||||
-- Make pager work without html by porting to newer architecture
|
||||
let htmlify str =
|
||||
let htmlify str1 =
|
||||
html $
|
||||
concat
|
||||
[ "<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>"
|
||||
, str
|
||||
, str1
|
||||
, "</textarea></form></div>"
|
||||
, "<script>CodeMirror.fromTextArea(document.getElementById('code'),"
|
||||
, " {mode: 'haskell', readOnly: 'nocursor'});</script>"
|
||||
@ -900,8 +905,8 @@ evalCommand output (Expression expr) state = do
|
||||
Failure -> return evalOut
|
||||
Success -> wrapExecution state $ do
|
||||
-- Compile the display data into a bytestring.
|
||||
let compileExpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)"
|
||||
displayedBytestring <- dynCompileExpr compileExpr
|
||||
let cexpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)"
|
||||
displayedBytestring <- dynCompileExpr cexpr
|
||||
|
||||
-- Convert from the bytestring into a display.
|
||||
case fromDynamic displayedBytestring of
|
||||
@ -910,30 +915,27 @@ evalCommand output (Expression expr) state = do
|
||||
bytestring <- liftIO bytestringIO
|
||||
case Serialize.decode bytestring of
|
||||
Left err -> error err
|
||||
Right display ->
|
||||
Right disp ->
|
||||
return $
|
||||
if useSvg state
|
||||
then display :: Display
|
||||
else removeSvg display
|
||||
then disp :: Display
|
||||
else removeSvg disp
|
||||
|
||||
#if MIN_VERSION_ghc(8,2,0)
|
||||
isIO expr = attempt $ exprType TM_Inst $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr
|
||||
isIO exp = attempt $ exprType TM_Inst $ printf "((\\x -> x) :: IO a -> IO a) (%s)" exp
|
||||
#else
|
||||
isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr
|
||||
isIO exp = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" exp
|
||||
#endif
|
||||
|
||||
postprocessShowError :: EvalOut -> EvalOut
|
||||
postprocessShowError evalOut = evalOut { evalResult = Display $ map postprocess disps }
|
||||
where
|
||||
Display disps = evalResult evalOut
|
||||
text = extractPlain disps
|
||||
txt = extractPlain disps
|
||||
|
||||
postprocess (DisplayData MimeHtml _) = html $ printf
|
||||
fmt
|
||||
unshowableType
|
||||
(formatErrorWithClass "err-msg collapse"
|
||||
text)
|
||||
script
|
||||
postprocess (DisplayData MimeHtml _) =
|
||||
html $ printf fmt unshowableType
|
||||
(formatErrorWithClass "err-msg collapse" txt) script
|
||||
where
|
||||
fmt = "<div class='collapse-group'><span class='btn btn-default' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"
|
||||
script = unlines
|
||||
@ -948,7 +950,7 @@ evalCommand output (Expression expr) state = do
|
||||
postprocess other = other
|
||||
|
||||
unshowableType = fromMaybe "" $ do
|
||||
let pieces = words text
|
||||
let pieces = words txt
|
||||
before = takeWhile (/= "arising") pieces
|
||||
after = init $ unwords $ tail $ dropWhile (/= "(Show") before
|
||||
|
||||
@ -1132,9 +1134,9 @@ capturedEval output stmt = do
|
||||
|
||||
runWithResult (CapturedStmt str) = goStmt str
|
||||
runWithResult (CapturedIO io) = do
|
||||
status <- gcatch (liftIO io >> return NoException) (return . AnyException)
|
||||
stat <- gcatch (liftIO io >> return NoException) (return . AnyException)
|
||||
return $
|
||||
case status of
|
||||
case stat of
|
||||
NoException -> ExecComplete (Right []) 0
|
||||
AnyException e -> ExecComplete (Left e) 0
|
||||
|
||||
@ -1146,9 +1148,9 @@ capturedEval output stmt = do
|
||||
pipe <- case fromDynamic dyn of
|
||||
Nothing -> fail "Evaluate: Bad pipe"
|
||||
Just fd -> liftIO $ do
|
||||
handle <- fdToHandle fd
|
||||
hSetEncoding handle utf8
|
||||
return handle
|
||||
hdl <- fdToHandle fd
|
||||
hSetEncoding hdl utf8
|
||||
return hdl
|
||||
|
||||
-- Keep track of whether execution has completed.
|
||||
completed <- liftIO $ newMVar False
|
||||
@ -1234,14 +1236,14 @@ evalStatementOrIO publish state cmd = do
|
||||
name == "it" ||
|
||||
name == "it" ++ show (getExecutionCounter state)
|
||||
nonItNames = filter (not . isItName) allNames
|
||||
output = [ plain printed
|
||||
oput = [ plain printed
|
||||
| not . null $ strip printed ]
|
||||
|
||||
write state $ "Names: " ++ show allNames
|
||||
|
||||
-- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
|
||||
if not $ useShowTypes state
|
||||
then return $ Display output
|
||||
then return $ Display oput
|
||||
else do
|
||||
-- Get all the type strings.
|
||||
types <- forM nonItNames $ \name -> do
|
||||
@ -1256,11 +1258,11 @@ evalStatementOrIO publish state cmd = do
|
||||
htmled = unlines $ map formatGetType types
|
||||
|
||||
return $
|
||||
case extractPlain output of
|
||||
case extractPlain oput of
|
||||
"" -> Display [html htmled]
|
||||
|
||||
-- Return plain and html versions. Previously there was only a plain version.
|
||||
text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text]
|
||||
txt -> Display [plain $ joined ++ "\n" ++ txt, html $ htmled ++ mono txt]
|
||||
|
||||
ExecComplete (Left exception) _ -> throw exception
|
||||
ExecBreak{} -> error "Should not break."
|
||||
@ -1271,17 +1273,17 @@ readChars :: Handle -> String -> Int -> IO String
|
||||
readChars _handle _delims 0 =
|
||||
-- If we're done reading, return nothing.
|
||||
return []
|
||||
readChars handle delims nchars = do
|
||||
readChars hdl delims nchars = do
|
||||
-- Try reading a single character. It will throw an exception if the handle is already closed.
|
||||
tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
|
||||
tryRead <- gtry $ hGetChar hdl :: IO (Either SomeException Char)
|
||||
case tryRead of
|
||||
Right char ->
|
||||
Right ch ->
|
||||
-- If this is a delimiter, stop reading.
|
||||
if char `elem` delims
|
||||
then return [char]
|
||||
if ch `elem` delims
|
||||
then return [ch]
|
||||
else do
|
||||
next <- readChars handle delims (nchars - 1)
|
||||
return $ char : next
|
||||
next <- readChars hdl delims (nchars - 1)
|
||||
return $ ch : next
|
||||
-- An error occurs at the end of the stream, so just stop reading.
|
||||
Left _ -> return []
|
||||
|
||||
@ -1306,8 +1308,8 @@ formatErrorWithClass cls =
|
||||
useDashV = "\n Use -v to see a list of the files searched for."
|
||||
|
||||
formatParseError :: StringLoc -> String -> ErrMsg
|
||||
formatParseError (Loc line col) =
|
||||
printf "Parse error (line %d, column %d): %s" line col
|
||||
formatParseError (Loc ln col) =
|
||||
printf "Parse error (line %d, column %d): %s" ln col
|
||||
|
||||
formatGetType :: String -> String
|
||||
formatGetType = printf "<span class='get-type'>%s</span>"
|
||||
|
||||
@ -92,8 +92,8 @@ search string = do
|
||||
return $
|
||||
case response of
|
||||
Left err -> [NoResult err]
|
||||
Right json ->
|
||||
case eitherDecode $ LBS.fromStrict $ CBS.pack json of
|
||||
Right jsn ->
|
||||
case eitherDecode $ LBS.fromStrict $ CBS.pack jsn of
|
||||
Left err -> [NoResult err]
|
||||
Right results ->
|
||||
case map SearchResult $ (\(HoogleResponseList l) -> l) results of
|
||||
@ -159,7 +159,7 @@ renderSelf string loc
|
||||
|
||||
| "module" `isPrefixOf` string =
|
||||
let package = extractPackageName loc
|
||||
in mod ++ " " ++
|
||||
in mdl ++ " " ++
|
||||
span "hoogle-module" (link loc $ extractModule string) ++
|
||||
packageSub package
|
||||
|
||||
@ -198,7 +198,7 @@ renderSelf string loc
|
||||
extractData = strip . replace "data" ""
|
||||
extractNewtype = strip . replace "newtype" ""
|
||||
pkg = span "hoogle-head" "package"
|
||||
mod = span "hoogle-head" "module"
|
||||
mdl = span "hoogle-head" "module"
|
||||
cls = span "hoogle-head" "class"
|
||||
dat = span "hoogle-head" "data"
|
||||
nwt = span "hoogle-head" "newtype"
|
||||
@ -220,7 +220,7 @@ renderSelf string loc
|
||||
packageAndModuleSub (Just package) (Just modname) =
|
||||
span "hoogle-sub" $
|
||||
"(" ++ pkg ++ " " ++ span "hoogle-package" package ++
|
||||
", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")"
|
||||
", " ++ mdl ++ " " ++ span "hoogle-module" modname ++ ")"
|
||||
|
||||
renderDocs :: String -> String
|
||||
renderDocs doc =
|
||||
@ -233,27 +233,26 @@ renderDocs doc =
|
||||
case xs of
|
||||
[] -> False
|
||||
(s:_) -> isPrefixOf ">" $ strip s
|
||||
makeBlock lines =
|
||||
if isCode lines
|
||||
then div' "hoogle-code" $ unlines $ nonull lines
|
||||
else div' "hoogle-text" $ unlines $ nonull lines
|
||||
makeBlock xs =
|
||||
if isCode xs
|
||||
then div' "hoogle-code" $ unlines $ nonull xs
|
||||
else div' "hoogle-text" $ unlines $ nonull xs
|
||||
in div' "hoogle-doc" $ unlines $ map makeBlock groups
|
||||
|
||||
extractPackageName :: String -> Maybe String
|
||||
extractPackageName link = do
|
||||
let pieces = split "/" link
|
||||
extractPackageName lnk = do
|
||||
let pieces = split "/" lnk
|
||||
archiveLoc <- List.elemIndex "archive" pieces
|
||||
latestLoc <- List.elemIndex "latest" pieces
|
||||
guard $ latestLoc - archiveLoc == 2
|
||||
return $ pieces List.!! (latestLoc - 1)
|
||||
|
||||
extractModuleName :: String -> Maybe String
|
||||
extractModuleName link = do
|
||||
let pieces = split "/" link
|
||||
extractModuleName lnk = do
|
||||
let pieces = split "/" lnk
|
||||
guard $ not $ null pieces
|
||||
let html = fromJust $ lastMay pieces
|
||||
mod = replace "-" "." $ takeWhile (/= '.') html
|
||||
return mod
|
||||
return $ replace "-" "." $ takeWhile (/= '.') html
|
||||
|
||||
div' :: String -> String -> String
|
||||
div' = printf "<div class='%s'>%s</div>"
|
||||
|
||||
@ -53,10 +53,9 @@ lint blocks = do
|
||||
|
||||
-- Get hlint settings
|
||||
(flags, classify, hint) <- readMVar hlintSettings
|
||||
let mode = hseFlags flags
|
||||
|
||||
-- create 'suggestions'
|
||||
let modules = mapMaybe (createModule mode) blocks
|
||||
let modules = mapMaybe (createModule (hseFlags flags)) blocks
|
||||
ideas = applyHints classify hint (map (\m -> (m, [])) modules)
|
||||
suggestions = mapMaybe showIdea $ filter (not . ignoredIdea) ideas
|
||||
|
||||
@ -66,33 +65,33 @@ lint blocks = do
|
||||
else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]
|
||||
where
|
||||
autoSettings' = do
|
||||
(fixities, classify, hints) <- autoSettings
|
||||
(fixts, classify, hints) <- autoSettings
|
||||
let hidingIgnore = Classify Ignore "Unnecessary hiding" "" ""
|
||||
return (fixities, hidingIgnore:classify, hints)
|
||||
return (fixts, hidingIgnore:classify, hints)
|
||||
ignoredIdea idea = ideaSeverity idea == Ignore
|
||||
|
||||
showIdea :: Idea -> Maybe LintSuggestion
|
||||
showIdea idea =
|
||||
case ideaTo idea of
|
||||
Nothing -> Nothing
|
||||
Just whyNot ->
|
||||
Just wn ->
|
||||
Just
|
||||
Suggest
|
||||
{ line = srcSpanStartLine $ ideaSpan idea
|
||||
, found = showSuggestion $ ideaFrom idea
|
||||
, whyNot = showSuggestion whyNot
|
||||
, whyNot = showSuggestion wn
|
||||
, severity = ideaSeverity idea
|
||||
, suggestion = ideaHint idea
|
||||
}
|
||||
|
||||
createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
|
||||
createModule mode (Located line block) =
|
||||
createModule md (Located ln block) =
|
||||
case block of
|
||||
Expression expr -> unparse $ exprToModule expr
|
||||
Declaration decl -> unparse $ declToModule decl
|
||||
Statement stmt -> unparse $ stmtToModule stmt
|
||||
Import impt -> unparse $ imptToModule impt
|
||||
Module mod -> unparse $ parseModule mod
|
||||
Module mdl -> unparse $ pModule mdl
|
||||
_ -> Nothing
|
||||
where
|
||||
blockStr =
|
||||
@ -101,7 +100,7 @@ createModule mode (Located line block) =
|
||||
Declaration decl -> decl
|
||||
Statement stmt -> stmt
|
||||
Import impt -> impt
|
||||
Module mod -> mod
|
||||
Module mdl -> mdl
|
||||
|
||||
-- TODO: Properly handle the other constructors
|
||||
_ -> []
|
||||
@ -113,49 +112,47 @@ createModule mode (Located line block) =
|
||||
srcSpan :: SrcSpan
|
||||
srcSpan = SrcSpan
|
||||
{ srcSpanFilename = "<interactive>"
|
||||
, srcSpanStartLine = line
|
||||
, srcSpanStartLine = ln
|
||||
, srcSpanStartColumn = 0
|
||||
, srcSpanEndLine = line + length (lines blockStr)
|
||||
, srcSpanEndLine = ln + length (lines blockStr)
|
||||
, srcSpanEndColumn = length $ last $ lines blockStr
|
||||
}
|
||||
|
||||
loc :: SrcSpanInfo
|
||||
loc = SrcSpanInfo srcSpan []
|
||||
lcn :: SrcSpanInfo
|
||||
lcn = SrcSpanInfo srcSpan []
|
||||
|
||||
moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule
|
||||
moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl]
|
||||
moduleWithDecls decl = SrcExts.Module lcn Nothing [] [] [decl]
|
||||
|
||||
parseModule :: String -> ParseResult ExtsModule
|
||||
parseModule = parseFileContentsWithMode mode
|
||||
pModule :: String -> ParseResult ExtsModule
|
||||
pModule = parseFileContentsWithMode md
|
||||
|
||||
declToModule :: String -> ParseResult ExtsModule
|
||||
declToModule decl = moduleWithDecls <$> parseDeclWithMode mode decl
|
||||
declToModule decl = moduleWithDecls <$> parseDeclWithMode md decl
|
||||
|
||||
exprToModule :: String -> ParseResult ExtsModule
|
||||
exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp
|
||||
exprToModule exp = moduleWithDecls <$> SpliceDecl lcn <$> parseExpWithMode md exp
|
||||
|
||||
stmtToModule :: String -> ParseResult ExtsModule
|
||||
stmtToModule stmtStr =
|
||||
case parseStmtWithMode mode stmtStr of
|
||||
ParseOk _ -> ParseOk mod
|
||||
case parseStmtWithMode md stmtStr of
|
||||
ParseOk _ -> ParseOk $ moduleWithDecls decl
|
||||
ParseFailed a b -> ParseFailed a b
|
||||
where
|
||||
mod = moduleWithDecls decl
|
||||
|
||||
decl :: Decl SrcSpanInfo
|
||||
decl = SpliceDecl loc expr
|
||||
decl = SpliceDecl lcn expr
|
||||
|
||||
expr :: Exp SrcSpanInfo
|
||||
expr = Do loc [stmt, ret]
|
||||
expr = Do lcn [stmt, ret]
|
||||
|
||||
stmt :: Stmt SrcSpanInfo
|
||||
ParseOk stmt = parseStmtWithMode mode stmtStr
|
||||
ParseOk stmt = parseStmtWithMode md stmtStr
|
||||
|
||||
ret :: Stmt SrcSpanInfo
|
||||
ParseOk ret = Qualifier loc <$> parseExp lintIdent
|
||||
ParseOk ret = Qualifier lcn <$> parseExp lintIdent
|
||||
|
||||
imptToModule :: String -> ParseResult ExtsModule
|
||||
imptToModule = parseFileContentsWithMode mode
|
||||
imptToModule = parseFileContentsWithMode md
|
||||
|
||||
plainSuggestion :: LintSuggestion -> String
|
||||
plainSuggestion suggest =
|
||||
@ -168,10 +165,10 @@ htmlSuggestions = concatMap toHtml
|
||||
toHtml :: LintSuggestion -> String
|
||||
toHtml suggest = concat
|
||||
[ named $ suggestion suggest
|
||||
, floating "left" $ style severityClass "Found:" ++
|
||||
, floating "left" $ styl severityClass "Found:" ++
|
||||
-- Things that look like this get highlighted.
|
||||
styleId "highlight-code" "haskell" (found suggest)
|
||||
, floating "left" $ style severityClass "Why Not:" ++
|
||||
, floating "left" $ styl severityClass "Why Not:" ++
|
||||
-- Things that look like this get highlighted.
|
||||
styleId "highlight-code" "haskell" (whyNot suggest)
|
||||
]
|
||||
@ -184,8 +181,8 @@ htmlSuggestions = concatMap toHtml
|
||||
-- Should not occur
|
||||
_ -> "warning"
|
||||
|
||||
style :: String -> String -> String
|
||||
style = printf "<div class=\"suggestion-%s\">%s</div>"
|
||||
styl :: String -> String -> String
|
||||
styl = printf "<div class=\"suggestion-%s\">%s</div>"
|
||||
|
||||
named :: String -> String
|
||||
named = printf "<div class=\"suggestion-name\" style=\"clear:both;\">%s</div>"
|
||||
|
||||
@ -63,4 +63,4 @@ shellWords = try (eof *> return []) <|> do
|
||||
return $ x : xs
|
||||
|
||||
parseShell :: String -> Either ParseError [String]
|
||||
parseShell string = parse shellWords "shell" (string ++ "\n")
|
||||
parseShell str = parse shellWords "shell" (str ++ "\n")
|
||||
|
||||
@ -78,8 +78,8 @@ parseString codeString = do
|
||||
flags <- getSessionDynFlags
|
||||
let output = runParser flags parserModule codeString
|
||||
case output of
|
||||
Parsed mod
|
||||
| Just _ <- hsmodName (unLoc mod) -> return [Located 1 $ Module codeString]
|
||||
Parsed mdl
|
||||
| Just _ <- hsmodName (unLoc mdl) -> return [Located 1 $ Module codeString]
|
||||
_ -> do
|
||||
-- Split input into chunks based on indentation.
|
||||
let chunks = layoutChunks $ removeComments codeString
|
||||
@ -92,12 +92,12 @@ parseString codeString = do
|
||||
|
||||
where
|
||||
parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)
|
||||
parseChunk chunk line = Located line <$> handleChunk chunk line
|
||||
parseChunk chunk ln = Located ln <$> handleChunk
|
||||
where
|
||||
handleChunk chunk line
|
||||
| isDirective chunk = return $ parseDirective chunk line
|
||||
| isPragma chunk = return $ parsePragma chunk line
|
||||
| otherwise = parseCodeChunk chunk line
|
||||
handleChunk
|
||||
| isDirective chunk = return $ parseDirective chunk ln
|
||||
| isPragma chunk = return $ parsePragma chunk ln
|
||||
| otherwise = parseCodeChunk chunk ln
|
||||
|
||||
processChunks :: GhcMonad m => [Located CodeBlock] -> [Located String] -> m [Located CodeBlock]
|
||||
processChunks accum remaining =
|
||||
@ -106,10 +106,10 @@ parseString codeString = do
|
||||
[] -> return $ reverse accum
|
||||
|
||||
-- If we have more remaining, parse the current chunk and recurse.
|
||||
Located line chunk:remaining -> do
|
||||
block <- parseChunk chunk line
|
||||
Located ln chunk:remain -> do
|
||||
block <- parseChunk chunk ln
|
||||
activateExtensions $ unloc block
|
||||
processChunks (block : accum) remaining
|
||||
processChunks (block : accum) remain
|
||||
|
||||
-- Test whether a given chunk is a directive.
|
||||
isDirective :: String -> Bool
|
||||
@ -125,11 +125,11 @@ activateExtensions (Directive SetDynFlag flags) =
|
||||
case stripPrefix "-X" flags of
|
||||
Just ext -> void $ setExtension ext
|
||||
Nothing -> return ()
|
||||
activateExtensions (Pragma PragmaLanguage extensions) = void $ setAll extensions
|
||||
activateExtensions (Pragma PragmaLanguage exts) = void $ setAll exts
|
||||
where
|
||||
setAll :: GhcMonad m => [String] -> m (Maybe String)
|
||||
setAll exts = do
|
||||
errs <- mapM setExtension exts
|
||||
setAll exts' = do
|
||||
errs <- mapM setExtension exts'
|
||||
return $ msum errs
|
||||
activateExtensions _ = return ()
|
||||
|
||||
@ -159,13 +159,13 @@ parseCodeChunk code startLine = do
|
||||
|
||||
failures :: [ParseOutput a] -> [(ErrMsg, LineNumber, ColumnNumber)]
|
||||
failures [] = []
|
||||
failures (Failure msg (Loc line col):rest) = (msg, line, col) : failures rest
|
||||
failures (Failure msg (Loc ln col):rest) = (msg, ln, col) : failures rest
|
||||
failures (_:rest) = failures rest
|
||||
|
||||
bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock
|
||||
bestError errors = ParseError (Loc (line + startLine - 1) col) msg
|
||||
bestError errors = ParseError (Loc (ln + startLine - 1) col) msg
|
||||
where
|
||||
(msg, line, col) = maximumBy compareLoc errors
|
||||
(msg, ln, col) = maximumBy compareLoc errors
|
||||
compareLoc (_, line1, col1) (_, line2, col2) = compare line1 line2 <> compare col1 col2
|
||||
|
||||
statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
|
||||
@ -184,8 +184,8 @@ parseCodeChunk code startLine = do
|
||||
_ -> False
|
||||
|
||||
tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock
|
||||
tryParser string (blockType, parser) =
|
||||
case parser string of
|
||||
tryParser string (blockType, psr) =
|
||||
case psr string of
|
||||
Parsed res -> Parsed (blockType res)
|
||||
Failure err loc -> Failure err loc
|
||||
_ -> error "tryParser failed, output was neither Parsed nor Failure"
|
||||
@ -199,10 +199,10 @@ parseCodeChunk code startLine = do
|
||||
]
|
||||
where
|
||||
unparser :: Parser a -> String -> ParseOutput String
|
||||
unparser parser code =
|
||||
case runParser flags parser code of
|
||||
Parsed _ -> Parsed code
|
||||
Partial _ strs -> Partial code strs
|
||||
unparser psr cd =
|
||||
case runParser flags psr cd of
|
||||
Parsed _ -> Parsed cd
|
||||
Partial _ strs -> Partial cd strs
|
||||
Failure err loc -> Failure err loc
|
||||
|
||||
-- | Find consecutive declarations of the same function and join them into a single declaration.
|
||||
@ -234,7 +234,7 @@ joinFunctions blocks =
|
||||
parsePragma :: String -- ^ Pragma string.
|
||||
-> Int -- ^ Line number at which the directive appears.
|
||||
-> CodeBlock -- ^ Pragma code block or a parse error.
|
||||
parsePragma pragma _line =
|
||||
parsePragma pragma _ln =
|
||||
let commaToSpace :: Char -> Char
|
||||
commaToSpace ',' = ' '
|
||||
commaToSpace x = x
|
||||
@ -251,8 +251,8 @@ parsePragma pragma _line =
|
||||
parseDirective :: String -- ^ Directive string.
|
||||
-> Int -- ^ Line number at which the directive appears.
|
||||
-> CodeBlock -- ^ Directive code block or a parse error.
|
||||
parseDirective (':':'!':directive) _line = Directive ShellCmd $ '!' : directive
|
||||
parseDirective (':':directive) line =
|
||||
parseDirective (':':'!':directive) _ln = Directive ShellCmd $ '!' : directive
|
||||
parseDirective (':':directive) ln =
|
||||
case find rightDirective directives of
|
||||
Just (directiveType, _) -> Directive directiveType arg
|
||||
where arg = unwords restLine
|
||||
@ -262,7 +262,7 @@ parseDirective (':':directive) line =
|
||||
case words directive of
|
||||
[] -> ""
|
||||
first:_ -> first
|
||||
in ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'."
|
||||
in ParseError (Loc ln 1) $ "Unknown directive: '" ++ directiveStart ++ "'."
|
||||
where
|
||||
rightDirective (_, dirname) =
|
||||
case words directive of
|
||||
@ -293,8 +293,8 @@ getModuleName moduleSrc = do
|
||||
let output = runParser flags parserModule moduleSrc
|
||||
case output of
|
||||
Failure{} -> error "Module parsing failed."
|
||||
Parsed mod ->
|
||||
case unLoc <$> hsmodName (unLoc mod) of
|
||||
Parsed mdl ->
|
||||
case unLoc <$> hsmodName (unLoc mdl) of
|
||||
Nothing -> error "Module must have a name."
|
||||
Just name -> return $ split "." $ moduleNameString name
|
||||
_ -> error "getModuleName failed, output was neither Parsed nor Failure"
|
||||
|
||||
@ -75,10 +75,10 @@ extensionFlag ext =
|
||||
Nothing -> Nothing
|
||||
where
|
||||
-- Check if a FlagSpec matches an extension name.
|
||||
flagMatches ext fs = ext == flagSpecName fs
|
||||
flagMatches ex fs = ex == flagSpecName fs
|
||||
|
||||
-- Check if a FlagSpec matches "No<ExtensionName>". In that case, we disable the extension.
|
||||
flagMatchesNo ext fs = ext == "No" ++ flagSpecName fs
|
||||
flagMatchesNo ex fs = ex == "No" ++ flagSpecName fs
|
||||
|
||||
-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)
|
||||
pprDynFlags :: Bool -- ^ Whether to include flags which are on by default
|
||||
@ -91,11 +91,11 @@ pprDynFlags show_all dflags =
|
||||
, O.text "other dynamic, non-language, flag settings:" O.$$
|
||||
O.nest 2 (O.vcat (map (setting opt) others))
|
||||
, O.text "warning settings:" O.$$
|
||||
O.nest 2 (O.vcat (map (setting wopt) warningFlags))
|
||||
O.nest 2 (O.vcat (map (setting wopt) wFlags))
|
||||
]
|
||||
where
|
||||
|
||||
warningFlags = DynFlags.wWarningFlags
|
||||
wFlags = DynFlags.wWarningFlags
|
||||
|
||||
opt = gopt
|
||||
|
||||
@ -336,14 +336,14 @@ evalImport imports = do
|
||||
_ -> False
|
||||
|
||||
removeImport :: GhcMonad m => String -> m ()
|
||||
removeImport moduleName = do
|
||||
removeImport modName = do
|
||||
ctx <- getContext
|
||||
let ctx' = filter (not . (isImportOf $ mkModuleName moduleName)) ctx
|
||||
let ctx' = filter (not . (isImportOf $ mkModuleName modName)) ctx
|
||||
setContext ctx'
|
||||
|
||||
where
|
||||
isImportOf :: ModuleName -> InteractiveImport -> Bool
|
||||
isImportOf name (IIModule modName) = name == modName
|
||||
isImportOf name (IIModule mName) = name == mName
|
||||
isImportOf name (IIDecl impDecl) = name == unLoc (ideclName impDecl)
|
||||
|
||||
-- | Evaluate a series of declarations. Return all names which were bound by these declarations.
|
||||
@ -396,9 +396,9 @@ getDescription str = do
|
||||
|
||||
-- Filter out types that have parents in the same set. GHCi also does this.
|
||||
let infos = catMaybes maybeInfos
|
||||
allNames = mkNameSet $ map (getName . getType) infos
|
||||
allNames = mkNameSet $ map (getName . getInfoType) infos
|
||||
hasParent info =
|
||||
case tyThingParent_maybe (getType info) of
|
||||
case tyThingParent_maybe (getInfoType info) of
|
||||
Just parent -> getName parent `elemNameSet` allNames
|
||||
Nothing -> False
|
||||
filteredOutput = filter (not . hasParent) infos
|
||||
@ -411,9 +411,9 @@ getDescription str = do
|
||||
getInfo' = getInfo False
|
||||
|
||||
#if MIN_VERSION_ghc(8,4,0)
|
||||
getType (theType, _, _, _, _) = theType
|
||||
getInfoType (theType, _, _, _, _) = theType
|
||||
#else
|
||||
getType (theType, _, _, _) = theType
|
||||
getInfoType (theType, _, _, _) = theType
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(8,4,0)
|
||||
|
||||
@ -47,7 +47,7 @@ queue = atomically . writeTChan widgetMessages
|
||||
widgetSend :: IHaskellWidget a
|
||||
=> (Widget -> Value -> WidgetMsg)
|
||||
-> a -> Value -> IO ()
|
||||
widgetSend msgType widget value = queue $ msgType (Widget widget) value
|
||||
widgetSend mtype widget value = queue $ mtype (Widget widget) value
|
||||
|
||||
-- | Send a message to open a comm
|
||||
widgetSendOpen :: IHaskellWidget a => a -> Value -> IO ()
|
||||
@ -79,7 +79,7 @@ widgetPublishDisplay widget disp = display disp >>= queue . DispMsg (Widget widg
|
||||
|
||||
-- | Send a `clear_output` message as a [method .= custom] message
|
||||
widgetClearOutput :: IHaskellWidget a => a -> Bool -> IO ()
|
||||
widgetClearOutput widget wait = queue $ ClrOutput (Widget widget) wait
|
||||
widgetClearOutput widget w = queue $ ClrOutput (Widget widget) w
|
||||
|
||||
-- | Handle a single widget message. Takes necessary actions according to the message type, such as
|
||||
-- opening comms, storing and updating widget representation in the kernel state etc.
|
||||
@ -108,8 +108,8 @@ handleMessage send replyHeader state msg = do
|
||||
then return state
|
||||
else do
|
||||
-- Send the comm open, with the initial state
|
||||
header <- dupHeader replyHeader CommOpenMessage
|
||||
send $ CommOpen header target_name target_module uuid value
|
||||
hdr <- dupHeader replyHeader CommOpenMessage
|
||||
send $ CommOpen hdr target_name target_module uuid value
|
||||
|
||||
-- Send anything else the widget requires.
|
||||
open widget communicate
|
||||
@ -127,8 +127,8 @@ handleMessage send replyHeader state msg = do
|
||||
-- If the widget is not present in the state, we don't close it.
|
||||
if present
|
||||
then do
|
||||
header <- dupHeader replyHeader CommCloseMessage
|
||||
send $ CommClose header uuid value
|
||||
hdr <- dupHeader replyHeader CommCloseMessage
|
||||
send $ CommClose hdr uuid value
|
||||
return newState
|
||||
else return state
|
||||
|
||||
@ -145,9 +145,9 @@ handleMessage send replyHeader state msg = do
|
||||
let dmsg = WidgetDisplay dispHeader $ unwrap disp
|
||||
sendMessage widget (toJSON $ CustomContent $ toJSON dmsg)
|
||||
|
||||
ClrOutput widget wait -> do
|
||||
header <- dupHeader replyHeader ClearOutputMessage
|
||||
let cmsg = WidgetClear header wait
|
||||
ClrOutput widget w -> do
|
||||
hdr <- dupHeader replyHeader ClearOutputMessage
|
||||
let cmsg = WidgetClear hdr w
|
||||
sendMessage widget (toJSON $ CustomContent $ toJSON cmsg)
|
||||
|
||||
where
|
||||
@ -158,8 +158,8 @@ handleMessage send replyHeader state msg = do
|
||||
|
||||
-- If the widget is present, we send an update message on its comm.
|
||||
when present $ do
|
||||
header <- dupHeader replyHeader CommDataMessage
|
||||
send $ CommData header uuid value
|
||||
hdr <- dupHeader replyHeader CommDataMessage
|
||||
send $ CommData hdr uuid value
|
||||
return state
|
||||
|
||||
unwrap :: Display -> [DisplayData]
|
||||
@ -178,20 +178,20 @@ instance ToJSON WidgetDisplay where
|
||||
data WidgetClear = WidgetClear MessageHeader Bool
|
||||
|
||||
instance ToJSON WidgetClear where
|
||||
toJSON (WidgetClear replyHeader wait) =
|
||||
let clrVal = toJSON $ ClearOutput replyHeader wait
|
||||
toJSON (WidgetClear replyHeader w) =
|
||||
let clrVal = toJSON $ ClearOutput replyHeader w
|
||||
in toJSON $ IPythonMessage replyHeader clrVal ClearOutputMessage
|
||||
|
||||
data IPythonMessage = IPythonMessage MessageHeader Value MessageType
|
||||
|
||||
instance ToJSON IPythonMessage where
|
||||
toJSON (IPythonMessage replyHeader val msgType) =
|
||||
toJSON (IPythonMessage replyHeader val mtype) =
|
||||
object
|
||||
[ "header" .= replyHeader
|
||||
, "parent_header" .= str ""
|
||||
, "metadata" .= str "{}"
|
||||
, "content" .= val
|
||||
, "msg_type" .= (toJSON . showMessageType $ msgType)
|
||||
, "msg_type" .= (toJSON . showMessageType $ mtype)
|
||||
]
|
||||
|
||||
str :: String -> String
|
||||
@ -203,4 +203,4 @@ widgetHandler :: (Message -> IO ())
|
||||
-> KernelState
|
||||
-> [WidgetMsg]
|
||||
-> IO KernelState
|
||||
widgetHandler sender header = foldM (handleMessage sender header)
|
||||
widgetHandler sender hdr = foldM (handleMessage sender hdr)
|
||||
|
||||
@ -65,7 +65,7 @@ data IHaskellMode = ShowDefault String
|
||||
-- | Given a list of command-line arguments, return the IHaskell mode and arguments to process.
|
||||
parseFlags :: [String] -> Either String Args
|
||||
parseFlags flags =
|
||||
let modeIndex = findIndex (`elem` modeFlags) flags
|
||||
let modeIndex = findIndex (`elem` modeFlgs) flags
|
||||
in case modeIndex of
|
||||
Nothing ->
|
||||
-- Treat no mode as 'console'.
|
||||
@ -77,14 +77,14 @@ parseFlags flags =
|
||||
let (start, first:end) = splitAt idx flags
|
||||
in process ihaskellArgs $ first : start ++ end
|
||||
where
|
||||
modeFlags = concatMap modeNames allModes
|
||||
modeFlgs = concatMap modeNames allModes
|
||||
|
||||
allModes :: [Mode Args]
|
||||
allModes = [installKernelSpec, kernel, convert]
|
||||
|
||||
-- | Get help text for a given IHaskell ode.
|
||||
help :: IHaskellMode -> String
|
||||
help mode = showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode mode
|
||||
help md = showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode md
|
||||
where
|
||||
chooseMode InstallKernelSpec = installKernelSpec
|
||||
chooseMode (Kernel _) = kernel
|
||||
@ -97,8 +97,8 @@ ghcLibFlag = flagReq ["ghclib", "l"] (store GhcLibDir) "<path>" "Library directo
|
||||
ghcRTSFlag :: Flag Args
|
||||
ghcRTSFlag = flagReq ["use-rtsopts"] storeRTS "\"<flags>\""
|
||||
"Runtime options (multithreading etc.). See `ghc +RTS -?`."
|
||||
where storeRTS allRTSFlags (Args mode prev)
|
||||
= fmap (Args mode . (:prev) . RTSFlags)
|
||||
where storeRTS allRTSFlags (Args md prev)
|
||||
= fmap (Args md . (:prev) . RTSFlags)
|
||||
. parseRTS . words $ filter (/='"') allRTSFlags
|
||||
parseRTS ("+RTS":fs) -- Ignore if this is included (we already wrap
|
||||
= parseRTS fs -- the ihaskell-kernel call in +RTS <flags> -RTS anyway)
|
||||
@ -111,13 +111,13 @@ ghcRTSFlag = flagReq ["use-rtsopts"] storeRTS "\"<flags>\""
|
||||
kernelDebugFlag :: Flag Args
|
||||
kernelDebugFlag = flagNone ["debug"] addDebug "Print debugging output from the kernel."
|
||||
where
|
||||
addDebug (Args mode prev) = Args mode (KernelDebug : prev)
|
||||
addDebug (Args md prev) = Args md (KernelDebug : prev)
|
||||
|
||||
kernelStackFlag :: Flag Args
|
||||
kernelStackFlag = flagNone ["stack"] addStack
|
||||
"Inherit environment from `stack` when it is installed"
|
||||
where
|
||||
addStack (Args mode prev) = Args mode (KernelspecUseStack : prev)
|
||||
addStack (Args md prev) = Args md (KernelspecUseStack : prev)
|
||||
|
||||
confFlag :: Flag Args
|
||||
confFlag = flagReq ["conf", "c"] (store ConfFile) "<rc.hs>"
|
||||
@ -131,10 +131,10 @@ helpFlag :: Flag Args
|
||||
helpFlag = flagHelpSimple (add Help)
|
||||
|
||||
add :: Argument -> Args -> Args
|
||||
add flag (Args mode flags) = Args mode $ flag : flags
|
||||
add flag (Args md flags) = Args md $ flag : flags
|
||||
|
||||
store :: (String -> Argument) -> String -> Args -> Either String Args
|
||||
store constructor str (Args mode prev) = Right $ Args mode $ constructor str : prev
|
||||
store constructor str (Args md prev) = Right $ Args md $ constructor str : prev
|
||||
|
||||
installKernelSpec :: Mode Args
|
||||
installKernelSpec =
|
||||
@ -166,14 +166,14 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag
|
||||
, helpFlag
|
||||
]
|
||||
|
||||
consForce (Args mode prev) = Args mode (OverwriteFiles : prev)
|
||||
consForce (Args md prev) = Args md (OverwriteFiles : prev)
|
||||
unnamedArg = Arg (store ConvertFrom) "<file>" False
|
||||
consStyle style (Args mode prev) = Args mode (ConvertLhsStyle style : prev)
|
||||
consStyle style (Args md prev) = Args md (ConvertLhsStyle style : prev)
|
||||
|
||||
storeFormat constructor str (Args mode prev) =
|
||||
storeFormat constructor str (Args md prev) =
|
||||
case T.toLower (T.pack str) of
|
||||
"lhs" -> Right $ Args mode $ constructor LhsMarkdown : prev
|
||||
"ipynb" -> Right $ Args mode $ constructor IpynbFile : prev
|
||||
"lhs" -> Right $ Args md $ constructor LhsMarkdown : prev
|
||||
"ipynb" -> Right $ Args md $ constructor IpynbFile : prev
|
||||
_ -> Left $ "Unknown format requested: " ++ str
|
||||
|
||||
storeLhs str previousArgs =
|
||||
@ -194,12 +194,9 @@ ihaskellArgs =
|
||||
let noMode = mode "IHaskell" defaultReport descr noArgs [helpFlag, versionFlag]
|
||||
defaultReport = Args (ShowDefault helpStr) []
|
||||
descr = "Haskell for Interactive Computing."
|
||||
helpFlag = flagHelpSimple (add Help)
|
||||
versionFlag = flagVersion (add Version)
|
||||
helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
|
||||
in noMode { modeGroupModes = toGroup allModes }
|
||||
where
|
||||
add flag (Args mode flags) = Args mode $ flag : flags
|
||||
|
||||
noArgs :: Arg a
|
||||
noArgs = flagArg unexpected ""
|
||||
|
||||
@ -89,14 +89,14 @@ ensure getDir = do
|
||||
ihaskellDir :: SH.Sh FilePath
|
||||
ihaskellDir = do
|
||||
home <- maybe (error "$HOME not defined.") SH.fromText <$> SH.get_env "HOME"
|
||||
fp <$> ensure (return (home SH.</> ".ihaskell"))
|
||||
fp <$> ensure (return (home SH.</> (".ihaskell" :: SH.FilePath)))
|
||||
|
||||
getIHaskellDir :: IO String
|
||||
getIHaskellDir = SH.shelly ihaskellDir
|
||||
|
||||
defaultConfFile :: IO (Maybe String)
|
||||
defaultConfFile = fmap (fmap fp) . SH.shelly $ do
|
||||
filename <- (SH.</> "rc.hs") <$> ihaskellDir
|
||||
filename <- (SH.</> ("rc.hs" :: SH.FilePath)) <$> ihaskellDir
|
||||
exists <- SH.test_f filename
|
||||
return $ if exists
|
||||
then Just filename
|
||||
@ -116,17 +116,17 @@ verifyIPythonVersion = do
|
||||
Nothing -> badIPython
|
||||
"No Jupyter / IPython detected -- install Jupyter 3.0+ before using IHaskell."
|
||||
Just path -> do
|
||||
stdout <- SH.silently (SH.run path ["--version"])
|
||||
stderr <- SH.lastStderr
|
||||
sout <- SH.silently (SH.run path ["--version"])
|
||||
serr <- SH.lastStderr
|
||||
let majorVersion = join . fmap listToMaybe . parseVersion . T.unpack
|
||||
case mplus (majorVersion stderr) (majorVersion stdout) of
|
||||
case mplus (majorVersion serr) (majorVersion sout) of
|
||||
Nothing -> badIPython $ T.concat
|
||||
[ "Detected Jupyter, but could not parse version number."
|
||||
, "\n"
|
||||
, "(stdout = "
|
||||
, stdout
|
||||
, sout
|
||||
, ", stderr = "
|
||||
, stderr
|
||||
, serr
|
||||
, ")"
|
||||
]
|
||||
|
||||
@ -143,7 +143,7 @@ verifyIPythonVersion = do
|
||||
-- | Install an IHaskell kernelspec into the right location. The right location is determined by
|
||||
-- using `ipython kernelspec install --user`.
|
||||
installKernelspec :: Bool -> KernelSpecOptions -> SH.Sh ()
|
||||
installKernelspec replace opts = void $ do
|
||||
installKernelspec repl opts = void $ do
|
||||
ihaskellPath <- getIHaskellPath
|
||||
confFile <- liftIO $ kernelSpecConfFile opts
|
||||
|
||||
@ -169,7 +169,7 @@ installKernelspec replace opts = void $ do
|
||||
-- shell out to IPython to install this kernelspec directory.
|
||||
SH.withTmpDir $ \tmp -> do
|
||||
let kernelDir = tmp SH.</> kernelName
|
||||
let filename = kernelDir SH.</> "kernel.json"
|
||||
let filename = kernelDir SH.</> ("kernel.json" :: SH.FilePath)
|
||||
|
||||
SH.mkdir_p kernelDir
|
||||
SH.writefile filename $ LT.toStrict $ toLazyText $ encodeToTextBuilder $ toJSON kernelSpec
|
||||
@ -180,7 +180,7 @@ installKernelspec replace opts = void $ do
|
||||
|
||||
ipython <- locateIPython
|
||||
|
||||
let replaceFlag = ["--replace" | replace]
|
||||
let replaceFlag = ["--replace" | repl]
|
||||
installPrefixFlag = maybe ["--user"] (\prefix -> ["--prefix", T.pack prefix]) (kernelSpecInstallPrefix opts)
|
||||
cmd = concat [["kernelspec", "install"], installPrefixFlag, [SH.toTextIgnore kernelDir], replaceFlag]
|
||||
|
||||
|
||||
@ -72,8 +72,8 @@ stdinOnce dir = do
|
||||
loop stdinInput oldStdin newStdin = do
|
||||
let FileHandle _ mvar = stdin
|
||||
threadDelay $ 150 * 1000
|
||||
empty <- isEmptyMVar mvar
|
||||
if not empty
|
||||
e <- isEmptyMVar mvar
|
||||
if not e
|
||||
then loop stdinInput oldStdin newStdin
|
||||
else do
|
||||
line <- getInputLine dir
|
||||
@ -87,17 +87,17 @@ getInputLine dir = do
|
||||
|
||||
-- Send a request for input.
|
||||
uuid <- UUID.random
|
||||
parentHeader <- fromJust . readMay <$> readFile (dir ++ "/.last-req-header")
|
||||
let header = MessageHeader
|
||||
{ username = username parentHeader
|
||||
, identifiers = identifiers parentHeader
|
||||
, parentHeader = Just parentHeader
|
||||
parentHdr <- fromJust . readMay <$> readFile (dir ++ "/.last-req-header")
|
||||
let hdr = MessageHeader
|
||||
{ username = username parentHdr
|
||||
, identifiers = identifiers parentHdr
|
||||
, parentHeader = Just parentHdr
|
||||
, messageId = uuid
|
||||
, sessionId = sessionId parentHeader
|
||||
, sessionId = sessionId parentHdr
|
||||
, metadata = Map.fromList []
|
||||
, msgType = InputRequestMessage
|
||||
}
|
||||
let msg = RequestInput header ""
|
||||
let msg = RequestInput hdr ""
|
||||
writeChan req msg
|
||||
|
||||
-- Get the reply.
|
||||
@ -105,8 +105,8 @@ getInputLine dir = do
|
||||
return value
|
||||
|
||||
recordParentHeader :: String -> MessageHeader -> IO ()
|
||||
recordParentHeader dir header =
|
||||
writeFile (dir ++ "/.last-req-header") $ show header
|
||||
recordParentHeader dir hdr =
|
||||
writeFile (dir ++ "/.last-req-hdr") $ show hdr
|
||||
|
||||
recordKernelProfile :: String -> Profile -> IO ()
|
||||
recordKernelProfile dir profile =
|
||||
|
||||
@ -25,7 +25,7 @@ publishResult :: (Message -> IO ()) -- ^ A function to send messages
|
||||
-> Bool -- ^ Whether to use the pager
|
||||
-> EvaluationResult -- ^ The evaluation result
|
||||
-> IO ()
|
||||
publishResult send replyHeader displayed updateNeeded pagerOutput usePager result = do
|
||||
publishResult send replyHeader displayed updateNeeded poutput upager result = do
|
||||
let final =
|
||||
case result of
|
||||
IntermediateResult{} -> False
|
||||
@ -51,21 +51,21 @@ publishResult send replyHeader displayed updateNeeded pagerOutput usePager resul
|
||||
-- If this has some pager output, store it for later.
|
||||
let pager = pagerOut result
|
||||
unless (null pager) $
|
||||
if usePager
|
||||
then modifyMVar_ pagerOutput (return . (++ pager))
|
||||
if upager
|
||||
then modifyMVar_ poutput (return . (++ pager))
|
||||
else sendOutput $ Display pager
|
||||
|
||||
where
|
||||
clearOutput = do
|
||||
header <- dupHeader replyHeader ClearOutputMessage
|
||||
send $ ClearOutput header True
|
||||
hdr <- dupHeader replyHeader ClearOutputMessage
|
||||
send $ ClearOutput hdr True
|
||||
|
||||
sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
|
||||
sendOutput (Display outs) = do
|
||||
header <- dupHeader replyHeader DisplayDataMessage
|
||||
send $ PublishDisplayData header $ map (convertSvgToHtml . prependCss) outs
|
||||
hdr <- dupHeader replyHeader DisplayDataMessage
|
||||
send $ PublishDisplayData hdr $ map (convertSvgToHtml . prependCss) outs
|
||||
|
||||
convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg
|
||||
convertSvgToHtml (DisplayData MimeSvg s) = html $ makeSvgImg $ base64 $ E.encodeUtf8 s
|
||||
convertSvgToHtml x = x
|
||||
|
||||
makeSvgImg :: Base64 -> String
|
||||
@ -73,6 +73,6 @@ publishResult send replyHeader displayed updateNeeded pagerOutput usePager resul
|
||||
base64data <>
|
||||
"\"/>"
|
||||
|
||||
prependCss (DisplayData MimeHtml html) =
|
||||
DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", html]
|
||||
prependCss (DisplayData MimeHtml h) =
|
||||
DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", h]
|
||||
prependCss x = x
|
||||
|
||||
@ -12,7 +12,7 @@ module IHaskell.Types (
|
||||
MessageType(..),
|
||||
dupHeader,
|
||||
Username,
|
||||
Metadata(..),
|
||||
Metadata,
|
||||
replyType,
|
||||
ExecutionState(..),
|
||||
StreamType(..),
|
||||
@ -39,7 +39,7 @@ module IHaskell.Types (
|
||||
|
||||
import IHaskellPrelude
|
||||
|
||||
import Data.Aeson (Value, (.=), object)
|
||||
import Data.Aeson (ToJSON, Value, (.=), object)
|
||||
import Data.Function (on)
|
||||
import Data.Serialize
|
||||
import GHC.Generics
|
||||
@ -91,6 +91,28 @@ class IHaskellDisplay a => IHaskellWidget a where
|
||||
-> IO ()
|
||||
close _ _ = return ()
|
||||
|
||||
-- | these instances cause the image, html etc. which look like:
|
||||
--
|
||||
-- > Display
|
||||
-- > [Display]
|
||||
-- > IO [Display]
|
||||
-- > IO (IO Display)
|
||||
--
|
||||
-- be run the IO and get rendered (if the frontend allows it) in the pretty form.
|
||||
instance IHaskellDisplay a => IHaskellDisplay (IO a) where
|
||||
display = (display =<<)
|
||||
|
||||
instance IHaskellDisplay Display where
|
||||
display = return
|
||||
|
||||
instance IHaskellDisplay DisplayData where
|
||||
display disp = return $ Display [disp]
|
||||
|
||||
instance IHaskellDisplay a => IHaskellDisplay [a] where
|
||||
display disps = do
|
||||
displays <- mapM display disps
|
||||
return $ ManyDisplay displays
|
||||
|
||||
data Widget = forall a. IHaskellWidget a => Widget a
|
||||
deriving Typeable
|
||||
|
||||
@ -221,9 +243,9 @@ data WidgetMethod = UpdateState Value
|
||||
| DisplayWidget
|
||||
|
||||
instance ToJSON WidgetMethod where
|
||||
toJSON DisplayWidget = object ["method" .= "display"]
|
||||
toJSON (UpdateState v) = object ["method" .= "update", "state" .= v]
|
||||
toJSON (CustomContent v) = object ["method" .= "custom", "content" .= v]
|
||||
toJSON DisplayWidget = object ["method" .= ("display" :: Text)]
|
||||
toJSON (UpdateState v) = object ["method" .= ("update" :: Text), "state" .= v]
|
||||
toJSON (CustomContent v) = object ["method" .= ("custom" :: Text), "content" .= v]
|
||||
|
||||
-- | Output of evaluation.
|
||||
data EvaluationResult =
|
||||
@ -243,7 +265,7 @@ data EvaluationResult =
|
||||
|
||||
-- | Duplicate a message header, giving it a new UUID and message type.
|
||||
dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
|
||||
dupHeader header messageType = do
|
||||
dupHeader hdr messageType = do
|
||||
uuid <- liftIO random
|
||||
|
||||
return header { messageId = uuid, msgType = messageType }
|
||||
return hdr { messageId = uuid, msgType = messageType }
|
||||
|
||||
@ -1,4 +1,9 @@
|
||||
{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
-- Shelly's types are kinda borked.
|
||||
{-# OPTIONS_GHC -Wno-type-defaults #-}
|
||||
|
||||
module IHaskell.Test.Completion (testCompletions) where
|
||||
|
||||
import Prelude
|
||||
@ -196,11 +201,11 @@ inDirectory dirs files action = shelly $ withTmpDir $ \dirPath -> do
|
||||
where
|
||||
cdEvent path = liftIO $ setCurrentDirectory path
|
||||
wrap :: String -> Interpreter a -> Interpreter a
|
||||
wrap path action = do
|
||||
wrap path actn = do
|
||||
initCompleter
|
||||
pwd <- IHaskell.Eval.Evaluate.liftIO getCurrentDirectory
|
||||
cdEvent path -- change to the temporary directory
|
||||
out <- action -- run action
|
||||
out <- actn -- run action
|
||||
cdEvent pwd -- change back to the original directory
|
||||
return out
|
||||
|
||||
@ -212,4 +217,5 @@ withHsDirectory = inDirectory [p "" </> p "dir", p "dir" </> p "dir1"]
|
||||
, p "dir" </> p "file2.lhs"
|
||||
]
|
||||
where
|
||||
p :: T.Text -> T.Text
|
||||
p = id
|
||||
|
||||
@ -37,8 +37,8 @@ eval string = do
|
||||
_ <- interpret GHC.Paths.libdir False $ const $
|
||||
IHaskell.Eval.Evaluate.evaluate state string publish noWidgetHandling
|
||||
out <- readIORef outputAccum
|
||||
pagerOut <- readIORef pagerAccum
|
||||
return (reverse out, unlines . map extractPlain . reverse $ pagerOut)
|
||||
pagerout <- readIORef pagerAccum
|
||||
return (reverse out, unlines . map extractPlain . reverse $ pagerout)
|
||||
|
||||
becomes :: String -> [String] -> IO ()
|
||||
becomes string expected = evaluationComparing comparison string
|
||||
@ -49,9 +49,9 @@ becomes string expected = evaluationComparing comparison string
|
||||
expectationFailure $ "Expected result to have " ++ show (length expected)
|
||||
++ " results. Got " ++ show results
|
||||
|
||||
forM_ (zip results expected) $ \(ManyDisplay [Display result], expected) -> case extractPlain result of
|
||||
"" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expected
|
||||
str -> str `shouldBe` expected
|
||||
forM_ (zip results expected) $ \(ManyDisplay [Display result], expect) -> case extractPlain result of
|
||||
"" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expect
|
||||
str -> str `shouldBe` expect
|
||||
|
||||
evaluationComparing :: (([Display], String) -> IO b) -> String -> IO b
|
||||
evaluationComparing comparison string = do
|
||||
@ -72,21 +72,21 @@ pages string expected = evaluationComparing comparison string
|
||||
-- A very, very hacky method for removing HTML
|
||||
stripHtml str = go str
|
||||
where
|
||||
go ('<':str) =
|
||||
case stripPrefix "script" str of
|
||||
go ('<':xs) =
|
||||
case stripPrefix "script" xs of
|
||||
Nothing -> go' str
|
||||
Just str -> dropScriptTag str
|
||||
Just s -> dropScriptTag s
|
||||
go (x:xs) = x : go xs
|
||||
go [] = []
|
||||
|
||||
go' ('>':str) = go str
|
||||
go' ('>':xs) = go xs
|
||||
go' (_:xs) = go' xs
|
||||
go' [] = error $ "Unending bracket html tag in string " ++ str
|
||||
|
||||
dropScriptTag str =
|
||||
case stripPrefix "</script>" str of
|
||||
Just str -> go str
|
||||
Nothing -> dropScriptTag $ tail str
|
||||
dropScriptTag str1 =
|
||||
case stripPrefix "</script>" str1 of
|
||||
Just s -> go s
|
||||
Nothing -> dropScriptTag $ tail str
|
||||
|
||||
fixQuotes :: String -> String
|
||||
fixQuotes = id
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user