Skip to content

Commit 8dc0bf2

Browse files
author
Santiago Weight
committed
compiling; failing tests
1 parent 98f758d commit 8dc0bf2

File tree

17 files changed

+171
-104
lines changed

17 files changed

+171
-104
lines changed

‎cabal.project

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@ packages:
66
./ghcide
77
./hls-plugin-api
88
./hls-test-utils
9-
./plugins/hls-tactics-plugin
9+
./plugins/hls-refine-destruct-plugin
1010
./plugins/hls-brittany-plugin
1111
./plugins/hls-stylish-haskell-plugin
1212
./plugins/hls-fourmolu-plugin

‎ghcide/src/Development/IDE/Core/Rules.hs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -143,7 +143,7 @@ import Ide.Plugin.Properties (HasProperty,
143143
ToHsType,
144144
useProperty)
145145
import Ide.PluginUtils (configForPlugin)
146-
import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
146+
import Ide.Types (GhcOptsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
147147
PluginId)
148148
import Control.Concurrent.STM.Stats (atomically)
149149
import Language.LSP.Server (LspT)
@@ -328,7 +328,7 @@ getParsedModuleWithCommentsRule recorder =
328328

329329
liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms
330330

331-
getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a
331+
getModifyDynFlags :: (GhcOptsModifications -> a) -> Action a
332332
getModifyDynFlags f = do
333333
opts <- getIdeOptions
334334
cfg <- getClientConfigAction def
@@ -1090,8 +1090,8 @@ getLinkableType f = use_ NeedsCompilation f
10901090

10911091
-- needsCompilationRule :: Rules ()
10921092
needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))
1093-
needsCompilationRule file
1094-
| "boot" `isSuffixOf` (fromNormalizedFilePath file) =
1093+
needsCompilationRule file
1094+
| "boot" `isSuffixOf` (fromNormalizedFilePath file) =
10951095
pure (Just $ encodeLinkableType Nothing, Just Nothing)
10961096
needsCompilationRule file = do
10971097
graph <- useNoFile GetModuleGraph

‎ghcide/src/Development/IDE/Plugin.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -4,13 +4,13 @@ import Data.Default
44
import Development.IDE.Graph
55

66
import Development.IDE.LSP.Server
7-
import Ide.Types (DynFlagsModifications)
7+
import Ide.Types (GhcOptsModifications)
88
import qualified Language.LSP.Server as LSP
99

1010
data Plugin c = Plugin
1111
{pluginRules :: Rules ()
1212
,pluginHandlers :: LSP.Handlers (ServerM c)
13-
,pluginModifyDynflags :: c -> DynFlagsModifications
13+
,pluginModifyDynflags :: c -> GhcOptsModifications
1414
}
1515

1616
instance Default (Plugin c) where

‎ghcide/src/Development/IDE/Plugin/HLS.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,7 @@ rulesPlugins rs = mempty { P.pluginRules = rules }
7979
where
8080
rules = foldMap snd rs
8181

