diff --git a/cabal.project b/cabal.project index 4700730c2a..dff789d029 100644 --- a/cabal.project +++ b/cabal.project @@ -36,7 +36,7 @@ source-repository-package write-ghc-environment-files: never -index-state: 2021-06-30T16:00:00Z +index-state: 2021-07-12T16:00:00Z constraints: -- Diagrams doesn't support optparse-applicative >= 0.16 yet diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index fa1c576205..bf564452d4 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -338,7 +338,7 @@ genericGraftWithSmallestM :: -- | The type of nodes we'd like to consider when finding the smallest. Proxy (Located ast) -> SrcSpan -> - (DynFlags -> GenericM (TransformT m)) -> + (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a genericGraftWithSmallestM proxy dst trans = Graft $ \dflags -> smallestM (genericIsSubspan proxy dst) (trans dflags) @@ -351,7 +351,7 @@ genericGraftWithLargestM :: -- | The type of nodes we'd like to consider when finding the largest. Proxy (Located ast) -> SrcSpan -> - (DynFlags -> GenericM (TransformT m)) -> + (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> largestM (genericIsSubspan proxy dst) (trans dflags) diff --git a/ghcide/src/Generics/SYB/GHC.hs b/ghcide/src/Generics/SYB/GHC.hs index 1e32f4ba8e..79afcbae08 100644 --- a/ghcide/src/Generics/SYB/GHC.hs +++ b/ghcide/src/Generics/SYB/GHC.hs @@ -29,9 +29,9 @@ genericIsSubspan :: -- | The type of nodes we'd like to consider. Proxy (Located ast) -> SrcSpan -> - GenericQ (Maybe Bool) + GenericQ (Maybe (Bool, ast)) genericIsSubspan _ dst = mkQ Nothing $ \case - (L span _ :: Located ast) -> Just $ dst `isSubspanOf` span + (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) -- | Lift a function that replaces a value with several values into a generic @@ -70,19 +70,19 @@ type GenericMQ r m = forall a. Data a => a -> m (r, a) -- with data nodes, so for any given node we can only definitely return an -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is -- used. -smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m smallestM q f = fmap snd . go where go :: GenericMQ Any m go x = do case q x of Nothing -> gmapMQ go x - Just True -> do + Just (True, a) -> do it@(r, x') <- gmapMQ go x case r of Any True -> pure it - Any False -> fmap (Any True,) $ f x' - Just False -> pure (mempty, x) + Any False -> fmap (Any True,) $ f a x' + Just (False, _) -> pure (mempty, x) ------------------------------------------------------------------------------ -- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but @@ -94,14 +94,14 @@ smallestM q f = fmap snd . go -- with data nodes, so for any given node we can only definitely return an -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is -- used. -largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m largestM q f = go where go :: GenericM m go x = do case q x of - Just True -> f x - Just False -> pure x + Just (True, a) -> f a x + Just (False, _) -> pure x Nothing -> gmapM go x newtype MonadicQuery r m a = MonadicQuery diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index 95a5228a3a..d500dde464 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -76,7 +76,7 @@ library , ghc , ghc-boot-th , ghc-exactprint - , ghc-source-gen + , ghc-source-gen ^>=0.4.1 , ghcide ^>=1.4 , hls-graph , hls-plugin-api ^>=1.1 diff --git a/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs b/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs index b1f1f567f7..c0ce1b1e29 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs @@ -11,7 +11,7 @@ import Data.Set (Set) import qualified Data.Set as S import Development.IDE.GHC.Compat import GHC.Exts (IsString (fromString)) -import GHC.SourceGen (funBinds, match, wildP) +import GHC.SourceGen (funBindsWithFixity, match, wildP) import OccName import Wingman.GHC import Wingman.Types @@ -72,12 +72,16 @@ rewriteVarPat name rep = everywhere $ ------------------------------------------------------------------------------ -- | Construct an 'HsDecl' from a set of 'AgdaMatch'es. splitToDecl - :: OccName -- ^ The name of the function + :: Maybe LexicalFixity + -> OccName -- ^ The name of the function -> [AgdaMatch] -> LHsDecl GhcPs -splitToDecl name ams = noLoc $ funBinds (fromString . occNameString . occName $ name) $ do - AgdaMatch pats body <- ams - pure $ match pats body +splitToDecl fixity name ams = do + traceX "fixity" fixity $ + noLoc $ + funBindsWithFixity fixity (fromString . occNameString . occName $ name) $ do + AgdaMatch pats body <- ams + pure $ match pats body ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs index 91ffd3743d..21c1e609a8 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs @@ -375,6 +375,10 @@ jHasBoundArgs . jLocalHypothesis +jNeedsToBindArgs :: Judgement' CType -> Bool +jNeedsToBindArgs = isFunTy . unCType . jGoal + + ------------------------------------------------------------------------------ -- | Fold a hypothesis into a single mapping from name to info. This -- unavoidably will cause duplicate names (things like methods) to shadow one diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 24cfe13352..abec9914a0 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -31,6 +31,7 @@ import System.Timeout import Wingman.CaseSplit import Wingman.EmptyCase import Wingman.GHC +import Wingman.Judgements (jNeedsToBindArgs) import Wingman.LanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.LanguageServer.TacticProviders @@ -189,20 +190,36 @@ graftHole -> Graft (Either String) ParsedSource graftHole span rtr | _jIsTopHole (rtr_jdg rtr) - = genericGraftWithSmallestM (Proxy @(Located [LMatch GhcPs (LHsExpr GhcPs)])) span $ \dflags -> - everywhereM' - $ mkBindListT $ \ix -> - graftDecl dflags span ix $ \name pats -> - splitToDecl (occName name) - $ iterateSplit - $ mkFirstAgda (fmap unXPat pats) - $ unLoc - $ rtr_extract rtr + = genericGraftWithSmallestM + (Proxy @(Located [LMatch GhcPs (LHsExpr GhcPs)])) span + $ \dflags matches -> + everywhereM' + $ mkBindListT $ \ix -> + graftDecl dflags span ix $ \name pats -> + splitToDecl + (case not $ jNeedsToBindArgs (rtr_jdg rtr) of + -- If the user has explicitly bound arguments, use the + -- fixity they wrote. + True -> matchContextFixity . m_ctxt . unLoc + =<< listToMaybe matches + -- Otherwise, choose based on the name of the function. + False -> Nothing + ) + (occName name) + $ iterateSplit + $ mkFirstAgda (fmap unXPat pats) + $ unLoc + $ rtr_extract rtr graftHole span rtr = graft span $ rtr_extract rtr +matchContextFixity :: HsMatchContext p -> Maybe LexicalFixity +matchContextFixity (FunRhs _ l _) = Just l +matchContextFixity _ = Nothing + + ------------------------------------------------------------------------------ -- | Helper function to route 'mergeFunBindMatches' into the right place in an -- AST --- correctly dealing with inserting into instance declarations. diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index 6c8da524e3..aa2595e119 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -154,6 +154,9 @@ instance Show TyCon where instance Show ConLike where show = unsafeRender +instance Show LexicalFixity where + show = unsafeRender + ------------------------------------------------------------------------------ -- | The state that should be shared between subgoals. Extracts move towards diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs index 472f8e8e5c..d0f76db01c 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs @@ -113,3 +113,7 @@ spec = do , (id, DestructLambdaCase, "") ] + -- test layouts that maintain user-written fixities + destructTest "b" 3 13 "LayoutInfixKeep" + destructTest "b" 2 12 "LayoutPrefixKeep" + diff --git a/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.expected.hs b/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.expected.hs index 7b090d52e4..c97ba98a6a 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.expected.hs +++ b/plugins/hls-tactics-plugin/test/golden/KnownBigSemigroup.expected.hs @@ -3,7 +3,7 @@ import Data.Monoid data Big a = Big [Bool] (Sum Int) String (Endo a) Any instance Semigroup (Big a) where - (<>) (Big bs sum s en any) (Big bs' sum' str en' any') + (Big bs sum s en any) <> (Big bs' sum' str en' any') = Big (bs <> bs') (sum <> sum') (s <> str) (en <> en') (any <> any') diff --git a/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.expected.hs b/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.expected.hs index ac653868a8..8bef710c69 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.expected.hs +++ b/plugins/hls-tactics-plugin/test/golden/KnownCounterfactualSemigroup.expected.hs @@ -3,5 +3,5 @@ data Semi = Semi [String] Int instance Semigroup Int => Semigroup Semi where - (<>) (Semi ss n) (Semi strs i) = Semi (ss <> strs) (n <> i) + (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) (n <> i) diff --git a/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.expected.hs b/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.expected.hs index 868331fae9..179937cb6a 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.expected.hs +++ b/plugins/hls-tactics-plugin/test/golden/KnownDestructedSemigroup.expected.hs @@ -1,5 +1,5 @@ data Test a = Test [a] instance Semigroup (Test a) where - (<>) (Test a) (Test c) = Test (a <> c) + (Test a) <> (Test c) = Test (a <> c) diff --git a/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.expected.hs b/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.expected.hs index 19573d9c8a..113ca4636d 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.expected.hs +++ b/plugins/hls-tactics-plugin/test/golden/KnownMissingSemigroup.expected.hs @@ -1,5 +1,5 @@ data Semi = Semi [String] Int instance Semigroup Semi where - (<>) (Semi ss n) (Semi strs i) = Semi (ss <> strs) _ + (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) _ diff --git a/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.expected.hs b/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.expected.hs index e5f3b54b7b..627217b285 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.expected.hs +++ b/plugins/hls-tactics-plugin/test/golden/KnownModuleInstanceSemigroup.expected.hs @@ -7,6 +7,6 @@ instance Semigroup Foo where data Bar = Bar Foo Foo instance Semigroup Bar where - (<>) (Bar foo foo') (Bar foo2 foo3) + (Bar foo foo') <> (Bar foo2 foo3) = Bar (foo <> foo2) (foo' <> foo3) diff --git a/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.expected.hs b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.expected.hs index d85d831093..3711af103a 100644 --- a/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.expected.hs +++ b/plugins/hls-tactics-plugin/test/golden/KnownThetaSemigroup.expected.hs @@ -1,5 +1,5 @@ data Semi a = Semi a instance Semigroup a => Semigroup (Semi a) where - (<>) (Semi a) (Semi a') = Semi (a <> a') + (Semi a) <> (Semi a') = Semi (a <> a') diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutInfixKeep.expected.hs b/plugins/hls-tactics-plugin/test/golden/LayoutInfixKeep.expected.hs new file mode 100644 index 0000000000..7274905dbe --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutInfixKeep.expected.hs @@ -0,0 +1,5 @@ +-- keep layout that was written by the user in infix +foo :: Bool -> a -> a +False `foo` a = _ +True `foo` a = _ + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutInfixKeep.hs b/plugins/hls-tactics-plugin/test/golden/LayoutInfixKeep.hs new file mode 100644 index 0000000000..60d198e5da --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutInfixKeep.hs @@ -0,0 +1,4 @@ +-- keep layout that was written by the user in infix +foo :: Bool -> a -> a +b `foo` a = _ + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutPrefixKeep.expected.hs b/plugins/hls-tactics-plugin/test/golden/LayoutPrefixKeep.expected.hs new file mode 100644 index 0000000000..a71fdba70e --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutPrefixKeep.expected.hs @@ -0,0 +1,4 @@ +(-/) :: Bool -> a -> a +(-/) False a = _ +(-/) True a = _ + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutPrefixKeep.hs b/plugins/hls-tactics-plugin/test/golden/LayoutPrefixKeep.hs new file mode 100644 index 0000000000..bfe7bdafb3 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutPrefixKeep.hs @@ -0,0 +1,3 @@ +(-/) :: Bool -> a -> a +(-/) b a = _ + diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index cbe1077c61..91e7b700f6 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -43,6 +43,7 @@ extra-deps: - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 + - ghc-source-gen-0.4.1.0 - lsp-1.2.0.0 - lsp-types-1.2.0.0 - lsp-test-0.14.0.0 diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index f3da34fb04..f1eb9b6e6e 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -43,6 +43,7 @@ extra-deps: - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 + - ghc-source-gen-0.4.1.0 - heapsize-0.3.0 - hie-bios-0.7.5 - implicit-hie-cradle-0.3.0.2 diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index 571ac51df7..ad29e02cbc 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -41,6 +41,7 @@ extra-deps: commit: 8fee87eac97a538dbe81ff1ab18cff10f2f9fa15 - ghc-check-0.5.0.4 - ghc-exactprint-0.6.4 + - ghc-source-gen-0.4.1.0 - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 diff --git a/stack-8.10.5.yaml b/stack-8.10.5.yaml index 2fc6323085..4c7d39c72f 100644 --- a/stack-8.10.5.yaml +++ b/stack-8.10.5.yaml @@ -43,6 +43,7 @@ extra-deps: commit: 8fee87eac97a538dbe81ff1ab18cff10f2f9fa15 - ghc-check-0.5.0.4 - ghc-exactprint-0.6.4 + - ghc-source-gen-0.4.1.0 - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 75e1f30245..0e25756153 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -52,7 +52,7 @@ extra-deps: - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - ghc-lib-parser-ex-8.10.0.17 - - ghc-source-gen-0.4.0.0 + - ghc-source-gen-0.4.1.0 - ghc-trace-events-0.1.2.1 - haddock-api-2.22.0@rev:1 - haddock-library-1.10.0 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 30cb1b1d13..a963ad2cf0 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -53,7 +53,7 @@ extra-deps: - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - ghc-lib-parser-ex-8.10.0.17 - - ghc-source-gen-0.4.0.0 + - ghc-source-gen-0.4.1.0 - ghc-trace-events-0.1.2.1 - haddock-api-2.22.0@rev:1 - haddock-library-1.10.0 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index dc530f81dc..a0164dbc95 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -45,6 +45,7 @@ extra-deps: - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 + - ghc-source-gen-0.4.1.0 - ghc-trace-events-0.1.2.1 - haskell-src-exts-1.21.1 - heapsize-0.3.0 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 821483e7e0..68c32e1a7c 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -45,6 +45,7 @@ extra-deps: - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 + - ghc-source-gen-0.4.1.0 - ghc-trace-events-0.1.2.1 - haskell-src-exts-1.21.1 - heapsize-0.3.0 diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 7bcdbb169b..bb0ac90b10 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -41,6 +41,7 @@ extra-deps: - ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279 - ghc-lib-parser-9.0.1.20210324@sha256:fb680f78d4ab08b5d089a05bda3b84ad857e5edcc2e4ca7c188c0207d369af80 - ghc-lib-parser-ex-9.0.0.4@sha256:8282b11c3797fc8ba225b245e736cc9a0745d9c48d0f9fea7f9bffb5c9997709,3642 +- ghc-source-gen-0.4.1.0 - haddock-library-1.10.0@sha256:2a6c239da9225951a5d837e1ce373faeeae60d1345c78dd0a0b0f29df30c4fe9,4098 - heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417 - hiedb-0.4.0.0 @@ -94,6 +95,7 @@ extra-deps: commit: ca23431a8dfa013992f9164ccc882a3277361f17 # https://github.com/diagrams/active/pull/36 + # benchmark dependency - github: HeinrichApfelmus/operational commit: 16e19aaf34e286f3d27b3988c61040823ec66537 diff --git a/stack.yaml b/stack.yaml index 124b5f7943..2434cc9952 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,6 +38,7 @@ extra-deps: - fourmolu-0.3.0.0 - ghc-api-compat-8.6 - ghc-exactprint-0.6.4 + - ghc-source-gen-0.4.1.0 - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5