1----------------------------------------------------------------------------- 2-- 3-- Module : Language.PureScript.Ide.State 4-- Description : Functions to access psc-ide's state 5-- Copyright : Christoph Hegemann 2016 6-- License : MIT (http://opensource.org/licenses/MIT) 7-- 8-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com> 9-- Stability : experimental 10-- 11-- | 12-- Functions to access psc-ide's state 13----------------------------------------------------------------------------- 14 15{-# LANGUAGE PackageImports #-} 16{-# LANGUAGE TypeApplications #-} 17 18module Language.PureScript.Ide.State 19 ( getLoadedModulenames 20 , getExternFiles 21 , getFileState 22 , resetIdeState 23 , cacheRebuild 24 , cachedRebuild 25 , insertExterns 26 , insertModule 27 , insertExternsSTM 28 , getAllModules 29 , populateVolatileState 30 , populateVolatileStateSync 31 , populateVolatileStateSTM 32 , getOutputDirectory 33 , updateCacheTimestamp 34 -- for tests 35 , resolveOperatorsForModule 36 , resolveInstances 37 , resolveDataConstructorsForModule 38 ) where 39 40import Protolude hiding (moduleName) 41 42import Control.Arrow 43import Control.Concurrent.STM 44import "monad-logger" Control.Monad.Logger 45import Data.IORef 46import qualified Data.Map.Lazy as Map 47import Data.Time.Clock (UTCTime) 48import qualified Language.PureScript as P 49import Language.PureScript.Docs.Convert.Single (convertComments) 50import Language.PureScript.Externs 51import Language.PureScript.Make.Actions (cacheDbFile) 52import Language.PureScript.Ide.Externs 53import Language.PureScript.Ide.Reexports 54import Language.PureScript.Ide.SourceFile 55import Language.PureScript.Ide.Types 56import Language.PureScript.Ide.Util 57import Lens.Micro.Platform hiding ((&)) 58import System.Directory (getModificationTime) 59 60-- | Resets all State inside psc-ide 61resetIdeState :: Ide m => m () 62resetIdeState = do 63 ideVar <- ideStateVar <$> ask 64 liftIO (atomically (writeTVar ideVar emptyIdeState)) 65 66getOutputDirectory :: Ide m => m FilePath 67getOutputDirectory = do 68 confOutputPath . ideConfiguration <$> ask 69 70getCacheTimestamp :: Ide m => m (Maybe UTCTime) 71getCacheTimestamp = do 72 x <- ideCacheDbTimestamp <$> ask 73 liftIO (readIORef x) 74 75readCacheTimestamp :: Ide m => m (Maybe UTCTime) 76readCacheTimestamp = do 77 cacheDb <- cacheDbFile <$> getOutputDirectory 78 liftIO (hush <$> try @SomeException (getModificationTime cacheDb)) 79 80updateCacheTimestamp :: Ide m => m (Maybe (Maybe UTCTime, Maybe UTCTime)) 81updateCacheTimestamp = do 82 old <- getCacheTimestamp 83 new <- readCacheTimestamp 84 if old == new 85 then pure Nothing 86 else do 87 ts <- ideCacheDbTimestamp <$> ask 88 liftIO (writeIORef ts new) 89 pure (Just (old, new)) 90 91-- | Gets the loaded Modulenames 92getLoadedModulenames :: Ide m => m [P.ModuleName] 93getLoadedModulenames = Map.keys <$> getExternFiles 94 95-- | Gets all loaded ExternFiles 96getExternFiles :: Ide m => m (ModuleMap ExternsFile) 97getExternFiles = fsExterns <$> getFileState 98 99-- | Insert a Module into Stage1 of the State 100insertModule :: Ide m => (FilePath, P.Module) -> m () 101insertModule module' = do 102 stateVar <- ideStateVar <$> ask 103 liftIO . atomically $ insertModuleSTM stateVar module' 104 105-- | STM version of insertModule 106insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM () 107insertModuleSTM ref (fp, module') = 108 modifyTVar ref $ \x -> 109 x { ideFileState = (ideFileState x) { 110 fsModules = Map.insert 111 (P.getModuleName module') 112 (module', fp) 113 (fsModules (ideFileState x))}} 114 115-- | Retrieves the FileState from the State. This includes loaded Externfiles 116-- and parsed Modules 117getFileState :: Ide m => m IdeFileState 118getFileState = do 119 st <- ideStateVar <$> ask 120 ideFileState <$> liftIO (readTVarIO st) 121 122-- | STM version of getFileState 123getFileStateSTM :: TVar IdeState -> STM IdeFileState 124getFileStateSTM ref = ideFileState <$> readTVar ref 125 126-- | Retrieves VolatileState from the State. 127-- This includes the denormalized Declarations and cached rebuilds 128getVolatileState :: Ide m => m IdeVolatileState 129getVolatileState = do 130 st <- ideStateVar <$> ask 131 liftIO (atomically (getVolatileStateSTM st)) 132 133-- | STM version of getVolatileState 134getVolatileStateSTM :: TVar IdeState -> STM IdeVolatileState 135getVolatileStateSTM st = ideVolatileState <$> readTVar st 136 137-- | Sets the VolatileState inside Ide's state 138setVolatileStateSTM :: TVar IdeState -> IdeVolatileState -> STM () 139setVolatileStateSTM ref vs = do 140 modifyTVar ref $ \x -> 141 x {ideVolatileState = vs} 142 pure () 143 144-- | Checks if the given ModuleName matches the last rebuild cache and if it 145-- does returns all loaded definitions + the definitions inside the rebuild 146-- cache 147getAllModules :: Ide m => Maybe P.ModuleName -> m (ModuleMap [IdeDeclarationAnn]) 148getAllModules mmoduleName = do 149 declarations <- vsDeclarations <$> getVolatileState 150 rebuild <- cachedRebuild 151 case mmoduleName of 152 Nothing -> pure declarations 153 Just moduleName -> 154 case rebuild of 155 Just (cachedModulename, ef) 156 | cachedModulename == moduleName -> do 157 AstData asts <- vsAstData <$> getVolatileState 158 let 159 ast = 160 fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts) 161 cachedModule = 162 resolveLocationsForModule ast (fst (convertExterns ef)) 163 tmp = 164 Map.insert moduleName cachedModule declarations 165 resolved = 166 Map.adjust (resolveOperatorsForModule tmp) moduleName tmp 167 168 pure resolved 169 _ -> pure declarations 170 171-- | Adds an ExternsFile into psc-ide's FileState. This does not populate the 172-- VolatileState, which needs to be done after all the necessary Externs and 173-- SourceFiles have been loaded. 174insertExterns :: Ide m => ExternsFile -> m () 175insertExterns ef = do 176 st <- ideStateVar <$> ask 177 liftIO (atomically (insertExternsSTM st ef)) 178 179-- | STM version of insertExterns 180insertExternsSTM :: TVar IdeState -> ExternsFile -> STM () 181insertExternsSTM ref ef = 182 modifyTVar ref $ \x -> 183 x { ideFileState = (ideFileState x) { 184 fsExterns = Map.insert (efModuleName ef) ef (fsExterns (ideFileState x))}} 185 186-- | Sets rebuild cache to the given ExternsFile 187cacheRebuild :: Ide m => ExternsFile -> m () 188cacheRebuild ef = do 189 st <- ideStateVar <$> ask 190 liftIO . atomically . modifyTVar st $ \x -> 191 x { ideVolatileState = (ideVolatileState x) { 192 vsCachedRebuild = Just (efModuleName ef, ef)}} 193 194-- | Retrieves the rebuild cache 195cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile)) 196cachedRebuild = vsCachedRebuild <$> getVolatileState 197 198-- | Resolves reexports and populates VolatileState with data to be used in queries. 199populateVolatileStateSync :: (Ide m, MonadLogger m) => m () 200populateVolatileStateSync = do 201 st <- ideStateVar <$> ask 202 let message duration = "Finished populating volatile state in: " <> displayTimeSpec duration 203 results <- logPerf message $ do 204 !r <- liftIO (atomically (populateVolatileStateSTM st)) 205 pure r 206 void $ Map.traverseWithKey 207 (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn))) 208 (Map.filter reexportHasFailures results) 209 210populateVolatileState :: (Ide m, MonadLogger m) => m (Async ()) 211populateVolatileState = do 212 env <- ask 213 let ll = confLogLevel (ideConfiguration env) 214 -- populateVolatileState return Unit for now, so it's fine to discard this 215 -- result. We might want to block on this in a benchmarking situation. 216 liftIO (async (runLogger ll (runReaderT populateVolatileStateSync env))) 217 218-- | STM version of populateVolatileState 219populateVolatileStateSTM 220 :: TVar IdeState 221 -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn])) 222populateVolatileStateSTM ref = do 223 IdeFileState{fsExterns = externs, fsModules = modules} <- getFileStateSTM ref 224 -- We're not using the cached rebuild for anything other than preserving it 225 -- through the repopulation 226 rebuildCache <- vsCachedRebuild <$> getVolatileStateSTM ref 227 let asts = map (extractAstInformation . fst) modules 228 let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs) 229 results = 230 moduleDeclarations 231 & map resolveDataConstructorsForModule 232 & resolveLocations asts 233 & resolveDocumentation (map fst modules) 234 & resolveInstances externs 235 & resolveOperators 236 & resolveReexports reexportRefs 237 setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache) 238 pure (force results) 239 240resolveLocations 241 :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) 242 -> ModuleMap [IdeDeclarationAnn] 243 -> ModuleMap [IdeDeclarationAnn] 244resolveLocations asts = 245 Map.mapWithKey (\mn decls -> 246 maybe decls (flip resolveLocationsForModule decls) (Map.lookup mn asts)) 247 248resolveLocationsForModule 249 :: (DefinitionSites P.SourceSpan, TypeAnnotations) 250 -> [IdeDeclarationAnn] 251 -> [IdeDeclarationAnn] 252resolveLocationsForModule (defs, types) = 253 map convertDeclaration 254 where 255 convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn 256 convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' 257 annotateFunction 258 annotateValue 259 annotateDataConstructor 260 annotateType 261 annotateType -- type classes live in the type namespace 262 annotateModule 263 d 264 where 265 annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs 266 , _annTypeAnnotation = Map.lookup x types 267 }) 268 annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) 269 annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) 270 annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) 271 annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs}) 272 273convertDeclaration' 274 :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn) 275 -> (Text -> IdeDeclaration -> IdeDeclarationAnn) 276 -> (Text -> IdeDeclaration -> IdeDeclarationAnn) 277 -> (Text -> IdeDeclaration -> IdeDeclarationAnn) 278 -> (Text -> IdeDeclaration -> IdeDeclarationAnn) 279 -> (Text -> IdeDeclaration -> IdeDeclarationAnn) 280 -> IdeDeclaration 281 -> IdeDeclarationAnn 282convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateClass annotateModule d = 283 case d of 284 IdeDeclValue v -> 285 annotateFunction (v ^. ideValueIdent) d 286 IdeDeclType t -> 287 annotateType (t ^. ideTypeName . properNameT) d 288 IdeDeclTypeSynonym s -> 289 annotateType (s ^. ideSynonymName . properNameT) d 290 IdeDeclDataConstructor dtor -> 291 annotateDataConstructor (dtor ^. ideDtorName . properNameT) d 292 IdeDeclTypeClass tc -> 293 annotateClass (tc ^. ideTCName . properNameT) d 294 IdeDeclValueOperator operator -> 295 annotateValue (operator ^. ideValueOpName . opNameT) d 296 IdeDeclTypeOperator operator -> 297 annotateType (operator ^. ideTypeOpName . opNameT) d 298 IdeDeclModule mn -> 299 annotateModule (P.runModuleName mn) d 300 301resolveDocumentation 302 :: ModuleMap P.Module 303 -> ModuleMap [IdeDeclarationAnn] 304 -> ModuleMap [IdeDeclarationAnn] 305resolveDocumentation modules = 306 Map.mapWithKey (\mn decls -> 307 maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules)) 308 309resolveDocumentationForModule 310 :: P.Module 311 -> [IdeDeclarationAnn] 312 -> [IdeDeclarationAnn] 313resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) = 314 map convertDecl 315 where 316 extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])] 317 extractDeclComments = \case 318 P.DataDeclaration (_, cs) _ ctorName _ ctors -> 319 (P.TyName ctorName, cs) : map dtorComments ctors 320 P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members -> 321 (P.TyClassName tyClassName, cs) : concatMap extractDeclComments members 322 decl -> 323 maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl) 324 325 comments :: Map P.Name [P.Comment] 326 comments = Map.insert (P.ModName moduleName) moduleComments $ 327 Map.fromListWith (flip (<>)) $ concatMap extractDeclComments sdecls 328 329 dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment]) 330 dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd)) 331 332 name :: P.Declaration -> Maybe P.Name 333 name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d 334 name decl = P.declName decl 335 336 convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn 337 convertDecl (IdeDeclarationAnn ann d) = 338 convertDeclaration' 339 (annotateValue . P.IdentName) 340 (annotateValue . P.IdentName . P.Ident) 341 (annotateValue . P.DctorName . P.ProperName) 342 (annotateValue . P.TyName . P.ProperName) 343 (annotateValue . P.TyClassName . P.ProperName) 344 (annotateValue . P.ModName . P.moduleNameFromString) 345 d 346 where 347 docs :: P.Name -> Text 348 docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments 349 350 annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident }) 351 352resolveInstances 353 :: ModuleMap P.ExternsFile 354 -> ModuleMap [IdeDeclarationAnn] 355 -> ModuleMap [IdeDeclarationAnn] 356resolveInstances externs declarations = 357 Map.foldr (flip (foldr go)) declarations 358 . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef)) 359 $ externs 360 where 361 extractInstances mn P.EDInstance{..} = 362 case edInstanceClassName of 363 P.Qualified (Just classModule) className -> 364 Just (IdeInstance mn 365 edInstanceName 366 edInstanceTypes 367 edInstanceConstraints, classModule, className) 368 _ -> Nothing 369 extractInstances _ _ = Nothing 370 371 go 372 :: (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName) 373 -> ModuleMap [IdeDeclarationAnn] 374 -> ModuleMap [IdeDeclarationAnn] 375 go (ideInstance, classModule, className) acc' = 376 let 377 matchTC = 378 anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className) 379 updateDeclaration = 380 mapIf matchTC (idaDeclaration 381 . _IdeDeclTypeClass 382 . ideTCInstances 383 %~ (ideInstance :)) 384 in 385 acc' & ix classModule %~ updateDeclaration 386 387resolveOperators 388 :: ModuleMap [IdeDeclarationAnn] 389 -> ModuleMap [IdeDeclarationAnn] 390resolveOperators modules = 391 map (resolveOperatorsForModule modules) modules 392 393-- | Looks up the types and kinds for operators and assigns them to their 394-- declarations 395resolveOperatorsForModule 396 :: ModuleMap [IdeDeclarationAnn] 397 -> [IdeDeclarationAnn] 398 -> [IdeDeclarationAnn] 399resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) 400 where 401 getDeclarations :: P.ModuleName -> [IdeDeclaration] 402 getDeclarations moduleName = 403 Map.lookup moduleName modules 404 & fromMaybe [] 405 & map discardAnn 406 407 resolveOperator (IdeDeclValueOperator op) 408 | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias = 409 let t = getDeclarations mn 410 & mapMaybe (preview _IdeDeclValue) 411 & filter (anyOf ideValueIdent (== ident)) 412 & map (view ideValueType) 413 & listToMaybe 414 in IdeDeclValueOperator (op & ideValueOpType .~ t) 415 | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias = 416 let t = getDeclarations mn 417 & mapMaybe (preview _IdeDeclDataConstructor) 418 & filter (anyOf ideDtorName (== dtor)) 419 & map (view ideDtorType) 420 & listToMaybe 421 in IdeDeclValueOperator (op & ideValueOpType .~ t) 422 resolveOperator (IdeDeclTypeOperator op) 423 | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias = 424 let k = getDeclarations mn 425 & mapMaybe (preview _IdeDeclType) 426 & filter (anyOf ideTypeName (== properName)) 427 & map (view ideTypeKind) 428 & listToMaybe 429 in IdeDeclTypeOperator (op & ideTypeOpKind .~ k) 430 resolveOperator x = x 431 432 433mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b 434mapIf p f = map (\x -> if p x then f x else x) 435 436resolveDataConstructorsForModule 437 :: [IdeDeclarationAnn] 438 -> [IdeDeclarationAnn] 439resolveDataConstructorsForModule decls = 440 map (idaDeclaration %~ resolveDataConstructors) decls 441 where 442 resolveDataConstructors :: IdeDeclaration -> IdeDeclaration 443 resolveDataConstructors decl = case decl of 444 IdeDeclType ty -> 445 IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty^.ideTypeName) dtors)) 446 _ -> 447 decl 448 449 dtors = 450 decls 451 & mapMaybe (preview (idaDeclaration._IdeDeclDataConstructor)) 452 & foldr (\(IdeDataConstructor name typeName type') -> 453 Map.insertWith (<>) typeName [(name, type')]) Map.empty 454