diff --git a/cabal.project b/cabal.project index 4519d816..c29b881d 100644 --- a/cabal.project +++ b/cabal.project @@ -38,7 +38,7 @@ source-repository-package source-repository-package type: git location: https://github.com/josephsumabat/haskell-arborist - tag: 340638fd5431fc574e211a2b1960ca47bfdcebdf + tag: 2d9813f278f5a9547186b5a326cf99b4e7d99dab source-repository-package type: git diff --git a/nix/overlays/default.nix b/nix/overlays/default.nix index d2015fc6..6a1ec84f 100644 --- a/nix/overlays/default.nix +++ b/nix/overlays/default.nix @@ -9,8 +9,8 @@ let haskell-arborist-repo = { url = "https://github.com/josephsumabat/haskell-arborist"; - sha256 = "sha256-rUgKJoGust+1Zu7K89AUKr8LHAAr46CUCTWM5cbnU5Y="; - rev = "340638fd5431fc574e211a2b1960ca47bfdcebdf"; + sha256 = "sha256-CroTvgRJN3vebLexf2saFYVQrg4cBEqLKUegZ0ZfYIE="; + rev = "2d9813f278f5a9547186b5a326cf99b4e7d99dab"; fetchSubmodules = true; }; diff --git a/src/Data/Change.hs b/src/Data/Change.hs deleted file mode 100644 index 5b67ac53..00000000 --- a/src/Data/Change.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Data.Change ( - Change (..), - insert, - delete, - replace, -) -where - -import Data.Pos (Pos) -import Data.Range (Range) -import Data.Range qualified as Range -import Data.Text (Text) -import Data.Text qualified as T - -data Change = Change - { insert :: !Text - , delete :: !Range - } - deriving (Show, Eq, Ord) - -insert :: Pos -> Text -> Change -insert pos text = Change {insert = text, delete = Range.empty pos} - -delete :: Range -> Change -delete r = Change {insert = T.empty, delete = r} - -replace :: Range -> Text -> Change -replace r text = Change {insert = text, delete = r} diff --git a/src/Data/Edit.hs b/src/Data/Edit.hs deleted file mode 100644 index 3687a078..00000000 --- a/src/Data/Edit.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Data.Edit ( - Edit, - insert, - delete, - replace, - changesToEdit, - getChanges, - empty, - singleton, -) -where - -import Data.Change (Change) -import Data.Change qualified as Change -import Data.List qualified as List -import Data.Pos (Pos) -import Data.Range (Range (..)) -import Data.Text (Text) - --- Invariant: disjoint, sorted by delete -data Edit = Edit [Change] - deriving (Show, Eq, Ord) - -instance Semigroup Edit where - Edit cs <> Edit cs' = Edit (cs <> cs') - -instance Monoid Edit where - mempty = empty - -insert :: Pos -> Text -> Edit -insert p t = Edit [Change.insert p t] - -delete :: Range -> Edit -delete r = Edit [Change.delete r] - -replace :: Range -> Text -> Edit -replace r t = Edit [Change.replace r t] - --- TODO: change if they are disjoint -changesToEdit :: [Change] -> Edit -changesToEdit = Edit - -getChanges :: Edit -> [Change] -getChanges (Edit cs) = List.sortOn (\c -> (c.delete.start, c.delete.end)) cs - -singleton :: Change -> Edit -singleton = Edit . pure - -empty :: Edit -empty = Edit [] diff --git a/src/StaticLS/Arborist.hs b/src/StaticLS/Arborist.hs index 4b01ab43..c626fdd5 100644 --- a/src/StaticLS/Arborist.hs +++ b/src/StaticLS/Arborist.hs @@ -3,7 +3,8 @@ module StaticLS.Arborist where import AST qualified import AST.Haskell qualified as H import Arborist.Files -import Arborist.ModGraph +import Arborist.Haddock +import Arborist.ProgramIndex import Arborist.Renamer import Arborist.Scope.Types import Control.Error @@ -27,7 +28,6 @@ import StaticLS.IDE.FileWith import StaticLS.IDE.Monad import StaticLS.ProtoLSP qualified as ProtoLSP import System.Directory (doesFileExist) -import Arborist.Haddock time :: (MonadIO m) => [Char] -> m a -> m a time label fn = do @@ -51,14 +51,12 @@ getResolvedVarAndPrgs target lc = do let resolvedVar = (AST.getDeepestContainingLineCol @(H.Variable RenamePhase) (point lc)) . (.dynNode) =<< renameTree pure (resolvedVar, requiredPrograms) - getRequiredHaddock :: ProgramIndex -> GlblVarInfo -> Maybe HaddockInfo getRequiredHaddock prgIndex varInfo = let mPrg = Map.lookup varInfo.originatingMod prgIndex haddockIndex = maybe Map.empty (indexPrgHaddocks Map.empty) mPrg qualName = glblVarInfoToQualified varInfo - in - Map.lookup qualName haddockIndex + in Map.lookup qualName haddockIndex ------------------- -- Definition @@ -96,32 +94,37 @@ varToHover prgIndex varNode = let mResolvedVar = varNode.ext range = ProtoLSP.lineColRangeToProto varNode.dynNode.nodeLineColRange mContents = (resolvedVarToContents prgIndex =<< mResolvedVar) - in (\contents -> Hover - { _range = Just range - , _contents = InL $ MarkupContent MarkupKind_Markdown contents - }) <$> mContents + in ( \contents -> + Hover + { _range = Just range + , _contents = InL $ MarkupContent MarkupKind_Markdown contents + } + ) + <$> mContents resolvedVarToContents :: ProgramIndex -> ResolvedVariable -> Maybe Text resolvedVarToContents prgIndex resolvedVar = case resolvedVar of ResolvedVariable (ResolvedGlobal glblVarInfo) -> - let mHover = getRequiredHaddock prgIndex glblVarInfo in - Just $ renderGlblVarInfo mHover glblVarInfo + let mHover = getRequiredHaddock prgIndex glblVarInfo + in Just $ renderGlblVarInfo mHover glblVarInfo _ -> Nothing renderGlblVarInfo :: Maybe HaddockInfo -> GlblVarInfo -> Text renderGlblVarInfo mHaddock glblVarInfo = - wrapHaskell - (T.intercalate "\n" - [haddock - ,tySig - ] + wrapHaskell + ( T.intercalate + "\n" + [ haddock + , tySig + ] ) <> " \n\nimported from: *" <> T.intercalate ", " (NE.toList $ (.mod.text) <$> NESet.toList glblVarInfo.importedFrom) <> "*" <> " \noriginates from: *" - <> glblVarInfo.originatingMod.text <> "*" + <> glblVarInfo.originatingMod.text + <> "*" where haddock = maybe "" (.text) mHaddock diff --git a/src/StaticLS/IDE/CodeActions.hs b/src/StaticLS/IDE/CodeActions.hs index 52ac6d08..2ff4115d 100644 --- a/src/StaticLS/IDE/CodeActions.hs +++ b/src/StaticLS/IDE/CodeActions.hs @@ -9,6 +9,7 @@ import Data.LineCol (LineCol (..)) import Data.Path (AbsPath) import Data.Rope qualified as Rope import StaticLS.IDE.CodeActions.AddTypeSig qualified as AddTypeSig +import StaticLS.IDE.CodeActions.AutoExport as AutoExport import StaticLS.IDE.CodeActions.AutoImport qualified as AutoImport import StaticLS.IDE.CodeActions.RemoveRedundantImports as RemoveRedundantImports import StaticLS.IDE.CodeActions.Types @@ -25,7 +26,8 @@ getCodeActions path lineCol = do typesCodeActions <- AddTypeSig.codeAction cx importCodeActions <- AutoImport.codeAction cx removeRedundantImports <- RemoveRedundantImports.codeAction cx - let codeActions = typesCodeActions ++ importCodeActions ++ removeRedundantImports + exportCodeActions <- AutoExport.codeAction cx + let codeActions = typesCodeActions ++ importCodeActions ++ removeRedundantImports ++ exportCodeActions pure codeActions resolveLazyAssist :: CodeActionMessage -> StaticLsM SourceEdit diff --git a/src/StaticLS/IDE/CodeActions/AutoExport.hs b/src/StaticLS/IDE/CodeActions/AutoExport.hs index 38fae8fa..f7570fb6 100644 --- a/src/StaticLS/IDE/CodeActions/AutoExport.hs +++ b/src/StaticLS/IDE/CodeActions/AutoExport.hs @@ -1,33 +1,91 @@ module StaticLS.IDE.CodeActions.AutoExport where import AST qualified +import AST.Haskell as Haskell +import Arborist.AutoExport (getAllDeclExportEdit, getDeclExportEdit) +import Data.Path import Data.Range (Range) import Data.Range qualified as Range +import Data.Text (Text) import Hir +import Hir.Parse as AST import Hir.Types qualified as Hir import StaticLS.IDE.CodeActions.Types import StaticLS.IDE.Monad +import StaticLS.IDE.SourceEdit as SourceEdit import StaticLS.Monad --- declToExportItem :: Hir.Decl -> ExportItem --- declToExportItem decl = case decl of --- DeclData d -> ExportItem (getDeclName decl) (AST.getDynNode d.node) --- DeclNewtype n -> ExportItem (getDeclName decl) (AST.getDynNode n.node) --- DeclClass c -> ExportItem (getDeclName decl) (AST.getDynNode c.node) --- DeclSig s -> ExportItem (getDeclName decl) (AST.getDynNode s.node) --- DeclBind b -> ExportItem (getDeclName decl) (AST.getDynNode b.node) --- DeclDataFamily d -> ExportItem (getDeclName decl) (AST.getDynNode d.node) --- DeclPatternSig p -> ExportItem (getDeclName decl) (AST.getDynNode p.node) --- DeclPattern p -> ExportItem (getDeclName decl) (AST.getDynNode p.node) --- DeclTypeFamily t -> ExportItem (getDeclName decl) (AST.getDynNode t.node) --- DeclTypeSynonym t -> ExportItem (getDeclName decl) (AST.getDynNode t.node) +dropModule :: Hir.Qualified -> Hir.Name +dropModule (Hir.Qualified _ name) = name + +qualifiedToText :: Hir.Name -> Text +qualifiedToText nm = AST.nodeToText (nm.node) + +isAlreadyExported :: Hir.Program -> Hir.Decl -> Bool +isAlreadyExported prog decl = + let current = getCurrentExportNames prog + nameTxt = declNameText decl + in nameTxt `elem` current + +getCurrentExportNames :: Hir.Program -> [Text] +getCurrentExportNames prog = + case prog.exports of + Nothing -> [] + Just xs -> map (qualifiedToText . dropModule) (exportItemNames xs) + +isSupportedDecl :: Hir.Decl -> Bool +isSupportedDecl decl = + case decl of + Hir.DeclBind _ -> True + Hir.DeclData _ -> True + Hir.DeclNewtype _ -> True + Hir.DeclClass _ -> True + _ -> False getDeclarationsAtPoint :: Range -> [Hir.Decl] -> [Hir.Decl] getDeclarationsAtPoint range decls = - filter (\decl -> (declDynNode decl).nodeRange `Range.containsRange` range) decls + filter (\decl -> (declName decl).node.nodeRange `Range.containsRange` range) decls + +getHeaderAtPoint :: Range -> Haskell.HeaderP -> Maybe Haskell.HeaderP +getHeaderAtPoint cursorLocation headerP = + if (AST.getDynNode headerP).nodeRange `Range.containsRange` cursorLocation + then Just headerP + else Nothing + +mkAssistForAllDecl :: AbsPath -> Hir.Program -> Haskell.HeaderP -> Assist +mkAssistForAllDecl path prog headerP = + let allExportEdit = getAllDeclExportEdit prog headerP + sourceEdit = SourceEdit.single path allExportEdit + label = "Add exports for all declarations" + in mkAssist label sourceEdit + +mkAssistForDecl :: AbsPath -> Haskell.HeaderP -> Hir.Decl -> Assist +mkAssistForDecl path headerP decl = + let declExportEdit = getDeclExportEdit headerP decl + sourceEdit = SourceEdit.single path declExportEdit + label = "Add export for " <> declNameText decl + in mkAssist label sourceEdit codeAction :: CodeActionContext -> StaticLsM [Assist] -codeAction cx = do - hir <- getHir cx.path - let _decls = getDeclarationsAtPoint (Range.point cx.pos) hir.decls - pure [] +codeAction CodeActionContext {path, pos} = do + hir <- getHir path + + -- get the decl at the current cursor/highlight pos + let cursorLocation = Range.point pos + allDeclsAtPoint = getDeclarationsAtPoint cursorLocation (filter isSupportedDecl hir.decls) + declsAtPoint = filter (not . isAlreadyExported hir) allDeclsAtPoint + + -- get header + let dynNode = AST.getDynNode hir.node + mHeaderP = AST.findNode (AST.cast @Haskell.HeaderP) dynNode + + case mHeaderP of + Nothing -> pure [] + Just headerP -> do + let mHeaderPCursor = getHeaderAtPoint cursorLocation headerP + assistAll = case mHeaderPCursor of + Just headerP -> [mkAssistForAllDecl path hir headerP] + _ -> [] + assistsPerDecl = map (mkAssistForDecl path headerP) declsAtPoint + + pure (assistAll ++ assistsPerDecl) diff --git a/src/StaticLS/IDE/Definition.hs b/src/StaticLS/IDE/Definition.hs index 4fd358ce..dcb72b18 100644 --- a/src/StaticLS/IDE/Definition.hs +++ b/src/StaticLS/IDE/Definition.hs @@ -209,4 +209,4 @@ convertPersistentModelFileLc fileLc = do Nothing -> pure [fileLc] Just persistentModelName -> do res <- persistentModelNameToFileLc persistentModelName - pure $ maybeToList res <> [fileLc] + pure $ maybeToList res <> [fileLc] \ No newline at end of file diff --git a/static-ls.cabal b/static-ls.cabal index 12a91edd..45fa4a84 100644 --- a/static-ls.cabal +++ b/static-ls.cabal @@ -101,10 +101,8 @@ library if flag(dev) ghc-options: -fwrite-ide-info -hiedir .hiefiles -fdefer-type-errors -fno-defer-typed-holes -Werror=deferred-type-errors -Werror=deferred-out-of-scope-variables exposed-modules: - Data.Change Data.ConcurrentCache Data.Diff - Data.Edit Data.ListUtils Data.RangeMap Data.Rope