[WIP/proposed] Ghc 8.4 hie

GhcMod.hs

@@ -48,7 +48,7 @@ module GhcMod (
   , splits
   , sig
   , refine
-  , auto
+  -- , auto
   , modules
   , languages
   , flags

GhcMod/Exe/CaseSplit.hs

@@ -2,6 +2,8 @@
 
 module GhcMod.Exe.CaseSplit (
     splits
+  , splits'
+  , SplitResult(..)
   ) where
 
 import Data.List (find, intercalate)
@@ -12,7 +14,6 @@ import System.FilePath
 import Prelude
 
 import qualified DataCon as Ty
-import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
 import qualified GHC as G
 import Outputable (PprStyle)
 import qualified TyCon as Ty
@@ -35,15 +36,22 @@ import Control.DeepSeq
 -- CASE SPLITTING
 ----------------------------------------------------------------
 
-data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan]
-               | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind)
+data SplitInfo = SplitInfo G.Name G.SrcSpan (G.SrcSpan, G.Type) [G.SrcSpan]
+               | TySplitInfo G.Name G.SrcSpan (G.SrcSpan, Ty.Kind)
 data SplitToTextInfo = SplitToTextInfo { sVarName     :: String
-                                       , sBindingSpan :: SrcSpan
-                                       , sVarSpan     :: SrcSpan
+                                       , sBindingSpan :: G.SrcSpan
+                                       , sVarSpan     :: G.SrcSpan
                                        , sTycons      :: [String]
                                        }
+data SplitResult = SplitResult { sStartLine :: Int
+                               , sStartCol  :: Int
+                               , sEndLine   :: Int
+                               , sEndCol    :: Int
+                               , sNewText   :: T.Text }
 
 -- | Splitting a variable in a equation.
+-- Unlike splits', this performs parsing an type checking on every invocation.
+-- This is meant for consumption by tools that call ghc-mod as a binary.
 splits :: IOish m
        => FilePath     -- ^ A target file.
        -> Int          -- ^ Line number.
@@ -53,84 +61,126 @@ splits file lineNo colNo =
   ghandle handler $ runGmlT' [Left file] deferErrors $ do
       oopts <- outputOpts
       crdl <- cradle
-      style <- getStyle
-      dflag <- G.getSessionDynFlags
       modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
-      whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do
-          let (varName, bndLoc, (varLoc,varT))
-                | (SplitInfo vn bl vlvt _matches) <- x
-                = (vn, bl, vlvt)
-                | (TySplitInfo vn bl vlvt) <- x
-                = (vn, bl, vlvt)
-              varName' = showName dflag style varName  -- Convert name to string
-          t <- withMappedFile file $ \file' ->
-                genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $
-                                             getTyCons dflag style varName varT)
-          return $!! (fourInts bndLoc, t)
+      p <- G.parseModule modSum
+      tcm <- G.typecheckModule p
+      whenFound' oopts (performSplit file tcm lineNo colNo) $
+        \(SplitResult sLine sCol eLine eCol newText) ->
+          return $!! ((sLine, sCol, eLine, eCol), T.unpack newText)
  where
    handler (SomeException ex) = do
      gmLog GmException "splits" $
            text "" $$ nest 4 (showToDoc ex)
      emptyResult =<< outputOpts
 
