module Language.PureScript.Ide.State
( getLoadedModulenames
, getExternFiles
, resetIdeState
, cacheRebuild
, insertExterns
, insertModule
, insertExternsSTM
, getAllModules
, populateVolatileState
, populateVolatileStateSTM
, resolveOperatorsForModule
, resolveInstances
) where
import Protolude
import Control.Arrow
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 (writeTVar ideVar emptyIdeState))
getLoadedModulenames :: Ide m => m [P.ModuleName]
getLoadedModulenames = Map.keys <$> getExternFiles
getExternFiles :: Ide m => m (ModuleMap ExternsFile)
getExternFiles = fsExterns <$> getFileState
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 { ideFileState = (ideFileState x) {
fsModules = Map.insert
(P.getModuleName module')
(module', fp)
(fsModules (ideFileState x))}}
getFileState :: Ide m => m IdeFileState
getFileState = do
st <- ideStateVar <$> ask
fmap ideFileState . liftIO . readTVarIO $ st
getFileStateSTM :: TVar IdeState -> STM IdeFileState
getFileStateSTM ref = ideFileState <$> readTVar ref
getVolatileState :: Ide m => m IdeVolatileState
getVolatileState = do
st <- ideStateVar <$> ask
fmap ideVolatileState . liftIO . readTVarIO $ st
setVolatileStateSTM :: TVar IdeState -> IdeVolatileState -> STM ()
setVolatileStateSTM ref vs = do
modifyTVar ref $ \x ->
x {ideVolatileState = vs}
pure ()
getAllModules :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclarationAnn])]
getAllModules mmoduleName = do
declarations <- vsDeclarations <$> getVolatileState
rebuild <- cachedRebuild
case mmoduleName of
Nothing -> pure (Map.toList declarations)
Just moduleName ->
case rebuild of
Just (cachedModulename, ef)
| cachedModulename == moduleName -> do
AstData asts <- vsAstData <$> getVolatileState
let
ast =
fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
cachedModule =
resolveLocationsForModule 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 { ideFileState = (ideFileState x) {
fsExterns = Map.insert (efModuleName ef) ef (fsExterns (ideFileState x))}}
cacheRebuild :: Ide m => ExternsFile -> m ()
cacheRebuild ef = do
st <- ideStateVar <$> ask
liftIO . atomically . modifyTVar st $ \x ->
x { ideVolatileState = (ideVolatileState x) {
vsCachedRebuild = Just (efModuleName ef, ef)}}
cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile))
cachedRebuild = vsCachedRebuild <$> getVolatileState
populateVolatileState :: (Ide m, MonadLogger m) => m ()
populateVolatileState = do
st <- ideStateVar <$> ask
let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration
results <- logPerf message (liftIO (atomically (populateVolatileStateSTM st)))
void $ Map.traverseWithKey
(\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))
(Map.filter reexportHasFailures results)
populateVolatileStateSTM
:: TVar IdeState
-> STM (ModuleMap (ReexportResult [IdeDeclarationAnn]))
populateVolatileStateSTM ref = do
IdeFileState{fsExterns = externs, fsModules = modules} <- getFileStateSTM ref
let asts = map (extractAstInformation . fst) modules
let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs)
results =
resolveLocations asts moduleDeclarations
& resolveInstances externs
& resolveOperators
& resolveReexports reexportRefs
setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) Nothing)
pure results
resolveLocations
:: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)
-> ModuleMap [IdeDeclarationAnn]
-> ModuleMap [IdeDeclarationAnn]
resolveLocations asts =
Map.mapWithKey (\mn decls ->
maybe decls (flip resolveLocationsForModule decls) (Map.lookup mn asts))
resolveLocationsForModule
:: (DefinitionSites P.SourceSpan, TypeAnnotations)
-> [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
resolveLocationsForModule (defs, types) decls =
map convertDeclaration decls
where
convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
convertDeclaration (IdeDeclarationAnn ann d) = case d of
IdeDeclValue v ->
annotateFunction (v ^. ideValueIdent) (IdeDeclValue v)
IdeDeclType t ->
annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t)
IdeDeclTypeSynonym s ->
annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s)
IdeDeclDataConstructor dtor ->
annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)
IdeDeclTypeClass tc ->
annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc)
IdeDeclValueOperator operator ->
annotateValue (operator ^. ideValueOpName . opNameT) (IdeDeclValueOperator operator)
IdeDeclTypeOperator operator ->
annotateType (operator ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator operator)
IdeDeclKind i ->
annotateKind (i ^. properNameT) (IdeDeclKind i)
where
annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs
, _annTypeAnnotation = Map.lookup x types
})
annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs})
annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs})
annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs})
resolveInstances
:: ModuleMap P.ExternsFile
-> ModuleMap [IdeDeclarationAnn]
-> ModuleMap [IdeDeclarationAnn]
resolveInstances externs declarations =
Map.foldr (flip (foldr go)) declarations
. Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef))
$ externs
where
extractInstances mn P.EDInstance{..} =
case edInstanceClassName of
P.Qualified (Just classModule) className ->
Just (IdeInstance mn
edInstanceName
edInstanceTypes
edInstanceConstraints, classModule, className)
_ -> Nothing
extractInstances _ _ = Nothing
go
:: (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName)
-> ModuleMap [IdeDeclarationAnn]
-> ModuleMap [IdeDeclarationAnn]
go (ideInstance, classModule, className) acc' =
let
matchTC =
anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className)
updateDeclaration =
mapIf matchTC (idaDeclaration
. _IdeDeclTypeClass
. ideTCInstances
%~ cons ideInstance)
in
acc' & ix classModule %~ updateDeclaration
resolveOperators
:: ModuleMap [IdeDeclarationAnn]
-> ModuleMap [IdeDeclarationAnn]
resolveOperators modules =
map (resolveOperatorsForModule modules) modules
resolveOperatorsForModule
:: ModuleMap [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator)
where
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 (anyOf 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 (anyOf 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 (anyOf ideTypeName (== properName))
& map (view ideTypeKind)
& listToMaybe
in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)
resolveOperator x = x
mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b
mapIf p f = map (\x -> if p x then f x else x)