diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs index 80afd35a0..c879022b5 100644 --- a/GhcMod/Exe/CaseSplit.hs +++ b/GhcMod/Exe/CaseSplit.hs @@ -2,6 +2,8 @@ module GhcMod.Exe.CaseSplit ( splits + , splits' + , SplitResult(..) ) where import Data.List (find, intercalate) @@ -42,8 +44,15 @@ data SplitToTextInfo = SplitToTextInfo { sVarName :: String , sVarSpan :: 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,41 +62,82 @@ 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 -> TypecheckedModule -> Int -> Int -> GhcModT m (Maybe SplitResult) +splits' file tcm lineNo colNo = + ghandle handler $ runGmlT' [Right modName] deferErrors $ performSplit file tcm lineNo colNo + where + modName = G.ms_mod_name $ pm_mod_summary $ tm_parsed_module tcm + handler (SomeException ex) = do + gmLog GmException "splits'" $ + text "" $$ nest 4 (showToDoc ex) + return Nothing + +performSplit :: IOish m => FilePath -> 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 -> 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.srcLocLine startLoc + endLine = G.srcLocCol endLoc + endCol = G.srcLocCol endLoc + newText = genCaseSplitTextFile file splitToTextInfo + return $ SplitResult startLine startCol endLine endCol . T.pack <$> newText + +constructSplitToTextInfo :: SplitInfo -> 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 :: GhcMonad m => 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 +getSrcSpanTypeForFnSplit :: GhcMonad m => TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForFnSplit tcm@TypecheckedModule{tm_typechecked_source = tcs} lineNo colNo = do let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Gap.GhcTc) match = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI case varPat of @@ -119,8 +169,8 @@ getPatternVarName (L _ (G.VarPat vName)) = G.getName vName 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 :: GhcMonad m => TypecheckedModule -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForTypeSplit _tcm _lineNo _colNo = return Nothing ---------------------------------------------------------------- -- b. Code for getting the possible constructors @@ -209,11 +259,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