ihaskell-0.2.0.2: Hspec.hs

{-# LANGUAGE QuasiQuotes #-}
import GHC
import GHC.Paths
import Data.IORef
import Control.Monad
import Data.List
import System.Directory
import Data.String.Here
import Data.String.Utils (strip, replace)

import IHaskell.Eval.Parser
import IHaskell.Types
import IHaskell.IPython
import IHaskell.Eval.Evaluate as Eval
import IHaskell.Eval.Completion

import Test.Hspec
import Test.Hspec.HUnit

doGhc = runGhc (Just libdir)

parses = doGhc . parseString

like parser desired = parser >>= (`shouldBe` desired)

is string blockType = do
  result <- doGhc $ parseString string
  result `shouldBe` [blockType $ strip string]

eval string = do
  outputAccum <- newIORef []
  let publish _ displayDatas = modifyIORef outputAccum (displayDatas :)
  getTemporaryDirectory >>= setCurrentDirectory
  interpret $ Eval.evaluate 1 string publish
  out <- readIORef outputAccum
  return $ reverse out

becomes string expected = do
    let indent (' ':x) = 1 + indent x
        indent _ = 0
        empty = null . strip
        stringLines = filter (not . empty) $ lines string
        minIndent = minimum (map indent stringLines)
        newString = unlines $ map (drop minIndent) stringLines
    eval newString >>= comparison
  where 
    comparison results = do
      when (length results /= length expected) $
        expectationFailure $ "Expected result to have " ++ show (length expected)
                             ++ " results. Got " ++ show results

      let isPlain (Display PlainText _) = True
          isPlain _ = False

      forM_ (zip results expected) $ \(result, expected) ->
        case find isPlain result of
          Just (Display PlainText str) -> str `shouldBe` expected
          Nothing -> expectationFailure $ "No plain-text output in " ++ show result

completes string expected = completionTarget newString cursorloc `shouldBe` expected
  where (newString, cursorloc) = case elemIndex '!' string of
          Nothing -> error "Expected cursor written as '!'."
          Just idx -> (replace "!" "" string, idx)

completionHas string expected = do
    (matched, completions) <- doGhc $ do
      initCompleter
      complete newString cursorloc
    let existsInCompletion =  (`elem` completions)
        unmatched = filter (not . existsInCompletion) expected
    unmatched `shouldBe` []
  where (newString, cursorloc) = case elemIndex '!' string of
          Nothing -> error "Expected cursor written as '!'."
          Just idx -> (replace "!" "" string, idx)

initCompleter :: GhcMonad m => m ()
initCompleter = do
  flags <- getSessionDynFlags
  setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory }

  -- Import modules.
  imports <- mapM parseImportDecl ["import Prelude",
                                  "import qualified Control.Monad",
                                  "import qualified Data.List as List",
                                  "import Data.Maybe as Maybe"]
  setContext $ map IIDecl imports

main :: IO ()
main = hspec $ do
  parserTests
  ipythonTests
  evalTests
  completionTests

completionTests = do
  describe "Completion" $ do
    it "correctly gets the completion identifier without dots" $ do
       "hello!"              `completes` ["hello"]
       "hello aa!bb goodbye" `completes` ["aa"]
       "hello aabb! goodbye" `completes` ["aabb"]
       "aacc! goodbye"       `completes` ["aacc"]
       "hello !aabb goodbye" `completes` []
       "!aabb goodbye"       `completes` []

    it "correctly gets the completion identifier with dots" $ do
       "hello test.aa!bb goodbye" `completes` ["test", "aa"]
       "Test.!"                   `completes` ["Test", ""]
       "Test.Thing!"              `completes` ["Test", "Thing"]
       "Test.Thing.!"             `completes` ["Test", "Thing", ""]
       "Test.Thing.!nope"         `completes` ["Test", "Thing", ""]

    it "correctly gets the completion type" $ do
      completionType "import Data." ["Data", ""]      `shouldBe` ModuleName "Data" ""
      completionType "import Prel" ["Prel"]           `shouldBe` ModuleName "" "Prel"
      completionType "import D.B.M" ["D", "B", "M"]   `shouldBe` ModuleName "D.B" "M"
      completionType " import A." ["A", ""]           `shouldBe` ModuleName "A" ""
      completionType "import a.x" ["a", "x"]          `shouldBe` Identifier "x"
      completionType "A.x" ["A", "x"]                 `shouldBe` Qualified "A" "x"
      completionType "a.x" ["a", "x"]                 `shouldBe` Identifier "x"
      completionType "pri" ["pri"]                    `shouldBe` Identifier "pri"

    it "properly completes identifiers" $ do
       "pri!"           `completionHas` ["print"]
       "ma!"            `completionHas` ["map"]
       "hello ma!"      `completionHas` ["map"]
       "print $ catMa!" `completionHas` ["catMaybes"]

    it "properly completes qualified identifiers" $ do
       "Control.Monad.liftM!"    `completionHas` [ "Control.Monad.liftM"
                                                 , "Control.Monad.liftM2"
                                                 , "Control.Monad.liftM5"]
       "print $ List.intercal!"  `completionHas` ["List.intercalate"]
       "print $ Data.Maybe.cat!" `completionHas` ["Data.Maybe.catMaybes"]
       "print $ Maybe.catM!"     `completionHas` ["Maybe.catMaybes"]

    it "properly completes imports" $ do
      "import Data.!"  `completionHas` ["Data.Maybe", "Data.List"]
      "import Data.M!" `completionHas` ["Data.Maybe"]
      "import Prel!"   `completionHas` ["Prelude"]

