things compile with new hlint and classy-prelude

src/IHaskell/Eval/Evaluate.hs

@@ -1010,10 +1010,11 @@ capturedStatement output stmt = do
       ]
     pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable
 
+    goStmt :: String -> Ghc RunResult
     goStmt s = runStmt s RunToCompletion
 
   -- Initialize evaluation context.
-  forM_ initStmts goStmt
+  void $ forM initStmts goStmt
 
   -- Get the pipe to read printed output from.
   -- This is effectively the source code of dynCompileExpr from GHC API's
@@ -1101,7 +1102,7 @@ capturedStatement output stmt = do
     liftIO $ modifyMVar_ completed (const $ return True)
 
     -- Finalize evaluation context.
-    forM_ postStmts goStmt
+    void $ forM postStmts goStmt
 
     -- Once context is finalized, reading can finish.
     -- Wait for reading to finish to that the output accumulator is

src/IHaskell/Eval/Lint.hs

@@ -4,34 +4,49 @@ module IHaskell.Eval.Lint (
   ) where
 
 import Data.String.Utils (replace, startswith, strip, split)
-import Prelude (head, tail)
-import Language.Haskell.HLint as HLint
-import ClassyPrelude
+import Prelude (head, tail, last)
+import ClassyPrelude hiding (last)
 import Control.Monad
 import Data.List (findIndex)
 import Text.Printf
 import Data.String.Here
 import Data.Char
 import Data.Monoid
+import Data.Maybe (mapMaybe)
+import System.IO.Unsafe (unsafePerformIO)
+
+import Language.Haskell.Exts.Annotated.Syntax hiding (Module)
+import qualified Language.Haskell.Exts.Annotated.Syntax as SrcExts
+import Language.Haskell.Exts.Annotated (parseFileContentsWithMode)
+import Language.Haskell.Exts.Annotated.Build (doE)
+import Language.Haskell.Exts.Annotated hiding (Module)
+import Language.Haskell.Exts.SrcLoc
+
+import Language.Haskell.HLint as HLint
+import Language.Haskell.HLint2
 
 import IHaskell.Types
 import IHaskell.Display
 import IHaskell.IPython
 import IHaskell.Eval.Parser hiding (line)
 
-data LintSeverity = LintWarning | LintError deriving (Eq, Show)
+type ExtsModule = SrcExts.Module SrcSpanInfo
 
 data LintSuggestion
   = Suggest {
     line :: LineNumber,
-    chunkNumber :: Int,
     found :: String,
     whyNot :: String,
-    severity :: LintSeverity,
+    severity :: Severity,
     suggestion :: String
   }
   deriving (Eq, Show)
 
