all parsing tests pass!

HaskellParser.y.pp

@@ -25,7 +25,7 @@ to inline certain key external functions, so we instruct GHC not to
 throw away inlinings as it would normally do in -O0 mode.
 -}
 
-module IHaskell.GHC.HaskellParser (partialStatement, partialExpression, partialImport, partialDeclaration) where
+module IHaskell.GHC.HaskellParser (fullExpression, partialStatement, partialExpression, partialImport, partialDeclaration) where
 
 import HsSyn
 import RdrHsSyn
@@ -367,6 +367,7 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 %partial partialImport importdecl
 %partial partialDeclaration topdecl
 %partial partialExpression exp
+%name fullExpression exp
 %%
 
 -----------------------------------------------------------------------------

IHaskell/Eval/Parser.hs

@@ -23,6 +23,7 @@ import Bag
 import Outputable hiding ((<>))
 import Lexer
 import OrdList
+import Data.List (findIndex)
 
 import IHaskell.GHC.HaskellParser
 
@@ -54,23 +55,26 @@ data DirectiveType
 
 -- $extendedParserTests
 --
+-- >>> test "3\nlet x = expr"
+-- [Expression "3",Statement "let x = expr"]
+--
 -- >>> test "let x = 3 in x + 3"
 -- [Expression "let x = 3 in x + 3"]
 --
 -- >>> test "3\n:t expr"
 -- [Expression "3",Directive GetType "expr"]
 --
--- >>> test "3\nlet x = expr"
--- [Expression "3",Statement "let x = expr"]
+-- >>> test "y <- print 'no'"
+-- [Statement "y <- print 'no'"]
 --
 -- >>> test "y <- do print 'no'\nlet x = expr"
--- [Statement "y <- do print 'no'",Statement "let x = expr"]
+-- [Statement "y <- do { print 'no' }",Statement "let x = expr"]
 --
--- >>> test "y <- do print 'no'\nlet x = expr"
--- [Statement "y <- print 'no'",Statement "let x = expr"]
+-- >>> test "y <- do print 'no'\nlet x = expr\nexpression"
+-- [Statement "y <- do { print 'no' }",Statement "let x = expr",Expression "expression"]
 --
 -- >>> test "print yes\nprint no"
--- [Expression "print yes",Statement "print no"]
+-- [Expression "print yes",Expression "print no"]
 
 
 -- | Parse a single cell into code blocks.
@@ -116,23 +120,54 @@ parseCell codeString = concat <$> processChunks 1 [] chunks
 parseCell' :: GhcMonad m => String -> Int  -> m [CodeBlock]
 parseCell' code startLine = do
     flags <- getSessionDynFlags
-    let parseResults = map tryParser (parsers flags)
+    let parseResults = map (stmtToExprs flags . tryParser) (parsers flags)
     case rights parseResults of
       [] -> return [ParseError startLine 0 "Failed"]
       (result, used, remaining):_ -> do
         remainResult <- parseCell' remaining $ startLine + length (lines used)
-        return $ result : if null (strip remaining)
+        return $ result ++ if null (strip remaining)
                           then []
                           else remainResult
 
   where
+    -- Attempt to convert a statement to an expression
+    stmtToExprs :: DynFlags -> Either String (CodeBlock, String, String) -> Either String ([CodeBlock], String, String)
+    stmtToExprs flags (Right (Statement string, used, remaining)) = Right (blocks, used, remaining)
+      where blocks = if isExpr flags string
+                     then parseExpressions used
+                     else [Statement string]
+    stmtToExprs _ (Left err) = Left err
+    stmtToExprs _ (Right (block, used, remaining)) = Right ([block], used, remaining)
+
+    -- Check whether a string is a valid expression.
+    isExpr :: DynFlags -> String -> Bool
+    isExpr flags str = case runParser flags fullExpression str of
+      Left _ -> False
+      Right _ -> True
+
+    parseExpressions :: String -> [CodeBlock]
+    parseExpressions string = map Expression $ filter (not . null) $ map strip $ separateByIndent string
+
+    separateByIndent string = 
+      let (first, rest) = splitByIndent (lines string) in
+        first : if null rest
+                then []
+                else separateByIndent (unlines rest)
+
+    splitByIndent :: [String] -> (String, [String])
+    splitByIndent (first:rest) = (unlines $ first:take endOfBlock rest, drop endOfBlock rest)
+      where
+        endOfBlock = fromMaybe (length rest) $ findIndex (\x -> indentLevel x <= indentLevel first) rest
+
+    indentLevel (' ':str) = 1 + indentLevel str
+    indentLevel _ = 0 :: Int
+
     tryParser :: (String -> CodeBlock, String -> (Either String String, String, String)) -> Either String (CodeBlock, String, String)
     tryParser (blockType, parser) = case parser code of
       (Left err, _, _) -> Left err
       (Right res, used, remaining) -> Right (blockType res, used, remaining)
     parsers flags =
       [ (Import,      strParser flags partialImport)
-      , (Expression,  strParser flags partialExpression)
       , (Statement,   strParser flags partialStatement)
       , (Declaration, lstParser flags partialDeclaration)
       ]
@@ -177,7 +212,7 @@ runParser dflags parser str = toEither (unP parser (mkPState dflags buffer locat
 
        toEither (PFailed span err) = Left $ printErrorBag $ unitBag $ mkPlainErrMsg dflags span err
        toEither (POk parseState result) = 
-         let parseEnd = loc parseState
+         let parseEnd = realSrcSpanStart $ last_loc parseState
              endLine = srcLocLine parseEnd
              endCol = srcLocCol parseEnd
              (before, after) = splitAtLoc endLine endCol str in
@@ -186,13 +221,17 @@ runParser dflags parser str = toEither (unP parser (mkPState dflags buffer locat
        -- Convert the bag of errors into an error string.
        printErrorBag bag = unlines . map show $ bagToList bag
 
--- | Split a string at a given line and column.
+-- | Split a string at a given line and column. The column is included in
+-- the second part of the split.
 --
 -- >>> splitAtLoc 2 3 "abc\ndefghi\nxyz\n123"
--- ("abc\ndef","ghi\nxyz\n123")
+-- ("abc\nde","fghi\nxyz\n123")
 --
 -- >>> splitAtLoc 2 1 "abc"
 -- ("abc","")
+--
+-- >>> splitAtLoc 2 1 "abc\nhello"
+-- ("abc\n","hello")
 splitAtLoc :: LineNumber -> ColumnNumber -> String -> (String, String)
 splitAtLoc line col string = 
   if line > length (lines string)
@@ -201,10 +240,10 @@ splitAtLoc line col string =
   where
     (beforeLines, afterLines) = splitAt line $ lines string
     theLine = last beforeLines
-    (beforeChars, afterChars) = splitAt col theLine
+    (beforeChars, afterChars) = splitAt (col - 1) theLine
 
     -- Not the same as 'unlines', due to trailing \n
     joinLines = intercalate "\n"
 
     before = joinLines (init beforeLines) ++ '\n' : beforeChars
-    after = afterChars ++ '\n' : joinLines afterLines
+    after = joinLines $ afterChars : afterLines