{-# LANGUAGE QuasiQuotes, OverloadedStrings, ExtendedDefaultRules, CPP #-} -- Keep all the language pragmas here so it can be compiled separately. module Main where import Prelude import qualified Data.Text as T import GHC hiding (Qualified) import GHC.Paths import Data.IORef import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO) import Data.List import System.Directory import Shelly (Sh, shelly, cmd, (), toTextIgnore, cd, withTmpDir, mkdir_p, touchfile, fromText) import qualified Data.Text as T import qualified Shelly import Control.Applicative ((<$>)) import System.SetEnv (setEnv) import Data.String.Here import Data.Monoid import IHaskell.Eval.Parser import IHaskell.Types import IHaskell.IPython import IHaskell.Eval.Evaluate as Eval hiding (liftIO) import qualified IHaskell.Eval.Evaluate as Eval (liftIO) import IHaskell.Eval.Completion import IHaskell.Eval.ParseShell import Debug.Trace import Test.Hspec import Test.Hspec.HUnit import Test.HUnit (assertBool, assertFailure) lstrip :: String -> String lstrip = dropWhile (`elem` (" \t\r\n" :: String)) rstrip :: String -> String rstrip = reverse . lstrip . reverse strip :: String -> String strip = rstrip . lstrip replace :: String -> String -> String -> String replace needle replacement haystack = T.unpack $ T.replace (T.pack needle) (T.pack replacement) (T.pack haystack) traceShowId x = traceShow x x doGhc = runGhc (Just libdir) parses str = do res <- doGhc $ parseString str return $ map unloc res like parser desired = parser >>= (`shouldBe` desired) is string blockType = do result <- doGhc $ parseString string map unloc result `shouldBe` [blockType $ strip string] eval string = do outputAccum <- newIORef [] pagerAccum <- newIORef [] let publish evalResult = case evalResult of IntermediateResult {} -> return () FinalResult outs page [] -> do modifyIORef outputAccum (outs :) modifyIORef pagerAccum (page :) noWidgetHandling s _ = return s getTemporaryDirectory >>= setCurrentDirectory let state = defaultKernelState { getLintStatus = LintOff } interpret libdir False $ const $ Eval.evaluate state string publish noWidgetHandling out <- readIORef outputAccum pagerOut <- readIORef pagerAccum return (reverse out, unlines . map extractPlain . reverse $ pagerOut) evaluationComparing comparison string = 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 becomes string expected = evaluationComparing comparison string where comparison :: ([Display], String) -> IO () comparison (results, pageOut) = do when (length results /= length expected) $ 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 pages string expected = evaluationComparing comparison string where comparison (results, pageOut) = strip (stripHtml pageOut) `shouldBe` strip (unlines expected) -- A very, very hacky method for removing HTML stripHtml str = go str where go ('<':str) = case stripPrefix "script" str of Nothing -> go' str Just str -> dropScriptTag str go (x:xs) = x : go xs go [] = [] go' ('>':str) = go str go' (x:xs) = go' xs go' [] = error $ "Unending bracket html tag in string " ++ str dropScriptTag str = case stripPrefix "" str of Just str -> go str Nothing -> dropScriptTag $ tail str readCompletePrompt :: String -> (String, Int) -- | @readCompletePrompt "xs*ys"@ return @(xs, i)@ where i is the location of -- @'*'@ in the input string. readCompletePrompt string = case elemIndex '*' string of Nothing -> error "Expected cursor written as '*'." Just idx -> (replace "*" "" string, idx) completes string expected = completionTarget newString cursorloc `shouldBe` expected where (newString, cursorloc) = readCompletePrompt string completionEvent :: String -> Interpreter (String, [String]) completionEvent string = complete newString cursorloc where (newString, cursorloc) = case elemIndex '*' string of Nothing -> error "Expected cursor written as '*'." Just idx -> (replace "*" "" string, idx) completionEventInDirectory :: String -> IO (String, [String]) completionEventInDirectory string = withHsDirectory $ const $ completionEvent string shouldHaveCompletionsInDirectory :: String -> [String] -> IO () shouldHaveCompletionsInDirectory string expected = do (matched, completions) <- completionEventInDirectory string let existsInCompletion = (`elem` completions) unmatched = filter (not . existsInCompletion) expected expected `shouldBeAmong` completions completionHas string expected = do (matched, completions) <- doGhc $ do initCompleter completionEvent string let existsInCompletion = (`elem` completions) unmatched = filter (not . existsInCompletion) expected expected `shouldBeAmong` completions initCompleter :: Interpreter () 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 IHaskell.Display", "import Data.Maybe as Maybe"] setContext $ map IIDecl imports inDirectory :: [Shelly.FilePath] -- ^ directories relative to temporary directory -> [Shelly.FilePath] -- ^ files relative to temporary directory -> (Shelly.FilePath -> Interpreter a) -> IO a -- | Run an Interpreter action, but first make a temporary directory -- with some files and folder and cd to it. inDirectory dirs files action = shelly $ withTmpDir $ \dirPath -> do cd dirPath mapM_ mkdir_p dirs mapM_ touchfile files liftIO $ doGhc $ wrap (T.unpack $ toTextIgnore dirPath) (action dirPath) where cdEvent path = liftIO $ setCurrentDirectory path --Eval.evaluate defaultKernelState (":! cd " ++ path) noPublish wrap :: FilePath -> Interpreter a -> Interpreter a wrap path action = do initCompleter pwd <- Eval.liftIO getCurrentDirectory cdEvent path -- change to the temporary directory out <- action -- run action cdEvent pwd -- change back to the original directory return out withHsDirectory :: (Shelly.FilePath -> Interpreter a) -> IO a withHsDirectory = inDirectory [p "" p "dir", p "dir" p "dir1"] [p "" p "file1.hs", p "dir" p "file2.hs", p "" p "file1.lhs", p "dir" p "file2.lhs"] where p :: FilePath -> FilePath p = id main :: IO () main = hspec $ do parserTests evalTests completionTests completionTests = do parseShellTests 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." 12 ["Data", ""] `shouldBe` ModuleName "Data" "" completionType "import Prel" 11 ["Prel"] `shouldBe` ModuleName "" "Prel" completionType "import D.B.M" 12 ["D", "B", "M"] `shouldBe` ModuleName "D.B" "M" completionType " import A." 10 ["A", ""] `shouldBe` ModuleName "A" "" completionType "import a.x" 10 ["a", "x"] `shouldBe` Identifier "x" completionType "A.x" 3 ["A", "x"] `shouldBe` Qualified "A" "x" completionType "a.x" 3 ["a", "x"] `shouldBe` Identifier "x" completionType "pri" 3 ["pri"] `shouldBe` Identifier "pri" completionType ":load A" 7 ["A"] `shouldBe` HsFilePath ":load A" "A" completionType ":! cd " 6 [""] `shouldBe` FilePath ":! cd " "" 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"] it "properly completes haskell file paths on :load directive" $ let loading xs = ":load " ++ T.unpack (toTextIgnore xs) paths = map (T.unpack . toTextIgnore) in do loading ("dir" "file*") `shouldHaveCompletionsInDirectory` paths ["dir" "file2.hs", "dir" "file2.lhs"] loading ("" "file1*") `shouldHaveCompletionsInDirectory` paths ["" "file1.hs", "" "file1.lhs"] loading ("" "file1*") `shouldHaveCompletionsInDirectory` paths ["" "file1.hs", "" "file1.lhs"] loading ("" "./*") `shouldHaveCompletionsInDirectory` paths ["./" "dir/" , "./" "file1.hs" , "./" "file1.lhs"] loading ("" "./*") `shouldHaveCompletionsInDirectory` paths ["./" "dir/" , "./" "file1.hs" , "./" "file1.lhs"] it "provides path completions on empty shell cmds " $ ":! cd *" `shouldHaveCompletionsInDirectory` map (T.unpack . toTextIgnore) ["" "dir/" , "" "file1.hs" , "" "file1.lhs"] let withHsHome action = withHsDirectory $ \dirPath-> do home <- shelly $ Shelly.get_env_text "HOME" setHomeEvent dirPath result <- action setHomeEvent $ Shelly.fromText home return result setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path) it "correctly interprets ~ as the environment HOME variable" $ let shouldHaveCompletions :: String -> [String] -> IO () shouldHaveCompletions string expected = do (matched, completions) <- withHsHome $ completionEvent string let existsInCompletion = (`elem` completions) unmatched = filter (not . existsInCompletion) expected expected `shouldBeAmong` completions in do ":! cd ~/*" `shouldHaveCompletions` ["~/dir/"] ":! ~/*" `shouldHaveCompletions` ["~/dir/"] ":load ~/*" `shouldHaveCompletions` ["~/dir/"] ":l ~/*" `shouldHaveCompletions` ["~/dir/"] let shouldHaveMatchingText :: String -> String -> IO () shouldHaveMatchingText string expected = do matchText <- withHsHome $ fst <$> uncurry complete (readCompletePrompt string) matchText `shouldBe` expected setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path) it "generates the correct matchingText on `:! cd ~/*` " $ do ":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String) it "generates the correct matchingText on `:load ~/*` " $ do ":load ~/*" `shouldHaveMatchingText` ("~/" :: String) it "generates the correct matchingText on `:l ~/*` " $ do ":l ~/*" `shouldHaveMatchingText` ("~/" :: String) 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 flags" $ do ":set -package hello" `becomes` ["Warning: -package not supported yet"] ":set -XNoImplicitPrelude" `becomes` [] 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` ["3 :: forall a. Num a => a"] ":k Maybe" `becomes` ["Maybe :: * -> *"] #if MIN_VERSION_ghc(7, 8, 0) ":in String" `pages` ["type String = [Char] \t-- Defined in \8216GHC.Base\8217"] #else ":in String" `pages` ["type String = [Char] \t-- Defined in `GHC.Base'"] #endif parserTests = do layoutChunkerTests moduleNameTests parseStringTests layoutChunkerTests = describe "Layout Chunk" $ do it "chunks 'a string'" $ map unloc (layoutChunks "a string") `shouldBe` ["a string"] it "chunks 'a\\n string'" $ map unloc (layoutChunks "a\n string") `shouldBe` ["a\n string"] it "chunks 'a\\n string\\nextra'" $ map unloc (layoutChunks "a\n string\nextra") `shouldBe` ["a\n string","extra"] it "chunks strings with too many lines" $ map unloc (layoutChunks "a\n\nstring") `shouldBe` ["a","string"] it "parses multiple exprs" $ do let text = [hereLit| first second third fourth |] layoutChunks text `shouldBe` [Located 2 "first", Located 4 "second", Located 5 "third", Located 7 "fourth"] 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 SetDynFlag "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` [ #if MIN_VERSION_ghc(7, 8, 0) ParseError (Loc 1 10) "Illegal literal in type (use DataKinds to enable): 3" #else ParseError (Loc 1 10) "Illegal literal in type (use -XDataKinds to enable): 3" #endif ] 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 it "correctly locates parsed items" $ do let go = doGhc . parseString go [hereLit| first second |] >>= (`shouldBe` [Located 2 (Expression "first"), Located 4 (Expression "second")]) parseShellTests = describe "Parsing Shell Commands" $ do test "A" ["A"] test ":load A" [":load", "A"] test ":!l ~/Downloads/MyFile\\ Has\\ Spaces.txt" [":!l", "~/Downloads/MyFile\\ Has\\ Spaces.txt"] test ":!l \"~/Downloads/MyFile Has Spaces.txt\" /Another/File\\ WithSpaces.doc" [":!l", "~/Downloads/MyFile Has Spaces.txt", "/Another/File\\ WithSpaces.doc" ] where test string expected = it ("parses " ++ string ++ " correctly") $ string `shouldParseTo` expected shouldParseTo xs ys = fun ys (parseShell xs) where fun ys (Right xs') = xs' `shouldBe` ys fun ys (Left e) = assertFailure $ "parseShell returned error: \n" ++ show e -- Useful HSpec expectations ---- --------------------------------- shouldBeAmong :: (Show a, Eq a) => [a] -> [a] -> Expectation -- | -- @sublist \`shouldbeAmong\` list@ sets the expectation that @sublist@ elements are -- among those in @list@. sublist `shouldBeAmong` list = assertBool errorMsg $ and [x `elem` list | x <- sublist] where errorMsg = show list ++ " doesn't contain " ++ show sublist