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