From 47e8788e185abd58ce6a384645e2e0da7ccd897c Mon Sep 17 00:00:00 2001 From: Thomas Smith Date: Sat, 21 Apr 2018 13:05:59 +0200 Subject: [PATCH 1/3] Implement splits' to return a structured restult for case splitting --- GhcMod/Exe/CaseSplit.hs | 64 ++++++++++++++++++++++++++++++++++------- 1 file changed, 53 insertions(+), 11 deletions(-) diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs index 80afd35a0..bdbdb99d4 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. @@ -56,7 +65,9 @@ splits file lineNo colNo = style <- getStyle dflag <- G.getSessionDynFlags modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) - whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do + p <- G.parseModule modSum + tcm <- G.typecheckModule p + whenFound' oopts (getSrcSpanTypeForSplit tcm lineNo colNo) $ \x -> do let (varName, bndLoc, (varLoc,varT)) | (SplitInfo vn bl vlvt _matches) <- x = (vn, bl, vlvt) @@ -73,21 +84,51 @@ splits file lineNo colNo = 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 $ do + style <- getStyle + dflag <- G.getSessionDynFlags + Just x <- getSrcSpanTypeForFnSplit tcm lineNo colNo + 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 + (G.RealSrcLoc startLoc) = G.srcSpanStart bndLoc + (G.RealSrcLoc endLoc) = G.srcSpanEnd bndLoc + startLine = G.srcLocLine startLoc + startCol = G.srcLocLine startLoc + endLine = G.srcLocCol endLoc + endCol = G.srcLocCol endLoc + t <- withMappedFile file $ \file' -> + genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $ + getTyCons dflag style varName varT) + return $ Just $ SplitResult startLine startCol endLine endCol $ T.pack t + 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 + ---------------------------------------------------------------- -- 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 +160,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 @@ -131,6 +172,7 @@ getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = 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] -- 1. Non-matcheable type constructors From d801a45bff8b39de38f362462ecd3e5b0e45ddb8 Mon Sep 17 00:00:00 2001 From: Thomas Smith Date: Sat, 21 Apr 2018 14:50:10 +0200 Subject: [PATCH 2/3] Refactor splits and split' to reduce duplicate code --- GhcMod/Exe/CaseSplit.hs | 71 +++++++++++++++++++---------------------- 1 file changed, 32 insertions(+), 39 deletions(-) diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs index bdbdb99d4..6a3bf4483 100644 --- a/GhcMod/Exe/CaseSplit.hs +++ b/GhcMod/Exe/CaseSplit.hs @@ -62,22 +62,12 @@ 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) p <- G.parseModule modSum tcm <- G.typecheckModule p - whenFound' oopts (getSrcSpanTypeForSplit tcm 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) + 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" $ @@ -88,34 +78,35 @@ splits file lineNo colNo = -- 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 $ do - style <- getStyle - dflag <- G.getSessionDynFlags - Just x <- getSrcSpanTypeForFnSplit tcm lineNo colNo - 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 - (G.RealSrcLoc startLoc) = G.srcSpanStart bndLoc - (G.RealSrcLoc endLoc) = G.srcSpanEnd bndLoc - startLine = G.srcLocLine startLoc - startCol = G.srcLocLine startLoc - endLine = G.srcLocCol endLoc - endCol = G.srcLocCol endLoc - t <- withMappedFile file $ \file' -> - genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $ - getTyCons dflag style varName varT) - return $ Just $ SplitResult startLine startCol endLine endCol $ T.pack t + 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 + Just x <- getSrcSpanTypeForSplit tcm lineNo colNo + 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 + (G.RealSrcLoc startLoc) = G.srcSpanStart bndLoc + (G.RealSrcLoc endLoc) = G.srcSpanEnd bndLoc + startLine = G.srcLocLine startLoc + startCol = G.srcLocLine startLoc + endLine = G.srcLocCol endLoc + endCol = G.srcLocCol endLoc + t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ + getTyCons dflag style varName varT) + return $ Just $ SplitResult startLine startCol endLine endCol $ T.pack t + ---------------------------------------------------------------- -- a. Code for getting the information of the variable @@ -251,11 +242,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 From fe299cc71b544effcf392b36a2c9fa77d10518d2 Mon Sep 17 00:00:00 2001 From: Thomas Smith Date: Sun, 22 Apr 2018 17:54:45 +0200 Subject: [PATCH 3/3] Make performSplit less partial --- GhcMod/Exe/CaseSplit.hs | 47 ++++++++++++++++++++++++++++------------- 1 file changed, 32 insertions(+), 15 deletions(-) diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs index 6a3bf4483..c879022b5 100644 --- a/GhcMod/Exe/CaseSplit.hs +++ b/GhcMod/Exe/CaseSplit.hs @@ -67,7 +67,7 @@ splits file lineNo colNo = 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) + return $!! ((sLine, sCol, eLine, eCol), T.unpack newText) where handler (SomeException ex) = do gmLog GmException "splits" $ @@ -90,23 +90,41 @@ performSplit :: IOish m => FilePath -> TypecheckedModule -> Int -> Int -> GmlT m performSplit file tcm lineNo colNo = do style <- getStyle dflag <- G.getSessionDynFlags - Just x <- getSrcSpanTypeForSplit tcm lineNo colNo - 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 - (G.RealSrcLoc startLoc) = G.srcSpanStart bndLoc - (G.RealSrcLoc endLoc) = G.srcSpanEnd bndLoc - startLine = G.srcLocLine startLoc + 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 - t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ - getTyCons dflag style varName varT) - return $ Just $ SplitResult startLine startCol endLine endCol $ T.pack t + 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 @@ -163,7 +181,6 @@ getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = 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] -- 1. Non-matcheable type constructors