hls-gadt-plugin (empty) → 1.0.0.0
raw patch · 37 files changed
+919/−0 lines, 37 filesdep +aesondep +basedep +containers
Dependencies added: aeson, base, containers, extra, filepath, ghc, ghc-boot-th, ghc-exactprint, ghcide, hls-gadt-plugin, hls-plugin-api, hls-refactor-plugin, hls-test-utils, lens, lsp, lsp-test, mtl, text, transformers, unordered-containers
Files
- LICENSE +201/−0
- hls-gadt-plugin.cabal +70/−0
- src/Ide/Plugin/GADT.hs +131/−0
- src/Ide/Plugin/GHC.hs +305/−0
- test/Main.hs +81/−0
- test/testdata/ConstructorContext.expected.hs +4/−0
- test/testdata/ConstructorContext.hs +3/−0
- test/testdata/Context.expected.hs +5/−0
- test/testdata/Context.hs +5/−0
- test/testdata/Data.expected.hs +5/−0
- test/testdata/Data.hs +3/−0
- test/testdata/DataContext.expected.hs +5/−0
- test/testdata/DataContext.hs +3/−0
- test/testdata/DataContextParen.expected.hs +4/−0
- test/testdata/DataContextParen.hs +4/−0
- test/testdata/Deriving.expected.hs +6/−0
- test/testdata/Deriving.hs +3/−0
- test/testdata/Forall.expected.hs +4/−0
- test/testdata/Forall.hs +3/−0
- test/testdata/Infix.expected.hs +5/−0
- test/testdata/Infix.hs +3/−0
- test/testdata/Newtype.expected.hs +4/−0
- test/testdata/Newtype.hs +3/−0
- test/testdata/Pragma.expected.hs +5/−0
- test/testdata/Pragma.hs +4/−0
- test/testdata/Record.expected.hs +4/−0
- test/testdata/Record.hs +6/−0
- test/testdata/SimpleData.expected.hs +4/−0
- test/testdata/SimpleData.hs +3/−0
- test/testdata/SimpleNewtype.expected.hs +4/−0
- test/testdata/SimpleNewtype.hs +3/−0
- test/testdata/SingleDeriving.expected.hs +5/−0
- test/testdata/SingleDeriving.hs +4/−0
- test/testdata/SingleDerivingGHC92.expected.hs +5/−0
- test/testdata/SingleDerivingGHC92.hs +4/−0
- test/testdata/TypeVariable.expected.hs +5/−0
- test/testdata/TypeVariable.hs +3/−0
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ hls-gadt-plugin.cabal view
@@ -0,0 +1,70 @@+cabal-version: 2.4+name: hls-gadt-plugin+version: 1.0.0.0+synopsis: Convert to GADT syntax plugin+description:+ Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/plugins/hls-gadt-plugin#readme>++license: Apache-2.0+license-file: LICENSE+author: Lei Zhu+maintainer: julytreee@gmail.com+category: Development+build-type: Simple+extra-source-files:+ LICENSE+ test/testdata/*.hs++library+ if impl(ghc >= 9.3)+ buildable: False+ else+ buildable: True+ exposed-modules: Ide.Plugin.GADT+ other-modules: Ide.Plugin.GHC++ hs-source-dirs: src+ build-depends:+ , aeson+ , base >=4.12 && <5+ , containers+ , extra+ , ghc+ , ghcide ^>= 1.8+ , ghc-boot-th+ , ghc-exactprint+ , hls-plugin-api ^>= 1.5+ , hls-refactor-plugin+ , lens+ , lsp >=1.2.0.1+ , mtl+ , text+ , transformers+ , unordered-containers++ ghc-options:+ -Wall+ -Wno-name-shadowing+ -Wno-unticked-promoted-constructors+ default-language: Haskell2010+ 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+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ , base+ , filepath+ , hls-gadt-plugin+ , hls-test-utils ^>=1.4+ , lens+ , lsp+ , lsp-test+ , text
+ src/Ide/Plugin/GADT.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+module Ide.Plugin.GADT (descriptor) where++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 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 Ide.Plugin.GHC+import Ide.PluginUtils+import Ide.Types+import Language.LSP.Server (sendRequest)+import Language.LSP.Types+import qualified Language.LSP.Types.Lens as L++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId = (defaultPluginDescriptor plId)+ { Ide.Types.pluginHandlers =+ mkPluginHandler STextDocumentCodeAction codeActionHandler+ , pluginCommands =+ [PluginCommand toGADTSyntaxCommandId "convert data decl to GADT syntax" (toGADTCommand plId)]+ }++-- | Parameter used in the command+data ToGADTParams = ToGADTParams+ { uri :: Uri+ , range :: Range+ } deriving (Generic, ToJSON, FromJSON)++toGADTSyntaxCommandId :: CommandId+toGADTSyntaxCommandId = "GADT.toGADT"++-- | A command replaces H98 data decl with GADT decl in place+toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams+toGADTCommand _ 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+ (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+ let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]]++ _ <- lift $ sendRequest+ SWorkspaceApplyEdit+ (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit)))+ (\_ -> pure ())++ pure Null+ where+ workSpaceEdit nfp edits = WorkspaceEdit+ (pure $ HashMap.fromList+ [(filePathToUri $ fromNormalizedFilePath nfp,+ List edits)])+ Nothing Nothing++codeActionHandler :: PluginMethodHandler IdeState TextDocumentCodeAction+codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponse $ do+ nfp <- getNormalizedFilePath (doc ^. L.uri)+ (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp+ let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls+ pure $ List actions+ where+ mkAction :: T.Text -> Command |? CodeAction+ mkAction name = InR CodeAction{..}+ where+ _title = "Convert \"" <> name <> "\" to GADT syntax"+ _kind = Just CodeActionRefactorRewrite+ _diagnostics = Nothing+ _isPreferred = Nothing+ _disabled = Nothing+ _edit = Nothing+ _command = Just+ $ mkLspCommand plId toGADTSyntaxCommandId _title (Just [toJSON mkParam])+ _xdata = Nothing++ mkParam = ToGADTParams (doc ^. L.uri) range++-- | Get all H98 decls in the given range, and enabled extensions+getInRangeH98DeclsAndExts :: (MonadIO m) =>+ IdeState+ -> Range+ -> NormalizedFilePath+ -> ExceptT String m ([LTyClDecl GP], [Extension])+getInRangeH98DeclsAndExts state range nfp = do+ pm <- handleMaybeM "Unable to get ParsedModuleWithComments"+ $ liftIO+ $ runAction "GADT.GetParsedModuleWithComments" state+ $ use GetParsedModuleWithComments nfp+ let (L _ hsDecls) = hsmodDecls <$> pm_parsed_source pm+ decls = filter isH98DataDecl+ $ mapMaybe getDataDecl+ $ filter (inRange range) hsDecls+ exts = (toList . extensionFlags . ms_hspp_opts . pm_mod_summary) 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
+ src/Ide/Plugin/GHC.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}+module Ide.Plugin.GHC where++import Data.Functor ((<&>))+import Data.List.Extra (stripInfix)+import qualified Data.Text as T+import Development.IDE+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.ExactPrint+import Ide.PluginUtils (subRange)+import Language.Haskell.GHC.ExactPrint.Parsers (parseDecl)++#if MIN_VERSION_ghc(9,2,1)+import GHC.Parser.Annotation (AddEpAnn (..),+ Anchor (Anchor),+ AnchorOperation (MovedAnchor),+ DeltaPos (..),+ EpAnn (..),+ EpAnnComments (EpaComments),+ EpaLocation (EpaDelta),+ SrcSpanAnn' (SrcSpanAnn),+ spanAsAnchor)+import Language.Haskell.GHC.ExactPrint (showAst)+#else+import qualified Data.Map.Lazy as Map+import Language.Haskell.GHC.ExactPrint.Types (AnnConName (CN),+ AnnKey (AnnKey),+ Annotation (..),+ DeltaPos (DP),+ KeywordId (G),+ deltaColumn)+#endif++type GP = GhcPass Parsed++-- | Check if a given range is in the range of located item+inRange :: HasSrcSpan a => Range -> a -> Bool+inRange range s = maybe False (subRange range) (srcSpanToRange (getLoc s))++-- | Get data decl and its location+getDataDecl :: LHsDecl GP -> Maybe (LTyClDecl GP)+getDataDecl (L l (TyClD _ d@DataDecl{})) = Just (L l d)+getDataDecl _ = Nothing++isConDeclH98 :: ConDecl GP -> Bool+isConDeclH98 ConDeclH98{} = True+isConDeclH98 _ = False++isH98DataDecl :: LTyClDecl GP -> Bool+isH98DataDecl (L _ decl@DataDecl{}) =+ any (isConDeclH98 . (\(L _ r) -> r)) (dd_cons $ tcdDataDefn decl)+isH98DataDecl _ = False++-- | Convert H98 data type definition to GADT's+h98ToGADTDecl :: TyClDecl GP -> TyClDecl GP+h98ToGADTDecl = \case+ DataDecl{..} -> DataDecl+ { tcdDataDefn = updateDefn tcdLName tcdTyVars tcdDataDefn+ , ..+ }+ x -> x+ where+ updateDefn dataName tyVars = \case+ HsDataDefn{..} -> HsDataDefn+ { dd_cons =+ mapX (h98ToGADTConDecl dataName tyVars (wrapCtxt dd_ctxt)) <$> dd_cons+ , dd_ctxt = emptyCtxt -- Context can't appear at the data name in GADT+ , ..+ }+ x -> x++-- | Convert H98 data constuctor to GADT data constructor+h98ToGADTConDecl ::+ LIdP GP -- ^Type constuctor name,+ -- used for constucting final result type in GADT+ -> LHsQTyVars GP+ -- ^Type variable names+ -- used for constucting final result type in GADT+ -> Maybe (LHsContext GP)+ -- ^Data type context+ -> ConDecl GP+ -> ConDecl GP+h98ToGADTConDecl dataName tyVars ctxt = \case+ ConDeclH98{..} ->+ ConDeclGADT+ con_ext+ [con_name]+#if !MIN_VERSION_ghc(9,2,1)+ con_forall+#endif+ -- Ignore all existential type variable since GADT not needed+ implicitTyVars+ (mergeContext ctxt con_mb_cxt)+ (renderDetails con_args)+ renderResultTy+ con_doc+ x -> x+ where+ -- Parameters in the data constructor+#if MIN_VERSION_ghc(9,2,1)+ renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP+ renderDetails (PrefixCon _ args) = PrefixConGADT args+ renderDetails (InfixCon arg1 arg2) = PrefixConGADT [arg1, arg2]+ renderDetails (RecCon recs) = RecConGADT recs+#else+ renderDetails (PrefixCon args) = PrefixCon args+ renderDetails (InfixCon arg1 arg2) = PrefixCon [arg1, arg2]+ renderDetails (RecCon recs) = RecCon recs+#endif++ -- | Construct GADT result type+ renderResultTy :: LHsType GP+ renderResultTy = case tyVars of+ -- Without type variable+ HsQTvs _ [] -> wrappedDataName+ -- With type variable+ HsQTvs _ vars -> foldl go wrappedDataName vars+ _ -> wrappedDataName+ where+ wrappedDataName = wrap (HsTyVar noUsed NotPromoted dataName)++ -- Bundle data name with type vars by `HsAppTy`+ go acc (L _(UserTyVar' var)) =+ wrap+ (HsAppTy noExtField acc+ (wrap (HsTyVar noUsed NotPromoted var)))+ go acc _ = acc++ -- Merge data type context and constructor type context+ mergeContext :: Maybe (LHsContext GP) -> Maybe (LHsContext GP) -> Maybe (LHsContext GP)+ mergeContext ctxt1 ctxt2 =+ (wrap . map wrap) . map unParTy+ <$> (getContextType ctxt1 <> getContextType ctxt2)+ where+ getContextType :: Maybe (LHsContext GP) -> Maybe [HsType GP]+ getContextType ctxt = map unWrap . unWrap <$> ctxt++ -- Unparen the outmost, it only occurs at the outmost+ -- for a valid type.+ --+ -- Note for context paren rule:+ --+ -- If only one element, it __can__ have a paren type.+ -- If not, there can't have a parent type.+ unParTy :: HsType GP -> HsType GP+ unParTy (HsParTy _ ty) = unWrap ty+ unParTy x = x+{- |+We use `printOutputable` to print H98 data decl as GADT syntax,+this print is not perfect, it will:++1. Make data name and the `where` key word in different lines.+2. Make the whole data decl prints in one line if there is only one data constructor.+3. The ident size of every data constructor depends on its origin+ format, and may have different ident size between constructors.++Hence, we first use `printOutputable` to get an initial GADT syntax,+then use `ghc-exactprint` to parse the initial result, and finally+adjust the details that mentioned above.++The adjustment includes:++1. Make the `where` key word at the same line of data name.+2. Remove the extra blank line caused by adjustment of `where`.+3. Make every data constructor start with a new line and 2 spaces+-}+prettyGADTDecl :: DynFlags -> TyClDecl GP -> Either String String+#if MIN_VERSION_ghc(9,2,1)+prettyGADTDecl df decl =+ let old = printOutputable decl+ hsDecl = parseDecl df "unused" (T.unpack old)+ tycld = adjustTyClD hsDecl+ in removeExtraEmptyLine . exactPrint <$> tycld+ where+ adjustTyClD = \case+ Right (L _ (TyClD _ tycld)) -> Right $ adjustDataDecl tycld+ Right x -> Left $ "Expect TyClD but got " <> showAst x+ Left err -> Left $ show err++ adjustDataDecl DataDecl{..} = DataDecl+ { tcdDExt = adjustWhere tcdDExt+ , tcdDataDefn = tcdDataDefn+ { dd_cons = map adjustCon (dd_cons tcdDataDefn)+ }+ , ..+ }+ adjustDataDecl x = x++ -- Make every data constructor start with a new line and 2 spaces+ adjustCon :: LConDecl GP -> LConDecl GP+ adjustCon (L (SrcSpanAnn _ loc) r) =+ L (SrcSpanAnn (EpAnn (go (spanAsAnchor loc)) (AnnListItem []) (EpaComments [])) loc) r+ where+ go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2))++ -- Adjust where annotation to the same line of the type constuctor+ adjustWhere tcdDExt = tcdDExt <&> map+ (\(AddEpAnn ann l) ->+ if ann == AnnWhere+ then AddEpAnn AnnWhere (EpaDelta (SameLine 1) [])+ else AddEpAnn ann l+ )++ -- Remove the first extra line if exist+ removeExtraEmptyLine s = case stripInfix "\n\n" s of+ Just (x, xs) -> x <> "\n" <> xs+ Nothing -> s+#else+prettyGADTDecl df decl =+ let old = printOutputable decl+ hsDecl = parseDecl df "unused" (T.unpack old)+ tycld = adjustTyClD hsDecl+ in removeExtraEmptyLine . uncurry (flip exactPrint) <$> tycld+ where+ adjustTyClD = \case+ Right (anns, t@(L _ (TyClD _ _))) -> Right (adjustDataDeclAnns anns, t)+ Right _ -> Left "Expect TyClD"+ Left err -> Left $ show err++ adjustDataDeclAnns = Map.mapWithKey go+ where+ isDataDeclAnn (AnnKey _ (CN name)) = name == "DataDecl"+ isConDeclGADTAnn (AnnKey _ (CN name)) = name == "ConDeclGADT"++ go key ann+ | isDataDeclAnn key = adjustWhere ann+ | isConDeclGADTAnn key = adjustCon ann+ | otherwise = ann++ -- Adjust where annotation to the same line of the type constuctor+ adjustWhere Ann{..} = Ann+ { annsDP = annsDP <&>+ (\(keyword, dp) ->+ if keyword == G AnnWhere+ then (keyword, DP (0, 1))+ else (keyword, dp))+ , ..+ }++ -- Make every data constructor start with a new line and 2 spaces+ --+ -- Here we can't force every GADT constuctor 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.+ --+ -- The original ann parsed with `praseDecl` shows the first+ -- constructor has (1, 4) delta, but others have (1, 0).+ -- Hence, the following code only deal with the first+ -- constructor.+ adjustCon Ann{..} = let c = deltaColumn annEntryDelta+ in Ann+ { annEntryDelta = DP $ (1,) $ if c > 0 then 2 else 0+ , ..+ }++ -- Remove the first extra line if exist+ removeExtraEmptyLine s = case stripInfix "\n\n" s of+ Just (x, xs) -> x <> "\n" <> xs+ Nothing -> s++#endif++#if MIN_VERSION_ghc(9,2,1)+wrap :: forall a. WrapXRec GP a => a -> XRec GP a+wrap = wrapXRec @GP+wrapCtxt = id+emptyCtxt = Nothing+unWrap = unXRec @GP+mapX = mapXRec @GP+noUsed = EpAnnNotUsed+#else+wrapCtxt = Just+wrap = L noSrcSpan+emptyCtxt = wrap []+unWrap (L _ r) = r+mapX = fmap+noUsed = noExtField+#endif++#if MIN_VERSION_ghc(9,0,1)+pattern UserTyVar' :: LIdP pass -> HsTyVarBndr flag pass+pattern UserTyVar' s <- UserTyVar _ _ s+#else+pattern UserTyVar' :: LIdP pass -> HsTyVarBndr pass+pattern UserTyVar' s <- UserTyVar _ s+#endif++#if MIN_VERSION_ghc(9,2,1)+implicitTyVars = (wrapXRec @GP mkHsOuterImplicit)+#elif MIN_VERSION_ghc(9,0,1)+implicitTyVars = []+#else+implicitTyVars = HsQTvs noExtField []+#endif
+ test/Main.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wall #-}++module Main where++import Control.Monad (void)+import Data.Either (rights)+import qualified Data.Text as T+import qualified Ide.Plugin.GADT as GADT+import System.FilePath ((</>))+import Test.Hls++main :: IO ()+main = defaultTestRunner tests++gadtPlugin :: PluginDescriptor IdeState+gadtPlugin = GADT.descriptor "GADT"++tests :: TestTree+tests = testGroup "GADT"+ [ runTest "range" "SimpleData" 2 0 2 1+ , runTest "SimpleData" "SimpleData" 2 0 2 10+ , runTest "SimpleNewtype" "SimpleNewtype" 2 0 2 17+ , runTest "Data" "Data" 2 0 2 36+ , runTest "Newtype" "Newtype" 2 0 2 21+ , runTest "Deriving" "Deriving" 2 0 2 56+ , runTest "Infix" "Infix" 2 0 2 35+ , runTest "Record" "Record" 2 0 5 1+ , runTest "TypeVariable" "TypeVariable" 2 0 2 32+ , 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 "Context" "Context" 2 0 4 41+ , runTest "Pragma" "Pragma" 2 0 3 29+ , onlyWorkForGhcVersions (==GHC92) "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" $+ runTest "SingleDeriving" "SingleDeriving" 2 0 3 14+ , onlyWorkForGhcVersions (==GHC92) "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" $+ gadtPragmaTest "insert pragma" True+ ]++gadtPragmaTest :: TestName -> Bool -> TestTree+gadtPragmaTest title hasGADT = testCase title+ $ withCanonicalTempDir+ $ \dir -> runSessionWithServer gadtPlugin dir $ do+ doc <- createDoc "A.hs" "haskell" (T.unlines ["module A where", "data Foo = Bar"])+ _ <- waitForProgressDone+ (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position 1 0) (Position 1 1))+ executeCodeAction act+ let expected = T.unlines $+ ["{-# LANGUAGE GADTs #-}" | hasGADT] +++ ["module A where", "data Foo where", " Bar :: Foo"]+ contents <- skipManyTill anyMessage (getDocumentEdit doc)+ liftIO $ contents @?= expected++runTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree+runTest title fp x1 y1 x2 y2 =+ goldenWithHaskellDoc gadtPlugin title testDataDir fp "expected" "hs" $ \doc -> do+ _ <- waitForProgressDone+ (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position x1 y1) (Position x2 y2))+ executeCodeAction act+ void $ skipManyTill anyMessage (getDocumentEdit doc)++findGADTAction :: [a |? CodeAction] -> [CodeAction]+findGADTAction = filter isGADTCodeAction . rights . map toEither++isGADTCodeAction :: CodeAction -> Bool+isGADTCodeAction CodeAction{..} = case _kind of+ Nothing -> False+ Just kind -> case kind of+ CodeActionRefactorRewrite -> True+ _ -> False++testDataDir :: FilePath+testDataDir = "test" </> "testdata"
+ test/testdata/ConstructorContext.expected.hs view
@@ -0,0 +1,4 @@+module ConstructorContext where++data Foo where+ Bar :: Show a => a -> Foo
+ test/testdata/ConstructorContext.hs view
@@ -0,0 +1,3 @@+module ConstructorContext where++data Foo = forall a. (Show a) => Bar a
+ test/testdata/Context.expected.hs view
@@ -0,0 +1,5 @@+module Context where++data Foo a where+ Bar :: (Eq a, Show b, Show a) => a -> b -> Foo a+ Baz :: (Eq a, Show c) => c -> c -> Foo a
+ test/testdata/Context.hs view
@@ -0,0 +1,5 @@+module Context where++data (Eq a) => Foo a =+ forall b c. (Show b, Show a) =>+ Bar a b | forall c. (Show c) => Baz c c
+ test/testdata/Data.expected.hs view
@@ -0,0 +1,5 @@+module Data where++data Foo where+ Bar :: Int -> Foo+ Baz :: Char -> String -> Foo
+ test/testdata/Data.hs view
@@ -0,0 +1,3 @@+module Data where++data Foo = Bar Int | Baz Char String
+ test/testdata/DataContext.expected.hs view
@@ -0,0 +1,5 @@+module DataContext where++data T a b where+ F :: Ord a => a -> T a b+ G :: Ord a => b -> T a b
+ test/testdata/DataContext.hs view
@@ -0,0 +1,3 @@+module DataContext where++data Ord a => T a b = F a | G b
+ test/testdata/DataContextParen.expected.hs view
@@ -0,0 +1,4 @@+module DataContextParen where++data F a where+ G :: Eq a => a -> F a
+ test/testdata/DataContextParen.hs view
@@ -0,0 +1,4 @@+module DataContextParen where++data (Eq a) => F a+ = G a
+ test/testdata/Deriving.expected.hs view
@@ -0,0 +1,6 @@+module Deriving where++data Foo where+ Bar :: Int -> Foo+ Baz :: Char -> String -> Foo+ deriving (Show, Eq)
+ test/testdata/Deriving.hs view
@@ -0,0 +1,3 @@+module Deriving where++data Foo = Bar Int | Baz Char String deriving (Show, Eq)
+ test/testdata/Forall.expected.hs view
@@ -0,0 +1,4 @@+module Forall where++data Foo where+ Bar :: Show a => a -> b -> a -> Foo
+ test/testdata/Forall.hs view
@@ -0,0 +1,3 @@+module Forall where++data Foo = forall a b. (Show a) => Bar a b a
+ test/testdata/Infix.expected.hs view
@@ -0,0 +1,5 @@+module Infix where++data Foo where+ (:->) :: Int -> Char -> Foo+ deriving ()
+ test/testdata/Infix.hs view
@@ -0,0 +1,3 @@+module Infix where++data Foo = Int :-> Char deriving ()
+ test/testdata/Newtype.expected.hs view
@@ -0,0 +1,4 @@+module Newtype where++newtype Foo where+ Bar :: Int -> Foo
+ test/testdata/Newtype.hs view
@@ -0,0 +1,3 @@+module Newtype where++newtype Foo = Bar Int
+ test/testdata/Pragma.expected.hs view
@@ -0,0 +1,5 @@+module Pragma where++data F where+ G :: {-# UNPACK #-}Int -> F+ H :: {-# NOUNPACK #-}Char -> F
+ test/testdata/Pragma.hs view
@@ -0,0 +1,4 @@+module Pragma where++data F = G{-# UNPACK #-}Int+ | H {-# NOUNPACK #-} Char
+ test/testdata/Record.expected.hs view
@@ -0,0 +1,4 @@+module Record where++data Foo where+ Foo :: {bar :: Char, baz :: Int} -> Foo
+ test/testdata/Record.hs view
@@ -0,0 +1,6 @@+module Record where++data Foo = Foo {+ bar :: Char,+ baz :: Int+}
+ test/testdata/SimpleData.expected.hs view
@@ -0,0 +1,4 @@+module SimpleData where++data A where+ B :: A
+ test/testdata/SimpleData.hs view
@@ -0,0 +1,3 @@+module SimpleData where++data A = B
+ test/testdata/SimpleNewtype.expected.hs view
@@ -0,0 +1,4 @@+module SimpleNewtype where++newtype A where+ B :: Int -> A
+ test/testdata/SimpleNewtype.hs view
@@ -0,0 +1,3 @@+module SimpleNewtype where++newtype A = B Int
+ test/testdata/SingleDeriving.expected.hs view
@@ -0,0 +1,5 @@+module SingleDeriving where++data Foo a b where+ Bar :: b -> a -> Foo a b+ deriving Eq
+ test/testdata/SingleDeriving.hs view
@@ -0,0 +1,4 @@+module SingleDeriving where++data Foo a b = Bar b a+ deriving (Eq)
+ test/testdata/SingleDerivingGHC92.expected.hs view
@@ -0,0 +1,5 @@+module SingleDerivingGHC92 where++data Foo a b where+ Bar :: b -> a -> Foo a b+ deriving (Eq)
+ test/testdata/SingleDerivingGHC92.hs view
@@ -0,0 +1,4 @@+module SingleDerivingGHC92 where++data Foo a b = Bar b a+ deriving (Eq)
+ test/testdata/TypeVariable.expected.hs view
@@ -0,0 +1,5 @@+module TypeVariable where++data Foo a f where+ Foo :: a -> Foo a f+ Bar :: (f a) -> Foo a f
+ test/testdata/TypeVariable.hs view
@@ -0,0 +1,3 @@+module TypeVariable where++data Foo a f = Foo a | Bar (f a)