purescript · hdgarrood · Feb 2, 2018 · Jan 31, 2018
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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,19 +75,22 @@ 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
 
 -- |
 -- 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
@@ -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 "<internal>"
 
 -- | 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
@@ -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
@@ -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"]