module Language.PureScript.Ide.State
( getLoadedModulenames
, getExternFiles
, resetIdeState
, cacheRebuild
, insertExterns
, insertModule
, insertExternsSTM
, getAllModules
, populateStage2
, populateStage3
, populateStage3STM
, resolveOperatorsForModule
) where
import Protolude
import Control.Concurrent.STM
import Control.Lens hiding (op, (&))
import "monad-logger" Control.Monad.Logger
import qualified Data.Map.Lazy as Map
import qualified Language.PureScript as P
import Language.PureScript.Externs
import Language.PureScript.Ide.Externs
import Language.PureScript.Ide.Reexports
import Language.PureScript.Ide.SourceFile
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
resetIdeState :: Ide m => m ()
resetIdeState = do
ideVar <- ideStateVar <$> ask
liftIO . atomically $ do
writeTVar ideVar emptyIdeState
setStage3STM ideVar emptyStage3
getLoadedModulenames :: Ide m => m [P.ModuleName]
getLoadedModulenames = Map.keys <$> getExternFiles
getExternFiles :: Ide m => m (Map P.ModuleName ExternsFile)
getExternFiles = s1Externs <$> getStage1
insertModule :: Ide m => (FilePath, P.Module) -> m ()
insertModule module' = do
stateVar <- ideStateVar <$> ask
liftIO . atomically $ insertModuleSTM stateVar module'
insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM ()
insertModuleSTM ref (fp, module') =
modifyTVar ref $ \x ->
x { ideStage1 = (ideStage1 x) {
s1Modules = Map.insert
(P.getModuleName module')
(module', fp)
(s1Modules (ideStage1 x))}}
getStage1 :: Ide m => m Stage1
getStage1 = do
st <- ideStateVar <$> ask
fmap ideStage1 . liftIO . readTVarIO $ st
getStage1STM :: TVar IdeState -> STM Stage1
getStage1STM ref = ideStage1 <$> readTVar ref
getStage2 :: Ide m => m Stage2
getStage2 = do
st <- ideStateVar <$> ask
liftIO (atomically (getStage2STM st))
getStage2STM :: TVar IdeState -> STM Stage2
getStage2STM ref = ideStage2 <$> readTVar ref
setStage2STM :: TVar IdeState -> Stage2 -> STM ()
setStage2STM ref s2 = do
modifyTVar ref $ \x ->
x {ideStage2 = s2}
pure ()
getStage3 :: Ide m => m Stage3
getStage3 = do
st <- ideStateVar <$> ask
fmap ideStage3 . liftIO . readTVarIO $ st
setStage3STM :: TVar IdeState -> Stage3 -> STM ()
setStage3STM ref s3 = do
modifyTVar ref $ \x ->
x {ideStage3 = s3}
pure ()
getAllModules :: Ide m => Maybe P.ModuleName -> m [Module]
getAllModules mmoduleName = do
declarations <- s3Declarations <$> getStage3
rebuild <- cachedRebuild
case mmoduleName of
Nothing -> pure (Map.toList declarations)
Just moduleName ->
case rebuild of
Just (cachedModulename, ef)
| cachedModulename == moduleName -> do
(AstData asts) <- s2AstData <$> getStage2
let
ast =
fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
cachedModule =
snd . annotateModule ast . fst . convertExterns $ ef
tmp =
Map.insert moduleName cachedModule declarations
resolved =
Map.adjust (resolveOperatorsForModule tmp) moduleName tmp
pure (Map.toList resolved)
_ -> pure (Map.toList declarations)
insertExterns :: Ide m => ExternsFile -> m ()
insertExterns ef = do
st <- ideStateVar <$> ask
liftIO (atomically (insertExternsSTM st ef))
insertExternsSTM :: TVar IdeState -> ExternsFile -> STM ()
insertExternsSTM ref ef =
modifyTVar ref $ \x ->
x { ideStage1 = (ideStage1 x) {
s1Externs = Map.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}
cacheRebuild :: Ide m => ExternsFile -> m ()
cacheRebuild ef = do
st <- ideStateVar <$> ask
liftIO . atomically . modifyTVar st $ \x ->
x { ideStage3 = (ideStage3 x) {
s3CachedRebuild = Just (efModuleName ef, ef)}}
cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile))
cachedRebuild = s3CachedRebuild <$> getStage3
populateStage2 :: (Ide m, MonadLogger m) => m ()
populateStage2 = do
st <- ideStateVar <$> ask
let message duration = "Finished populating Stage2 in " <> displayTimeSpec duration
logPerf message (liftIO (atomically (populateStage2STM st)))
populateStage2STM :: TVar IdeState -> STM ()
populateStage2STM ref = do
modules <- s1Modules <$> getStage1STM ref
let astData = map (extractAstInformation . fst) modules
setStage2STM ref (Stage2 (AstData astData))
populateStage3 :: (Ide m, MonadLogger m) => m ()
populateStage3 = do
st <- ideStateVar <$> ask
let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration
results <- logPerf message (liftIO (atomically (populateStage3STM st)))
traverse_
(logWarnN . prettyPrintReexportResult (P.runModuleName . fst))
(filter reexportHasFailures results)
populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]
populateStage3STM ref = do
externs <- s1Externs <$> getStage1STM ref
(AstData asts) <- s2AstData <$> getStage2STM ref
let modules = Map.map convertExterns externs
nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])
nModules = Map.mapWithKey
(\moduleName (m, refs) ->
(fromMaybe m $ annotateModule <$> Map.lookup moduleName asts <*> pure m, refs)) modules
result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules
resultP = resolveOperators (Map.fromList (reResolved <$> result))
setStage3STM ref (Stage3 resultP Nothing)
pure result
resolveOperators
:: Map P.ModuleName [IdeDeclarationAnn]
-> Map P.ModuleName [IdeDeclarationAnn]
resolveOperators modules =
map (resolveOperatorsForModule modules) modules
resolveOperatorsForModule
:: Map P.ModuleName [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)
where
hasName :: Eq b => Lens' a b -> b -> a -> Bool
hasName l a x = x ^. l == a
getDeclarations :: P.ModuleName -> [IdeDeclaration]
getDeclarations moduleName =
Map.lookup moduleName modules
& fromMaybe []
& map discardAnn
resolveOperator (IdeDeclValueOperator op)
| (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias =
let t = getDeclarations mn
& mapMaybe (preview _IdeDeclValue)
& filter (hasName ideValueIdent ident)
& map (view ideValueType)
& listToMaybe
in IdeDeclValueOperator (op & ideValueOpType .~ t)
| (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias =
let t = getDeclarations mn
& mapMaybe (preview _IdeDeclDataConstructor)
& filter (hasName ideDtorName dtor)
& map (view ideDtorType)
& listToMaybe
in IdeDeclValueOperator (op & ideValueOpType .~ t)
resolveOperator (IdeDeclTypeOperator op)
| P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias =
let k = getDeclarations mn
& mapMaybe (preview _IdeDeclType)
& filter (hasName ideTypeName properName)
& map (view ideTypeKind)
& listToMaybe
in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)
resolveOperator x = x