+-- | Split an identifier in a function definition.
+-- Meant for library-usage.
+splits' :: IOish m => FilePath -> G.TypecheckedModule -> Int -> Int -> GhcModT m (Maybe SplitResult)
+splits' file tcm lineNo colNo =
+  ghandle handler $ runGmlT' [Left file] deferErrors $ performSplit file tcm lineNo colNo
+  where
+    handler (SomeException ex) = do
+      gmLog GmException "splits'" $
+            text "" $$ nest 4 (showToDoc ex)
+      return Nothing
+
+performSplit :: IOish m => FilePath -> G.TypecheckedModule -> Int -> Int -> GmlT m (Maybe SplitResult)
+performSplit file tcm lineNo colNo = do
+  style <- getStyle
+  dflag <- G.getSessionDynFlags
+  maybeSplitInfo <- getSrcSpanTypeForSplit tcm lineNo colNo
+  sequenceA $ constructSplitResult file maybeSplitInfo dflag style
+
+constructSplitResult :: (IOish m) => FilePath -> Maybe SplitInfo -> G.DynFlags -> PprStyle -> Maybe (GmlT m SplitResult)
+constructSplitResult file maybeSplitInfo dflag style = do
+  splitInfo <- maybeSplitInfo
+  let splitToTextInfo = constructSplitToTextInfo splitInfo dflag style
+  startLoc <- maybeSrcSpanStart $ sBindingSpan splitToTextInfo
+  endLoc <- maybeSrcSpanEnd $ sBindingSpan splitToTextInfo
+  let startLine = G.srcLocLine startLoc
+      startCol  = G.srcLocCol startLoc
+      endLine   = G.srcLocLine endLoc
+      endCol    = G.srcLocCol endLoc
+      newText   = genCaseSplitTextFile file splitToTextInfo
+  return $ SplitResult startLine startCol endLine endCol . T.pack <$> newText
+
+constructSplitToTextInfo :: SplitInfo -> G.DynFlags -> PprStyle -> SplitToTextInfo
+constructSplitToTextInfo splitInfo dflag style =
+  SplitToTextInfo varName' bndLoc varLoc typeCons
+  where
+    typeCons = getTyCons dflag style varName varT
+    varName' = showName dflag style varName  -- Convert name to string
+    (varName, bndLoc, varLoc, varT) = case splitInfo of
+      (SplitInfo vn bl (vl, vt) _matches) -> (vn, bl, vl, vt)
+      (TySplitInfo vn bl (vl, vt)) -> (vn, bl, vl, vt)
+
+maybeSrcSpanStart :: G.SrcSpan -> Maybe G.RealSrcLoc
+maybeSrcSpanStart s = case G.srcSpanStart s of
+  (G.RealSrcLoc startLoc) -> Just startLoc
+  _ -> Nothing
+
+maybeSrcSpanEnd :: G.SrcSpan -> Maybe G.RealSrcLoc
+maybeSrcSpanEnd s = case G.srcSpanEnd s of
+  (G.RealSrcLoc endLoc) -> Just endLoc
+  _ -> Nothing
 ----------------------------------------------------------------
 -- a. Code for getting the information of the variable
 
-getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
-getSrcSpanTypeForSplit modSum lineNo colNo = do
-  fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo
+getSrcSpanTypeForSplit :: G.GhcMonad m => G.TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo)
+getSrcSpanTypeForSplit tcm lineNo colNo = do
+  fn <- getSrcSpanTypeForFnSplit tcm lineNo colNo
   if isJust fn
      then return fn
-     else getSrcSpanTypeForTypeSplit modSum lineNo colNo
+     else getSrcSpanTypeForTypeSplit tcm lineNo colNo
 
 -- Information for a function case split
-getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
-getSrcSpanTypeForFnSplit modSum lineNo colNo = do
-    p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum
-    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
-    let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
-        match  = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI
+getSrcSpanTypeForFnSplit :: G.GhcMonad m => G.TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo)
+getSrcSpanTypeForFnSplit tcm@G.TypecheckedModule{G.tm_typechecked_source = tcs} lineNo colNo = do
+    let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (G.LPat Gap.GhcTc)
+        match  = last $ listifySpans tcs (lineNo, colNo) :: G.LMatch Gap.GhcTc (G.LHsExpr Gap.GhcTc)
     case varPat of
       Nothing  -> return Nothing
       Just varPat' -> do
         varT <- Gap.getType tcm varPat'  -- Finally we get the type of the var
         case varT of
           Just varT' ->
