{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} {-# LANGUAGE CPP #-} -- Shelly's types are kinda borked. {-# OPTIONS_GHC -Wno-type-defaults #-} module IHaskell.Test.Completion (testCompletions) where import Prelude import Data.List (elemIndex) import qualified Data.Text as T import Control.Monad.IO.Class (liftIO) import System.Environment (setEnv) import System.Directory (setCurrentDirectory, getCurrentDirectory) import GHC (getSessionDynFlags, setSessionDynFlags, DynFlags(..), GhcLink(..), setContext, parseImportDecl, HscTarget(..), InteractiveImport(..)) import Test.Hspec import Shelly (toTextIgnore, (), shelly, fromText, get_env_text, FilePath, cd, mkdir_p, touchfile, withTmpDir) import IHaskell.Eval.Evaluate (Interpreter, liftIO) import IHaskell.Eval.Completion (complete, CompletionType(..), completionType, completionTarget) import IHaskell.Test.Util (replace, shouldBeAmong, ghc) -- | @readCompletePrompt "xs*ys"@ return @(xs, i)@ where i is the location of -- @'*'@ in the input string. readCompletePrompt :: String -> (String, Int) readCompletePrompt string = case elemIndex '*' string of Nothing -> error "Expected cursor written as '*'." Just idx -> (replace "*" "" string, idx) 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 (_, completions) <- completionEventInDirectory string expected `shouldBeAmong` completions completionHas :: String -> [String] -> IO () completionHas string expected = do (_, completions) <- ghc $ do initCompleter completionEvent string 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 completes :: String -> [String] -> IO () completes string expected = completionTarget newString cursorloc `shouldBe` expected where (newString, cursorloc) = readCompletePrompt string testCompletions :: Spec testCompletions = do testIdentifierCompletion testCommandCompletion testIdentifierCompletion :: Spec testIdentifierCompletion = 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` [] "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"] testCommandCompletion :: Spec testCommandCompletion = describe "Completes commands" $ do it "properly completes haskell file paths on :load directive" $ do let loading xs = ":load " ++ T.unpack (toTextIgnore xs) paths = map (T.unpack . toTextIgnore) testInDirectory start comps = loading start `shouldHaveCompletionsInDirectory` paths comps testInDirectory ("dir" "file*") ["dir" "file2.hs", "dir" "file2.lhs"] testInDirectory ("" "file1*") ["" "file1.hs", "" "file1.lhs"] testInDirectory ("" "file1*") ["" "file1.hs", "" "file1.lhs"] testInDirectory ("" "./*") ["./" "dir/", "./" "file1.hs", "./" "file1.lhs"] testInDirectory ("" "./*") ["./" "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" $ do let shouldHaveCompletions :: String -> [String] -> IO () shouldHaveCompletions string expected = do (_, completions) <- withHsHome $ completionEvent string expected `shouldBeAmong` completions ":! 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 it "generates the correct matchingText on `:! cd ~/*` " $ ":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String) it "generates the correct matchingText on `:load ~/*` " $ ":load ~/*" `shouldHaveMatchingText` ("~/" :: String) it "generates the correct matchingText on `:l ~/*` " $ ":l ~/*" `shouldHaveMatchingText` ("~/" :: String) 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 $ ghc $ wrap (T.unpack $ toTextIgnore dirPath) (action dirPath) where cdEvent path = liftIO $ setCurrentDirectory path wrap :: String -> Interpreter a -> Interpreter a wrap path actn = do initCompleter pwd <- IHaskell.Eval.Evaluate.liftIO getCurrentDirectory cdEvent path -- change to the temporary directory out <- actn -- 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 :: T.Text -> T.Text p = id