evalTests = do
  describe "Code Evaluation" $ do
    it "evaluates expressions" $  do
      "3" `becomes` ["3"]
      "3+5" `becomes` ["8"]
      "print 3" `becomes` ["3"]
      [hereLit|
        let x = 11
            z = 10 in
          x+z
      |] `becomes` ["21"]

    it "evaluates multiline expressions" $  do
      [hereLit|
        import Control.Monad
        forM_ [1, 2, 3] $ \x ->
          print x
      |] `becomes` ["1\n2\n3"]

    it "evaluates function declarations silently" $ do
      [hereLit|
        fun :: [Int] -> Int
        fun [] = 3
        fun (x:xs) = 10
        fun [1, 2]
      |] `becomes` ["10"]

    it "evaluates data declarations" $ do
      [hereLit|
        data X = Y Int
               | Z String
               deriving (Show, Eq)
        print [Y 3, Z "No"]
        print (Y 3 == Z "No")
      |] `becomes` ["[Y 3,Z \"No\"]", "False"]

    it "evaluates do blocks in expressions" $ do
      [hereLit|
        show (show (do
            Just 10
            Nothing
            Just 100))
      |] `becomes` ["\"\\\"Nothing\\\"\""]

    it "is silent for imports" $ do
      "import Control.Monad" `becomes` []
      "import qualified Control.Monad" `becomes` []
      "import qualified Control.Monad as CM" `becomes` []
      "import Control.Monad (when)" `becomes` []

    it "evaluates directives" $ do
      ":typ 3" `becomes` ["forall a. Num a => a"]
      ":in String" `becomes` ["type String = [Char] \t-- Defined in `GHC.Base'"]

ipythonTests = do
  describe "Parse IPython Version" $ do
    it "parses 2.0.0-dev" $
      parseVersion "2.0.0-dev" `shouldBe` [2, 0, 0]
    it "parses 2.0.0-alpha" $
      parseVersion "2.0.0-dev" `shouldBe` [2, 0, 0]
    it "parses 12.5.10" $
      parseVersion "12.5.10" `shouldBe` [12, 5, 10]

parserTests = do
  layoutChunkerTests
  moduleNameTests
  parseStringTests

layoutChunkerTests = describe "Layout Chunk" $ do
  it "chunks 'a string'" $
    layoutChunks "a string" `shouldBe` ["a string"]

  it "chunks 'a\\nstring'" $
    layoutChunks "a\n string" `shouldBe` ["a\n string"]

  it "chunks 'a\\n string\\nextra'" $
    layoutChunks "a\n string\nextra" `shouldBe` ["a\n string","extra"]

  it "chunks strings with too many lines" $
    layoutChunks "a\n\nstring" `shouldBe` ["a","string"]

moduleNameTests = describe "Get Module Name" $ do
  it "parses simple module names" $
    "module A where\nx = 3" `named` ["A"]
  it "parses module names with dots" $
    "module A.B where\nx = 3" `named` ["A", "B"]
  it "parses module names with exports" $
    "module A.B.C ( x ) where x = 3" `named` ["A", "B", "C"]
  it "errors when given unnamed modules" $ do
    doGhc (getModuleName "x = 3") `shouldThrow` anyException
  where
    named str result = do
      res <- doGhc $ getModuleName str
      res `shouldBe` result