82-
dynFlagsPlugins :: [(PluginId, DynFlagsModifications)] -> Plugin Config
82+
dynFlagsPlugins :: [(PluginId, GhcOptsModifications)] -> Plugin Config
8383
dynFlagsPlugins rs = mempty
8484
{ P.pluginModifyDynflags =
8585
flip foldMap rs $ \(plId, dflag_mods) cfg ->
@@ -173,7 +173,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }
173173
Nothing -> do
174174
logWith recorder Info LogNoEnabledPlugins
175175
pure $ Left $ ResponseError InvalidRequest
176-
( "No plugin enabled for " <> T.pack (show m)
176+
( "No plugin enabled for " <> T.pack (show m)
177177
<> ", available: " <> T.pack (show $ map (\(plid,_,_) -> plid) fs)
178178
)
179179
Nothing

‎ghcide/src/Development/IDE/Types/Options.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ import Development.IDE.GHC.Compat as GHC
2626
import Development.IDE.Graph
2727
import Development.IDE.Types.Diagnostics
2828
import Ide.Plugin.Config
29-
import Ide.Types (DynFlagsModifications)
29+
import Ide.Types (GhcOptsModifications)
3030
import qualified Language.LSP.Types.Capabilities as LSP
3131

3232
data IdeOptions = IdeOptions
@@ -74,7 +74,7 @@ data IdeOptions = IdeOptions
7474
-- Otherwise, return the result of parsing without Opt_Haddock, so
7575
-- that the parsed module contains the result of Opt_KeepRawTokenStream,
7676
-- which might be necessary for hlint.
77-
, optModifyDynFlags :: Config -> DynFlagsModifications
77+
, optModifyDynFlags :: Config -> GhcOptsModifications
7878
-- ^ Will be called right after setting up a new cradle,
7979
-- allowing to customize the Ghc options used
8080
, optShakeOptions :: ShakeOptions

‎hls-plugin-api/src/Ide/Types.hs

Lines changed: 23 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -74,34 +74,38 @@ import System.FilePath
7474
import System.IO.Unsafe
7575
import Text.Regex.TDFA.Text ()
7676

77+
import GHC.Plugins (StaticPlugin)
78+
79+
7780
-- ---------------------------------------------------------------------
7881

7982
newtype IdePlugins ideState = IdePlugins
8083
{ ipMap :: [(PluginId, PluginDescriptor ideState)]}
8184
deriving newtype (Monoid, Semigroup)
8285

83-
-- | Hooks for modifying the 'DynFlags' at different times of the compilation
84-
-- process. Plugins can install a 'DynFlagsModifications' via
85-
-- 'pluginModifyDynflags' in their 'PluginDescriptor'.
86-
data DynFlagsModifications =
87-
DynFlagsModifications
88-
{ -- | Invoked immediately at the package level. Changes to the 'DynFlags'
89-
-- made in 'dynFlagsModifyGlobal' are guaranteed to be seen everywhere in
90-
-- the compilation pipeline.
91-
dynFlagsModifyGlobal :: DynFlags -> DynFlags
92-
-- | Invoked just before the parsing step, and reset immediately
93-
-- afterwards. 'dynFlagsModifyParser' allows plugins to enable language
94-
-- extensions only during parsing. for example, to let them enable
95-
-- certain pieces of syntax.
86+
{- | Hooks for modifying the 'DynFlags' at different times of the compilation
87+
process. Plugins can install a 'GhcOptsModifications' via
88+
'pluginModifyDynflags' in their 'PluginDescriptor'.
89+
-}
90+
data GhcOptsModifications = GhcOptsModifications
91+
{ dynFlagsModifyGlobal :: DynFlags -> DynFlags
92+
-- ^ Invoked immediately at the package level. Changes to the 'DynFlags'
93+
-- made in 'dynFlagsModifyGlobal' are guaranteed to be seen everywhere in
94+
-- the compilation pipeline.
9695
, dynFlagsModifyParser :: DynFlags -> DynFlags
96+
-- ^ Invoked just before the parsing step, and reset immediately
97+
-- afterwards. 'dynFlagsModifyParser' allows plugins to enable language
98+
-- extensions only during parsing. for example, to let them enable
99+
-- certain pieces of syntax.
100+
, staticPlugins :: [StaticPlugin]
97101
}
98102

99-
instance Semigroup DynFlagsModifications where
100-
DynFlagsModifications g1 p1 <> DynFlagsModifications g2 p2 =
101-
DynFlagsModifications (g2 . g1) (p2 . p1)
103+
instance Semigroup GhcOptsModifications where
104+
GhcOptsModifications g1 p1 plugins1 <> GhcOptsModifications g2 p2 plugins2 =
105+
GhcOptsModifications (g2 . g1) (p2 . p1) (plugins1 <> plugins2)
102106

103-
instance Monoid DynFlagsModifications where
104-
mempty = DynFlagsModifications id id
107+
instance Monoid GhcOptsModifications where
108+
mempty = GhcOptsModifications id id []
105109

106110
-- ---------------------------------------------------------------------
107111

@@ -118,7 +122,7 @@ data PluginDescriptor (ideState :: *) =
118122
, pluginHandlers :: PluginHandlers ideState
119123
, pluginConfigDescriptor :: ConfigDescriptor
120124
, pluginNotificationHandlers :: PluginNotificationHandlers ideState
121-
, pluginModifyDynflags :: DynFlagsModifications
125+
, pluginModifyDynflags :: GhcOptsModifications
122126
, pluginCli :: Maybe (ParserInfo (IdeCommand ideState))
123127
, pluginFileType :: [T.Text]
124128
-- ^ File extension of the files the plugin is responsible for.

‎plugins/hls-refine-destruct-plugin/src/Wingman/AbstractLSP/TacticActions.hs

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ import Wingman.LanguageServer.TacticProviders
2626
import Wingman.Machinery (runTactic)
2727
import Wingman.Range
2828
import Wingman.Types
29+
import GHC (SrcSpanAnn'(SrcSpanAnn))
2930

3031

3132
------------------------------------------------------------------------------
@@ -153,7 +154,7 @@ graftDecl
153154
-> (RdrName -> [Pat GhcPs] -> LHsDecl GhcPs)
154155
-> LMatch GhcPs (LHsExpr GhcPs)
155156
-> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]
156-
graftDecl dflags dst ix make_decl (L src (AMatch (FunRhs (L _ name) _ _) pats _))
157+
graftDecl dflags dst ix make_decl (L (SrcSpanAnn _ src) (AMatch (FunRhs (L _ name) _ _) pats _))
157158
| dst `isSubspanOf` src = do
158159
L _ dec <- annotateDecl dflags $ make_decl name pats
159160
case dec of
@@ -165,8 +166,8 @@ graftDecl dflags dst ix make_decl (L src (AMatch (FunRhs (L _ name) _ _) pats _)
165166
-- insert a preceeding newline (done in 'annotateDecl') on all
166167
-- matches, except for the first one --- since it gets its newline
167168
-- from the line above.
168-
when (ix == 0) $
169-
setPrecedingLinesT first_match 0 0
169+
-- when (ix == 0) $
170+
-- setPrecedingLinesT first_match 0 0
170171
pure alts
171172
_ -> lift $ Left "annotateDecl didn't produce a funbind"
172173
graftDecl _ _ _ _ x = pure $ pure x

‎plugins/hls-refine-destruct-plugin/src/Wingman/CaseSplit.hs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ containsVar name = everything (||) $
6565
(_ :: Pat GhcPs) -> False
6666
)
6767
`extQ` \case
68-
HsRecField lbl _ True -> eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl
68+
HsRecField _ lbl _ True -> eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl
6969
(_ :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> False
7070

7171

@@ -78,9 +78,9 @@ rewriteVarPat name rep = everywhere $
7878
(x :: Pat GhcPs) -> x
7979
)
8080
`extT` \case
81-
HsRecField lbl _ True
81+
HsRecField ann lbl _ True
8282
| eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl
83-
-> HsRecField lbl (toPatCompat rep) False
83+
-> HsRecField ann lbl (toPatCompat rep) False
8484
(x :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> x
8585

8686

@@ -93,7 +93,7 @@ splitToDecl
9393
-> LHsDecl GhcPs
9494
splitToDecl fixity name ams = do
9595
traceX "fixity" fixity $
96-
noLoc $
96+
noLocA $
9797
funBindsWithFixity fixity (fromString . occNameString . occName $ name) $ do
9898
AgdaMatch pats body <- ams
9999
pure $ match pats body

‎plugins/hls-refine-destruct-plugin/src/Wingman/CodeGen.hs

Lines changed: 23 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Wingman.Judgements
3131
import Wingman.Machinery
3232
import Wingman.Naming
3333
import Wingman.Types
34+
import GHC (EpAnn(..), emptyComments)
3435

3536

3637
destructMatches
@@ -84,14 +85,13 @@ destructionFor hy t = do
8485
args = conLikeInstOrigArgTys' con apps
8586
names = mkManyGoodNames (hyNamesInScope hy) args
8687
pure
87-
. noLoc
88+
. noLocA
8889
. Match
89-
noExtField
90+
EpAnnNotUsed
9091
CaseAlt
9192
[toPatCompat $ snd $ mkDestructPat Nothing con names]
92-
. GRHSs noExtField (pure $ noLoc $ GRHS noExtField [] $ noLoc $ var "_")
93-
. noLoc
94-
$ EmptyLocalBinds noExtField
93+
. GRHSs emptyComments (pure $ noLoc $ GRHS EpAnnNotUsed [] $ noLocA $ var "_")
94+
$ EmptyLocalBinds NoExtField
9595

9696

9797

@@ -110,17 +110,19 @@ mkDestructPat already_in_scope con names
110110
case S.member label_occ in_scope of
111111
-- We have a shadow, so use the generated name instead
112112
True ->
113-
(name,) $ noLoc $
113+
(name,) $ noLocA $
114114
HsRecField
115-
(noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ)
116-
(noLoc $ bvar' name)
115+
EpAnnNotUsed
116+
(noLoc $ mkFieldOcc $ noLocA $ Unqual label_occ)
117+
(noLocA $ bvar' name)
117118
False
118119
-- No shadow, safe to use a pun
119120
False ->
120-
(label_occ,) $ noLoc $
121+
(label_occ,) $ noLocA $
121122
HsRecField
122-
(noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ)
123-
(noLoc $ bvar' label_occ)
123+
EpAnnNotUsed
124+
(noLoc $ mkFieldOcc $ noLocA $ Unqual label_occ)
125+
(noLocA $ bvar' label_occ)
124126
True
125127

126128
in (names', )
@@ -140,7 +142,7 @@ infixifyPatIfNecessary :: ConLike -> Pat GhcPs -> Pat GhcPs
140142
infixifyPatIfNecessary dcon x
141143
| conLikeIsInfix dcon =
142144
case x of
143-
ConPatIn op (PrefixCon [lhs, rhs]) ->
145+
ConPatIn op (PrefixCon _ [lhs, rhs]) ->
144146
ConPatIn op $ InfixCon lhs rhs
145147
y -> y
146148
| otherwise = x
@@ -201,7 +203,7 @@ destruct' use_field_puns f hi jdg = do
201203
(hi_type hi)
202204
$ disallowing AlreadyDestructed (S.singleton term) jdg
203205
pure $ ext
204-
& #syn_val %~ noLoc . case' (var' term)
206+
& #syn_val %~ noLocA . case' (var' term)
205207

206208

207209
------------------------------------------------------------------------------
@@ -216,7 +218,7 @@ destructLambdaCase' use_field_puns f jdg = do
216218
#else
217219
Just (arg, _) | isAlgType arg ->
218220
#endif
219-
fmap (fmap noLoc lambdaCase) <$>
221+
fmap (fmap noLocA lambdaCase) <$>
220222
destructMatches use_field_puns f Nothing (CType arg) jdg
221223
_ -> cut -- throwError $ GoalMismatch "destructLambdaCase'" g
222224

@@ -259,8 +261,8 @@ buildDataCon jdg dc tyapps = do
259261
mkApply :: OccName -> [HsExpr GhcPs] -> LHsExpr GhcPs
260262
mkApply occ (lhs : rhs : more)
261263
| isSymOcc occ
262-
= noLoc $ foldl' (@@) (op lhs (coerceName occ) rhs) more
263-
mkApply occ args = noLoc $ foldl' (@@) (var' occ) args
264+
= noLocA $ foldl' (@@) (op lhs (coerceName occ) rhs) more
265+
mkApply occ args = noLocA $ foldl' (@@) (var' occ) args
264266

265267

266268
------------------------------------------------------------------------------
@@ -285,7 +287,7 @@ letForEach rename solve (unHypothesis -> hy) jdg = do
285287
let hy' = fmap (g <$) $ syn_val terms
286288
matches = fmap (fmap (\(occ, expr) -> valBind (occNameToStr occ) expr)) terms
287289
g <- fmap (fmap unLoc) $ newSubgoal $ introduce (userHypothesis hy') jdg
288-
pure $ fmap noLoc $ let' <$> matches <*> g
290+
pure $ fmap noLocA $ let' <$> matches <*> g
289291

290292

291293
------------------------------------------------------------------------------
@@ -298,7 +300,7 @@ nonrecLet occjdgs jdg = do
298300
occexts <- traverse newSubgoal $ fmap snd occjdgs
299301
ext <- newSubgoal
300302
$ introduce (userHypothesis $ fmap (second jGoal) occjdgs) jdg
301-
pure $ fmap noLoc $
303+
pure $ fmap noLocA $
302304
let'
303305
<$> traverse
304306
(\(occ, ext) -> valBind (occNameToStr occ) <$> fmap unLoc ext)
@@ -309,12 +311,12 @@ nonrecLet occjdgs jdg = do
309311
------------------------------------------------------------------------------
310312
-- | Converts a function application into applicative form
311313
idiomize :: LHsExpr GhcPs -> LHsExpr GhcPs
312-
idiomize x = noLoc $ case unLoc x of
314+
idiomize x = noLocA $ case unLoc x of
313315
HsApp _ (L _ (HsVar _ (L _ x))) gshgp3 ->
314316
op (bvar' $ occName x) "<$>" (unLoc gshgp3)
315317
HsApp _ gsigp gshgp3 ->
316318
op (unLoc $ idiomize gsigp) "<*>" (unLoc gshgp3)
317-
RecordCon _ con flds ->
318-
unLoc $ idiomize $ noLoc $ foldl' (@@) (HsVar noExtField con) $ fmap unLoc flds
319+
RecordCon _ con (HsRecFields flds _) ->
320+
unLoc $ idiomize $ noLocA $ foldl' (@@) (HsVar noExtField con) $ fmap (unLoc . hsRecFieldArg . unLoc) flds
319321
y -> y
320322

‎plugins/hls-refine-destruct-plugin/src/Wingman/CodeGen/Utils.hs

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -15,25 +15,25 @@ mkCon con apps (fmap unLoc -> args)
1515
| RealDataCon dcon <- con
1616
, dcon == nilDataCon
1717
, [ty] <- apps
18-
, ty `eqType` charTy = noLoc $ string ""
18+
, ty `eqType` charTy = noLocA $ string ""
1919

2020
| RealDataCon dcon <- con
2121
, isTupleDataCon dcon =
22-
noLoc $ tuple args
22+
noLocA $ tuple args
2323

2424
| RealDataCon dcon <- con
2525
, dataConIsInfix dcon
2626
, (lhs : rhs : args') <- args =
27-
noLoc $ foldl' (@@) (op lhs (coerceName con_name) rhs) args'
27+
noLocA $ foldl' (@@) (op lhs (coerceName con_name) rhs) args'
2828

2929
| Just fields <- getRecordFields con
3030
, length fields >= 2 = -- record notation is unnatural on single field ctors
31-
noLoc $ recordConE (coerceName con_name) $ do
31+
noLocA $ recordConE (coerceName con_name) $ do
3232
(arg, (field, _)) <- zip args fields
3333
pure (coerceName field, arg)
3434

3535
| otherwise =
36-
noLoc $ foldl' (@@) (bvar' $ occName con_name) args
36+
noLocA $ foldl' (@@) (bvar' $ occName con_name) args
3737
where
3838
con_name = conLikeName con
3939

0 commit comments

Comments
 (0)