Shan/haskell-arborist/auto-export

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

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;
   };
 

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

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

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)

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]

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