Skip to content

Commit 00331a1

Browse files
seastianseastian
committed
wip
1 parent c94b046 commit 00331a1

2 files changed

Lines changed: 295 additions & 0 deletions

File tree

‎src/Language/PureScript/Ide/ToI.hs‎

Lines changed: 292 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,292 @@
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 TypeApplications #-}
16+
17+
module Language.PureScript.Ide.ToI
18+
( toIdeDeclarationAnn
19+
-- for tests
20+
, resolveOperatorsForModule
21+
, resolveInstances
22+
, resolveDataConstructorsForModule
23+
) where
24+
25+
import Protolude hiding (moduleName, unzip)
26+
27+
import Control.Concurrent.STM (TVar, modifyTVar, readTVar, readTVarIO, writeTVar)
28+
import Control.Lens (Ixed(..), preview, view, (%~), (.~), (^.))
29+
import Data.IORef (readIORef, writeIORef)
30+
import Data.Map.Lazy qualified as Map
31+
import Data.Time.Clock (UTCTime)
32+
import Data.Zip (unzip)
33+
import Language.PureScript.Docs.Convert.Single (convertComments)
34+
import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..))
35+
import Language.PureScript.Ide.Externs (convertExterns)
36+
import Language.PureScript.Ide.SourceFile (extractAstInformation)
37+
import Language.PureScript.Ide.Types
38+
import Language.PureScript.Ide.Util (discardAnn, displayTimeSpec, logPerf, opNameT, properNameT, runLogger)
39+
import System.Directory (getModificationTime)
40+
import Database.SQLite.Simple qualified as SQLite
41+
import Debug.Trace qualified as Debug
42+
import Language.PureScript.AST.Declarations qualified as P
43+
import Language.PureScript.AST.SourcePos qualified as P
44+
import Language.PureScript.Names qualified as P
45+
import Language.PureScript.Comments qualified as P
46+
import Language.PureScript.Externs qualified as P
47+
import Language.PureScript.Ide.Reexports (resolveReexports)
48+
49+
50+
toI :: P.Module -> ExternsFile -> [IdeDeclarationAnn]
51+
toI m e = do
52+
let externs = Map.singleton (P.getModuleName m) e
53+
let modules = Map.singleton (P.getModuleName m) (m, "adfasd")
54+
let asts = map (extractAstInformation . fst) modules
55+
let (moduleDeclarations, reexportRefs) = unzip (Map.map convertExterns externs)
56+
results =
57+
moduleDeclarations
58+
& map resolveDataConstructorsForModule
59+
& resolveLocations asts
60+
& resolveDocumentation (map fst modules)
61+
& resolveInstances externs
62+
& resolveOperators
63+
& resolveReexports reexportRefs
64+
fromMaybe [] $ Map.lookup (P.getModuleName m) (map reResolved results)
65+
66+
toIdeDeclarationAnn :: P.Module -> ExternsFile -> [IdeDeclarationAnn]
67+
toIdeDeclarationAnn m e = results
68+
where
69+
asts = extractAstInformation m
70+
(moduleDeclarations, reexportRefs) = convertExterns e
71+
results =
72+
moduleDeclarations
73+
& resolveDataConstructorsForModule
74+
& resolveLocationsForModule asts
75+
& resolveDocumentationForModule m
76+
-- & resolveInstances externs
77+
-- & resolveOperators
78+
-- & resolveReexports reexportRefs
79+
80+
resolveLocations
81+
:: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)
82+
-> ModuleMap [IdeDeclarationAnn]
83+
-> ModuleMap [IdeDeclarationAnn]
84+
resolveLocations asts =
85+
Map.mapWithKey (\mn decls ->
86+
maybe decls (flip resolveLocationsForModule decls) (Map.lookup mn asts))
87+
88+
resolveLocationsForModule
89+
:: (DefinitionSites P.SourceSpan, TypeAnnotations)
90+
-> [IdeDeclarationAnn]
91+
-> [IdeDeclarationAnn]
92+
resolveLocationsForModule (defs, types) =
93+
map convertDeclaration
94+
where
95+
convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
96+
convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration'
97+
annotateFunction
98+
annotateValue
99+
annotateDataConstructor
100+
annotateType
101+
annotateType -- type classes live in the type namespace
102+
annotateModule
103+
d
104+
where
105+
annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs
106+
, _annTypeAnnotation = Map.lookup x types
107+
})
108+
annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs})
109+
annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs})
110+
annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs})
111+
annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs})
112+
113+
convertDeclaration'
114+
:: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn)
115+
-> (Text -> IdeDeclaration -> IdeDeclarationAnn)
116+
-> (Text -> IdeDeclaration -> IdeDeclarationAnn)
117+
-> (Text -> IdeDeclaration -> IdeDeclarationAnn)
118+
-> (Text -> IdeDeclaration -> IdeDeclarationAnn)
119+
-> (Text -> IdeDeclaration -> IdeDeclarationAnn)
120+
-> IdeDeclaration
121+
-> IdeDeclarationAnn
122+
convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateClass annotateModule d =
123+
case d of
124+
IdeDeclValue v ->
125+
annotateFunction (v ^. ideValueIdent) d
126+
IdeDeclType t ->
127+
annotateType (t ^. ideTypeName . properNameT) d
128+
IdeDeclTypeSynonym s ->
129+
annotateType (s ^. ideSynonymName . properNameT) d
130+
IdeDeclDataConstructor dtor ->
131+
annotateDataConstructor (dtor ^. ideDtorName . properNameT) d
132+
IdeDeclTypeClass tc ->
133+
annotateClass (tc ^. ideTCName . properNameT) d
134+
IdeDeclValueOperator operator ->
135+
annotateValue (operator ^. ideValueOpName . opNameT) d
136+
IdeDeclTypeOperator operator ->
137+
annotateType (operator ^. ideTypeOpName . opNameT) d
138+
IdeDeclModule mn ->
139+
annotateModule (P.runModuleName mn) d
140+
141+
resolveDocumentation
142+
:: ModuleMap P.Module
143+
-> ModuleMap [IdeDeclarationAnn]
144+
-> ModuleMap [IdeDeclarationAnn]
145+
resolveDocumentation modules =
146+
Map.mapWithKey (\mn decls ->
147+
maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules))
148+
149+
resolveDocumentationForModule
150+
:: P.Module
151+
-> [IdeDeclarationAnn]
152+
-> [IdeDeclarationAnn]
153+
resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) =
154+
map convertDecl
155+
where
156+
extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])]
157+
extractDeclComments = \case
158+
P.DataDeclaration (_, cs) _ ctorName _ ctors ->
159+
(P.TyName ctorName, cs) : map dtorComments ctors
160+
P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members ->
161+
(P.TyClassName tyClassName, cs) : concatMap extractDeclComments members
162+
decl ->
163+
maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl)
164+
165+
comments :: Map P.Name [P.Comment]
166+
comments = Map.insert (P.ModName moduleName) moduleComments $
167+
Map.fromListWith (flip (<>)) $ concatMap extractDeclComments sdecls
168+
169+
dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment])
170+
dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd))
171+
172+
name :: P.Declaration -> Maybe P.Name
173+
name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d
174+
name decl = P.declName decl
175+
176+
convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn
177+
convertDecl (IdeDeclarationAnn ann d) =
178+
convertDeclaration'
179+
(annotateValue . P.IdentName)
180+
(annotateValue . P.IdentName . P.Ident)
181+
(annotateValue . P.DctorName . P.ProperName)
182+
(annotateValue . P.TyName . P.ProperName)
183+
(annotateValue . P.TyClassName . P.ProperName)
184+
(annotateValue . P.ModName . P.moduleNameFromString)
185+
d
186+
where
187+
docs :: P.Name -> Text
188+
docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments
189+
190+
annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident })
191+
192+
resolveInstances
193+
:: ModuleMap P.ExternsFile
194+
-> ModuleMap [IdeDeclarationAnn]
195+
-> ModuleMap [IdeDeclarationAnn]
196+
resolveInstances externs declarations =
197+
Map.foldr (flip (foldr go)) declarations
198+
. Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef))
199+
$ externs
200+
where
201+
extractInstances mn P.EDInstance{..} =
202+
case edInstanceClassName of
203+
P.Qualified (P.ByModuleName classModule) className ->
204+
Just (IdeInstance mn
205+
edInstanceName
206+
edInstanceTypes
207+
edInstanceConstraints, classModule, className)
208+
_ -> Nothing
209+
extractInstances _ _ = Nothing
210+
211+
go
212+
:: (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName)
213+
-> ModuleMap [IdeDeclarationAnn]
214+
-> ModuleMap [IdeDeclarationAnn]
215+
go (ideInstance, classModule, className) acc' =
216+
let
217+
matchTC =
218+
anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className)
219+
updateDeclaration =
220+
mapIf matchTC (idaDeclaration
221+
. _IdeDeclTypeClass
222+
. ideTCInstances
223+
%~ (ideInstance :))
224+
in
225+
acc' & ix classModule %~ updateDeclaration
226+
227+
resolveOperators
228+
:: ModuleMap [IdeDeclarationAnn]
229+
-> ModuleMap [IdeDeclarationAnn]
230+
resolveOperators modules =
231+
map (resolveOperatorsForModule modules) modules
232+
233+
-- | Looks up the types and kinds for operators and assigns them to their
234+
-- declarations
235+
resolveOperatorsForModule
236+
:: ModuleMap [IdeDeclarationAnn]
237+
-> [IdeDeclarationAnn]
238+
-> [IdeDeclarationAnn]
239+
resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator)
240+
where
241+
getDeclarations :: P.ModuleName -> [IdeDeclaration]
242+
getDeclarations moduleName =
243+
Map.lookup moduleName modules
244+
& foldMap (map discardAnn)
245+
246+
resolveOperator (IdeDeclValueOperator op)
247+
| (P.Qualified (P.ByModuleName mn) (Left ident)) <- op ^. ideValueOpAlias =
248+
let t = getDeclarations mn
249+
& mapMaybe (preview _IdeDeclValue)
250+
& filter (anyOf ideValueIdent (== ident))
251+
& map (view ideValueType)
252+
& listToMaybe
253+
in IdeDeclValueOperator (op & ideValueOpType .~ t)
254+
| (P.Qualified (P.ByModuleName mn) (Right dtor)) <- op ^. ideValueOpAlias =
255+
let t = getDeclarations mn
256+
& mapMaybe (preview _IdeDeclDataConstructor)
257+
& filter (anyOf ideDtorName (== dtor))
258+
& map (view ideDtorType)
259+
& listToMaybe
260+
in IdeDeclValueOperator (op & ideValueOpType .~ t)
261+
resolveOperator (IdeDeclTypeOperator op)
262+
| P.Qualified (P.ByModuleName mn) properName <- op ^. ideTypeOpAlias =
263+
let k = getDeclarations mn
264+
& mapMaybe (preview _IdeDeclType)
265+
& filter (anyOf ideTypeName (== properName))
266+
& map (view ideTypeKind)
267+
& listToMaybe
268+
in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)
269+
resolveOperator x = x
270+
271+
272+
mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b
273+
mapIf p f = map (\x -> if p x then f x else x)
274+
275+
resolveDataConstructorsForModule
276+
:: [IdeDeclarationAnn]
277+
-> [IdeDeclarationAnn]
278+
resolveDataConstructorsForModule decls =
279+
map (idaDeclaration %~ resolveDataConstructors) decls
280+
where
281+
resolveDataConstructors :: IdeDeclaration -> IdeDeclaration
282+
resolveDataConstructors decl = case decl of
283+
IdeDeclType ty ->
284+
IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty ^. ideTypeName) dtors))
285+
_ ->
286+
decl
287+
288+
dtors =
289+
decls
290+
& mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor))
291+
& foldr (\(IdeDataConstructor name typeName type') ->
292+
Map.insertWith (<>) typeName [(name, type')]) Map.empty

‎src/Language/PureScript/Make/IdeCache.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@ module Language.PureScript.Make.IdeCache where
22

33
import Prelude
44

5+
import Language.PureScript.Ide.ToI (toI)
56
import Language.PureScript.Ide.ToIde (toIdeDeclarationAnn)
67
import Database.SQLite.Simple (NamedParam(..))
78
import Database.SQLite.Simple qualified as SQLite
@@ -50,6 +51,8 @@ sqliteExtern outputDir m docs extern = liftIO $ do
5051
, ":dependency" := runModuleName (eiModule i)
5152
])
5253

54+
toI
55+
5356
for_ (toIdeDeclarationAnn m extern) (\ideDeclaration -> do
5457
withRetry $ SQLite.executeNamed conn
5558
("INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, span, declaration) " <>

0 commit comments

Comments
 (0)