Skip to content

G
gargantext-ihaskell
Commit f43b9129 authored by Erik de Castro Lopo's avatar Erik de Castro Lopo
Browse files
Options

Switch warnings to -Wall and fix the rest

parent 4c0b3d24
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 314 additions and 319 deletions
ihaskell.cabal
View file @ f43b9129
......@@ -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,
......
main/Main.hs
View file @ f43b9129
......@@ -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 }
_ ->
......
src/IHaskell/Convert/IpynbToLhs.hs
View file @ f43b9129
......@@ -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
......
src/IHaskell/Convert/LhsToIpynb.hs
View file @ f43b9129
......@@ -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 [] = []
......
src/IHaskell/Display.hs
View file @ f43b9129
......@@ -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
......
src/IHaskell/Eval/Completion.hs
View file @ f43b9129
......@@ -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
......
src/IHaskell/Eval/Evaluate.hs
View file @ f43b9129
This diff is collapsed.
src/IHaskell/Eval/Hoogle.hs
View file @ f43b9129
......@@ -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>"
......
src/IHaskell/Eval/Lint.hs
View file @ f43b9129
......@@ -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>"
......
src/IHaskell/Eval/ParseShell.hs
View file @ f43b9129
......@@ -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")
src/IHaskell/Eval/Parser.hs
View file @ f43b9129
......@@ -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"
src/IHaskell/Eval/Util.hs
View file @ f43b9129
......@@ -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)
......
src/IHaskell/Eval/Widgets.hs
View file @ f43b9129
......@@ -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)
src/IHaskell/Flags.hs
View file @ f43b9129
......@@ -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 ""
......
src/IHaskell/IPython.hs
View file @ f43b9129
......@@ -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]
......
src/IHaskell/IPython/Stdin.hs
View file @ f43b9129
......@@ -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 =
......
src/IHaskell/Publish.hs
View file @ f43b9129
......@@ -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
src/IHaskell/Types.hs
View file @ f43b9129
......@@ -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 }
src/tests/IHaskell/Test/Completion.hs
View file @ f43b9129
{-# 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
src/tests/IHaskell/Test/Eval.hs
View file @ f43b9129
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment