Skip to content

Commit 9a5d4c9

Browse files
kritzcreekkritzcreek
committed
[psc-ide] look up types/kinds for operators
1 parent c993ec2 commit 9a5d4c9

10 files changed

Lines changed: 170 additions & 35 deletions

File tree

‎purescript.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -521,5 +521,6 @@ test-suite tests
521521
Language.PureScript.Ide.ReexportsSpec
522522
Language.PureScript.Ide.SourceFile.IntegrationSpec
523523
Language.PureScript.Ide.SourceFileSpec
524+
Language.PureScript.Ide.StateSpec
524525
buildable: True
525526
hs-source-dirs: tests

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

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -87,17 +87,19 @@ convertOperator :: P.ExternsFixity -> IdeDeclaration
8787
convertOperator P.ExternsFixity{..} =
8888
IdeValueOperator
8989
efOperator
90-
(toS (P.showQualified (either P.runIdent P.runProperName) efAlias))
90+
efAlias
9191
efPrecedence
9292
efAssociativity
93+
Nothing
9394

9495
convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration
9596
convertTypeOperator P.ExternsTypeFixity{..} =
9697
IdeTypeOperator
9798
efTypeOperator
98-
(toS (P.showQualified P.runProperName efTypeAlias))
99+
efTypeAlias
99100
efTypePrecedence
100101
efTypeAssociativity
102+
Nothing
101103

102104
annotateModule
103105
:: (DefinitionSites P.SourceSpan, TypeAnnotations)
@@ -118,10 +120,10 @@ annotateModule (defs, types) (moduleName, decls) =
118120
annotateValue (runProperNameT i) (IdeDataConstructor i tn t)
119121
IdeTypeClass i ->
120122
annotateType (runProperNameT i) (IdeTypeClass i)
121-
IdeValueOperator n i p a ->
122-
annotateValue i (IdeValueOperator n i p a)
123-
IdeTypeOperator n i p a ->
124-
annotateType i (IdeTypeOperator n i p a)
123+
IdeValueOperator n i p a t ->
124+
annotateValue (valueOperatorAliasT i) (IdeValueOperator n i p a t)
125+
IdeTypeOperator n i p a k ->
126+
annotateType (typeOperatorAliasT i) (IdeTypeOperator n i p a k)
125127
where
126128
annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs
127129
, annTypeAnnotation = Map.lookup x types

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -203,9 +203,9 @@ addExplicitImport' decl moduleName imports =
203203
P.TypeRef tn (Just [n])
204204
refFromDeclaration (IdeType n _) =
205205
P.TypeRef n (Just [])
206-
refFromDeclaration (IdeValueOperator op _ _ _) =
206+
refFromDeclaration (IdeValueOperator op _ _ _ _) =
207207
P.ValueOpRef op
208-
refFromDeclaration (IdeTypeOperator op _ _ _) =
208+
refFromDeclaration (IdeTypeOperator op _ _ _ _) =
209209
P.TypeOpRef op
210210
refFromDeclaration d =
211211
P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -91,9 +91,9 @@ resolveRef decls ref = case ref of
9191
P.ValueRef i ->
9292
findWrapped (\case IdeValue i' _ -> i' == i; _ -> False)
9393
P.TypeOpRef name ->
94-
findWrapped (\case IdeTypeOperator n _ _ _ -> n == name; _ -> False)
94+
findWrapped (\case IdeTypeOperator n _ _ _ _ -> n == name; _ -> False)
9595
P.ValueOpRef name ->
96-
findWrapped (\case IdeValueOperator n _ _ _ -> n == name; _ -> False)
96+
findWrapped (\case IdeValueOperator n _ _ _ _ -> n == name; _ -> False)
9797
P.TypeClassRef name ->
9898
findWrapped (\case IdeTypeClass n -> n == name; _ -> False)
9999
_ ->

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

Lines changed: 84 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -28,14 +28,17 @@ module Language.PureScript.Ide.State
2828
, populateStage2
2929
, populateStage3
3030
, populateStage3STM
31+
-- for tests
32+
, resolveOperatorsForModule
3133
) where
3234

3335
import Protolude
3436
import qualified Prelude
3537

