diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/hls-splice-plugin.cabal b/hls-splice-plugin.cabal new file mode 100644 --- /dev/null +++ b/hls-splice-plugin.cabal @@ -0,0 +1,37 @@ +cabal-version: 2.2 +name: hls-splice-plugin +version: 0.1.0.0 +synopsis: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes +description: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes. +license: Apache-2.0 +license-file: LICENSE +author: Hiromi ISHII +maintainer: konn.jinro_at_gmail.com +category: Development +build-type: Simple + +library + exposed-modules: Ide.Plugin.Splice + ghc-options: -Wall + other-modules: Ide.Plugin.Splice.Types + hs-source-dirs: src + build-depends: aeson + , base >=4.12 && <5 + , containers + , foldl + , haskell-lsp + , hls-plugin-api + , ghc + , ghc-exactprint + , hls-exactprint-utils + , ghcide + , lens + , dlist + , retrie + , shake + , syb + , text + , transformers + , unordered-containers + + default-language: Haskell2010 diff --git a/src/Ide/Plugin/Splice.hs b/src/Ide/Plugin/Splice.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Splice.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Splice + ( descriptor, + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow +import qualified Control.Foldl as L +import Control.Lens (ix, view, (%~), (<&>), (^.)) +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Function +import Data.Generics +import qualified Data.Kind as Kinds +import Data.List (sortOn) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.GHC.Compat hiding (getLoc) +import Exception +import GHC.Exts +import GhcMonad +import GhcPlugins hiding (Var, getLoc, (<>)) +import Ide.Plugin.Splice.Types +import Ide.PluginUtils (mkLspCommand, responseError) +import Ide.TreeTransform +import Ide.Types +import Language.Haskell.GHC.ExactPrint (TransformT, setPrecedingLines, uniqueSrcSpanT) +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as J +import Retrie.ExactPrint (Annotated) +import RnSplice +import TcRnMonad +import Data.Foldable (Foldable(foldl')) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = + (defaultPluginDescriptor plId) + { pluginCommands = commands + , pluginCodeActionProvider = Just codeAction + } + +commands :: [PluginCommand IdeState] +commands = + [ PluginCommand expandInplaceId inplaceCmdName $ expandTHSplice Inplace + -- , PluginCommand expandCommentedId commentedCmdName $ expandTHSplice Commented + ] + +newtype SubSpan = SubSpan {runSubSpan :: SrcSpan} + +instance Eq SubSpan where + (==) = (==) `on` runSubSpan + +instance Ord SubSpan where + (<=) = coerce isSubspanOf + +expandTHSplice :: + -- | Inplace? + ExpandStyle -> + CommandFunction IdeState ExpandSpliceParams +expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = + fmap (fromMaybe defaultResult) $ + runMaybeT $ do + + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri + eedits <- + ( lift . runExceptT . withTypeChecked fp + =<< MaybeT + (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp) + ) + <|> lift (runExceptT $ expandManually fp) + + case eedits of + Left err -> do + reportEditor + lsp + MtError + ["Error during expanding splice: " <> T.pack err] + pure (Left $ responseError $ T.pack err, Nothing) + Right edits -> + pure + ( Right Null + , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams edits) + ) + where + range = realSrcSpanToRange spliceSpan + srcSpan = RealSrcSpan spliceSpan + defaultResult = (Right Null, Nothing) + expandManually fp = do + mresl <- + liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp + (TcModuleResult {..}, _) <- + maybe + (throwE "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (errornous) macro and expand splice again." + ) + pure mresl + reportEditor + lsp + MtWarning + [ "Expansion in type-chcking phase failed;" + , "trying to expand manually, but note taht it is less rigorous." + ] + pm <- + liftIO $ + runAction "expandTHSplice.fallback.GetParsedModule" ideState $ + use_ GetParsedModule fp + (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm + + manualCalcEdit + lsp + range + ps + hscEnv + tmrTypechecked + spliceSpan + _eStyle + params + withTypeChecked fp TcModuleResult {..} = do + (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed + let Splices {..} = tmrTopLevelSplices + let exprSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan exprSplices + _patSuperSpans = +#if __GLASGOW_HASKELL__ == 808 + fmap (second dL) $ +#endif + listToMaybe $ findSubSpansDesc srcSpan patSplices + typeSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan typeSplices + declSuperSpans = + listToMaybe $ findSubSpansDesc srcSpan declSplices + + graftSpliceWith :: + forall ast. + HasSplice ast => + Maybe (SrcSpan, Located (ast GhcPs)) -> + Maybe (Either String WorkspaceEdit) + graftSpliceWith expandeds = + expandeds <&> \(_, expanded) -> + transform + dflags + (clientCapabilities lsp) + uri + (graft (RealSrcSpan spliceSpan) expanded) + ps + maybe (throwE "No splice information found") (either throwE pure) $ + case spliceContext of + Expr -> graftSpliceWith exprSuperSpans + Pat -> + + graftSpliceWith _patSuperSpans + + HsType -> graftSpliceWith typeSuperSpans + HsDecl -> + declSuperSpans <&> \(_, expanded) -> + transform + dflags + (clientCapabilities lsp) + uri + (graftDecls (RealSrcSpan spliceSpan) expanded) + ps + <&> + -- FIXME: Why ghc-exactprint sweeps preceeding comments? + adjustToRange uri range + +setupHscEnv + :: IdeState + -> NormalizedFilePath + -> ParsedModule + -> ExceptT String IO (Annotated ParsedSource, HscEnv, DynFlags) +setupHscEnv ideState fp pm = do + hscEnvEq <- + liftIO $ + runAction "expandTHSplice.fallback.ghcSessionDeps" ideState $ + use_ GhcSessionDeps fp + let ps = annotateParsedSource pm + hscEnv0 = hscEnvWithImportPaths hscEnvEq + modSum = pm_mod_summary pm + df' <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum + let hscEnv = hscEnv0 { hsc_dflags = df' } + pure (ps, hscEnv, df') + +setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags +setupDynFlagsForGHCiLike env dflags = do + let dflags3 = + dflags + { hscTarget = HscInterpreted + , ghcMode = CompManager + , ghcLink = LinkInMemory + } + platform = targetPlatform dflags3 + dflags3a = updateWays $ dflags3 {ways = interpWays} + dflags3b = + foldl gopt_set dflags3a $ + concatMap (wayGeneralFlags platform) interpWays + dflags3c = + foldl gopt_unset dflags3b $ + concatMap (wayUnsetGeneralFlags platform) interpWays + dflags4 = + dflags3c + `gopt_set` Opt_ImplicitImportQualified + `gopt_set` Opt_IgnoreOptimChanges + `gopt_set` Opt_IgnoreHpcChanges + `gopt_unset` Opt_DiagnosticsShowCaret + initializePlugins env dflags4 + +adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit +adjustToRange uri ran (WorkspaceEdit mhult mlt) = + WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt) + where + adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit + adjustTextEdits eds = + let Just minStart = + L.fold + (L.premap (view J.range) L.minimum) + eds + in adjustLine minStart <$> eds + adjustWS = ix uri %~ adjustTextEdits + adjustDoc es + | es ^. J.textDocument . J.uri == uri = + es & J.edits %~ adjustTextEdits + | otherwise = es + + adjustLine :: Range -> TextEdit -> TextEdit + adjustLine bad = + J.range %~ \r -> + if r == bad then ran else bad + +findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] +findSubSpansDesc srcSpan = + sortOn (Down . SubSpan . fst) + . mapMaybe + ( \(L spn _, e) -> do + guard (spn `isSubspanOf` srcSpan) + pure (spn, e) + ) + +data SpliceClass where + OneToOneAST :: HasSplice ast => Proxy# ast -> SpliceClass + IsHsDecl :: SpliceClass + +class (Outputable (ast GhcRn), ASTElement (ast GhcPs)) => HasSplice ast where + type SpliceOf ast :: Kinds.Type -> Kinds.Type + type SpliceOf ast = HsSplice + matchSplice :: Proxy# ast -> ast GhcPs -> Maybe (SpliceOf ast GhcPs) + expandSplice :: Proxy# ast -> SpliceOf ast GhcPs -> RnM (Either (ast GhcPs) (ast GhcRn), FreeVars) + +instance HasSplice HsExpr where + matchSplice _ (HsSpliceE _ spl) = Just spl + matchSplice _ _ = Nothing + expandSplice _ = fmap (first Right) . rnSpliceExpr + +instance HasSplice Pat where + matchSplice _ (SplicePat _ spl) = Just spl + matchSplice _ _ = Nothing + expandSplice _ = rnSplicePat + + +instance HasSplice HsType where + matchSplice _ (HsSpliceTy _ spl) = Just spl + matchSplice _ _ = Nothing + expandSplice _ = fmap (first Right) . rnSpliceType + +classifyAST :: SpliceContext -> SpliceClass +classifyAST = \case + Expr -> OneToOneAST @HsExpr proxy# + HsDecl -> IsHsDecl + Pat -> OneToOneAST @Pat proxy# + HsType -> OneToOneAST @HsType proxy# + +reportEditor :: MonadIO m => LspFuncs a -> MessageType -> [T.Text] -> m () +reportEditor lsp msgTy msgs = + liftIO $ + sendFunc lsp $ + NotShowMessage $ + NotificationMessage "2.0" WindowShowMessage $ + ShowMessageParams msgTy $ + T.unlines msgs + +manualCalcEdit :: + LspFuncs a -> + Range -> + Annotated ParsedSource -> + HscEnv -> + TcGblEnv -> + RealSrcSpan -> + ExpandStyle -> + ExpandSpliceParams -> + ExceptT String IO WorkspaceEdit +manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do + (warns, resl) <- + ExceptT $ do + ((warns, errs), eresl) <- + initTcWithGbl hscEnv typechkd srcSpan $ + case classifyAST spliceContext of + IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $ + flip (transformM dflags (clientCapabilities lsp) uri) ps $ + graftDeclsWithM (RealSrcSpan srcSpan) $ \case + (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do + eExpr <- + either (fail . show) pure + =<< lift + ( lift $ + gtry @_ @SomeException $ + (fst <$> rnTopSpliceDecls spl) + ) + pure $ Just eExpr + _ -> pure Nothing + OneToOneAST astP -> + flip (transformM dflags (clientCapabilities lsp) uri) ps $ + graftWithM (RealSrcSpan srcSpan) $ \case + (L _spn (matchSplice astP -> Just spl)) -> do + eExpr <- + either (fail . show) pure + =<< lift + ( lift $ + gtry @_ @SomeException $ + (fst <$> expandSplice astP spl) + ) + Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr + _ -> pure Nothing + pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl + + unless + (null warns) + $ reportEditor + lsp + MtWarning + [ "Warning during expanding: " + , "" + , T.pack (show warns) + ] + pure resl + where + dflags = hsc_dflags hscEnv + +-- | FIXME: Is thereAny "clever" way to do this exploiting TTG? +unRenamedE :: + forall ast m. + (Fail.MonadFail m, HasSplice ast) => + DynFlags -> + ast GhcRn -> + TransformT m (Located (ast GhcPs)) +unRenamedE dflags expr = do + uniq <- show <$> uniqueSrcSpanT + (anns, expr') <- + either (fail . show) pure $ + parseAST @(ast GhcPs) dflags uniq $ + showSDoc dflags $ ppr expr + let _anns' = setPrecedingLines expr' 0 1 anns + pure expr' + +data SearchResult r = + Continue | Stop | Here r + deriving (Read, Show, Eq, Ord, Data, Typeable) + +fromSearchResult :: SearchResult a -> Maybe a +fromSearchResult (Here r) = Just r +fromSearchResult _ = Nothing + +-- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) +-- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? +codeAction :: CodeActionProvider IdeState +codeAction _ state plId docId ran _ = + fmap (maybe (Right $ List []) Right) $ + runMaybeT $ do + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri + ParsedModule {..} <- + MaybeT . runAction "splice.codeAction.GitHieAst" state $ + use GetParsedModule fp + let spn = + rangeToRealSrcSpan ran $ + fromString $ + fromNormalizedFilePath fp + mouterSplice = something' (detectSplice spn) pm_parsed_source + mcmds <- forM mouterSplice $ + \(spliceSpan, spliceContext) -> + forM expandStyles $ \(_, (title, cmdId)) -> do + let params = ExpandSpliceParams {uri = theUri, ..} + act <- liftIO $ mkLspCommand plId cmdId title (Just [toJSON params]) + pure $ + CACodeAction $ + CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing (Just act) + + pure $ maybe mempty List mcmds + where + theUri = docId ^. J.uri + detectSplice :: + RealSrcSpan -> + GenericQ (SearchResult (RealSrcSpan, SpliceContext)) + detectSplice spn = + mkQ + Continue + ( \case + (L l@(RealSrcSpan spLoc) expr :: LHsExpr GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> + case expr of + HsSpliceE {} -> Here (spLoc, Expr) + _ -> Continue + _ -> Stop + ) + `extQ` \case +#if __GLASGOW_HASKELL__ == 808 + (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc) pat :: Located (Pat GhcPs)) +#else + (L l@(RealSrcSpan spLoc) pat :: LPat GhcPs) +#endif + | RealSrcSpan spn `isSubspanOf` l -> + case pat of + SplicePat{} -> Here (spLoc, Pat) + _ -> Continue + _ -> Stop + `extQ` \case + (L l@(RealSrcSpan spLoc) ty :: LHsType GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> + case ty of + HsSpliceTy {} -> Here (spLoc, HsType) + _ -> Continue + _ -> Stop + `extQ` \case + (L l@(RealSrcSpan spLoc) decl :: LHsDecl GhcPs) + | RealSrcSpan spn `isSubspanOf` l -> + case decl of + SpliceD {} -> Here (spLoc, HsDecl) + _ -> Continue + _ -> Stop + +-- | Like 'something', but performs top-down searching, cutoffs when 'Stop' received, +-- and picks inenrmost result. +something' :: forall a. GenericQ (SearchResult a) -> GenericQ (Maybe a) +something' f = go + where + go :: GenericQ (Maybe a) + go x = + case f x of + Stop -> Nothing + resl -> foldl' (flip (<|>)) (fromSearchResult resl) (gmapQ go x) + +posToRealSrcLoc :: Position -> FastString -> RealSrcLoc +posToRealSrcLoc pos fs = mkRealSrcLoc fs (line + 1) (col + 1) + where + line = _line pos + col = _character pos + +rangeToRealSrcSpan :: Range -> FastString -> RealSrcSpan +rangeToRealSrcSpan ran fs = + mkRealSrcSpan + (posToRealSrcLoc (_start ran) fs) + (posToRealSrcLoc (_end ran) fs) diff --git a/src/Ide/Plugin/Splice/Types.hs b/src/Ide/Plugin/Splice/Types.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Splice/Types.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +module Ide.Plugin.Splice.Types where + +import Data.Aeson (FromJSON, ToJSON) +import Development.IDE (Uri) +import GHC.Generics (Generic) +import Development.IDE.GHC.Compat (RealSrcSpan) +import qualified Data.Text as T +import Ide.Types ( CommandId ) + +-- | Parameter for the addMethods PluginCommand. +data ExpandSpliceParams = ExpandSpliceParams + { uri :: Uri + , spliceSpan :: RealSrcSpan + , spliceContext :: SpliceContext + } + deriving (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- FIXME: HsDecl needs different treatment of splicing. +data SpliceContext = Expr | HsDecl | Pat | HsType + deriving (Read, Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +data ExpandStyle = Inplace | Commented + deriving (Read, Show, Eq, Ord, Generic) + +expandStyles :: [(ExpandStyle, (T.Text, CommandId))] +expandStyles = + [ (Inplace, (inplaceCmdName, expandInplaceId)) + -- , (Commented, commentedCmdName, expandCommentedId) + ] + +toExpandCmdTitle :: ExpandStyle -> T.Text +toExpandCmdTitle Inplace = inplaceCmdName +toExpandCmdTitle Commented = commentedCmdName + +toCommandId :: ExpandStyle -> CommandId +toCommandId Inplace = expandInplaceId +toCommandId Commented = expandCommentedId + +expandInplaceId, expandCommentedId :: CommandId +expandInplaceId = "expandTHSpliceInplace" +expandCommentedId = "expandTHSpliceCommented" + +inplaceCmdName :: T.Text +inplaceCmdName = "expand TemplateHaskell Splice (in-place)" + +commentedCmdName :: T.Text +commentedCmdName = "expand TemplateHaskell Splice (comented-out)"