-#if __GLASGOW_HASKELL__ >= 710
-            let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match
+#if __GLASGOW_HASKELL__ >= 804
+            let (G.L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
+#elif __GLASGOW_HASKELL__ >= 710
+            let (G.L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match
 #else
-            let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
+            let (G.L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
 #endif
             in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )
           _ -> return Nothing
 
-isPatternVar :: LPat Id -> Bool
-isPatternVar (L _ (G.VarPat _)) = True
+isPatternVar :: G.LPat Gap.GhcTc -> Bool
+isPatternVar (G.L _ (G.VarPat _)) = True
 isPatternVar _                  = False
 
-getPatternVarName :: LPat Id -> G.Name
+getPatternVarName :: G.LPat Gap.GhcTc -> G.Name
 #if __GLASGOW_HASKELL__ >= 800
-getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName
+getPatternVarName (G.L _ (G.VarPat (G.L _ vName))) = G.getName vName
 #else
-getPatternVarName (L _ (G.VarPat vName)) = G.getName vName
+getPatternVarName (G.L _ (G.VarPat vName)) = G.getName vName
 #endif
 getPatternVarName _                      = error "This should never happened"
 
 -- TODO: Information for a type family case split
-getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
-getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing
+getSrcSpanTypeForTypeSplit :: G.GhcMonad m => G.TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo)
+getSrcSpanTypeForTypeSplit _tcm _lineNo _colNo = return Nothing
 
 ----------------------------------------------------------------
 -- b. Code for getting the possible constructors
 
-getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type ->  [String]
+getTyCons :: G.DynFlags -> PprStyle -> G.Name -> G.Type ->  [String]
 getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty =
   let name' = showName dflag style name  -- Convert name to string
   in getTyCon dflag style name' tyCon
 getTyCons dflag style name _ = [showName dflag style name]
 
 -- Write cases for one type
-getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String]
+getTyCon :: G.DynFlags -> PprStyle -> String -> Ty.TyCon -> [String]
 -- 1. Non-matcheable type constructors
 getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name]
 -- 2. Special cases
@@ -152,7 +202,7 @@ isNotMatcheableTyCon ty = Ty.isPrimTyCon ty  -- Primitive types, such as Int#
                        || Ty.isFunTyCon ty   -- Function types
 
 -- Write case for one constructor
-getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String
+getDataCon :: G.DynFlags -> PprStyle -> String -> Ty.DataCon -> String
 -- 1. Infix constructors
 getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon =
   let dName  = showName dflag style $ Ty.dataConName dcon
@@ -196,7 +246,7 @@ newVarsSpecialSingleton :: String -> Int -> Int -> String
 newVarsSpecialSingleton v _     1 = v
 newVarsSpecialSingleton v start n = newVars v start n
 
-showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String
+showFieldNames :: G.DynFlags -> PprStyle -> String -> [G.Name] -> String
 showFieldNames _     _     _ []      = "" -- This should never happen
 showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
                                           fAcc  = fName ++ " = " ++ v ++ "_" ++ fName
@@ -207,11 +257,13 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
 ----------------------------------------------------------------
 -- c. Code for performing the case splitting
 
-genCaseSplitTextFile :: (MonadIO m, GhcMonad m) =>
-    FilePath -> SplitToTextInfo -> m String
-genCaseSplitTextFile file info = liftIO $ do
-  t <- T.readFile file
-  return $ getCaseSplitText (T.lines t) info
+
+genCaseSplitTextFile :: IOish m =>
+    FilePath -> SplitToTextInfo -> GmlT m String
+genCaseSplitTextFile file info =
+  withMappedFile file $ \file' -> liftIO $ do
+    t <- T.readFile file'
+    return $ getCaseSplitText (T.lines t) info
 
 getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
 getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS
@@ -224,7 +276,7 @@ getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS
       replaced'   = head replaced : map (indentBindingTo sBS) (tail replaced)
    in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')
 
-getBindingText :: [T.Text] -> SrcSpan -> [T.Text]
+getBindingText :: [T.Text] -> G.SrcSpan -> [T.Text]
 getBindingText t srcSpan =
   let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan
       lines_ = drop (sl - 1) $ take el t
@@ -235,7 +287,7 @@ getBindingText t srcSpan =
             let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)
              in T.drop (sc - 1) first : rest ++ [T.take ec last_]
 
-srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)
+srcSpanDifference :: G.SrcSpan -> G.SrcSpan -> (Int,Int,Int,Int)
 srcSpanDifference b v =
   let Just (bsl,bsc,_   ,_)  = Gap.getSrcSpan b
       Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v
@@ -254,7 +306,7 @@ replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon =
                                else T.replicate spacesToAdd (T.pack " ") `T.append` line)
               [0 ..] t
 
-indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]
+indentBindingTo :: G.SrcSpan -> [T.Text] -> [T.Text]
 indentBindingTo bndLoc binds =
   let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc
       indent      = (T.replicate (sl - 1) (T.pack " ") `T.append`)

GhcMod/Exe/Debug.hs

@@ -123,7 +123,7 @@ componentInfo ts = do
         mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
         candidates = findCandidates $ map snd mdlcs
         cn = pickComponent candidates
-    opts <- targetGhcOptions crdl sefnmn
+    opts <- fst <$> targetGhcOptions crdl sefnmn
 
     return $ unlines $
          [ "Matching Components:\n"     ++ renderGm (nest 4 $