e647963 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #2307 from kRITZCREEK/psc-ide-resolve-operator-types

e647963Phil Freeman10 years ago

purescript.cabal+1

compare with golang

unifiedsplit

@@ -521,5 +521,6 @@ test-suite tests

521 Language.PureScript.Ide.ReexportsSpec

522 Language.PureScript.Ide.SourceFile.IntegrationSpec

523 Language.PureScript.Ide.SourceFileSpec

524+ Language.PureScript.Ide.StateSpec

524 buildable: True

525 buildable: True

525 hs-source-dirs: tests

526 hs-source-dirs: tests

src/Language/PureScript/Ide/Externs.hs+8−6

@@ -87,17 +87,19 @@ convertOperator :: P.ExternsFixity -> IdeDeclaration

87convertOperator P.ExternsFixity{..} =

88 IdeValueOperator

89 efOperator

90− (toS (P.showQualified (either P.runIdent P.runProperName) efAlias))

90+ efAlias

91 efPrecedence

92 efAssociativity

93+ Nothing

94convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration

95convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration

95convertTypeOperator P.ExternsTypeFixity{..} =

96convertTypeOperator P.ExternsTypeFixity{..} =

96 IdeTypeOperator

97 IdeTypeOperator

97 efTypeOperator

98 efTypeOperator

98− (toS (P.showQualified P.runProperName efTypeAlias))

99+ efTypeAlias

99 efTypePrecedence

100 efTypePrecedence

100 efTypeAssociativity

101 efTypeAssociativity

102+ Nothing

101

103

102annotateModule

104annotateModule

103 :: (DefinitionSites P.SourceSpan, TypeAnnotations)

105 :: (DefinitionSites P.SourceSpan, TypeAnnotations)

@@ -118,10 +120,10 @@ annotateModule (defs, types) (moduleName, decls) =

118 annotateValue (runProperNameT i) (IdeDataConstructor i tn t)

120 annotateValue (runProperNameT i) (IdeDataConstructor i tn t)

119 IdeTypeClass i ->

121 IdeTypeClass i ->

120 annotateType (runProperNameT i) (IdeTypeClass i)

122 annotateType (runProperNameT i) (IdeTypeClass i)

121− IdeValueOperator n i p a ->

123+ IdeValueOperator n i p a t ->

122− annotateValue i (IdeValueOperator n i p a)

124+ annotateValue (valueOperatorAliasT i) (IdeValueOperator n i p a t)

123− IdeTypeOperator n i p a ->

125+ IdeTypeOperator n i p a k ->

124− annotateType i (IdeTypeOperator n i p a)

126+ annotateType (typeOperatorAliasT i) (IdeTypeOperator n i p a k)

125 where

127 where

126 annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs

128 annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs

127 , annTypeAnnotation = Map.lookup x types

129 , annTypeAnnotation = Map.lookup x types

src/Language/PureScript/Ide/Imports.hs+2−2

@@ -203,9 +203,9 @@ addExplicitImport' decl moduleName imports =

203 P.TypeRef tn (Just [n])

204 refFromDeclaration (IdeType n _) =

205 P.TypeRef n (Just [])

206− refFromDeclaration (IdeValueOperator op _ _ _) =

206+ refFromDeclaration (IdeValueOperator op _ _ _ _) =

207 P.ValueOpRef op

208− refFromDeclaration (IdeTypeOperator op _ _ _) =

208+ refFromDeclaration (IdeTypeOperator op _ _ _ _) =

209 P.TypeOpRef op

210 refFromDeclaration d =

211 P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)

src/Language/PureScript/Ide/Reexports.hs+2−2

@@ -91,9 +91,9 @@ resolveRef decls ref = case ref of

91 P.ValueRef i ->

92 findWrapped (\case IdeValue i' _ -> i' == i; _ -> False)

93 P.TypeOpRef name ->

94− findWrapped (\case IdeTypeOperator n _ _ _ -> n == name; _ -> False)

94+ findWrapped (\case IdeTypeOperator n _ _ _ _ -> n == name; _ -> False)

95 P.ValueOpRef name ->

96− findWrapped (\case IdeValueOperator n _ _ _ -> n == name; _ -> False)

96+ findWrapped (\case IdeValueOperator n _ _ _ _ -> n == name; _ -> False)

97 P.TypeClassRef name ->

98 findWrapped (\case IdeTypeClass n -> n == name; _ -> False)

99 _ ->

src/Language/PureScript/Ide/State.hs+84−16

@@ -28,6 +28,8 @@ module Language.PureScript.Ide.State