+-- Store settings for Hlint once it's initialized.
+{-# NOINLINE hlintSettings #-}
+hlintSettings :: MVar (ParseFlags, [Classify], Hint)
+hlintSettings = unsafePerformIO newEmptyMVar
+
 -- | Identifier used when one is needed for proper context.
 lintIdent :: String
 lintIdent = "lintIdentAEjlkQeh"
@@ -40,31 +55,106 @@ lintIdent = "lintIdentAEjlkQeh"
 -- report on linting warnings and errors.
 lint :: [Located CodeBlock] -> IO Display
 lint blocks = do
-  let validBlocks = map makeValid blocks
-      fileContents = joinBlocks validBlocks
-  -- Get a temporarly location to store this file.
-  ihaskellDir <- getIHaskellDir
-  let filename = ihaskellDir ++ "/.hlintFile.hs"
-
-  writeFile (fromString filename) fileContents
-  suggestions <- catMaybes <$> map parseSuggestion <$> hlint [filename, "--quiet"]
+  -- Initialize hlint settings
+  initialized <- isEmptyMVar hlintSettings
+  when (not initialized) $ autoSettings >>= putMVar hlintSettings
+
+  -- Get hlint settings
+  (flags, classify, hint) <- readMVar hlintSettings
+  let mode = hseFlags flags
+
+
+  -- create 'suggestions'
+  let modules = mapMaybe (createModule mode) blocks
+      ideas = applyHints classify hint modules
+      suggestions = mapMaybe showIdea ideas
+
   return $ Display $
     if null suggestions
     then []
     else 
       [plain $ concatMap plainSuggestion suggestions,
        html $ htmlSuggestions suggestions]
+
+showIdea :: Idea -> Maybe LintSuggestion
+showIdea idea = 
+  case ideaTo idea of
+    Nothing -> Nothing
+    Just whyNot -> Just Suggest {
+      line = srcSpanStartLine $ ideaSpan idea,
+      found = showSuggestion $ ideaFrom idea,
+      whyNot = showSuggestion $ whyNot,
+      severity = ideaSeverity idea,
+      suggestion = ideaHint idea
+  }
+
+createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
+createModule mode (Located line 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
+    _ -> Nothing
   where
-    -- Join together multiple valid file blocks into a single file.
-    -- However, join them with padding so that the line numbers are
-    -- correct.
-    joinBlocks :: [Located String] -> String
-    joinBlocks = unlines . zipWith addPragma [1 .. ]
+    blockStr = 
+      case block of
+        Expression expr   -> expr
+        Declaration decl  -> decl 
+        Statement stmt    -> stmt
+        Import impt       -> impt
+        Module mod        -> mod
+
+    unparse :: ParseResult a -> Maybe a
+    unparse (ParseOk a) = Just a
+    unparse _ = Nothing
+
+    srcSpan :: SrcSpan
+    srcSpan = SrcSpan {
+      srcSpanFilename = "<interactive>",
+      srcSpanStartLine = line,
+      srcSpanStartColumn = 0,
+      srcSpanEndLine = line + length (lines blockStr),
+      srcSpanEndColumn = length $ last $ lines blockStr
+    }
+
+    loc :: SrcSpanInfo
+    loc = SrcSpanInfo srcSpan []
+
+    moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule 
+    moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl]
+
+    parseModule :: String -> ParseResult ExtsModule
+    parseModule = parseFileContentsWithMode mode
+
+    declToModule :: String -> ParseResult ExtsModule
+    declToModule decl = moduleWithDecls <$> parseDeclWithMode mode decl
+
+    exprToModule :: String -> ParseResult ExtsModule
+    exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp
+
+    stmtToModule :: String -> ParseResult ExtsModule
+    stmtToModule stmtStr = case parseStmtWithMode mode stmtStr of
+      ParseOk stmt -> ParseOk mod
+      ParseFailed a b -> ParseFailed a b
+      where
+        mod = moduleWithDecls decl
+
+        decl :: Decl SrcSpanInfo
+        decl = SpliceDecl loc expr
+
+        expr :: Exp SrcSpanInfo
+        expr = doE loc [stmt, ret]
+
+        stmt :: Stmt SrcSpanInfo
+        ParseOk stmt = parseStmtWithMode mode stmtStr
 
-    addPragma :: Int -> Located String -> String
-    addPragma i (Located desiredLine str) = linePragma desiredLine i ++ str
+        ret :: Stmt SrcSpanInfo
+        ParseOk ret = Qualifier loc <$> parseExp lintIdent
 
-    linePragma = printf "{-# LINE %d \"%d\" #-}\n"
+    imptToModule :: String -> ParseResult ExtsModule
+    imptToModule = parseFileContentsWithMode mode
 
 plainSuggestion :: LintSuggestion -> String
 plainSuggestion suggest = 
@@ -91,8 +181,11 @@ htmlSuggestions = concatMap toHtml
 
       where
         severityClass = case severity suggest of
-          LintWarning -> "warning"
-          LintError -> "error"
+          Error -> "error"
+          Warning -> "warning"
+
+          -- Should not occur
+          _ -> "warning"
 
     style :: String -> String -> String
     style cls thing = [i| <div class="suggestion-${cls}">${thing}</div> |]
@@ -106,60 +199,18 @@ htmlSuggestions = concatMap toHtml
     floating :: String -> String -> String
     floating dir thing = [i| <div class="suggestion-row" style="float: ${dir};">${thing}</div> |]
 
--- | Parse a suggestion from Hlint. The suggestions look like this:
---   .ihaskell/.hlintFile.hs:1:19: Warning: Redundant bracket
---   Found:
---     ((3))
---   Why not:
---     (3)
--- We extract all the necessary fields and store them.
--- If parsing fails, return Nothing.
-parseSuggestion :: Suggestion -> Maybe LintSuggestion
-parseSuggestion suggestion = do
-  let str = showSuggestion (show suggestion)
-      severity = suggestionSeverity suggestion
-
-  guard (severity /= HLint.Ignore)
-  let lintSeverity = case severity of
-        Warning -> LintWarning
-        Error -> LintError
-
-  headerLine:foundLine:rest <- Just (lines str)
-
-  -- Expect the line after the header to have 'Found' in it.
-  guard ("Found:" `isInfixOf` foundLine)
-
-  -- Expect something like:
-  -- ".hlintFile.hs:1:19: Warning: Redundant bracket"
-  -- ==> 
-  -- [".hlintFile.hs","1","19"," Warning"," Redundant bracket"]
-  [readMay -> Just chunkN,
-   readMay -> Just lineNum, _col, severity, name] <- Just (split ":" headerLine)
-
-  (before, _:after) <- Just (break ("Why not:" `isInfixOf`) rest)
-  return Suggest {
-    line = lineNum,
-    chunkNumber = chunkN,
-    found = unlines before,
-    whyNot = unlines after,
-    suggestion = name,
-    severity = lintSeverity
-  }
-
 
 showSuggestion :: String -> String
-showSuggestion = 
-  remove ("return " ++ lintIdent) .
-  remove (lintIdent ++ "=") .
-  dropDo
+showSuggestion = removeSplices . remove lintIdent .  dropDo
   where
     remove str = replace str ""
+    removeSplices = id
 
     -- Drop leading '  do ', and blank spaces following.
     dropDo :: String -> String
     dropDo string = 
       -- If this is not a statement, we don't need to drop the do statement.
-      if ("return " ++ lintIdent) `isInfixOf` string
+      if lintIdent `isInfixOf` string
       then unlines . clean . lines $ string
       else string
 
@@ -180,43 +231,3 @@ showSuggestion =
     -- Ignore other list elements - just proceed onwards.
     clean (x:xs) = x : clean xs
     clean [] = []
-
--- | Convert a code chunk into something that could go into a file.
--- The line number on the output is the same as on the input.
-makeValid :: Located CodeBlock -> Located String
-makeValid (Located line block) = Located line $
-  case block of
-    -- Expressions need to be bound to some identifier.
-    Expression expr -> lintIdent ++ "=" ++ expr
-
-    -- Statements go in a 'do' block bound to an identifier.
-    --
-    -- a cell can contain:
-    -- > x <- readFile "foo"
-    -- so add a return () to avoid a Parse error: Last statement in
-    -- a do-block must be an expression
-    --
-    -- one place this goes wrong is when the chunk is:
-    --
-    -- > do
-    -- >  {- a comment that has to -} let x = 1
-    -- >   {- count as whitespace -}      y = 2
-    -- >                              return (x+y) 
-    Statement stmt ->
-        let expandTabs = replace "\t" "        " 
-            nLeading = maybe 0 (length . takeWhile isSpace)
-                    $ listToMaybe
-                    $ filter (not . all isSpace)
-                            (lines (expandTabs stmt))
-            finalReturn = replicate nLeading ' ' ++ "return " ++ lintIdent
-        in intercalate "\n " ((lintIdent ++ " $ do") : lines stmt ++ [finalReturn])
-
-    -- Modules, declarations, and type signatures are fine as is.
-    Module mod -> mod
-    Declaration decl -> decl
-    TypeSignature sig -> sig
-    Import imp -> imp
-
-    -- Output nothing for directives or parse errors.
-    Directive {} -> ""
-    ParseError {} -> ""

src/Main.hs

@@ -170,8 +170,8 @@ runKernel profileSrc initInfo = do
           state <- liftIO $ takeMVar stateVar
           evaluate state line noPublish
 
-    mapM_ evaluator extLines
-    mapM_ evaluator $ initCells initInfo
+    mapM evaluator extLines
+    mapM evaluator $ initCells initInfo
 
     forever $ do
       -- Read the request from the request channel.