parseStringTests = describe "Parser" $ do
  it "parses empty strings" $
    parses "" `like` []

  it "parses simple imports" $
    "import Data.Monoid" `is` Import

  it "parses simple arithmetic" $
    "3 + 5" `is` Expression

  it "parses :type" $
    parses ":type x\n:ty x" `like` [
      Directive GetType "x",
      Directive GetType "x"
    ]

  it "parses :info" $
    parses ":info x\n:in x" `like` [
      Directive GetInfo "x",
      Directive GetInfo "x"
    ]

  it "parses :help and :?" $
    parses ":? x\n:help x" `like` [
      Directive GetHelp "x",
      Directive GetHelp "x"
    ]

  it "parses :set x" $
    parses ":set x" `like` [
      Directive HelpForSet "x"
    ]

  it "parses :extension x" $
    parses ":ex x\n:extension x" `like` [
      Directive SetExtension "x",
      Directive SetExtension "x"
    ]

  it "fails to parse :nope" $ 
    parses ":nope goodbye" `like` [
      ParseError (Loc 1 1) "Unknown directive: 'nope'."
    ]

  it "parses number followed by let stmt" $
    parses "3\nlet x = expr"  `like` [
      Expression "3",
      Statement "let x = expr"
    ]

  it "parses let x in y" $
    "let x = 3 in x + 3" `is` Expression

  it "parses a data declaration" $
    "data X = Y Int" `is` Declaration

  it "parses number followed by type directive" $
    parses "3\n:t expr" `like` [
      Expression "3",
      Directive GetType "expr"
    ]

  it "parses a <- statement" $
    "y <- print 'no'" `is` Statement

  it "parses a <- stmt followed by let stmt" $
    parses "y <- do print 'no'\nlet x = expr" `like` [
      Statement "y <- do print 'no'",
      Statement "let x = expr"
    ]

  it "parses <- followed by let followed by expr" $
    parses "y <- do print 'no'\nlet x = expr\nexpression" `like` [
      Statement "y <- do print 'no'",
      Statement "let x = expr",
      Expression "expression"
    ]

  it "parses two print statements" $
    parses "print yes\nprint no" `like` [
      Expression "print yes",
      Expression "print no"
    ]

  it "parses a pattern-maching function declaration" $
    "fun [] = 10" `is` Declaration

  it "parses a function decl followed by an expression" $
    parses "fun [] = 10\nprint 'h'" `like` [
      Declaration "fun [] = 10",
      Expression "print 'h'"
    ]

  it "parses list pattern matching fun decl" $
    "fun (x : xs) = 100" `is` Declaration

  it "parses two pattern matches as the same declaration" $
    "fun [] = 10\nfun (x : xs) = 100" `is` Declaration

  it "parses a type signature followed by a declaration" $
    "fun :: [a] -> Int\nfun [] = 10\nfun (x : xs) = 100" `is` Declaration

  it "parases a simple module" $
    "module A where x = 3" `is` Module

  it "parses a module with an export" $
    "module B (x) where x = 3" `is` Module

  it "breaks when a let is incomplete" $
    parses "let x = 3 in" `like` [
      ParseError (Loc 1 13) "parse error (possibly incorrect indentation or mismatched brackets)"
    ]

  it "breaks without data kinds" $
    parses "data X = 3" `like` [
      ParseError (Loc 1 10) "Illegal literal in type (use -XDataKinds to enable): 3"
    ]

  it "parses statements after imports" $ do
    parses "import X\nprint 3" `like` [
        Import "import X",
        Expression "print 3" 
      ]
    parses "import X\n\nprint 3" `like` [
        Import "import X",
        Expression "print 3" 
      ]
  it "ignores blank lines properly" $ 
    [hereLit|
      test arg = hello
        where
          x = y

          z = w
    |] `is` Declaration
  it "doesn't break on long strings" $ do
    let longString = concat $ replicate 20 "hello "
    ("img ! src \"" ++ longString ++ "\" ! width \"500\"") `is` Expression

  it "parses do blocks in expression" $ do
    [hereLit|
      show (show (do
        Just 10
        Nothing
        Just 100))
    |] `is` Expression