From 2f886bfdca36b957aa0b99f3cd7d5dd1b1493b1d Mon Sep 17 00:00:00 2001 From: Kobayashi Date: Sat, 16 Jul 2022 18:16:55 +0800 Subject: [PATCH] handle trailing comma in import list properly (#3035) * handle trailing comma in import list properly * no longer backup .ghcup in gitpod * fix for ghc < 9 * fix it without using CPP * explain gitpod change * read trailing comma before adding one * refine imports * refine gitpod * gitpod store ghcide and hie-bios cache These cache directories are small, but not preserving them requires HLS to compile all modules in local project on workspace restarts. * fix code styling --- .gitpod.Dockerfile | 16 ++- .gitpod.yml | 7 +- .../IDE/Plugin/CodeAction/ExactPrint.hs | 112 +++++++++++------- ghcide/test/exe/Main.hs | 22 ++++ 4 files changed, 108 insertions(+), 49 deletions(-) diff --git a/.gitpod.Dockerfile b/.gitpod.Dockerfile index 5a244cf56..5631a302f 100644 --- a/.gitpod.Dockerfile +++ b/.gitpod.Dockerfile @@ -2,17 +2,23 @@ FROM gitpod/workspace-full RUN sudo install-packages build-essential curl libffi-dev libffi7 libgmp-dev libgmp10 \ libncurses-dev libncurses5 libtinfo5 && \ - BOOTSTRAP_HASKELL_NONINTERACTIVE=1 \ - BOOTSTRAP_HASKELL_MINIMAL=1 \ - curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && \ + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh && \ echo 'source $HOME/.ghcup/env' >> $HOME/.bashrc && \ echo 'export PATH=$HOME/.cabal/bin:$HOME/.local/bin:$PATH' >> $HOME/.bashrc && \ . /home/gitpod/.ghcup/env && \ - ghcup install ghc --set && \ + # Install all verions of GHC that HLS supports. Putting GHC into Docker image makes workspace start much faster. + ghcup install ghc 8.6.5 && \ + ghcup install ghc 8.8.4 && \ + ghcup install ghc 8.10.7 && \ + ghcup install ghc 9.0.2 && \ + ghcup install ghc 9.2.2 && \ + ghcup install ghc 9.2.3 --set && \ ghcup install hls --set && \ ghcup install cabal --set && \ ghcup install stack --set && \ cabal update && \ - cabal install stylish-haskell hoogle implicit-hie && \ + cabal install --disable-executable-dynamic --install-method copy --constraint "stylish-haskell +ghc-lib" \ + stylish-haskell implicit-hie hoogle && \ + rm -rf $HOME/.cabal/store && \ pip install pre-commit && \ npm install -g http-server diff --git a/.gitpod.yml b/.gitpod.yml index e49200482..ae2cf47a3 100644 --- a/.gitpod.yml +++ b/.gitpod.yml @@ -10,7 +10,8 @@ tasks: $HOME/.local $HOME/.cabal $HOME/.stack - $HOME/.ghcup + $HOME/.cache/ghcide + $HOME/.cache/hie-bios /nix ) for DIR in "${CACHE_DIRS[@]}"; do @@ -41,9 +42,7 @@ tasks: echo '}' >> .vscode/settings.json fi - pushd docs - pip install -r requirements.txt - popd + pip install -r docs/requirements.txt init: | cabal update cabal configure --enable-executable-dynamic diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index ef2e13704..4b516a16a 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} module Development.IDE.Plugin.CodeAction.ExactPrint ( Rewrite (..), @@ -23,41 +24,47 @@ module Development.IDE.Plugin.CodeAction.ExactPrint ( wildCardSymbol ) where -import Control.Applicative import Control.Monad -import Control.Monad.Extra (whenJust) import Control.Monad.Trans -import Data.Char (isAlphaNum) -import Data.Data (Data) -import Data.Functor -import Data.Generics (listify) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, isNothing, - mapMaybe) -import qualified Data.Text as T -import Development.IDE.GHC.Compat hiding (Annotation) +import Data.Char (isAlphaNum) +import Data.Data (Data) +import Data.Generics (listify) +import qualified Data.Text as T +import Development.IDE.GHC.Compat hiding (Annotation) import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint +import Development.IDE.GHC.Util import Development.IDE.Spans.Common -import GHC.Exts (IsList (fromList)) +import GHC.Exts (IsList (fromList)) +import GHC.Stack (HasCallStack) import Language.Haskell.GHC.ExactPrint -#if !MIN_VERSION_ghc(9,2,0) +import Language.LSP.Types + +-- GHC version specific imports. For any supported GHC version, make sure there is no warning in imports. +#if MIN_VERSION_ghc(9,2,0) +import Control.Lens (_head, _last, over) +import Data.Bifunctor (first) +import Data.Default (Default (..)) +import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import GHC (AddEpAnn (..), AnnContext (..), AnnList (..), + AnnParen (..), DeltaPos (SameLine), EpAnn (..), + EpaLocation (EpaDelta), + IsUnicodeSyntax (NormalSyntax), + NameAdornment (NameParens), + TrailingAnn (AddCommaAnn), addAnns, ann, + emptyComments, reAnnL) +#else +import Control.Applicative (Alternative ((<|>))) +import Control.Monad.Extra (whenJust) +import Data.Foldable (find) +import Data.Functor (($>)) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, isJust, + isNothing, mapMaybe) import qualified Development.IDE.GHC.Compat.Util as Util import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) -#else -import Data.Default -import GHC (AddEpAnn (..), AnnContext (..), AnnParen (..), - DeltaPos (SameLine), EpAnn (..), EpaLocation (EpaDelta), - IsUnicodeSyntax (NormalSyntax), - NameAdornment (NameParens), NameAnn (..), addAnns, ann, emptyComments, - reAnnL, AnnList (..), TrailingAnn (AddCommaAnn), addTrailingAnnToA) #endif -import Language.LSP.Types -import Development.IDE.GHC.Util -import Data.Bifunctor (first) -import Control.Lens (_head, _last, over) -import GHC.Stack (HasCallStack) ------------------------------------------------------------------------------ @@ -367,17 +374,28 @@ extendImportTopLevel thing (L l it@ImportDecl{..}) then lift (Left $ thing <> " already imported") else do #if !MIN_VERSION_ghc(9,2,0) - when hasSibling $ - addTrailingCommaT (last lies) + anns <- getAnnsT + maybe (pure ()) addTrailingCommaT (lastMaybe lies) addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) [] addSimpleAnnT rdr dp00 [(G AnnVal, dp00)] + + -- When the last item already has a trailing comma, we append a trailing comma to the new item. + let isAnnComma (G AnnComma, _) = True + isAnnComma _ = False + shouldAddTrailingComma = maybe False nodeHasComma (lastMaybe lies) + && not (nodeHasComma (L l' lies)) + + nodeHasComma :: Data a => Located a -> Bool + nodeHasComma x = isJust $ Map.lookup (mkAnnKey x) anns >>= find isAnnComma . annsDP + when shouldAddTrailingComma (addTrailingCommaT x) + -- Parens are attachted to `lies`, so if `lies` was empty previously, -- we need change the ann key from `[]` to `:` to keep parens and other anns. unless hasSibling $ transferAnn (L l' lies) (L l' [x]) id return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} #else - lies' <- addCommaInImportList lies x + let lies' = addCommaInImportList lies x return $ L l it{ideclHiding = Just (hide, L l' lies')} #endif extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list" @@ -514,30 +532,44 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)] x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE] - lies' <- addCommaInImportList (reverse pre) x + lies' = addCommaInImportList (reverse pre) x #endif return $ L l it{ideclHiding = Just (hide, L l' lies')} extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" #if MIN_VERSION_ghc(9,2,0) -- Add an item in an import list, taking care of adding comma if needed. -addCommaInImportList :: Monad m => +addCommaInImportList :: -- | Initial list [LocatedAn AnnListItem a] -- | Additionnal item -> LocatedAn AnnListItem a - -> m [LocatedAn AnnListItem a] -addCommaInImportList lies x = do - let hasSibling = not (null lies) - -- Add the space before the comma - x <- pure $ setEntryDP x (SameLine $ if hasSibling then 1 else 0) + -> [LocatedAn AnnListItem a] +addCommaInImportList lies x = + fixLast lies ++ [newItem] + where + isTrailingAnnComma :: TrailingAnn -> Bool + isTrailingAnnComma (AddCommaAnn _) = True + isTrailingAnnComma _ = False - -- Add the comma (if needed) - let - fixLast = if hasSibling then first addComma else id - lies' = over _last fixLast lies ++ [x] + -- check if there is an existing trailing comma + existingTrailingComma = fromMaybe False $ do + L lastItemSrcAnn _ <- lastMaybe lies + lastItemAnn <- case ann lastItemSrcAnn of + EpAnn _ lastItemAnn _ -> pure lastItemAnn + _ -> Nothing + pure $ any isTrailingAnnComma (lann_trailing lastItemAnn) - pure lies' + hasSibling = not . null $ lies + + -- Setup the new item. It should have a preceding whitespace if it has siblings, and a trailing comma if the + -- preceding item already has one. + newItem = first (if existingTrailingComma then addComma else id) $ + setEntryDP x (SameLine $ if hasSibling then 1 else 0) + + -- Add the comma (if needed) + fixLast :: [LocatedAn AnnListItem a] -> [LocatedAn AnnListItem a] + fixLast = over _last (first (if existingTrailingComma then id else addComma)) #endif unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 2b0dfd0dd..b2da4beb1 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -1882,6 +1882,28 @@ extendImportTests = testGroup "extend import actions" , " )" , "main = print (stuffA, stuffB)" ]) + , testSession "extend multi line import with trailing comma" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB," + , " )" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB, stuffA," + , " )" + , "main = print (stuffA, stuffB)" + ]) , testSession "extend single line import with method within class" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where"