diff --git a/hls-gadt-plugin.cabal b/hls-gadt-plugin.cabal --- a/hls-gadt-plugin.cabal +++ b/hls-gadt-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-gadt-plugin -version: 1.0.0.0 +version: 1.0.1.0 synopsis: Convert to GADT syntax plugin description: Please see the README on GitHub at @@ -15,11 +15,11 @@ LICENSE test/testdata/*.hs +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server.git + library - if impl(ghc >= 9.3) - buildable: False - else - buildable: True exposed-modules: Ide.Plugin.GADT other-modules: Ide.Plugin.GHC @@ -30,10 +30,10 @@ , containers , extra , ghc - , ghcide ^>= 1.8 + , ghcide ^>= 1.9 , ghc-boot-th , ghc-exactprint - , hls-plugin-api ^>= 1.5 + , hls-plugin-api ^>= 1.6 , hls-refactor-plugin , lens , lsp >=1.2.0.1 @@ -50,10 +50,6 @@ default-extensions: DataKinds test-suite tests - if impl(ghc >= 9.3) - buildable: False - else - buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test @@ -63,7 +59,7 @@ , base , filepath , hls-gadt-plugin - , hls-test-utils ^>=1.4 + , hls-test-utils ^>=1.5 , lens , lsp , lsp-test diff --git a/src/Ide/Plugin/GADT.hs b/src/Ide/Plugin/GADT.hs --- a/src/Ide/Plugin/GADT.hs +++ b/src/Ide/Plugin/GADT.hs @@ -8,30 +8,26 @@ {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.GADT (descriptor) where -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.Except -import Data.Aeson (FromJSON, ToJSON, - Value (Null), toJSON) -import Data.Either.Extra (maybeToEither) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Text as T +import Data.Aeson (FromJSON, ToJSON, Value (Null), + toJSON) +import Data.Either.Extra (maybeToEither) +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Text as T import Development.IDE import Development.IDE.GHC.Compat -import Control.Monad.Trans.Except (throwE) -import Data.Maybe (mapMaybe) -import Development.IDE.GHC.Compat.Util (toList) -import Development.IDE.Spans.Pragmas (NextPragmaInfo, - getNextPragmaInfo, - insertNewPragma) -import GHC.Generics (Generic) -import GHC.LanguageExtensions.Type (Extension (GADTSyntax, GADTs)) +import Control.Monad.Trans.Except (throwE) +import Data.Maybe (mapMaybe) +import Development.IDE.Spans.Pragmas (getFirstPragma, insertNewPragma) +import GHC.Generics (Generic) import Ide.Plugin.GHC import Ide.PluginUtils import Ide.Types -import Language.LSP.Server (sendRequest) +import Language.LSP.Server (sendRequest) import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Types.Lens as L descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) @@ -52,20 +48,20 @@ -- | A command replaces H98 data decl with GADT decl in place toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams -toGADTCommand _ state ToGADTParams{..} = pluginResponse $ do +toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponse $ do nfp <- getNormalizedFilePath uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of [d] -> pure d _ -> throwE $ "Expected 1 declaration, but got " <> show (Prelude.length decls) - deps <- liftIO $ runAction "GADT.GhcSessionDeps" state $ use GhcSessionDeps nfp + deps <- liftIO $ runAction (T.unpack pId' <> ".GhcSessionDeps") state $ use GhcSessionDeps nfp (hsc_dflags . hscEnv -> df) <- liftEither $ maybeToEither "Get GhcSessionDeps failed" deps txt <- liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl range <- liftEither $ maybeToEither "Unable to get data decl range" $ srcSpanToRange $ locA ann - pragma <- getNextPragma state nfp + pragma <- getFirstPragma pId state nfp let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] _ <- lift $ sendRequest @@ -118,14 +114,5 @@ decls = filter isH98DataDecl $ mapMaybe getDataDecl $ filter (inRange range) hsDecls - exts = (toList . extensionFlags . ms_hspp_opts . pm_mod_summary) pm + exts = getExtensions pm pure (decls, exts) - --- Copy from hls-alternate-number-format-plugin -getNextPragma :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo -getNextPragma state nfp = handleMaybeM "Error: Could not get NextPragmaInfo" $ do - ghcSession <- liftIO $ runAction "GADT.GhcSession" state $ useWithStale GhcSession nfp - (_, fileContents) <- liftIO $ runAction "GADT.GetFileContents" state $ getFileContents nfp - case ghcSession of - Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents - Nothing -> pure Nothing diff --git a/src/Ide/Plugin/GHC.hs b/src/Ide/Plugin/GHC.hs --- a/src/Ide/Plugin/GHC.hs +++ b/src/Ide/Plugin/GHC.hs @@ -79,13 +79,13 @@ } x -> x --- | Convert H98 data constuctor to GADT data constructor +-- | Convert H98 data constructor to GADT data constructor h98ToGADTConDecl :: - LIdP GP -- ^Type constuctor name, - -- used for constucting final result type in GADT + LIdP GP -- ^Type constructor name, + -- used for constructing final result type in GADT -> LHsQTyVars GP -- ^Type variable names - -- used for constucting final result type in GADT + -- used for constructing final result type in GADT -> Maybe (LHsContext GP) -- ^Data type context -> ConDecl GP @@ -111,7 +111,12 @@ renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP renderDetails (PrefixCon _ args) = PrefixConGADT args renderDetails (InfixCon arg1 arg2) = PrefixConGADT [arg1, arg2] +#if MIN_VERSION_ghc(9,3,0) + renderDetails (RecCon recs) = RecConGADT recs noHsUniTok +#else renderDetails (RecCon recs) = RecConGADT recs +#endif + #else renderDetails (PrefixCon args) = PrefixCon args renderDetails (InfixCon arg1 arg2) = PrefixCon [arg1, arg2] @@ -185,7 +190,11 @@ adjustTyClD = \case Right (L _ (TyClD _ tycld)) -> Right $ adjustDataDecl tycld Right x -> Left $ "Expect TyClD but got " <> showAst x +#if MIN_VERSION_ghc(9,3,0) + Left err -> Left $ printWithoutUniques err +#else Left err -> Left $ show err +#endif adjustDataDecl DataDecl{..} = DataDecl { tcdDExt = adjustWhere tcdDExt @@ -203,7 +212,7 @@ where go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2)) - -- Adjust where annotation to the same line of the type constuctor + -- Adjust where annotation to the same line of the type constructor adjustWhere tcdDExt = tcdDExt <&> map (\(AddEpAnn ann l) -> if ann == AnnWhere @@ -237,7 +246,7 @@ | isConDeclGADTAnn key = adjustCon ann | otherwise = ann - -- Adjust where annotation to the same line of the type constuctor + -- Adjust where annotation to the same line of the type constructor adjustWhere Ann{..} = Ann { annsDP = annsDP <&> (\(keyword, dp) -> @@ -249,7 +258,7 @@ -- Make every data constructor start with a new line and 2 spaces -- - -- Here we can't force every GADT constuctor has (1, 2) + -- Here we can't force every GADT constructor has (1, 2) -- delta. For the first constructor with (1, 2), it prints -- a new line with 2 spaces, but for other constructors -- with (1, 2), it will print a new line with 4 spaces. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -15,8 +15,8 @@ main :: IO () main = defaultTestRunner tests -gadtPlugin :: PluginDescriptor IdeState -gadtPlugin = GADT.descriptor "GADT" +gadtPlugin :: PluginTestDescriptor () +gadtPlugin = mkPluginTestDescriptor' GADT.descriptor "GADT" tests :: TestTree tests = testGroup "GADT" @@ -32,16 +32,16 @@ , runTest "DataContext" "DataContext" 2 0 2 31 , runTest "DataContextParen" "DataContextParen" 2 0 3 6 , runTest "Forall" "Forall" 2 0 2 44 - , runTest "ConstuctorContext" "ConstructorContext" 2 0 2 38 + , runTest "ConstructorContext" "ConstructorContext" 2 0 2 38 , runTest "Context" "Context" 2 0 4 41 , runTest "Pragma" "Pragma" 2 0 3 29 - , onlyWorkForGhcVersions (==GHC92) "Single deriving has different output on ghc9.2" $ + , onlyWorkForGhcVersions (`elem`[GHC92, GHC94]) "Single deriving has different output on ghc9.2+" $ runTest "SingleDerivingGHC92" "SingleDerivingGHC92" 2 0 3 14 - , knownBrokenForGhcVersions [GHC92] "Single deriving has different output on ghc9.2" $ + , knownBrokenForGhcVersions [GHC92,GHC94] "Single deriving has different output on ghc9.2+" $ runTest "SingleDeriving" "SingleDeriving" 2 0 3 14 - , onlyWorkForGhcVersions (==GHC92) "only ghc-9.2 enabled GADTs pragma implicitly" $ + , onlyWorkForGhcVersions (`elem`[GHC92, GHC94]) "only ghc-9.2+ enabled GADTs pragma implicitly" $ gadtPragmaTest "ghc-9.2 don't need to insert GADTs pragma" False - , knownBrokenForGhcVersions [GHC92] "ghc-9.2 has enabled GADTs pragma implicitly" $ + , knownBrokenForGhcVersions [GHC92,GHC94] "ghc-9.2 has enabled GADTs pragma implicitly" $ gadtPragmaTest "insert pragma" True ]