From affadb74c07f925dd0ff69ae931e491849f63547 Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Tue, 30 Jan 2018 18:04:49 -0600 Subject: [PATCH 1/2] Improvments to REPL tab-completion - Complete all names that have been imported (transitively or directly) - Do not complete names that haven't been imported - Only recompute list of names after import or adding a let binding rather than after each request for name completion This commit fixes #3227 --- CONTRIBUTORS.md | 1 + app/Command/REPL.hs | 2 +- src/Language/PureScript/Interactive.hs | 3 +- .../PureScript/Interactive/Completion.hs | 93 ++++---------- src/Language/PureScript/Interactive/Module.hs | 13 +- src/Language/PureScript/Interactive/Types.hs | 116 +++++++++++++++--- src/Language/PureScript/Sugar/Names/Env.hs | 1 + tests/TestPsci/CommandTest.hs | 6 +- tests/TestPsci/CompletionTest.hs | 63 ++++++---- tests/TestPsci/TestEnv.hs | 2 +- 10 files changed, 178 insertions(+), 122 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 620c7929df..b87b25adf3 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -90,6 +90,7 @@ If you would prefer to use different terms, please use the section below instead | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | | [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | +| [@rndnoise](https://github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) | | [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | | [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | | [@Rufflewind](https://github.com/Rufflewind) | Phil Ruffwind | [MIT license](https://opensource.org/licenses/MIT) | diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 1b8199495d..c07db590d0 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -330,7 +330,7 @@ command = loop <$> options Right (modules, externs, env) -> do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } - initialState = PSCiState [] [] (zip (map snd modules) externs) + initialState = updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState config = PSCiConfig psciInputGlob env runner = flip runReaderT config . flip evalStateT initialState diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index ce051e9f3e..facde9e992 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -190,9 +190,8 @@ handleShowImportedModules => (String -> m ()) -> m () handleShowImportedModules print' = do - PSCiState { psciImportedModules = importedModules } <- get + importedModules <- psciImportedModules <$> get print' $ showModules importedModules - return () where showModules = unlines . sort . map (T.unpack . showModule) showModule (mn, declType, asQ) = diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 90d05ee871..8833eb46fa 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -9,19 +9,16 @@ module Language.PureScript.Interactive.Completion import Prelude.Compat import Protolude (ordNub) -import Control.Arrow (second) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) -import Data.Function (on) -import Data.List (nubBy, isPrefixOf, sortBy, stripPrefix) +import Data.List (nub, isPrefixOf, sortBy, stripPrefix) +import Data.Map (keys) import Data.Maybe (mapMaybe) -import Data.Text (Text) import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Interactive.Directive as D import Language.PureScript.Interactive.Types -import qualified Language.PureScript.Names as N import System.Console.Haskeline -- Completions may read the state, but not modify it. @@ -157,76 +154,36 @@ getLoadedModules = asks (map fst . psciLoadedExterns) getModuleNames :: CompletionM [String] getModuleNames = moduleNames <$> getLoadedModules -mapLoadedModulesAndQualify :: (a -> Text) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] -mapLoadedModulesAndQualify sho f = do - ms <- getLoadedModules - let argPairs = do m <- ms - fm <- f m - return (m, fm) - concat <$> traverse (uncurry (getAllQualifications sho)) argPairs - getIdentNames :: CompletionM [String] -getIdentNames = mapLoadedModulesAndQualify P.showIdent identNames - -getDctorNames :: CompletionM [String] -getDctorNames = mapLoadedModulesAndQualify P.runProperName dctorNames - -getTypeNames :: CompletionM [String] -getTypeNames = mapLoadedModulesAndQualify P.runProperName typeDecls - --- | Given a module and a declaration in that module, return all possible ways --- it could have been referenced given the current PSCiState - including fully --- qualified, qualified using an alias, and unqualified. -getAllQualifications :: (a -> Text) -> P.Module -> (a, P.Declaration) -> CompletionM [String] -getAllQualifications sho m (declName, decl) = do - imports <- getAllImportsOf m - let fullyQualified = qualifyWith (Just (P.getModuleName m)) - let otherQuals = ordNub (concatMap qualificationsUsing imports) - return $ fullyQualified : otherQuals - where - qualifyWith mMod = T.unpack (P.showQualified sho (P.Qualified mMod declName)) - referencedBy refs = P.isExported (Just refs) decl +getIdentNames = do + importedVals <- asks (keys . P.importedValues . psciImports) + exportedVals <- asks (keys . P.exportedValues . psciExports) - qualificationsUsing (_, importType, asQ') = - let q = qualifyWith asQ' - in case importType of - P.Implicit -> [q] - P.Explicit refs -> [q | referencedBy refs] - P.Hiding refs -> [q | not $ referencedBy refs] + importedValOps <- asks (keys . P.importedValueOps . psciImports) + exportedValOps <- asks (keys . P.exportedValueOps . psciExports) + return . nub $ map (T.unpack . P.showQualified P.showIdent) importedVals + ++ map (T.unpack . P.showQualified P.runOpName) importedValOps + ++ map (T.unpack . P.showIdent) exportedVals + ++ map (T.unpack . P.runOpName) exportedValOps --- | Returns all the ImportedModule values referring to imports of a particular --- module. -getAllImportsOf :: P.Module -> CompletionM [ImportedModule] -getAllImportsOf = asks . allImportsOf +getDctorNames :: CompletionM [String] +getDctorNames = do + imports <- asks (keys . P.importedDataConstructors . psciImports) + return . nub $ map (T.unpack . P.showQualified P.runProperName) imports -nubOnFst :: Eq a => [(a, b)] -> [(a, b)] -nubOnFst = nubBy ((==) `on` fst) +getTypeNames :: CompletionM [String] +getTypeNames = do + importedTypes <- asks (keys . P.importedTypes . psciImports) + exportedTypes <- asks (keys . P.exportedTypes . psciExports) -typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)] -typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations - where - getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration) - getTypeName d@(P.TypeSynonymDeclaration _ name _ _) = Just (name, d) - getTypeName d@(P.DataDeclaration _ _ name _ _) = Just (name, d) - getTypeName _ = Nothing + importedTypeOps <- asks (keys . P.importedTypeOps . psciImports) + exportedTypeOps <- asks (keys . P.exportedTypeOps . psciExports) -identNames :: P.Module -> [(N.Ident, P.Declaration)] -identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations - where - getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)] - getDeclNames d@(P.ValueDecl _ ident _ _ _) = [(ident, d)] - getDeclNames d@(P.TypeDeclaration td) = [(P.tydeclIdent td, d)] - getDeclNames d@(P.ExternDeclaration _ ident _) = [(ident, d)] - getDeclNames d@(P.TypeClassDeclaration _ _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds - getDeclNames _ = [] - -dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)] -dctorNames = nubOnFst . concatMap go . P.exportedDeclarations - where - go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)] - go decl@(P.DataDeclaration _ _ _ _ ctors) = map ((\n -> (n, decl)) . fst) ctors - go _ = [] + return . nub $ map (T.unpack . P.showQualified P.runProperName) importedTypes + ++ map (T.unpack . P.showQualified P.runOpName) importedTypeOps + ++ map (T.unpack . P.runProperName) exportedTypes + ++ map (T.unpack . P.runOpName) exportedTypeOps moduleNames :: [P.Module] -> [String] moduleNames = ordNub . map (T.unpack . P.runModuleName . P.getModuleName) diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index a7855cdb68..1984471b2f 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -43,8 +43,10 @@ loadAllModules files = do -- Makes a volatile module to execute the current expression. -- createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module -createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val = +createTemporaryModule exec st val = let + imports = psciImportedModules st + lets = psciLetBindings st moduleName = P.ModuleName [P.ProperName "$PSCI"] effModuleName = P.moduleNameFromString "Control.Monad.Eff" effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Eff"])) @@ -73,10 +75,12 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi -- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration. -- createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module -createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = +createTemporaryModuleForKind st typ = let + imports = psciImportedModules st + lets = psciLetBindings st moduleName = P.ModuleName [P.ProperName "$PSCI"] - itDecl = P.TypeSynonymDeclaration (internalSpan, []) (P.ProperName "IT") [] typ + itDecl = P.TypeSynonymDeclaration (internalSpan, []) (P.ProperName "IT") [] typ in P.Module internalSpan [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing @@ -84,8 +88,9 @@ createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBin -- Makes a volatile module to execute the current imports. -- createTemporaryModuleForImports :: PSCiState -> P.Module -createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = +createTemporaryModuleForImports st = let + imports = psciImportedModules st moduleName = P.ModuleName [P.ProperName "$PSCI"] in P.Module internalSpan [] moduleName (importDecl `map` imports) Nothing diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 003b90b100..15e1427024 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -1,11 +1,38 @@ -- | -- Type declarations and associated basic functions for PSCI. -- -module Language.PureScript.Interactive.Types where +module Language.PureScript.Interactive.Types + ( PSCiConfig(..) + , PSCiState -- constructor is not exported, to prevent psciImports and psciExports from + -- becoming inconsistent with importedModules, letBindings and loadedExterns + , ImportedModule + , psciExports + , psciImports + , psciLoadedExterns + , psciImportedModules + , psciLetBindings + , initialPSCiState + , psciImportedModuleNames + , updateImportedModules + , updateLoadedExterns + , updateLets + , Command(..) + , ReplQuery(..) + , replQueries + , replQueryStrings + , showReplQuery + , parseReplQuery + , Directive(..) + ) where import Prelude.Compat import qualified Language.PureScript as P +import qualified Data.Map as M +import Language.PureScript.Sugar.Names.Env (nullImports, primExports) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Writer.Strict (runWriterT) + -- | The PSCI configuration. -- @@ -19,16 +46,37 @@ data PSCiConfig = PSCiConfig -- | The PSCI state. -- -- Holds a list of imported modules, loaded files, and partial let bindings. --- The let bindings are partial, --- because it makes more sense to apply the binding to the final evaluated expression. +-- The let bindings are partial, because it makes more sense to apply the +-- binding to the final evaluated expression. +-- +-- The last two fields are derived from the first three via updateImportExports +-- each time a module is imported, a let binding is added, or the session is +-- cleared or reloaded data PSCiState = PSCiState - { psciImportedModules :: [ImportedModule] - , psciLetBindings :: [P.Declaration] - , psciLoadedExterns :: [(P.Module, P.ExternsFile)] - } deriving Show + [ImportedModule] + [P.Declaration] + [(P.Module, P.ExternsFile)] + P.Imports + P.Exports + deriving Show + +psciImportedModules :: PSCiState -> [ImportedModule] +psciImportedModules (PSCiState x _ _ _ _) = x + +psciLetBindings :: PSCiState -> [P.Declaration] +psciLetBindings (PSCiState _ x _ _ _) = x + +psciLoadedExterns :: PSCiState -> [(P.Module, P.ExternsFile)] +psciLoadedExterns (PSCiState _ _ x _ _) = x + +psciImports :: PSCiState -> P.Imports +psciImports (PSCiState _ _ _ x _) = x + +psciExports :: PSCiState -> P.Exports +psciExports (PSCiState _ _ _ _ x) = x initialPSCiState :: PSCiState -initialPSCiState = PSCiState [] [] [] +initialPSCiState = PSCiState [] [] [] nullImports primExports -- | All of the data that is contained by an ImportDeclaration in the AST. -- That is: @@ -42,29 +90,59 @@ initialPSCiState = PSCiState [] [] [] type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) psciImportedModuleNames :: PSCiState -> [P.ModuleName] -psciImportedModuleNames PSCiState{psciImportedModules = is} = - map (\(mn, _, _) -> mn) is +psciImportedModuleNames st = + map (\(mn, _, _) -> mn) (psciImportedModules st) + +-- * State helpers -allImportsOf :: P.Module -> PSCiState -> [ImportedModule] -allImportsOf m PSCiState{psciImportedModules = is} = - filter isImportOfThis is +-- This function updates the Imports and Exports values in the PSCiState, which are used for +-- handling completions. This function must be called whenever the PSCiState is modified to +-- ensure that completions remain accurate. +updateImportExports :: PSCiState -> PSCiState +updateImportExports st@(PSCiState modules lets externs _ _) = + case desugarModule [temporaryModule] of + Left _ -> st -- TODO: can this fail and what should we do? + Right (env, _) -> + case M.lookup temporaryName env of + Just (_, is, es) -> PSCiState modules lets externs is es + _ -> st -- impossible where - name = P.getModuleName m - isImportOfThis (name', _, _) = name == name' --- * State helpers + desugarModule :: [P.Module] -> Either P.MultipleErrors (P.Env, [P.Module]) + desugarModule = runExceptT =<< hushWarnings . P.desugarImportsWithEnv (map snd externs) + hushWarnings = fmap fst . runWriterT + + temporaryName :: P.ModuleName + temporaryName = P.ModuleName [P.ProperName "$PSCI"] + + temporaryModule :: P.Module + temporaryModule = + let + prim = (P.ModuleName [P.ProperName "Prim"], P.Implicit, Nothing) + decl = (importDecl `map` (prim : modules)) ++ lets + in + P.Module internalSpan [] temporaryName decl Nothing + + importDecl :: ImportedModule -> P.Declaration + importDecl (mn, declType, asQ) = P.ImportDeclaration (internalSpan, []) mn declType asQ + + internalSpan :: P.SourceSpan + internalSpan = P.internalModuleSourceSpan "" -- | Updates the imported modules in the state record. updateImportedModules :: ([ImportedModule] -> [ImportedModule]) -> PSCiState -> PSCiState -updateImportedModules f st = st { psciImportedModules = f (psciImportedModules st) } +updateImportedModules f (PSCiState x a b c d) = + updateImportExports (PSCiState (f x) a b c d) -- | Updates the loaded externs files in the state record. updateLoadedExterns :: ([(P.Module, P.ExternsFile)] -> [(P.Module, P.ExternsFile)]) -> PSCiState -> PSCiState -updateLoadedExterns f st = st { psciLoadedExterns = f (psciLoadedExterns st) } +updateLoadedExterns f (PSCiState a b x c d) = + PSCiState a b (f x) c d -- | Updates the let bindings in the state record. updateLets :: ([P.Declaration] -> [P.Declaration]) -> PSCiState -> PSCiState -updateLets f st = st { psciLetBindings = f (psciLetBindings st) } +updateLets f (PSCiState a x b c d) = + updateImportExports (PSCiState a (f x) b c d) -- * Commands diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 7a7994fac7..fc5f2cd21a 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -7,6 +7,7 @@ module Language.PureScript.Sugar.Names.Env , nullExports , Env , primEnv + , primExports , envModuleSourceSpan , envModuleImports , envModuleExports diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index 57e7742a82..2e3980da81 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -35,6 +35,8 @@ commandTests = context "commandTests" $ do specPSCi ":complete" $ do ":complete ma" `prints` [] - ":complete Data.Functor.ma" `prints` (unlines (map ("Data.Functor." ++ ) ["map", "mapFlipped"])) + ":complete Data.Functor.ma" `prints` [] run "import Data.Functor" - ":complete ma" `prints` (unlines ["map", "mapFlipped"]) + ":complete ma" `prints` unlines ["map", "mapFlipped"] + run "import Control.Monad as M" + ":complete M.a" `prints` unlines ["M.ap", "M.apply"] diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index da1e586f85..958ce0b2a1 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -50,19 +50,24 @@ completionTestData supportModuleNames = , (":show ", [":show import", ":show loaded"]) , (":show a", []) - -- :type should complete values and data constructors in scope - , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log", ":type Control.Monad.Eff.Console.logShow"]) - --, (":type uni", [":type unit"]) - --, (":type E", [":type EQ"]) - - -- :kind should complete types in scope - --, (":kind C", [":kind Control.Monad.Eff.Pure"]) - --, (":kind O", [":kind Ordering"]) + -- :type should complete next word from values and constructors in scope + , (":type uni", [":type unit"]) + , (":type E", [":type EQ"]) + , (":type P.", map (":type P." ++) ["EQ", "GT", "LT", "unit"]) -- import Prelude (unit, Ordering(..)) as P + , (":type Control.Monad.Eff.Console.lo", []) + , (":type voi", []) + + -- :kind should complete next word from types in scope + , (":kind Str", [":kind String"]) + , (":kind ST.", [":kind ST.ST", ":kind ST.STRef"]) -- import Control.Monad.ST as ST + , (":kind Control.Monad.Eff.", []) -- Only one argument for directives should be completed , (":show import ", []) , (":type EQ ", []) + , (":type unit compa", []) , (":kind Ordering ", []) + , (":kind Array In", []) -- a few other import tests , ("impor", ["import"]) @@ -73,16 +78,13 @@ completionTestData supportModuleNames = , ("\"hi", []) , ("34", []) - -- Identifiers and data constructors should be completed - --, ("uni", ["unit"]) - , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"]) - --, ("G", ["GT"]) - , ("Data.Ordering.L", ["Data.Ordering.LT"]) - - -- if a module is imported qualified, values should complete under the - -- qualified name, as well as the original name. - , ("ST.new", ["ST.newSTRef"]) - , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"]) + -- Identifiers and data constructors in scope should be completed + , ("uni", ["unit"]) + , ("G", ["GT"]) + , ("P.G", ["P.GT"]) + , ("P.uni", ["P.unit"]) + , ("voi", []) -- import Prelude hiding (void) + , ("Control.Monad.Eff.Class.", []) ] assertCompletedOk :: (String, [String]) -> Spec @@ -98,11 +100,22 @@ runCM act = do getPSCiStateForCompletion :: IO PSCiState getPSCiStateForCompletion = do - (PSCiState _ bs es, _) <- initTestPSCiEnv - let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] - return $ PSCiState imports bs es - -controlMonadSTasST :: ImportedModule -controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) + (st, _) <- initTestPSCiEnv + let imports = [-- import Control.Monad.ST as S + (qualName "Control.Monad.ST" + ,P.Implicit + ,Just (qualName "ST")) + -- import Prelude hiding (void) + ,(qualName "Prelude" + ,P.Hiding [valName "void"] + ,Nothing) + -- import Prelude (unit, Ordering(..)) as P + ,(qualName "Prelude" + ,P.Explicit [valName "unit", typeName "Ordering"] + ,Just (qualName "P"))] + return $ updateImportedModules (const imports) st where - s = P.moduleNameFromString + qualName = P.moduleNameFromString + valName = P.ValueRef srcSpan . P.Ident + typeName t = P.TypeRef srcSpan (P.ProperName t) Nothing + srcSpan = P.internalModuleSourceSpan "" diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index fdf0ca9a91..13a655f1a2 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -35,7 +35,7 @@ initTestPSCiEnv = do case makeResultOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right (externs, env) -> - return (PSCiState [] [] (zip (map snd modules) externs), PSCiConfig pursFiles env) + return (updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState, PSCiConfig pursFiles env) -- | Execute a TestPSCi, returning IO execTestPSCi :: TestPSCi a -> IO a From cfa07392f91307edd10543dded039a4f3410d0aa Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Fri, 2 Feb 2018 11:50:51 -0600 Subject: [PATCH 2/2] Complete type identifiers following '::' in REPL --- .../PureScript/Interactive/Completion.hs | 22 +++++++++++++++---- tests/TestPsci/CompletionTest.hs | 7 ++++++ 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 8833eb46fa..7796299120 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -12,7 +12,7 @@ import Protolude (ordNub) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) -import Data.List (nub, isPrefixOf, sortBy, stripPrefix) +import Data.List (nub, isPrefixOf, isInfixOf, isSuffixOf, sortBy, stripPrefix) import Data.Map (keys) import Data.Maybe (mapMaybe) import qualified Data.Text as T @@ -63,7 +63,7 @@ findCompletions prev word = do CtxFilePath f -> map Right <$> listFiles f CtxModule -> map Left <$> getModuleNames CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames) - CtxType -> map Left <$> getTypeNames + CtxType pre -> map (Left . (pre ++)) <$> getTypeNames CtxFixed str -> return [Left str] CtxDirective d -> return (map Left (completeDirectives d)) @@ -96,7 +96,7 @@ data CompletionContext | CtxFilePath String | CtxModule | CtxIdentifier - | CtxType + | CtxType String | CtxFixed String deriving (Show) @@ -105,11 +105,21 @@ data CompletionContext -- a list of complete words (to the left of the cursor) as the first argument, -- and the current word as the second argument. completionContext :: [String] -> String -> [CompletionContext] +completionContext _ w | "::" `isInfixOf` w = [CtxType (w `endingWith` "::")] +completionContext ws _ | lastSatisfies ("::" `isSuffixOf`) ws = [CtxType ""] completionContext [] _ = [CtxDirective "", CtxIdentifier, CtxFixed "import"] completionContext ws w | headSatisfies (":" `isPrefixOf`) ws = completeDirective ws w completionContext ws w | headSatisfies (== "import") ws = completeImport ws w completionContext _ _ = [CtxIdentifier] +endingWith :: String -> String -> String +endingWith str stop = aux "" str + where + aux acc s@(x:xs) + | stop `isPrefixOf` s = reverse (stop ++ acc) + | otherwise = aux (x:acc) xs + aux acc [] = reverse (stop ++ acc) + completeDirective :: [String] -> String -> [CompletionContext] completeDirective ws w = case ws of @@ -133,7 +143,7 @@ directiveArg _ Help = [] directiveArg _ Paste = [] directiveArg _ Show = map CtxFixed replQueryStrings directiveArg _ Type = [CtxIdentifier] -directiveArg _ Kind = [CtxType] +directiveArg _ Kind = [CtxType ""] directiveArg _ Complete = [] completeImport :: [String] -> String -> [CompletionContext] @@ -148,6 +158,10 @@ headSatisfies p str = (c:_) -> p c _ -> False +lastSatisfies :: (a -> Bool) -> [a] -> Bool +lastSatisfies _ [] = False +lastSatisfies p xs = p (last xs) + getLoadedModules :: CompletionM [P.Module] getLoadedModules = asks (map fst . psciLoadedExterns) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 958ce0b2a1..9b1b90449b 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -85,6 +85,13 @@ completionTestData supportModuleNames = , ("P.uni", ["P.unit"]) , ("voi", []) -- import Prelude hiding (void) , ("Control.Monad.Eff.Class.", []) + + -- complete first name after type annotation symbol + , ("1 :: I", ["1 :: Int"]) + , ("1 ::I", ["1 ::Int"]) + , ("1:: I", ["1:: Int"]) + , ("1::I", ["1::Int"]) + , ("(1::Int) uni", ["(1::Int) unit"]) -- back to completing values ] assertCompletedOk :: (String, [String]) -> Spec