@@ -14,6 +14,7 @@
15{-# LANGUAGE PackageImports #-}
15{-# LANGUAGE PackageImports #-}
16{-# LANGUAGE TemplateHaskell #-}
16{-# LANGUAGE TemplateHaskell #-}
17+{-# LANGUAGE NamedFieldPuns #-}
18module Language.PureScript.Ide.State
19module Language.PureScript.Ide.State
19 ( getLoadedModulenames
20 ( getLoadedModulenames
@@ -29,10 +30,12 @@ module Language.PureScript.Ide.State
29 , populateStage3STM
30 , populateStage3STM
30 -- for tests
31 -- for tests
31 , resolveOperatorsForModule
32 , resolveOperatorsForModule
34import Protolude
36import Protolude
36import Control.Concurrent.STM
39import Control.Concurrent.STM
37import Control.Lens hiding (op, (&))
40import Control.Lens hiding (op, (&))
38import "monad-logger" Control.Monad.Logger
41import "monad-logger" Control.Monad.Logger
@@ -58,7 +61,7 @@ getLoadedModulenames :: Ide m => m [P.ModuleName]
58getLoadedModulenames = Map.keys <$> getExternFiles
61getLoadedModulenames = Map.keys <$> getExternFiles
60-- | Gets all loaded ExternFiles
63-- | Gets all loaded ExternFiles
61−getExternFiles :: Ide m => m (Map P.ModuleName ExternsFile)
64+getExternFiles :: Ide m => m (ModuleMap ExternsFile)
62getExternFiles = s1Externs <$> getStage1
65getExternFiles = s1Externs <$> getStage1
64-- | Insert a Module into Stage1 of the State
67-- | Insert a Module into Stage1 of the State
@@ -121,7 +124,7 @@ setStage3STM ref s3 = do
121-- | Checks if the given ModuleName matches the last rebuild cache and if it
124-- | Checks if the given ModuleName matches the last rebuild cache and if it
122-- does returns all loaded definitions + the definitions inside the rebuild
125-- does returns all loaded definitions + the definitions inside the rebuild
124−getAllModules :: Ide m => Maybe P.ModuleName -> m [Module]
127+getAllModules :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclarationAnn])]
125getAllModules mmoduleName = do
128getAllModules mmoduleName = do
126 declarations <- s3Declarations <$> getStage3
129 declarations <- s3Declarations <$> getStage3
127 rebuild <- cachedRebuild
130 rebuild <- cachedRebuild
@@ -136,7 +139,7 @@ getAllModules mmoduleName = do
137 fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
140 fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
138 cachedModule =
141 cachedModule =
139− snd . annotateModule ast . fst . convertExterns $ ef
142+ annotateModule ast (fst (convertExterns ef))
141 Map.insert moduleName cachedModule declarations
144 Map.insert moduleName cachedModule declarations
142 resolved =
145 resolved =
@@ -192,43 +195,84 @@ populateStage3 = do
192 st <- ideStateVar <$> ask
195 st <- ideStateVar <$> ask
193 let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration
196 let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration
194 results <- logPerf message (liftIO (atomically (populateStage3STM st)))
197 results <- logPerf message (liftIO (atomically (populateStage3STM st)))
195− traverse_
198+ void $ Map.traverseWithKey
196− (logWarnN . prettyPrintReexportResult (P.runModuleName . fst))
199+ (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))
197− (filter reexportHasFailures results)
200+ (Map.filter reexportHasFailures results)
199-- | STM version of populateStage3
202-- | STM version of populateStage3
200−populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]
203+populateStage3STM
205+ -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn]))
201populateStage3STM ref = do
206populateStage3STM ref = do
202 externs <- s1Externs <$> getStage1STM ref
207 externs <- s1Externs <$> getStage1STM ref
203 (AstData asts) <- s2AstData <$> getStage2STM ref
208 (AstData asts) <- s2AstData <$> getStage2STM ref
204− let modules = Map.map convertExterns externs
209+ let (modules, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs)
205− nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])
210+ results =
206− nModules = Map.mapWithKey
211+ resolveLocations asts modules
207− (\moduleName (m, refs) ->
212+ & resolveInstances externs
208− (fromMaybe m $ annotateModule <$> Map.lookup moduleName asts <*> pure m, refs)) modules
209− -- resolves reexports and discards load failures for now
210− result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules
211− resultP = resolveOperators (Map.fromList (reResolved <$> result))
213+ & resolveOperators
214+ & resolveReexports reexportRefs
212− setStage3STM ref (Stage3 resultP Nothing)
215+ setStage3STM ref (Stage3 (map reResolved results) Nothing)
213− pure result
216+ pure results
220+ :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)
221+ -> ModuleMap [IdeDeclarationAnn]
222+ -> ModuleMap [IdeDeclarationAnn]
223+resolveLocations asts =
224+ Map.mapWithKey (\mn decls ->
225+ maybe decls (flip annotateModule decls) (Map.lookup mn asts))
228+ :: ModuleMap P.ExternsFile
229+ -> ModuleMap [IdeDeclarationAnn]
230+ -> ModuleMap [IdeDeclarationAnn]
231+resolveInstances externs declarations =
232+ Map.foldr (flip (foldr go)) declarations
233+ . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef))
236+ extractInstances mn P.EDInstance{..} =
237+ case edInstanceClassName of
238+ P.Qualified (Just classModule) className ->
239+ Just (IdeInstance mn
242+ edInstanceConstraints, classModule, className)
244+ extractInstances _ _ = Nothing
247+ (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName)
248+ -> ModuleMap [IdeDeclarationAnn]
249+ -> ModuleMap [IdeDeclarationAnn]
250+ go (ideInstance, classModule, className) acc' =
253+ lensSatisfies (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className)
255+ mapIf matchTC (idaDeclaration
258+ %~ cons ideInstance)
260+ acc' & ix classModule %~ updateDeclaration
215resolveOperators
262resolveOperators
216− :: Map P.ModuleName [IdeDeclarationAnn]
263+ :: ModuleMap [IdeDeclarationAnn]
217− -> Map P.ModuleName [IdeDeclarationAnn]
264+ -> ModuleMap [IdeDeclarationAnn]
218resolveOperators modules =
265resolveOperators modules =
219 map (resolveOperatorsForModule modules) modules
266 map (resolveOperatorsForModule modules) modules
221-- | Looks up the types and kinds for operators and assigns them to their
268-- | Looks up the types and kinds for operators and assigns them to their
222-- declarations
269-- declarations
223resolveOperatorsForModule
270resolveOperatorsForModule
224− :: Map P.ModuleName [IdeDeclarationAnn]
271+ :: ModuleMap [IdeDeclarationAnn]
225 -> [IdeDeclarationAnn]
272 -> [IdeDeclarationAnn]
226 -> [IdeDeclarationAnn]
273 -> [IdeDeclarationAnn]
227−resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)
274+resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator)
229− hasName :: Eq b => Lens' a b -> b -> a -> Bool
230− hasName l a x = x ^. l == a
232 getDeclarations :: P.ModuleName -> [IdeDeclaration]
276 getDeclarations :: P.ModuleName -> [IdeDeclaration]
233 getDeclarations moduleName =
277 getDeclarations moduleName =
234 Map.lookup moduleName modules
278 Map.lookup moduleName modules
@@ -239,14 +283,14 @@ resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)
239 | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias =
283 | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias =
240 let t = getDeclarations mn
284 let t = getDeclarations mn
241 & mapMaybe (preview _IdeDeclValue)
285 & mapMaybe (preview _IdeDeclValue)
242− & filter (hasName ideValueIdent ident)
286+ & filter (lensSatisfies ideValueIdent (== ident))
243 & map (view ideValueType)
287 & map (view ideValueType)
244 & listToMaybe
288 & listToMaybe
245 in IdeDeclValueOperator (op & ideValueOpType .~ t)
289 in IdeDeclValueOperator (op & ideValueOpType .~ t)
246 | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias =
290 | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias =
247 let t = getDeclarations mn
291 let t = getDeclarations mn
248 & mapMaybe (preview _IdeDeclDataConstructor)
292 & mapMaybe (preview _IdeDeclDataConstructor)
249− & filter (hasName ideDtorName dtor)
293+ & filter (lensSatisfies ideDtorName (== dtor))
250 & map (view ideDtorType)
294 & map (view ideDtorType)
251 & listToMaybe
295 & listToMaybe
252 in IdeDeclValueOperator (op & ideValueOpType .~ t)
296 in IdeDeclValueOperator (op & ideValueOpType .~ t)
@@ -254,9 +298,12 @@ resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)
254 | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias =
298 | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias =
255 let k = getDeclarations mn
299 let k = getDeclarations mn
256 & mapMaybe (preview _IdeDeclType)
300 & mapMaybe (preview _IdeDeclType)
257− & filter (hasName ideTypeName properName)
301+ & filter (lensSatisfies ideTypeName (== properName))
258 & map (view ideTypeKind)
302 & map (view ideTypeKind)
259 & listToMaybe
303 & listToMaybe
260 in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)
304 in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)
261 resolveOperator x = x
305 resolveOperator x = x
308+mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b
309+mapIf p f = map (\x -> if p x then f x else x)