use LINE pragmas in the file generated for HLint

Hspec.hs

@@ -36,7 +36,8 @@ eval string = do
   outputAccum <- newIORef []
   let publish _ displayDatas = modifyIORef outputAccum (displayDatas :)
   getTemporaryDirectory >>= setCurrentDirectory
-  let state = mempty :: KernelState
+  let state :: KernelState
+      state = mempty { getLintStatus = LintOff }
   interpret $ Eval.evaluate state string publish
   out <- readIORef outputAccum
   return $ reverse out

IHaskell/Display.hs

 {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
 module IHaskell.Display (
   IHaskellDisplay(..),
   plain, html, png, jpg, svg, latex,
@@ -14,6 +13,12 @@ import Data.String.Utils (rstrip)
 import IHaskell.Types
 
 -- | A class for displayable Haskell types.
+--
+-- IHaskell's displaying of results behaves as if these two
+-- overlapping/undecidable instances also existed:
+-- 
+-- > instance (Show a) => IHaskellDisplay a
+-- > instance Show a where shows _ = id
 class IHaskellDisplay a where
   display :: a -> [DisplayData]
 

IHaskell/Eval/Evaluate.hs

@@ -450,9 +450,9 @@ evalCommand output (Expression expr) state = do
   -- The output is bound to 'it', so we can then use it.
   evalOut <- evalCommand output (Statement expr) state
 
-    -- Try to use `display` to convert our type into the output
+  -- Try to use `display` to convert our type into the output
   -- DisplayData. If typechecking fails and there is no appropriate
-  -- typeclass, this will throw an exception and thus `attempt` will
+  -- typeclass instance, this will throw an exception and thus `attempt` will
   -- return False, and we just resort to plaintext.
   let displayExpr = printf "(IHaskell.Display.display (%s))" expr
   canRunDisplay <- attempt $ exprType displayExpr

IHaskell/Eval/Lint.hs

-{-# LANGUAGE NoImplicitPrelude, QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
 module IHaskell.Eval.Lint ( 
   lint
   ) where
@@ -11,6 +11,8 @@ import Control.Monad
 import Data.List (findIndex)
 import Text.Printf
 import Data.String.Here
+import Data.Char
+import Data.Monoid
 
 import IHaskell.Types
 import IHaskell.Display
@@ -22,6 +24,7 @@ data LintSeverity = LintWarning | LintError deriving (Eq, Show)
 data LintSuggestion
   = Suggest {
     line :: LineNumber,
+    chunkNumber :: Int,
     found :: String,
     whyNot :: String,
     severity :: LintSeverity,
@@ -38,7 +41,7 @@ lintIdent = "lintIdentAEjlkQeh"
 lint :: [Located CodeBlock] -> IO [DisplayData]
 lint blocks = do
   let validBlocks = map makeValid blocks
-      fileContents = joinBlocks 1 validBlocks
+      fileContents = joinBlocks validBlocks
   -- Get a temporarly location to store this file.
   ihaskellDir <- getIHaskellDir
   let filename = ihaskellDir ++ "/.hlintFile.hs"
@@ -54,15 +57,13 @@ lint blocks = do
     -- Join together multiple valid file blocks into a single file.
     -- However, join them with padding so that the line numbers are
     -- correct.
-    joinBlocks :: LineNumber -> [Located String] -> String
-    joinBlocks nextLine (Located desiredLine str:strs) =
-      -- Place padding to shift the line number appropriately.
-      replicate (desiredLine - nextLine) '\n' ++
-      str ++ "\n" ++
-      joinBlocks (desiredLine + nlines str) strs
-    joinBlocks _ [] = ""
+    joinBlocks :: [Located String] -> String
+    joinBlocks = unlines . zipWith addPragma [1 .. ]
 
-    nlines = length . lines
+    addPragma :: Int -> Located String -> String
+    addPragma i (Located desiredLine str) = linePragma desiredLine i ++ str
+
+    linePragma = printf "{-# LINE %d \"%d\" #-}\n"
 
 plainSuggestion :: LintSuggestion -> String
 plainSuggestion suggest = 
@@ -114,46 +115,56 @@ htmlSuggestions = concatMap toHtml
 -- If parsing fails, return Nothing.
 parseSuggestion :: Suggestion -> Maybe LintSuggestion
 parseSuggestion suggestion = do
-  let str = showSuggestion suggestion
+  let str = showSuggestion (show suggestion)
       severity = suggestionSeverity suggestion
   guard (severity /= HLint.Ignore)
   let lintSeverity = case severity of
         Warning -> LintWarning
         Error -> LintError
 
-  let suggestionLines = lines str
-  -- Expect a header line, a "Found" line, and a "Why not" line.
-  guard (length suggestionLines > 3)
+  headerLine:foundLine:rest <- Just (lines str)
 
   -- Expect the line after the header to have 'Found' in it.
-  let headerLine:foundLine:rest = suggestionLines
   guard ("Found:" `isInfixOf` foundLine)
 
   -- Expect something like:
   -- ".hlintFile.hs:1:19: Warning: Redundant bracket"
-  let headerPieces = split ":" headerLine
-  guard (length headerPieces == 5)
-  let [file, line, col, severity, name] = headerPieces
+  -- ==> 
+  -- [".hlintFile.hs","1","19"," Warning"," Redundant bracket"]
+  [readMay -> Just chunkN,
+   readMay -> Just lineNum, _col, severity, name] <- Just (split ":" headerLine)
 
-  whyIndex <- findIndex ("Why not:" `isInfixOf`) rest
-  let (before, _:after) = splitAt whyIndex rest
-  lineNum <- readMay line
+  (before, _:after) <- Just (break ("Why not:" `isInfixOf`) rest)
   return Suggest {
     line = lineNum,
+    chunkNumber = chunkN,
     found = unlines before,
     whyNot = unlines after,
     suggestion = name,
     severity = lintSeverity
   }
-  where
-    showSuggestion = 
-      replace (lintIdent ++ "=") "" .
-      replace (lintIdent ++ "$do ") "" .
-      replace (replicate (length lintIdent + length " $ do ") ' ' ++ lintIdent) "" .
-      replace (" in " ++ lintIdent) "" .
-      show
 
 
+showSuggestion :: String -> String
+showSuggestion = 
+    replace ("return " ++ lintIdent) "" .
+    replace (lintIdent ++ "=") "" .
+    dropDo
+    where
+
+    -- drop leading '  do ', and blank spaces following
+    dropDo :: String -> String
+    dropDo = unlines . f . lines
+        where
+        f :: [String] -> [String]
+        f ((stripPrefix "  do " -> Just a) : as) =
+                let as' = catMaybes
+                        $ takeWhile isJust
+                        $ map (stripPrefix "     ") as
+                in a : as' ++ f (drop (length as') as)
+        f (x:xs) = x : f xs
+        f [] = []
+
 -- | 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
@@ -162,28 +173,27 @@ makeValid (Located line block) = Located line $
     -- Expressions need to be bound to some identifier.
     Expression expr -> lintIdent ++ "=" ++ expr
 
-    -- Statements need to go in a 'do' block bound to an identifier.
-    -- It must also end with a 'return'.
-    Statement stmt -> 
-      -- Let's must be handled specially, because we can't have layout
-      -- inside non-layout. For instance, this is illegal:
-      --   a = do { let x = 3; return 3 }
-      --   because it should be
-      --   a = do { let {x = 3}; return 3 }
-      -- Thus, we rely on template haskell and instead turn it into an
-      -- expression via let x = blah 'in blah'.
-      if startswith "let" $ strip stmt
-      then stmt ++ " in " ++ lintIdent
-      else 
-        -- We take advantage of the fact that naked expressions at toplevel
-        -- are allowed by Template Haskell, and output them to a file.
-        let prefix = lintIdent ++ " $ do "
-            first:rest = split "\n" stmt
-            indent = replicate (length prefix) ' '
-            fixedLines = first : map (indent ++) rest
-            extraReturnLine = [indent ++ lintIdent]
-            code = intercalate "\n" (fixedLines ++ extraReturnLine) in
-        prefix ++ code
+    -- 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