28 , populateStage2

29 , populateStage3

30 , populateStage3STM

31+ -- for tests

32+ , resolveOperatorsForModule

31 ) where

33 ) where

33import Protolude

35import Protolude

@@ -35,7 +37,8 @@ import qualified Prelude

36import Control.Concurrent.STM

38import Control.Concurrent.STM

37import "monad-logger" Control.Monad.Logger

39import "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

39import Language.PureScript.Externs

42import Language.PureScript.Externs

40import Language.PureScript.Ide.Externs

43import Language.PureScript.Ide.Externs

41import Language.PureScript.Ide.Reexports

44import Language.PureScript.Ide.Reexports

@@ -55,10 +58,10 @@ resetIdeState = do

56-- | Gets the loaded Modulenames

59-- | Gets the loaded Modulenames

57getLoadedModulenames :: Ide m => m [P.ModuleName]

60getLoadedModulenames :: Ide m => m [P.ModuleName]

58−getLoadedModulenames = M.keys <$> getExternFiles

61+getLoadedModulenames = Map.keys <$> getExternFiles

60-- | Gets all loaded ExternFiles

63-- | Gets all loaded ExternFiles

61−getExternFiles :: Ide m => m (M.Map P.ModuleName ExternsFile)

64+getExternFiles :: Ide m => m (Map P.ModuleName 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

@@ -72,7 +75,7 @@ insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM ()

72insertModuleSTM ref (fp, module') =

75insertModuleSTM ref (fp, module') =

73 modifyTVar ref $ \x ->

76 modifyTVar ref $ \x ->

74 x { ideStage1 = (ideStage1 x) {

77 x { ideStage1 = (ideStage1 x) {

75− s1Modules = M.insert

78+ s1Modules = Map.insert

76 (P.getModuleName module')

79 (P.getModuleName module')

77 (module', fp)

80 (module', fp)

78 (s1Modules (ideStage1 x))}}

81 (s1Modules (ideStage1 x))}}

@@ -126,17 +129,24 @@ getAllModules mmoduleName = do

126 declarations <- s3Declarations <$> getStage3

129 declarations <- s3Declarations <$> getStage3

127 rebuild <- cachedRebuild

130 rebuild <- cachedRebuild

128 case mmoduleName of

131 case mmoduleName of

129− Nothing -> pure (M.toList declarations)

132+ Nothing -> pure (Map.toList declarations)

130 Just moduleName ->

133 Just moduleName ->

131 case rebuild of

134 case rebuild of

132 Just (cachedModulename, ef)

135 Just (cachedModulename, ef)

133 | cachedModulename == moduleName -> do

136 | cachedModulename == moduleName -> do

134 (AstData asts) <- s2AstData <$> getStage2

137 (AstData asts) <- s2AstData <$> getStage2

138+ let

139+ ast =

135− let ast = fromMaybe (M.empty, M.empty) (M.lookup moduleName asts)

140+ fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)

136− pure . M.toList $

141+ cachedModule =

137− M.insert moduleName

138− (snd . annotateModule ast . fst . convertExterns $ ef) declarations

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)

139− _ -> pure (M.toList declarations)

149+ _ -> pure (Map.toList declarations)

140

150

141-- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the

151-- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the

142-- following Stages, which needs to be done after all the necessary Exterms have

152-- following Stages, which needs to be done after all the necessary Exterms have

@@ -151,7 +161,7 @@ insertExternsSTM :: TVar IdeState -> ExternsFile -> STM ()

151insertExternsSTM ref ef =

161insertExternsSTM ref ef =

152 modifyTVar ref $ \x ->

162 modifyTVar ref $ \x ->

153 x { ideStage1 = (ideStage1 x) {

163 x { ideStage1 = (ideStage1 x) {

154− s1Externs = M.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}

164+ s1Externs = Map.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}

155

165

156-- | Sets rebuild cache to the given ExternsFile

166-- | Sets rebuild cache to the given ExternsFile

157cacheRebuild :: Ide m => ExternsFile -> m ()

167cacheRebuild :: Ide m => ExternsFile -> m ()

@@ -202,12 +212,70 @@ populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]

202populateStage3STM ref = do

212populateStage3STM ref = do

203 externs <- s1Externs <$> getStage1STM ref

213 externs <- s1Externs <$> getStage1STM ref

204 (AstData asts) <- s2AstData <$> getStage2STM ref

214 (AstData asts) <- s2AstData <$> getStage2STM ref

205− let modules = M.map convertExterns externs

215+ let modules = Map.map convertExterns externs

206 nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])

216 nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])

207− nModules = M.mapWithKey

217+ nModules = Map.mapWithKey

208 (\moduleName (m, refs) ->

218 (\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

210 -- resolves reexports and discards load failures for now

220 -- resolves reexports and discards load failures for now

211− result = resolveReexports (M.map (snd . fst) nModules) <$> M.elems nModules

221+ result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules

222+ resultP = resolveOperators (Map.fromList (reResolved <$> result))

212− setStage3STM ref (Stage3 (M.fromList (map reResolved result)) Nothing)

223+ setStage3STM ref (Stage3 resultP Nothing)

213 pure result

224 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+2−2

@@ -36,8 +36,8 @@ data IdeDeclaration

36 | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type

37 | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type

38 | IdeTypeClass (P.ProperName 'P.ClassName)

39− | IdeValueOperator (P.OpName 'P.ValueOpName) 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) Text P.Precedence P.Associativity

40+ | IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind)

41 deriving (Show, Eq, Ord)

43data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration

src/Language/PureScript/Ide/Util.hs+18−6

@@ -24,6 +24,8 @@ module Language.PureScript.Ide.Util

24 , decodeT

25 , discardAnn

26 , withEmptyAnn

27+ , valueOperatorAliasT

28+ , typeOperatorAliasT

27 , module Language.PureScript.Ide.Conversions

29 , module Language.PureScript.Ide.Conversions

28 ) where

30 ) where

@@ -42,8 +44,8 @@ identifierFromIdeDeclaration d = case d of

42 IdeTypeSynonym name _ -> runProperNameT name

44 IdeTypeSynonym name _ -> runProperNameT name

43 IdeDataConstructor name _ _ -> runProperNameT name

45 IdeDataConstructor name _ _ -> runProperNameT name

44 IdeTypeClass name -> runProperNameT name

46 IdeTypeClass name -> runProperNameT name

45− IdeValueOperator op _ _ _ -> runOpNameT op

47+ IdeValueOperator op _ _ _ _ -> runOpNameT op

46− IdeTypeOperator op _ _ _ -> runOpNameT op

48+ IdeTypeOperator op _ _ _ _ -> runOpNameT op

48discardAnn :: IdeDeclarationAnn -> IdeDeclaration

50discardAnn :: IdeDeclarationAnn -> IdeDeclaration

49discardAnn (IdeDeclarationAnn _ d) = d

51discardAnn (IdeDeclarationAnn _ d) = d

@@ -64,10 +66,10 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =

64 IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind)

66 IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind)

65 IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type')

67 IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type')

66 IdeTypeClass name -> (runProperNameT name, "class")

68 IdeTypeClass name -> (runProperNameT name, "class")

67− IdeValueOperator op ref precedence associativity ->

69+ IdeValueOperator op ref precedence associativity typeP ->

68− (runOpNameT op, showFixity precedence associativity ref op)

70+ (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)

69− IdeTypeOperator op ref precedence associativity ->

71+ IdeTypeOperator op ref precedence associativity kind ->

70− (runOpNameT op, showFixity precedence associativity ref op)

72+ (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)

72 complModule = runModuleNameT m

74 complModule = runModuleNameT m

@@ -84,6 +86,16 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =

84 P.Infixr -> "infixr"

86 P.Infixr -> "infixr"

85 in T.unwords [asso, show p, r, "as", runOpNameT o]

87 in T.unwords [asso, show p, r, "as", runOpNameT o]

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+

87encodeT :: (ToJSON a) => a -> Text

99encodeT :: (ToJSON a) => a -> Text

88encodeT = toS . decodeUtf8 . encode

100encodeT = toS . decodeUtf8 . encode

101

tests/Language/PureScript/Ide/ImportsSpec.hs+1−1

@@ -70,7 +70,7 @@ spec = do

70 addValueImport i mn is =

71 prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is)

72 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)

74 addDtorImport i t mn is =

75 prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is)

76 it "adds an implicit unqualified import" $

tests/Language/PureScript/Ide/StateSpec.hsnew file+51

@@ -0,0 +1,51 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE NoImplicitPrelude #-}

3+module Language.PureScript.Ide.StateSpec where

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+1

@@ -11,4 +11,5 @@ main = do

11 s <- compileTestProject

12 unless s $ fail "Failed to compile .purs sources"

14+ quitServer -- shuts down any left over server (primarily happens during development)

14 withServer (hspec PscIdeSpec.spec)

15 withServer (hspec PscIdeSpec.spec)