3638
import Control.Concurrent.STM
3739
import "monad-logger" Control.Monad.Logger
38-
import qualified Data.Map.Lazy as M
40+
import qualified Data.Map.Lazy as Map
41+
import qualified Data.List as List
3942
import Language.PureScript.Externs
4043
import Language.PureScript.Ide.Externs
4144
import Language.PureScript.Ide.Reexports
@@ -55,10 +58,10 @@ resetIdeState = do
5558

5659
-- | Gets the loaded Modulenames
5760
getLoadedModulenames :: Ide m => m [P.ModuleName]
58-
getLoadedModulenames = M.keys <$> getExternFiles
61+
getLoadedModulenames = Map.keys <$> getExternFiles
5962

6063
-- | Gets all loaded ExternFiles
61-
getExternFiles :: Ide m => m (M.Map P.ModuleName ExternsFile)
64+
getExternFiles :: Ide m => m (Map P.ModuleName ExternsFile)
6265
getExternFiles = s1Externs <$> getStage1
6366

6467
-- | Insert a Module into Stage1 of the State
@@ -72,7 +75,7 @@ insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM ()
7275
insertModuleSTM ref (fp, module') =
7376
modifyTVar ref $ \x ->
7477
x { ideStage1 = (ideStage1 x) {
75-
s1Modules = M.insert
78+
s1Modules = Map.insert
7679
(P.getModuleName module')
7780
(module', fp)
7881
(s1Modules (ideStage1 x))}}
@@ -126,17 +129,24 @@ getAllModules mmoduleName = do
126129
declarations <- s3Declarations <$> getStage3
127130
rebuild <- cachedRebuild
128131
case mmoduleName of
129-
Nothing -> pure (M.toList declarations)
132+
Nothing -> pure (Map.toList declarations)
130133
Just moduleName ->
131134
case rebuild of
132135
Just (cachedModulename, ef)
133136
| cachedModulename == moduleName -> do
134137
(AstData asts) <- s2AstData <$> getStage2
135-
let ast = fromMaybe (M.empty, M.empty) (M.lookup moduleName asts)
136-
pure . M.toList $
137-
M.insert moduleName
138-
(snd . annotateModule ast . fst . convertExterns $ ef) declarations
139-
_ -> pure (M.toList declarations)
138+
let
139+
ast =
140+
fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
141+
cachedModule =
142+
snd . annotateModule ast . fst . convertExterns $ ef
143+
tmp =
144+
Map.insert moduleName cachedModule declarations
145+
resolved =
146+
Map.adjust (resolveOperatorsForModule tmp) moduleName tmp
147+
148+
pure (Map.toList resolved)
149+
_ -> pure (Map.toList declarations)
140150

141151
-- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the
142152
-- following Stages, which needs to be done after all the necessary Exterms have
@@ -151,7 +161,7 @@ insertExternsSTM :: TVar IdeState -> ExternsFile -> STM ()
151161
insertExternsSTM ref ef =
152162
modifyTVar ref $ \x ->
153163
x { ideStage1 = (ideStage1 x) {
154-
s1Externs = M.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}
164+
s1Externs = Map.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}
155165

156166
-- | Sets rebuild cache to the given ExternsFile
157167
cacheRebuild :: Ide m => ExternsFile -> m ()
@@ -202,12 +212,70 @@ populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]
202212
populateStage3STM ref = do
203213
externs <- s1Externs <$> getStage1STM ref
204214
(AstData asts) <- s2AstData <$> getStage2STM ref
205-
let modules = M.map convertExterns externs
215+
let modules = Map.map convertExterns externs
206216
nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])
207-
nModules = M.mapWithKey
217+
nModules = Map.mapWithKey
208218
(\moduleName (m, refs) ->
209-
(fromMaybe m $ annotateModule <$> M.lookup moduleName asts <*> pure m, refs)) modules
219+
(fromMaybe m $ annotateModule <$> Map.lookup moduleName asts <*> pure m, refs)) modules
210220
-- resolves reexports and discards load failures for now
211-
result = resolveReexports (M.map (snd . fst) nModules) <$> M.elems nModules
212-
setStage3STM ref (Stage3 (M.fromList (map reResolved result)) Nothing)
221+
result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules
222+
resultP = resolveOperators (Map.fromList (reResolved <$> result))
223+
setStage3STM ref (Stage3 resultP Nothing)
213224
pure result
225+
226+
resolveOperators
227+
:: Map P.ModuleName [IdeDeclarationAnn]
228+
-> Map P.ModuleName [IdeDeclarationAnn]
229+
resolveOperators modules =
230+
map (resolveOperatorsForModule modules) modules
231+
232+
-- | Looks up the types and kinds for operators and assigns them to their
233+
-- declarations
234+
resolveOperatorsForModule
235+
:: Map P.ModuleName [IdeDeclarationAnn]
236+
-> [IdeDeclarationAnn]
237+
-> [IdeDeclarationAnn]
238+
resolveOperatorsForModule modules = map (mapIdeDeclaration resolveOperator)
239+
where
240+
resolveOperator (IdeValueOperator
241+
opName
242+
i@(P.Qualified (Just moduleName)
243+
(Left ident)) precedence assoc _) =
244+
let t = do
245+
sourceModule <- Map.lookup moduleName modules
246+
IdeValue _ tP <-
247+
List.find (\case
248+
IdeValue iP _ -> iP == ident
249+
_ -> False) (discardAnn <$> sourceModule)
250+
pure tP
251+
252+
in IdeValueOperator opName i precedence assoc t
253+
resolveOperator (IdeValueOperator
254+
opName
255+
i@(P.Qualified (Just moduleName)
256+
(Right ctor)) precedence assoc _) =
257+
let t = do
258+
sourceModule <- Map.lookup moduleName modules
259+
IdeDataConstructor _ _ tP <-
260+
List.find (\case
261+
IdeDataConstructor cname _ _ -> ctor == cname
262+
_ -> False) (discardAnn <$> sourceModule)
263+
pure tP
264+
265+
in IdeValueOperator opName i precedence assoc t
266+
resolveOperator (IdeTypeOperator
267+
opName
268+
i@(P.Qualified (Just moduleName) properName) precedence assoc _) =
269+
let k = do
270+
sourceModule <- Map.lookup moduleName modules
271+
IdeType _ kP <-
272+
List.find (\case
273+
IdeType name _ -> name == properName
274+
_ -> False) (discardAnn <$> sourceModule)
275+
pure kP
276+
277+
in IdeTypeOperator opName i precedence assoc k
278+
resolveOperator x = x
279+
280+
mapIdeDeclaration :: (IdeDeclaration -> IdeDeclaration) -> IdeDeclarationAnn -> IdeDeclarationAnn
281+
mapIdeDeclaration f (IdeDeclarationAnn ann decl) = IdeDeclarationAnn ann (f decl)

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -36,8 +36,8 @@ data IdeDeclaration
3636
| IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type
3737
| IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type
3838
| IdeTypeClass (P.ProperName 'P.ClassName)
39-
| IdeValueOperator (P.OpName 'P.ValueOpName) Text P.Precedence P.Associativity
40-
| IdeTypeOperator (P.OpName 'P.TypeOpName) Text P.Precedence P.Associativity
39+
| IdeValueOperator (P.OpName 'P.ValueOpName) (P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))) P.Precedence P.Associativity (Maybe P.Type)
40+
| IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind)
4141
deriving (Show, Eq, Ord)
4242

4343
data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration

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

Lines changed: 18 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,8 @@ module Language.PureScript.Ide.Util
2424
, decodeT
2525
, discardAnn
2626
, withEmptyAnn
27+
, valueOperatorAliasT
28+
, typeOperatorAliasT
2729
, module Language.PureScript.Ide.Conversions
2830
) where
2931

@@ -42,8 +44,8 @@ identifierFromIdeDeclaration d = case d of
4244
IdeTypeSynonym name _ -> runProperNameT name
4345
IdeDataConstructor name _ _ -> runProperNameT name
4446
IdeTypeClass name -> runProperNameT name
45-
IdeValueOperator op _ _ _ -> runOpNameT op
46-
IdeTypeOperator op _ _ _ -> runOpNameT op
47+
IdeValueOperator op _ _ _ _ -> runOpNameT op
48+
IdeTypeOperator op _ _ _ _ -> runOpNameT op
4749

4850
discardAnn :: IdeDeclarationAnn -> IdeDeclaration
4951
discardAnn (IdeDeclarationAnn _ d) = d
@@ -64,10 +66,10 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
6466
IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind)
6567
IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type')
6668
IdeTypeClass name -> (runProperNameT name, "class")
67-
IdeValueOperator op ref precedence associativity ->
68-
(runOpNameT op, showFixity precedence associativity ref op)
69-
IdeTypeOperator op ref precedence associativity ->
70-
(runOpNameT op, showFixity precedence associativity ref op)
69+
IdeValueOperator op ref precedence associativity typeP ->
70+
(runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)
71+
IdeTypeOperator op ref precedence associativity kind ->
72+
(runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)
7173

7274
complModule = runModuleNameT m
7375

@@ -84,6 +86,16 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
8486
P.Infixr -> "infixr"
8587
in T.unwords [asso, show p, r, "as", runOpNameT o]
8688

89+
valueOperatorAliasT
90+
:: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text
91+
valueOperatorAliasT i =
92+
toS (P.showQualified (either P.runIdent P.runProperName) i)
93+
94+
typeOperatorAliasT
95+
:: P.Qualified (P.ProperName 'P.TypeName) -> Text
96+
typeOperatorAliasT i =
97+
toS (P.showQualified P.runProperName i)
98+
8799
encodeT :: (ToJSON a) => a -> Text
88100
encodeT = toS . decodeUtf8 . encode
89101

‎tests/Language/PureScript/Ide/ImportsSpec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -70,7 +70,7 @@ spec = do
7070
addValueImport i mn is =
7171
prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is)
7272
addOpImport op mn is =
73-
prettyPrintImportSection (addExplicitImport' (IdeValueOperator op "" 2 P.Infix) mn is)
73+
prettyPrintImportSection (addExplicitImport' (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing) mn is)
7474
addDtorImport i t mn is =
7575
prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is)
7676
it "adds an implicit unqualified import" $

‎tests/Language/PureScript/Ide/StateSpec.hs‎

Lines changed: 51 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,51 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE NoImplicitPrelude #-}
3+
module Language.PureScript.Ide.StateSpec where
4+
5+
import Protolude
6+
import Language.PureScript.Ide.Types
7+
import Language.PureScript.Ide.State
8+
import qualified Language.PureScript as P
9+
import Test.Hspec
10+
import qualified Data.Map as Map
11+
12+
valueOperator :: Maybe P.Type -> IdeDeclarationAnn
13+
valueOperator =
14+
d . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix
15+
16+
ctorOperator :: Maybe P.Type -> IdeDeclarationAnn
17+
ctorOperator =
18+
d . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix
19+
20+
typeOperator :: Maybe P.Kind -> IdeDeclarationAnn
21+
typeOperator =
22+
d . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix
23+
24+
testModule :: Module
25+
testModule = (mn "Test", [ d (IdeValue (P.Ident "function") P.REmpty)
26+
, d (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))
27+
, d (IdeType (P.ProperName "List") P.Star)
28+
, valueOperator Nothing
29+
, ctorOperator Nothing
30+
, typeOperator Nothing
31+
])
32+
33+
d :: IdeDeclaration -> IdeDeclarationAnn
34+
d = IdeDeclarationAnn emptyAnn
35+
36+
mn :: Text -> P.ModuleName
37+
mn = P.moduleNameFromString . toS
38+
39+
testState :: Map P.ModuleName [IdeDeclarationAnn]
40+
testState = Map.fromList
41+
[ testModule
42+
]
43+
44+
spec :: Spec
45+
spec = describe "resolving operators" $ do
46+
it "resolves the type for a value operator" $
47+
resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty))
48+
it "resolves the type for a constructor operator" $
49+
resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty))
50+
it "resolves the kind for a type operator" $
51+
resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.Star))

‎tests/TestPscIde.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,4 +11,5 @@ main = do
1111
s <- compileTestProject
1212
unless s $ fail "Failed to compile .purs sources"
1313

14+
quitServer -- shuts down any left over server (primarily happens during development)
1415
withServer (hspec PscIdeSpec.spec)

0 commit comments

Comments
 (0)