HaRe 0.7.0.5 → 0.7.0.6
raw patch · 17 files changed
+899/−579 lines, 17 filesdep ~Diffdep ~ghc-moddep ~hspec
Dependency ranges changed: Diff, ghc-mod, hspec
Files
- HaRe.cabal +11/−10
- src/Language/Haskell/Refact/Case.hs +9/−3
- src/Language/Haskell/Refact/DupDef.hs +1/−2
- src/Language/Haskell/Refact/MoveDef.hs +10/−10
- src/Language/Haskell/Refact/Renaming.hs +4/−5
- src/Language/Haskell/Refact/SwapArgs.hs +1/−1
- src/Language/Haskell/Refact/Utils.hs +70/−35
- src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs +162/−17
- src/Language/Haskell/Refact/Utils/GhcUtils.hs +0/−1
- src/Language/Haskell/Refact/Utils/LocUtils.hs +52/−50
- src/Language/Haskell/Refact/Utils/Monad.hs +62/−31
- src/Language/Haskell/Refact/Utils/MonadFunctions.hs +60/−8
- src/Language/Haskell/Refact/Utils/TokenUtils.hs +186/−103
- src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs +6/−4
- src/Language/Haskell/Refact/Utils/TypeSyn.hs +4/−143
- src/Language/Haskell/Refact/Utils/TypeUtils.hs +253/−119
- src/MainHaRe.hs +8/−37
HaRe.cabal view
@@ -1,5 +1,5 @@ Name: HaRe-Version: 0.7.0.5+Version: 0.7.0.6 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha@@ -22,9 +22,9 @@ . Current known defects: .- * After renaming, the layout of surrounding 'do','let','where' or- 'of' clauses is not adjusted. This can cause problems if the new- name is a different length from the old one.+ * After renaming, the layout of nested let/where clauses is not adjusted.+ This can cause problems if the new name is a different length from the+ old one. . * liftToTopLevel of a recursive function may introduce parameter errors. e.g. lifting 'g' in the 'zmapQ' function from 'syz-0.2.0.0'@@ -55,7 +55,7 @@ , ghc-paths , ghc-prim , ghc-syb-utils- , ghc-mod >= 2.1.2+ , ghc-mod >= 3.1.2 , mtl , old-time , pretty@@ -95,7 +95,6 @@ Executable ghc-hare- -- Main-Is: Main.hs Main-Is: MainHaRe.hs -- Other-Modules: Paths_HaRe -- GHC-Options: -Wall@@ -113,7 +112,7 @@ , ghc-paths , ghc-prim , ghc-syb-utils- , ghc-mod >= 2.1.2+ , ghc-mod >= 3.1.2 , mtl , old-time , parsec@@ -147,7 +146,8 @@ test build-depends: base >= 4.0 && < 4.7- , Diff == 0.1.3+ -- , Diff == 0.1.3+ , Diff , HUnit == 1.2.* , QuickCheck >= 2.5 , containers@@ -158,8 +158,9 @@ , ghc-paths == 0.1.* , ghc-prim , ghc-syb-utils- , ghc-mod >= 2.1.2- , hspec == 1.4.*+ , ghc-mod >= 3.1.2+ -- , hspec == 1.4.*+ , hspec , mtl , old-time , process
src/Language/Haskell/Refact/Case.hs view
@@ -65,9 +65,14 @@ ofTok <- liftIO $ tokenise (realSrcLocFromTok (glast "reallyDoIfToCase" condToks)) 1 True "of" trueToks <- liftIO $ basicTokenise "True ->" falseToks <- liftIO $ basicTokenise "False ->"- thenToks <- getToksForSpan l2- elseToks <- getToksForSpan l3+ thenToksRaw <- getToksForSpan l2+ elseToksRaw <- getToksForSpan l3 + let thenToks = dropWhile isEmpty thenToksRaw+ let elseToks = dropWhile isEmpty elseToksRaw++ logm $ "reallyDoIfToCase:elseToks=" ++ (show elseToks)+ let t0 = reIndentToks PlaceAdjacent caseTok condToks let t1' = reIndentToks PlaceAdjacent (caseTok ++ t0) ofTok let t1 = caseTok ++ t0 ++ t1'@@ -78,6 +83,7 @@ let (_,col) = tokenPos $ ghead "reallyDoIfToCase" t2 let t4 = reIndentToks (PlaceAbsCol 1 col 0) (t1++t2++t3) falseToks+ -- logm $ "reallyDoIfToCase:(t1++t2++t3++t4)=" ++ (show (t1++t2++t3++t4)) let t5 = reIndentToks PlaceAdjacent (t1++t2++t3++t4) elseToks let caseToks = t1++t2++t3++t4++t5 ++ [newLnToken (last t5)]@@ -86,7 +92,7 @@ logm $ "reallyDoIfToCase:t2=[" ++ (GHC.showRichTokenStream t2) ++ "]" logm $ "reallyDoIfToCase:t3=[" ++ (GHC.showRichTokenStream t3) ++ "]" - logm $ "reallyDoIfToCase:t1++t2++t3=" ++ (show (t1++t2++t3))+ -- logm $ "reallyDoIfToCase:t1++t2++t3=" ++ (show (t1++t2++t3)) logm $ "reallyDoIfToCase:t4=[" ++ (GHC.showRichTokenStream t4) ++ "]" logm $ "reallyDoIfToCase:t5=[" ++ (GHC.showRichTokenStream t5) ++ "]"
src/Language/Haskell/Refact/DupDef.hs view
@@ -4,7 +4,6 @@ import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB -import qualified FastString as GHC import qualified GHC import qualified OccName as GHC @@ -39,7 +38,7 @@ parsed <- getRefactParsed let (Just (modName,_)) = getModuleName parsed- let maybePn = locToName (GHC.mkFastString fileName) (row, col) renamed+ let maybePn = locToName (row, col) renamed case maybePn of Just pn -> do
src/Language/Haskell/Refact/MoveDef.hs view
@@ -12,13 +12,9 @@ import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB --- import qualified Bag as GHC import qualified Exception as GHC-import qualified FastString as GHC import qualified GHC import qualified Name as GHC--- import qualified OccName as GHC--- import qualified Outputable as GHC import Control.Exception import Control.Monad.State@@ -92,7 +88,7 @@ parsed <- getRefactParsed let (Just (modName,_)) = getModuleName parsed- let maybePn = locToName (GHC.mkFastString fileName) (row, col) renamed+ let maybePn = locToName (row, col) renamed case maybePn of Just pn -> do liftToTopLevel' modName pn@@ -118,7 +114,7 @@ logm $ "compLiftOneLevel:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ let (Just (modName,_)) = getModuleName parsed- let maybePn = locToName (GHC.mkFastString fileName) (row, col) renamed+ let maybePn = locToName (row, col) renamed case maybePn of Just pn -> do rs <- liftOneLevel' modName pn@@ -147,7 +143,7 @@ parsed <- getRefactParsed let (Just (modName,_)) = getModuleName parsed- let maybePn = locToName (GHC.mkFastString fileName) (row, col) renamed+ let maybePn = locToName (row, col) renamed case maybePn of Just pn -> do demote' modName pn@@ -324,15 +320,18 @@ -- drawTokenTree "before getting toks" -- ++AZ++ funToks <- getToksForSpan sspan logm $ "moveDecl1:funToks=" ++ (showToks funToks)- drawTokenTree "moveDecl1:after getting toks" -- ++AZ+++ drawTokenTree "moveDecl1:after getting toks" -- ++AZ++ 'in' present+ --- drawTokenTreeDetailed "moveDecl1:after getting toks" -- ++AZ++ -- (t'',sigsRemoved) <- rmTypeSigs ns t (t'',sigsRemoved) <- rmTypeSigs sigNames t- drawTokenTree "moveDecl1:after rmTypeSigs" -- ++AZ+++ -- drawTokenTree "moveDecl1:after rmTypeSigs" -- ++AZ+++ drawTokenTreeDetailed "moveDecl1:after rmTypeSigs" -- ++AZ++ -- logm $ "moveDecl1:t''=" ++ (SYB.showData SYB.Renamer 0 t'') -- ++AZ++ (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t'' -- logm $ "moveDecl1:t'=" ++ (SYB.showData SYB.Renamer 0 t') -- ++AZ++- drawTokenTree "moveDecl1:after rmDecl" -- ++AZ+++ -- drawTokenTree "moveDecl1:after rmDecl" -- ++AZ+++ drawTokenTreeDetailed "moveDecl1:after rmDecl" -- ++AZ++ 'in' missing let getToksForMaybeSig (GHC.L ss _) = do@@ -401,6 +400,7 @@ addParamsToParent pn params t = do logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params)) t' <- addActualParamsToRhs True pn params t+ -- drawTokenTreeDetailed "addParamsToParent done" return t'
src/Language/Haskell/Refact/Renaming.hs view
@@ -4,7 +4,6 @@ import qualified Data.Generics.Aliases as SYB import qualified GHC.SYB.Utils as SYB -import qualified FastString as GHC import qualified GHC import qualified Name as GHC import qualified RdrName as GHC@@ -59,7 +58,7 @@ runRefacSession settings cradle (comp fileName newName (row,col)) -- | Body of the refactoring-comp :: String -> String -> SimpPos -> RefactGhc [ApplyRefacResult]+comp :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] comp fileName newName (row,col) = do logm $ "Renaming.comp: (fileName,newName,(row,col))=" ++ (show (fileName,newName,(row,col))) getModuleGhc fileName@@ -68,7 +67,7 @@ logm $ "comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ -- logm $ "comp:parsed=" ++ (SYB.showData SYB.Parser 0 parsed) -- ++AZ++ - let (GHC.L _ rdrName') = gfromJust "Renaming.comp" $ locToRdrName (GHC.mkFastString fileName) (row, col) parsed+ let (GHC.L _ rdrName') = gfromJust "Renaming.comp" $ locToRdrName (row, col) parsed logm $ "Renaming.comp:rdrName'=" ++ (showGhc rdrName') modu <- getModule@@ -76,12 +75,12 @@ let modName = case (getModuleName parsed) of Just (mn,_) -> mn Nothing -> GHC.mkModuleName "Main"- let maybePn = locToName (GHC.mkFastString fileName) (row, col) renamed+ let maybePn = locToName (row, col) renamed logm $ "Renamed.comp:maybePn=" ++ (showGhc maybePn) -- ++AZ++ case maybePn of Just pn@(GHC.L _ n) -> do logm $ "Renaming:(n,modu)=" ++ (showGhc (n,modu))- let (GHC.L _ rdrName) = gfromJust "Renaming.comp" $ locToRdrName (GHC.mkFastString fileName) (row, col) parsed+ let (GHC.L _ rdrName) = gfromJust "Renaming.comp" $ locToRdrName (row, col) parsed let rdrNameStr = GHC.occNameString $ GHC.rdrNameOcc rdrName logm $ "Renaming: rdrName=" ++ (SYB.showData SYB.Parser 0 rdrName) logm $ "Renaming: occname rdrName=" ++ (show $ GHC.occNameString $ GHC.rdrNameOcc rdrName)
src/Language/Haskell/Refact/SwapArgs.hs view
@@ -45,7 +45,7 @@ -- putStrLn $ showParsedModule mod -- let pnt = locToPNT fileName (row, col) mod - let name = locToName (GHC.mkFastString fileName) (row, col) renamed+ let name = locToName (row, col) renamed -- error (SYB.showData SYB.Parser 0 name) case name of
src/Language/Haskell/Refact/Utils.hs view
@@ -43,7 +43,6 @@ import Data.List import Data.Maybe import Language.Haskell.GhcMod-import Language.Haskell.GhcMod.Internal import Language.Haskell.Refact.Utils.GhcBugWorkArounds import Language.Haskell.Refact.Utils.GhcModuleGraph import Language.Haskell.Refact.Utils.GhcUtils@@ -56,7 +55,6 @@ import System.Directory import qualified Digraph as GHC-import qualified DynFlags as GHC import qualified FastString as GHC import qualified GHC import qualified Outputable as GHC@@ -76,18 +74,56 @@ -- | From file name to module name. fileNameToModName :: FilePath -> RefactGhc GHC.ModuleName fileNameToModName fileName = do+{- graph <- GHC.getModuleGraph+ cgraph <- liftIO $ canonicalizeGraph graph+ cfileName <- liftIO $ canonicalizePath fileName - let mm = filter (\(mfn,_ms) -> mfn == Just fileName) $- map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph+ let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph + -- let mm = filter (\(mfn,_ms) -> mfn == Just fileName) $+ -- map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph+ case mm of [] -> error $ "Can't find module name" _ -> return $ GHC.moduleName $ GHC.ms_mod $ snd $ head mm+-}+ mm <- getModuleMaybe fileName+ case mm of+ Nothing -> error $ "Can't find module name"+ Just ms -> return $ GHC.moduleName $ GHC.ms_mod ms +-- --------------------------------------------------------------------- +getModuleMaybe :: FilePath -> RefactGhc (Maybe GHC.ModSummary)+getModuleMaybe fileName = do+ graph <- GHC.getModuleGraph+ cgraph <- liftIO $ canonicalizeGraph graph+ cfileName <- liftIO $ canonicalizePath fileName++ let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph++ case mm of+ [] -> return Nothing+ _ -> return $ Just $ snd (ghead "getModuleMaybe" mm)+ -- --------------------------------------------------------------------- +canonicalizeGraph ::+ [GHC.ModSummary] -> IO [(Maybe (FilePath), GHC.ModSummary)]+canonicalizeGraph graph = do+ let mm = map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph+ canon ((Just fp),m) = do+ fp' <- canonicalizePath fp+ return $ (Just fp',m)+ canon (Nothing,m) = return (Nothing,m)++ mm' <- mapM canon mm++ return mm'++-- ---------------------------------------------------------------------+ -- | Extract the module name from the parsed source, if there is one getModuleName :: GHC.ParsedSource -> Maybe (GHC.ModuleName,String) getModuleName (GHC.L _ modn) =@@ -117,18 +153,28 @@ -- | Once the module graph has been loaded, load the given module into -- the RefactGhc monad+-- TODO: relax the equality test, if the file is loaded via cabal it+-- may have a full filesystem path. getModuleGhc ::- -- FilePath -> RefactGhc (ParseResult,[PosToken]) FilePath -> RefactGhc () getModuleGhc targetFile = do+{- graph <- GHC.getModuleGraph let mm = filter (\(mfn,_ms) -> mfn == Just targetFile) $ map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph +-- let mm = filter (\(mfn,_ms) -> mfn == Just targetFile) $+-- map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph+ case mm of [(_,modSum)] -> getModuleDetails modSum _ -> parseSourceFileGhc targetFile+-}+ mm <- getModuleMaybe targetFile+ case mm of+ Just ms -> getModuleDetails ms+ Nothing -> parseSourceFileGhc targetFile -- --------------------------------------------------------------------- @@ -164,22 +210,28 @@ -- --------------------------------------------------------------------- -- | Parse a single source file into a GHC session-parseSourceFileGhc ::- String -> RefactGhc ()+parseSourceFileGhc :: FilePath -> RefactGhc () parseSourceFileGhc targetFile = do target <- GHC.guessTarget ("*" ++ targetFile) Nothing -- The * -- is to force interpretation, for inscopes GHC.setTargets [target] GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling ghc --make +{- graph <- GHC.getModuleGraph +-- TODO: canonicalize paths let mm = filter (\(mfn,_ms) -> mfn == Just targetFile) $ map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph -- let modSum = head g let [(_,modSum)] = mm getModuleDetails modSum+-}+ mm <- getModuleMaybe targetFile+ case mm of+ Nothing -> error $ "HaRe:unexpected error parsing " ++ targetFile+ Just modSum -> getModuleDetails modSum -- --------------------------------------------------------------------- @@ -315,7 +367,7 @@ where inExp (e::GHC.Located (GHC.HsExpr n)) | sameOccurrence e oldExp- = do + = do drawTokenTree "update Located HsExpr starting" -- ++AZ++ _ <- updateToks oldExp newExp prettyprint False drawTokenTree "update Located HsExpr done" -- ++AZ++@@ -341,25 +393,25 @@ update oldTy newTy t = everywhereMStaged SYB.Parser (SYB.mkM inTyp) t where- inTyp (t::GHC.LHsType n)- | sameOccurrence t oldTy+ inTyp (t'::GHC.LHsType n)+ | sameOccurrence t' oldTy = do _ <- updateToks oldTy newTy prettyprint False -- TODO: make sure to call syncAST return newTy- | otherwise = return t+ | otherwise = return t' instance (SYB.Data t, GHC.OutputableBndr n1, GHC.OutputableBndr n2, SYB.Data n1, SYB.Data n2) => Update (GHC.LHsBindLR n1 n2) t where update oldBind newBind t = everywhereMStaged SYB.Parser (SYB.mkM inBind) t where- inBind (t::GHC.LHsBindLR n1 n2)- | sameOccurrence t oldBind+ inBind (t'::GHC.LHsBindLR n1 n2)+ | sameOccurrence t' oldBind = do _ <- updateToks oldBind newBind prettyprint False -- TODO: make sure to call syncAST return newBind- | otherwise = return t+ | otherwise = return t' {- instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update [GHC.LPat n] t where update oldPat newPat t@@ -422,11 +474,6 @@ -- --------------------------------------------------------------------- -getDynFlags :: IO GHC.DynFlags-getDynFlags = getDynamicFlags---- ---------------------------------------------------------------------- -- | Write refactored program source to files. writeRefactoredFiles :: VerboseLevel -> [((String, Bool), ([PosToken], GHC.RenamedSource))] -> IO ()@@ -461,18 +508,6 @@ "\n\n----------------------\n\n" ++ (SYB.showData SYB.Renamer 0 renamed)) ---- http://hackage.haskell.org/trac/ghc/ticket/7351-bypassGHCBug7351 :: [PosToken] -> [PosToken]-bypassGHCBug7351 ts = map go ts- where- go :: (GHC.Located GHC.Token, String) -> (GHC.Located GHC.Token, String)- go rt@(GHC.L (GHC.UnhelpfulSpan _) _t,_s) = rt- go (GHC.L (GHC.RealSrcSpan l) t,s) = (GHC.L (fixCol l) t,s)-- fixCol l = GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanStartLine l) ((GHC.srcSpanStartCol l) - 1)) - (GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanEndLine l) ((GHC.srcSpanEndCol l) - 1)) - -- --------------------------------------------------------------------- -- | Return the client modules and file names. The client modules of@@ -487,8 +522,8 @@ modsum <- GHC.getModSummary m let mg = getModulesAsGraph False ms Nothing rg = GHC.transposeG mg- modNode = fromJust $ find (\(msum,_,_) -> mycomp msum modsum) (GHC.verticesG rg)- clientMods = filter (\msum -> not (mycomp msum modsum))+ modNode = fromJust $ find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG rg)+ clientMods = filter (\msum' -> not (mycomp msum' modsum)) $ map summaryNodeSummary $ GHC.reachableG rg modNode return clientMods@@ -509,8 +544,8 @@ ms <- GHC.getModuleGraph modsum <- GHC.getModSummary m let mg = getModulesAsGraph False ms Nothing- modNode = fromJust $ find (\(msum,_,_) -> mycomp msum modsum) (GHC.verticesG mg)- serverMods = filter (\msum -> not (mycomp msum modsum))+ modNode = fromJust $ find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG mg)+ serverMods = filter (\msum' -> not (mycomp msum' modsum)) $ map summaryNodeSummary $ GHC.reachableG mg modNode return serverMods
src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE CPP #-} -- | Provide workarounds for bugs detected in GHC, until they are -- fixed in a later version module Language.Haskell.Refact.Utils.GhcBugWorkArounds (- getRichTokenStreamWA+ bypassGHCBug7351+ , getRichTokenStreamWA ) where import qualified Bag as GHC@@ -20,33 +22,121 @@ import Control.Exception import Data.IORef+-- import Data.List.Utils import System.Directory import System.FilePath import qualified Data.Map as Map+import qualified Data.Set as Set -import Language.Haskell.Refact.Utils.GhcVersionSpecific+import Language.Haskell.Refact.Utils.TypeSyn +-- --------------------------------------------------------------------- +-- http://hackage.haskell.org/trac/ghc/ticket/7351+bypassGHCBug7351 :: [PosToken] -> [PosToken]+bypassGHCBug7351 ts = map go ts+ where+ go :: (GHC.Located GHC.Token, String) -> (GHC.Located GHC.Token, String)+ go rt@(GHC.L (GHC.UnhelpfulSpan _) _t,_s) = rt+ go (GHC.L (GHC.RealSrcSpan l) t,s) = (GHC.L (fixCol l) t,s)++ fixCol l = GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanStartLine l) ((GHC.srcSpanStartCol l) - 1))+ (GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanEndLine l) ((GHC.srcSpanEndCol l) - 1))++-- ---------------------------------------------------------------------+ -- | Replacement for original 'getRichTokenStream' which will return -- the tokens for a file processed by CPP. -- See bug <http://ghc.haskell.org/trac/ghc/ticket/8265> getRichTokenStreamWA :: GHC.GhcMonad m => GHC.Module -> m [(GHC.Located GHC.Token, String)]-getRichTokenStreamWA mod = do- (sourceFile, source, flags) <- getModuleSourceAndFlags mod+getRichTokenStreamWA modu = do+ (sourceFile, source, flags) <- getModuleSourceAndFlags modu let startLoc = GHC.mkRealSrcLoc (GHC.mkFastString sourceFile) 1 1 case GHC.lexTokenStream source startLoc flags of GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc source ts- GHC.PFailed span err ->+ GHC.PFailed _span _err -> do strSrcBuf <- getPreprocessedSrc sourceFile case GHC.lexTokenStream strSrcBuf startLoc flags of- GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc source ts- GHC.PFailed span err ->- do dflags <- GHC.getDynFlags- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags span err)+ GHC.POk _ ts ->+ do directiveToks <- GHC.liftIO $ getPreprocessorAsComments sourceFile+ nonDirectiveToks <- tokeniseOriginalSrc startLoc flags source+ let toks = GHC.addSourceToTokens startLoc source ts+ return $ combineTokens directiveToks nonDirectiveToks toks+ -- return directiveToks+ -- return nonDirectiveToks+ -- return toks+ GHC.PFailed sspan err -> parseError flags sspan err -- --------------------------------------------------------------------- +-- | Combine the three sets of tokens to produce a single set that+-- represents the code compiled, and will regenerate the original+-- source file.+-- [@directiveToks@] are the tokens corresponding to preprocessor+-- directives, converted to comments+-- [@origSrcToks@] are the tokenised source of the original code, with+-- the preprocessor directives stripped out so that+-- the lexer does not complain+-- [@postCppToks@] are the tokens that the compiler saw originally+-- NOTE: this scheme will only work for cpp in -nomacro mode+combineTokens ::+ [(GHC.Located GHC.Token, String)]+ -> [(GHC.Located GHC.Token, String)]+ -> [(GHC.Located GHC.Token, String)]+ -> [(GHC.Located GHC.Token, String)]+combineTokens directiveToks origSrcToks postCppToks = toks+ where+ locFn (GHC.L l1 _,_) (GHC.L l2 _,_) = compare l1 l2+ m1Toks = mergeBy locFn postCppToks directiveToks++ -- We must now find the set of tokens that are in origSrcToks, but+ -- not in m1Toks++ -- GHC.Token does not have Ord, can't use a set directly+ origSpans = map (\(GHC.L l _,_) -> l) origSrcToks+ m1Spans = map (\(GHC.L l _,_) -> l) m1Toks+ missingSpans = (Set.fromList origSpans) Set.\\ (Set.fromList m1Spans)++ missingToks = filter (\(GHC.L l _,_) -> Set.member l missingSpans) origSrcToks++ missingAsComments = map mkCommentTok missingToks+ where+ mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String)+ mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s),s)++ toks = mergeBy locFn m1Toks missingAsComments++-- ---------------------------------------------------------------------++tokeniseOriginalSrc ::+ GHC.GhcMonad m+ => GHC.RealSrcLoc -> GHC.DynFlags -> GHC.StringBuffer+ -> m [(GHC.Located GHC.Token, String)]+tokeniseOriginalSrc startLoc flags buf = do+ let src = stripPreprocessorDirectives buf+ case GHC.lexTokenStream src startLoc flags of+ GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts+ GHC.PFailed sspan err -> parseError flags sspan err++-- ---------------------------------------------------------------------++-- | Strip out the CPP directives so that the balance of the source+-- can tokenised.+stripPreprocessorDirectives :: GHC.StringBuffer -> GHC.StringBuffer+stripPreprocessorDirectives buf = buf'+ where+ srcByLine = lines $ sbufToString buf+ noDirectivesLines = map (\line -> if line /= [] && head line == '#' then "" else line) srcByLine+ buf' = GHC.stringToStringBuffer $ unlines noDirectivesLines++-- ---------------------------------------------------------------------++sbufToString :: GHC.StringBuffer -> String+sbufToString sb@(GHC.StringBuffer _buf len _cur) = GHC.lexemeToString sb len++-- ---------------------------------------------------------------------+ -- | The preprocessed files are placed in a temporary directory, with -- a temporary name, and extension .hscpp. Each of these files has -- three lines at the top identifying the original origin of the@@ -65,10 +155,6 @@ let tmpFile = head $ filter (\(o,_) -> o == srcFile) origNames buf <- GHC.liftIO $ GHC.hGetStringBuffer $ snd tmpFile - -- strSrcWithHead <- GHC.liftIO $ readFile $ snd tmpFile- -- let strSrc = unlines $ drop 3 $ lines strSrcWithHead- -- let strSrcBuf = GHC.stringToStringBuffer strSrc- return buf -- ---------------------------------------------------------------------@@ -92,16 +178,50 @@ let (_,originalFname) = break (== '"') firstLine return $ (tail $ init $ originalFname,fname) +-- --------------------------------------------------------------------- +-- | Get the preprocessor directives as comment tokens from the+-- source.+getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)]+getPreprocessorAsComments srcFile = do+ fcontents <- readFile srcFile+ let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#') $ zip [1..] $ lines fcontents++ let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line),line)+ where+ start = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum 1+ end = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum (length line)+ l = GHC.mkSrcSpan start end++ let toks = map mkTok directives+ return toks+ -- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 704+parseError :: GHC.GhcMonad m => GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b+parseError dflags sspan err = do+ throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)+#else+parseError :: GHC.GhcMonad m => GHC.DynFlags -> GHC.SrcSpan -> GHC.Message -> m b+parseError _dflags sspan err = do+ throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg sspan err)+#endif++-- --------------------------------------------------------------------- -- Copied from the GHC source, since not exported getModuleSourceAndFlags :: GHC.GhcMonad m => GHC.Module -> m (String, GHC.StringBuffer, GHC.DynFlags)-getModuleSourceAndFlags mod = do- m <- GHC.getModSummary (GHC.moduleName mod)+getModuleSourceAndFlags modu = do+ m <- GHC.getModSummary (GHC.moduleName modu) case GHC.ml_hs_file $ GHC.ms_location m of- Nothing -> do dflags <- GHC.getDynFlags- GHC.liftIO $ throwIO $ GHC.mkApiErr dflags (GHC.text "No source available for module " GHC.<+> GHC.ppr mod)+ Nothing ->+#if __GLASGOW_HASKELL__ > 704+ do dflags <- GHC.getDynFlags+ GHC.liftIO $ throwIO $ GHC.mkApiErr dflags (GHC.text "No source available for module " GHC.<+> GHC.ppr modu)+#else+ GHC.liftIO $ throwIO $ GHC.mkApiErr (GHC.text "No source available for module " GHC.<+> GHC.ppr modu)+#endif -- error $ ("No source available for module " ++ showGhc mod) Just sourceFile -> do source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile@@ -117,4 +237,29 @@ case Map.lookup tmp_dir mapping of Nothing -> error "should already be a tmpDir" Just d -> return d++-- ---------------------------------------------------------------------++-- Copied over from MissingH, the dependency cause travis to fail++{- | Merge two sorted lists using into a single, sorted whole,+allowing the programmer to specify the comparison function.++QuickCheck test property:++prop_mergeBy xs ys =+ mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys)+ where types = xs :: [ (Int, Int) ]+ cmp (x1,_) (x2,_) = compare x1 x2+-}+mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy cmp [] ys = ys+mergeBy cmp xs [] = xs+mergeBy cmp (allx@(x:xs)) (ally@(y:ys))+ -- Ordering derives Eq, Ord, so the comparison below is valid.+ -- Explanation left as an exercise for the reader.+ -- Someone please put this code out of its misery.+ | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally+ | otherwise = y : mergeBy cmp allx ys+
src/Language/Haskell/Refact/Utils/GhcUtils.hs view
@@ -59,7 +59,6 @@ import Data.Maybe import qualified GHC as GHC-import qualified HsTypes as GHC import qualified NameSet as GHC import Data.Generics.Strafunski.StrategyLib.StrategyLib
src/Language/Haskell/Refact/Utils/LocUtils.hs view
@@ -19,7 +19,10 @@ , realSrcLocFromTok , isWhite , notWhite- -- , isWhiteSpace+ , isWhiteSpace+ , isWhiteSpaceOrIgnored+ , isIgnored+ , isIgnoredNonComment {- ,isNewLn,isCommentStart -},isComment {-, isNestedComment-},isMultiLineComment {-,isOpenBracket,isCloseBracket, -}@@ -56,7 +59,7 @@ , lexStringToRichTokens , prettyprint -- , prettyprintGhc , prettyprintPatList- -- , groupTokensByLine+ , groupTokensByLine , addLocInfo -- , getIndentOffset , getLineOffset@@ -84,7 +87,6 @@ , splitToks , emptyList, nonEmptyList , divideComments- , isWhiteSpace , notWhiteSpace , isDoubleColon , isEmpty@@ -93,12 +95,13 @@ , isLet , isElse , isThen+ , isOf+ , isDo , getIndentOffset , splitOnNewLn , tokenLen , newLnToken , newLinesToken- , groupTokensByLine , monotonicLineToks , reSequenceToks , mkToken@@ -273,15 +276,10 @@ _ -> False -{----Returns True if a token stream starts with a newline token (apart from the white spaces tokens)-startsWithEmptyLn::[PosToken]->Bool-startsWithEmptyLn toks=isJust (find isNewLn $ takeWhile (\t->isWhiteSpace t || isNewLn t) toks)--}---- |get the last non-space token in a token stream.+-- |get the last non-ignored token in a token stream. lastNonSpaceToken::[PosToken] -> PosToken-lastNonSpaceToken toks=case dropWhile isWhiteSpace (reverse toks) of+-- lastNonSpaceToken toks=case dropWhile isWhiteSpace (reverse toks) of+lastNonSpaceToken toks=case dropWhile isWhiteSpaceOrIgnored (reverse toks) of [] -> defaultToken l -> ghead "lastNonSpaceToken" l {-@@ -306,12 +304,6 @@ -- |Remove the following extra empty lines. compressEndNewLns::[PosToken]->[PosToken] compressEndNewLns toks = toks-{- ++AZ++: is this still needed?-compressEndNewLns toks=let (toks1, toks2) = break (not.(\t->isNewLn t || isWhiteSpace t)) (reverse toks)- groupedToks = groupTokensByLine toks1- in if length groupedToks>1 then reverse ((ghead "compressEndNewLns" groupedToks)++toks2)- else toks--} {- prettyprintPatList beginWithSpace t = replaceTabBySpaces $ if beginWithSpace then format1 t else format2 t@@ -786,9 +778,6 @@ doRmWhites 0 ts = ts doRmWhites _ [] = [] doRmWhites _ ts = ts--- ++AZ++ IS this still needed?--- doRmWhites n toks@(t:ts)=if isWhiteSpace t then doRmWhites (n-1) ts--- else toks {-@@ -1132,41 +1121,17 @@ -- the start and end location to cover the preceding and following -- comments. --+-- In this routine, 'then','else','do' and 'in' are treated as comments. startEndLocIncComments::(SYB.Data t) => [PosToken] -> t -> (SimpPos,SimpPos) startEndLocIncComments toks t = startEndLocIncComments' toks (getStartEndLoc t) -{--startEndLocIncComments' :: [PosToken] -> (SimpPos,SimpPos) -> (SimpPos,SimpPos)-startEndLocIncComments' toks (startLoc,endLoc) =- let- (begin,middle,end) = splitToks (startLoc,endLoc) toks - (leadinr,leadr) = break notWhiteSpace $ reverse begin- leadr' = filter (\t -> not (isEmpty t)) leadr- prevLine = if (emptyList leadr') then 0 else (tokenRow $ ghead "startEndLocIncComments'1" leadr')- firstLine = if (emptyList middle) then 0 else (tokenRow $ ghead "startEndLocIncComments'1" middle)- (_,leadComments) = divideComments prevLine firstLine $ reverse leadinr-- (trail,trailrest) = break notWhiteSpace end- trail' = filter (\t -> not (isEmpty t)) trail- lastLine = if (emptyList middle) then 0 else (tokenRow $ glast "startEndLocIncComments'2" middle)- nextLine = if (emptyList trailrest) then 1000 else (tokenRow $ ghead "startEndLocIncComments'2" trailrest)- (trailComments,_) = divideComments lastLine nextLine trail'-- middle' = leadComments ++ middle ++ trailComments- in- if (emptyList middle')- then ((0,0),(0,0))- else ((tokenPos $ ghead "startEndLocIncComments 4" middle'),(tokenPosEnd $ last middle'))- -- else error $ "startEndLocIncComments: (prevLine,firstLine) reverse leadr =" ++ (show (prevLine,firstLine)) ++ "," ++ (showToks $ reverse leadr)--}- startEndLocIncComments' :: [PosToken] -> (SimpPos,SimpPos) -> (SimpPos,SimpPos) startEndLocIncComments' toks (startLoc,endLoc) = let (begin,middle,end) = splitToks (startLoc,endLoc) toks - notIgnored tt = not (isWhiteSpace tt || isThen tt || isElse tt)+ notIgnored tt = not (isWhiteSpaceOrIgnored tt) -- (leadinr,leadr) = break notWhiteSpace $ reverse begin (leadinr,leadr) = break notIgnored $ reverse begin@@ -1174,12 +1139,17 @@ prevLine = if (emptyList leadr') then 0 else (tokenRow $ ghead "startEndLocIncComments'1" leadr') firstLine = if (emptyList middle) then 0 else (tokenRow $ ghead "startEndLocIncComments'1" middle) (_nonleadComments,leadComments') = divideComments prevLine firstLine $ reverse leadinr- leadComments = dropWhile (\tt -> (isThen tt || isElse tt || isEmpty tt)) leadComments'+ -- leadComments = dropWhile (\tt -> (isThen tt || isElse tt || isEmpty tt || isIn tt || isDo tt)) leadComments'+ leadComments = dropWhile (\tt -> (isEmpty tt)) leadComments' (trail,trailrest) = break notWhiteSpace end trail' = filter (\t -> not (isEmpty t)) trail- lastLine = if (emptyList middle) then 0 else (tokenRow $ glast "startEndLocIncComments'2" middle)- nextLine = if (emptyList trailrest) then 1000 else (tokenRow $ ghead "startEndLocIncComments'2" trailrest)+ lastLine = if (emptyList middle)+ then 0+ else (tokenRow $ glast "startEndLocIncComments'2" middle)+ nextLine = if (emptyList trailrest)+ then 100000+ else (tokenRow $ ghead "startEndLocIncComments'2" trailrest) (trailComments,_) = divideComments lastLine nextLine trail' middle' = leadComments ++ middle ++ trailComments@@ -1241,6 +1211,19 @@ notWhiteSpace :: PosToken -> Bool notWhiteSpace tok = not (isWhiteSpace tok) +isWhiteSpaceOrIgnored :: PosToken -> Bool+isWhiteSpaceOrIgnored tok = isWhiteSpace tok || isIgnored tok++-- Tokens that are ignored when allocating tokens to a SrcSpan+isIgnored :: PosToken -> Bool+isIgnored tok = isThen tok || isElse tok || isIn tok || isDo tok++-- | Tokens that are ignored when determining the first non-comment+-- token in a span+isIgnoredNonComment :: PosToken -> Bool+isIgnoredNonComment tok = isThen tok || isElse tok || isWhiteSpace tok++ -- --------------------------------------------------------------------- isDoubleColon :: PosToken -> Bool@@ -1266,6 +1249,11 @@ isWhereOrLet :: PosToken -> Bool isWhereOrLet t = isWhere t || isLet t++-- ---------------------------------------------------------------------+-- This section is horrible because there is no Eq instance for+-- GHC.Token+ isWhere :: PosToken -> Bool isWhere ((GHC.L _ t),_s) = case t of GHC.ITwhere -> True@@ -1284,6 +1272,20 @@ isThen ((GHC.L _ t),_s) = case t of GHC.ITthen -> True _ -> False++isOf :: PosToken -> Bool+isOf ((GHC.L _ t),_s) = case t of+ GHC.ITof -> True+ _ -> False++isDo :: PosToken -> Bool+isDo ((GHC.L _ t),_s) = case t of+ GHC.ITdo -> True+ _ -> False+++-- ---------------------------------------------------------------------+ -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/Monad.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.Refact.Utils.Monad@@ -23,20 +24,24 @@ ) where -import Control.Monad.State-import Exception-import qualified Control.Monad.IO.Class as MU import qualified GHC as GHC import qualified GHC.Paths as GHC import qualified GhcMonad as GHC import qualified MonadUtils as GHC +import Control.Monad.State import Data.List+-- import Data.Maybe+import Exception import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal import Language.Haskell.Refact.Utils.TokenUtilsTypes import Language.Haskell.Refact.Utils.TypeSyn+-- import System.Directory+-- import System.FilePath+-- import System.Log.Logger+import qualified Control.Monad.IO.Class as MU -- --------------------------------------------------------------------- @@ -47,15 +52,27 @@ { rsetGhcOpts :: ![String] , rsetImportPaths :: ![FilePath] , rsetExpandSplice :: Bool+ , rsetLineSeparator :: LineSeparator , rsetMainFile :: Maybe FilePath- -- | The sandbox directory.- , rsetSandbox :: Maybe FilePath , rsetCheckTokenUtilsInvariant :: !Bool , rsetVerboseLevel :: !VerboseLevel+ , rsetEnabledTargets :: (Bool,Bool,Bool,Bool) } deriving (Show) +deriving instance Show LineSeparator++ defaultSettings :: RefactSettings-defaultSettings = RefSet [] [] False Nothing Nothing False Normal+defaultSettings = RefSet+ { rsetGhcOpts = []+ , rsetImportPaths = []+ , rsetExpandSplice = False+ , rsetLineSeparator = LineSeparator "\0"+ , rsetMainFile = Nothing+ , rsetCheckTokenUtilsInvariant = False+ , rsetVerboseLevel = Normal+ , rsetEnabledTargets = (True,False,True,False)+ } logSettings :: RefactSettings logSettings = defaultSettings { rsetVerboseLevel = Debug }@@ -134,24 +151,6 @@ -- | Initialise the GHC session, when starting a refactoring. -- This should never be called directly.-{--initGhcSession :: RefactGhc ()-initGhcSession = do- settings <- getRefacSettings- dflags <- GHC.getSessionDynFlags- let dflags' = foldl GHC.xopt_set dflags- [GHC.Opt_Cpp, GHC.Opt_ImplicitPrelude, GHC.Opt_MagicHash- ]- dflags'' = dflags' { GHC.importPaths = rsetImportPath settings }-- -- Enable GHCi style in-memory linking- dflags''' = dflags'' { GHC.hscTarget = GHC.HscInterpreted,- GHC.ghcLink = GHC.LinkInMemory }-- _ <- GHC.setSessionDynFlags dflags'''- return ()--}- initGhcSession :: Cradle -> [FilePath] -> RefactGhc () initGhcSession cradle importDirs = do settings <- getRefacSettings@@ -166,14 +165,33 @@ , operators = False , detailed = False , expandSplice = False- , sandbox = (rsetSandbox settings)- , lineSeparator = LineSeparator "\n"+ , lineSeparator = rsetLineSeparator settings }- _readLog <- initializeFlagsWithCradle opt cradle (options settings) True- -- setTargetFile fileNames- -- checkSlowAndSet- void $ GHC.load GHC.LoadAllTargets- -- liftIO readLog+ (_readLog,mcabal) <- initializeFlagsWithCradle opt cradle (options settings) True++ case mcabal of+ Just cabal -> do+ targets <- liftIO $ cabalAllTargets cabal+ -- liftIO $ warningM "HaRe" $ "initGhcSession:targets=" ++ show targets++ -- TODO: Cannot load multiple main modules, must try to load+ -- each main module and retrieve its module graph, and then+ -- set the targets to this superset.++ let targets' = getEnabledTargets settings targets+ -- let (libt,exet,testt,bencht) = targets+ -- case libt ++ exet ++ testt ++ bencht of+ -- case libt {- ++ exet -} ++ testt ++ bencht of+ case targets' of+ [] -> return ()+ tgts -> do+ -- liftIO $ warningM "HaRe" $ "initGhcSession:tgts=" ++ (show tgts)+ setTargetFiles tgts+ checkSlowAndSet+ void $ GHC.load GHC.LoadAllTargets++ Nothing -> return()+ return () where options opt@@ -191,6 +209,19 @@ getRefacSettings = do s <- get return (rsSettings s)++-- ---------------------------------------------------------------------++getEnabledTargets :: RefactSettings -> ([FilePath],[FilePath],[FilePath],[FilePath]) -> [FilePath]+getEnabledTargets settings (libt,exet,testt,bencht) = targets+ where+ (libEnabled, exeEnabled, testEnabled, benchEnabled) = rsetEnabledTargets settings+ targets = on libEnabled libt+ ++ on exeEnabled exet+ ++ on testEnabled testt+ ++ on benchEnabled bencht++ on flag xs = if flag then xs else [] -- --------------------------------------------------------------------- -- ++AZ++ trying to wrap this in GhcT, or vice versa
src/Language/Haskell/Refact/Utils/MonadFunctions.hs view
@@ -11,7 +11,6 @@ ( -- * Conveniences for state access - -- * Original API provided fetchToksFinal , fetchOrigToks , fetchToks -- Deprecated@@ -30,6 +29,8 @@ , replaceToken , putToksForSpan , getToksForSpan+ , getToksForSpanNoInv+ , getToksForSpanWithIntros , getToksBeforeSpan , putToksForPos , putToksAfterSpan@@ -38,11 +39,7 @@ , removeToksForSpan , removeToksForPos , syncDeclToLatestStash-- -- , putSrcSpan -- ^Make sure a SrcSpan is in the tree-- -- , putNewSpanAndToks- -- , putNewPosAndToks+ , indentDeclAndToks -- * For debugging , drawTokenTree@@ -119,13 +116,47 @@ let checkInv = rsetCheckTokenUtilsInvariant $ rsSettings st let Just tm = rsModule st let forest = getTreeFromCache sspan (rsTokenCache tm)+ -- let (forest',toks) = getTokensFor checkInv forest sspan+ let (forest',toks) = getTokensForNoIntros checkInv forest sspan+ let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm+ let rsModule' = Just (tm {rsTokenCache = tk'})+ put $ st { rsModule = rsModule' }+ logm $ "getToksForSpan " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks))+ return toks++-- |Get the current tokens for a given GHC.SrcSpan, without checking+-- the invariant.+-- TODO: this should not be necessary+getToksForSpanNoInv :: GHC.SrcSpan -> RefactGhc [PosToken]+getToksForSpanNoInv sspan = do+ st <- get+ let checkInv = False+ let Just tm = rsModule st+ let forest = getTreeFromCache sspan (rsTokenCache tm) let (forest',toks) = getTokensFor checkInv forest sspan+ -- let (forest',toks) = getTokensForNoIntros checkInv forest sspan let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm let rsModule' = Just (tm {rsTokenCache = tk'}) put $ st { rsModule = rsModule' } logm $ "getToksForSpan " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks)) return toks ++-- |Get the current tokens for a given GHC.SrcSpan, leaving out any+-- leading 'then', 'else', 'of', 'do' or 'in' tokens+getToksForSpanWithIntros :: GHC.SrcSpan -> RefactGhc [PosToken]+getToksForSpanWithIntros sspan = do+ st <- get+ let checkInv = rsetCheckTokenUtilsInvariant $ rsSettings st+ let Just tm = rsModule st+ let forest = getTreeFromCache sspan (rsTokenCache tm)+ let (forest',toks) = getTokensFor checkInv forest sspan+ let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm+ let rsModule' = Just (tm {rsTokenCache = tk'})+ put $ st { rsModule = rsModule' }+ logm $ "getToksForSpanNoIntros " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks))+ return toks+ -- |Get the current tokens preceding a given GHC.SrcSpan. getToksBeforeSpan :: GHC.SrcSpan -> RefactGhc ReversedToks getToksBeforeSpan sspan = do@@ -139,6 +170,7 @@ logm $ "getToksBeforeSpan " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks)) return toks + -- |Replace a token occurring in a given GHC.SrcSpan replaceToken :: GHC.SrcSpan -> PosToken -> RefactGhc () replaceToken sspan tok = do@@ -290,6 +322,24 @@ -- --------------------------------------------------------------------- +-- | Indent an AST fragment and its associated tokens by a set amount+indentDeclAndToks :: (SYB.Data t) => (GHC.Located t) -> Int -> RefactGhc (GHC.Located t)+indentDeclAndToks t offset = do+ let (GHC.L sspan _) = t+ logm $ "indentDeclAndToks " ++ (showGhc sspan) ++ ":" ++ (showSrcSpanF sspan) ++ ",offset=" ++ show offset+ st <- get+ let Just tm = rsModule st+ let tk = rsTokenCache tm+ let forest = (tkCache tk) Map.! mainTid+ let (t',forest') = indentDeclToks t forest offset+ let tk' = tk {tkCache = Map.insert mainTid forest' (tkCache tk) }+ let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True})+ put $ st { rsModule = rsModule' }+ drawTokenTree "indentDeclToks result"+ return t'++-- ---------------------------------------------------------------------+ getTypecheckedModule :: RefactGhc GHC.TypecheckedModule getTypecheckedModule = do mtm <- gets rsModule@@ -392,8 +442,9 @@ let loggingOn = (rsetVerboseLevel settings == Debug) -- || (rsetVerboseLevel settings == Normal) when loggingOn $ do- ts <- liftIO timeStamp- liftIO $ warningM "HaRe" (ts ++ ":" ++ string)+ -- ts <- liftIO timeStamp+ -- liftIO $ warningM "HaRe" (ts ++ ":" ++ string)+ liftIO $ warningM "HaRe" (string) return () timeStamp :: IO String@@ -422,6 +473,7 @@ -> RefactGhc () -- ^ Updates the RefactState updateToks (GHC.L sspan _) newAST printFun addTrailingNl = do+ logm $ "updateToks " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan)) newToks <- liftIO $ basicTokenise (printFun newAST) let newToks' = if addTrailingNl then newToks ++ [newLnToken (last newToks)]
src/Language/Haskell/Refact/Utils/TokenUtils.hs view
@@ -11,56 +11,58 @@ -- modules, it should probably never be used directly in a refactoring. module Language.Haskell.Refact.Utils.TokenUtils(- -- * A token stream with last tokens first, and functions to- -- manipulate it- ReversedToks(..)- , reverseToks- , unReverseToks- , reversedToks- -- *- , Entry(..)- , Positioning(..)- , initTokenCache+ -- * Creating+ initTokenCache+ , mkTreeFromTokens+ , mkTreeFromSpanTokens++ -- * Operations at 'TokenCache' level+ , putToksInCache+ , replaceTokenInCache+ , removeToksFromCache+ , getTreeFromCache+ , replaceTreeInCache+ , syncAstToLatestCache++ -- * Operations at 'Tree' 'Entry' level , getTokensFor+ , getTokensForNoIntros , getTokensBefore , replaceTokenForSrcSpan , updateTokensForSrcSpan- , treeStartEnd- , spanStartEnd , insertSrcSpan , removeSrcSpan , getSrcSpanFor- , retrieveTokensFinal- , retrieveTokensInterim- -- , retrieveTokens- , retrieveTokens' -- temporary for debug , addNewSrcSpanAndToksAfter , addToksAfterSrcSpan , addDeclToksAfterSrcSpan+ , syncAST+ , indentDeclToks+ , Positioning(..) + -- * Retrieving tokens+ , retrieveTokensFinal+ , retrieveTokensInterim+ , retrieveTokens' -- temporary for debug+ -- * Token Tree Selection , treeIdFromForestSpan- , replaceTokenInCache- , putToksInCache- , removeToksFromCache- , getTreeFromCache- , replaceTreeInCache- , syncAstToLatestCache -- * Token marking and re-alignment- -- , tokenFileMark- -- , markToken- -- , isMarked , reAlignMarked -- * Utility , posToSrcSpan , posToSrcSpanTok , fileNameFromTok-- -- * AST tie up- , syncAST+ , treeStartEnd+ , spanStartEnd + -- * A token stream with last tokens first, and functions to manipulate it+ , ReversedToks(..)+ , reverseToks+ , unReverseToks+ , reversedToks -- * Internal, for testing , placeToksForSpan@@ -76,8 +78,6 @@ -- , lookupSrcSpan , invariantOk , invariant- , mkTreeFromTokens- , mkTreeFromSpanTokens , showForest , showTree , showSrcSpan@@ -449,11 +449,13 @@ -- --------------------------------------------------------------------- +-- | Replace any ForestLine flags already in a SrcSpan with the given ones insertForestLineInSrcSpan :: ForestLine -> GHC.SrcSpan -> GHC.SrcSpan insertForestLineInSrcSpan fl@(ForestLine ch tr v _l) (GHC.RealSrcSpan ss) = ss' where lineStart = forestLineToGhcLine fl- lineEnd = forestLineToGhcLine (ForestLine ch tr v (GHC.srcSpanEndLine ss))+ (_,(ForestLine _ _ _ le,_)) = srcSpanToForestSpan (GHC.RealSrcSpan ss)+ lineEnd = forestLineToGhcLine (ForestLine ch tr v le) locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss) locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss) ss' = GHC.mkSrcSpan locStart locEnd@@ -509,6 +511,12 @@ -- --------------------------------------------------------------------- +insertLenChangedInForestSpan :: Bool -> ForestSpan -> ForestSpan+insertLenChangedInForestSpan chNew ((ForestLine _chs trs vs ls,cs),(ForestLine _che tre ve le,ce))+ = ((ForestLine chNew trs vs ls,cs),(ForestLine chNew tre ve le,ce))++-- ---------------------------------------------------------------------+ srcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan srcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol)) where@@ -521,6 +529,10 @@ forestSpanFromEntry (Entry ss _ ) = ss forestSpanFromEntry (Deleted ss _) = ss +putForestSpanInEntry :: Entry -> ForestSpan -> Entry+putForestSpanInEntry (Entry _ss toks) ssnew = (Entry ssnew toks)+putForestSpanInEntry (Deleted _ss toks) ssnew = (Deleted ssnew toks)+ -- -------------------------------------------------------------------- treeIdFromForestSpan :: ForestSpan -> TreeId@@ -549,7 +561,6 @@ initTokenCache :: [PosToken] -> TokenCache initTokenCache toks = TK (Map.fromList [((TId 0),(mkTreeFromTokens toks))]) (TId 0) - -- --------------------------------------------------------------------- treeIdIntoTree :: TreeId -> Tree Entry -> Tree Entry@@ -605,7 +616,6 @@ where tid = treeIdFromForestSpan $ srcSpanToForestSpan sspan - -- --------------------------------------------------------------------- replaceTreeInCache :: GHC.SrcSpan -> Tree Entry -> TokenCache -> TokenCache@@ -646,8 +656,6 @@ -- |Get the (possible cached) tokens for a given source span, and -- cache their being fetched. -- NOTE: The SrcSpan may be one introduced by HaRe, rather than GHC.--- TODO: consider returning an Either. Although in reality the error--- should never happen getTokensFor :: Bool -> Tree Entry -> GHC.SrcSpan -> (Tree Entry,[PosToken]) getTokensFor checkInvariant forest sspan = (forest'', tokens) where@@ -661,6 +669,19 @@ -- --------------------------------------------------------------------- +-- |Get the (possible cached) tokens for a given source span, and+-- cache their being fetched.+-- NOTE: The SrcSpan may be one introduced by HaRe, rather than GHC.+getTokensForNoIntros :: Bool -> Tree Entry -> GHC.SrcSpan -> (Tree Entry,[PosToken])+getTokensForNoIntros checkInvariant forest sspan = (forest', tokens')+ where+ (forest',tokens) = getTokensFor checkInvariant forest sspan+ -- (lead,rest) = break (not . isWhiteSpaceOrIgnored) tokens+ (lead,rest) = break (not . isIgnoredNonComment) tokens+ tokens' = (filter (not . isIgnored) lead) ++ rest++-- ---------------------------------------------------------------------+ -- |Get the tokens preceding a given 'SrcSpan' getTokensBefore :: Tree Entry -> GHC.SrcSpan -> (Tree Entry,ReversedToks) getTokensBefore forest sspan = (forest', prevToks')@@ -718,9 +739,12 @@ (forest',tree@(Node (Entry _s _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan) prevToks = retrieveTokensInterim tree - endComments = reverse $ takeWhile isWhiteSpace $ reverse toks- startComments = takeWhile isWhiteSpace $ toks+ -- endComments = reverse $ takeWhile isWhiteSpace $ reverse toks+ -- startComments = takeWhile isWhiteSpace $ toks + endComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse toks+ startComments = takeWhile isWhiteSpaceOrIgnored $ toks+ newTokStart = if (emptyList prevToks) then mkZeroToken else ghead "updateTokensForSrcSpan.1" prevToks@@ -731,9 +755,13 @@ else -- Must reuse any pre-existing start or end comments, and -- resync the tokens across all three. let- origEndComments = reverse $ takeWhile isWhiteSpace $ reverse prevToks- origStartComments = takeWhile isWhiteSpace $ prevToks- core = reIndentToks (PlaceAbsolute (tokenRow newTokStart) (tokenCol newTokStart)) prevToks toks+ -- origEndComments = reverse $ takeWhile isWhiteSpace $ reverse prevToks+ -- origStartComments = takeWhile isWhiteSpace $ prevToks+ origEndComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse prevToks+ origStartComments = takeWhile isWhiteSpaceOrIgnored $ prevToks+ -- core = reIndentToks (PlaceAbsolute (tokenRow newTokStart) (tokenCol newTokStart)) prevToks toks+ ((startRow,startCol),_) = forestSpanToGhcPos $ srcSpanToForestSpan sspan+ core = reIndentToks (PlaceAbsolute startRow startCol) prevToks toks trail = if (emptyList origEndComments) then [] else addOffsetToToks (lineOffset,colOffset) origEndComments@@ -800,11 +828,13 @@ (startLoc,endLoc) = startEndLocIncComments' toks (tokStartPos,tokEndPos) (startToks,middleToks,endToks) = splitToks (startLoc,endLoc) toks- tree1 = if (emptyList $ filter (\t -> not $ isEmpty t) startToks)+ -- tree1 = if (emptyList $ filter (\t -> not $ isEmpty t) startToks)+ tree1 = if (nonCommentSpan startToks == ((0,0),(0,0))) then [] else [mkTreeFromTokens startToks] tree2 = [mkTreeFromSpanTokens sspan middleToks]- tree3 = if (emptyList $ filter (\t -> not $ isEmpty t) endToks)+ -- tree3 = if (emptyList $ filter (\t -> not $ isEmpty t) endToks)+ tree3 = if (nonCommentSpan endToks == ((0,0),(0,0))) then [] else [mkTreeFromTokens endToks] @@ -875,43 +905,46 @@ -- --------------------------------------------------------------------- -mkTreeListFromTokens :: [PosToken] -> ForestSpan -> [Tree Entry]-mkTreeListFromTokens [] _sspan = []-mkTreeListFromTokens toks sspan = res+-- TODO: The Bool is horrible+mkTreeListFromTokens :: [PosToken] -> ForestSpan -> Bool -> [Tree Entry]+mkTreeListFromTokens [] _sspan _ = []+mkTreeListFromTokens toks sspan useOriginalSpan = res where (Node (Entry tspan treeToks) sub) = mkTreeFromTokens toks ((ForestLine chs ts vs _, _),(ForestLine che te ve _, _)) = sspan ((ForestLine _ _ _ ls,cs),(ForestLine _ _ _ le,ce)) = tspan - span' = ((ForestLine chs ts vs ls, cs),(ForestLine che te ve le, ce))+ span' = ((ForestLine chs ts vs ls, cs),(ForestLine che te ve le, ce)) - res = if ((ls,cs),(le,ce)) == ((0,0),(0,0))+ res = if nonCommentSpan toks == ((0,0),(0,0)) then []- else [(Node (Entry span' treeToks) sub)]+ else if useOriginalSpan+ then [(Node (Entry sspan treeToks) sub)]+ else [(Node (Entry span' treeToks) sub)] +-- --------------------------------------------------------------------- splitSubToks :: Tree Entry -> (ForestPos, ForestPos) -> ([Tree Entry], [Tree Entry], [Tree Entry])-splitSubToks n@(Node (Deleted (ssStart,ssEnd) _eg) []) (sspanStart,sspanEnd) = (b',m',e')+splitSubToks n@(Node (Deleted (treeStart,treeEnd) _eg) []) (sspanStart,sspanEnd) = (b',m',e') where egs = (0,0) -- TODO: calculate this ege = (0,0) -- TODO: calculate this- b' = if sspanStart > ssStart- then [Node (Deleted (ssStart,ssStart) egs) []]- -- then error $ "splitSubToks:would return:b'=" ++ (show [Node (Deleted (ssStart,ssStart) egs) []]) -- ++AZ+++ b' = if sspanStart > treeStart+ then [Node (Deleted (treeStart,treeStart) egs) []] else [] m' = [n]- e' = if ssEnd > sspanEnd- then [Node (Deleted (sspanEnd,ssEnd) ege) []]- -- then error $ "splitSubToks:would return:e'=" ++ (show [Node (Deleted (sspanEnd,ssEnd) ege) []]) -- ++AZ+++ e' = if treeEnd > sspanEnd+ then [Node (Deleted (sspanEnd,treeEnd) ege) []] else []+ splitSubToks tree sspan = (b',m',e') -- error $ "splitSubToks:(sspan,tree)=" ++ (show (sspan,tree)) where- (Node (Entry ss@(ssStart,ssEnd) toks) []) = tree+ (Node (Entry ss@(treeStart,treeEnd) toks) []) = tree (sspanStart,sspanEnd) = sspan -- TODO: ignoring comment boundaries to start @@ -924,21 +957,16 @@ -- error $ "splitSubToks:StartOnly:(sspan,tree,(b'',m''))=" ++ (show (sspan,tree,(b'',m''))) where (_,toksb,toksm) = splitToks (forestSpanToSimpPos (nullPos,sspanStart)) toks--- b'' = if (emptyList toksb) then [] else [Node (Entry (ssStart, sspanEnd) toksb) []]- b'' = if (emptyList toksb) then [] else [mkTreeFromTokens toksb] -- Need to get end from actual toks-{-- m'' = if (ssStart == sspanStart) -- Eq does not compare all flags- then mkTreeListFromTokens toksm (ssStart, ssEnd)- else mkTreeListFromTokens toksm (sspanStart,ssEnd)--}+-- b'' = if (emptyList toksb) then [] else [Node (Entry (treeStart, sspanEnd) toksb) []]+ b'' = if (emptyList toksb || nonCommentSpan toksb == ((0,0),(0,0)))+ then []+ else [mkTreeFromTokens toksb] -- Need to get end from actual toks m'' = let- -- ssStart, ssEnd is passed in node- -- sspanStart, sspanEnd is span we are matching (ForestLine _ch _ts _v le,ce) = sspanEnd tl =- if (ssStart == sspanStart) -- Eq does not compare all flags- then mkTreeListFromTokens toksm (ssStart, ssEnd)- else mkTreeListFromTokens toksm (sspanStart,ssEnd)+ if (treeStart == sspanStart) -- Eq does not compare all flags+ then mkTreeListFromTokens toksm (treeStart, treeEnd) False+ else mkTreeListFromTokens toksm (sspanStart,treeEnd) False _tl' = if emptyList tl then [] else [Node (Entry (st,(ForestLine ch ts v le,ce)) tk) []]@@ -947,26 +975,30 @@ -- tl' tl e'' = []+ (True, True) -> (b'',m'',e'') -- Start and End where- (toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (ssStart,ssEnd)) toks- b'' = mkTreeListFromTokens toksb (sspanStart,ssStart)- m'' = mkTreeListFromTokens toksm (ssStart,ssEnd)- e'' = mkTreeListFromTokens tokse (ssEnd,sspanEnd)+ -- (toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (treeStart,treeEnd)) toks+ (toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (sspanStart,sspanEnd)) toks+ b'' = mkTreeListFromTokens toksb (treeStart, sspanStart) False+ m'' = mkTreeListFromTokens toksm (sspanStart, sspanEnd) True+ e'' = mkTreeListFromTokens tokse (sspanEnd, treeEnd) False+ (False,True) -> (b'',m'',e'') -- End only where (_,toksm,tokse) = splitToks (forestSpanToSimpPos (nullPos,sspanEnd)) toks b'' = [] m'' = let -- If the last span is changed, make sure it stays -- as it was- tl = mkTreeListFromTokens toksm (ssStart,sspanEnd)+ tl = mkTreeListFromTokens toksm (treeStart,sspanEnd) False tl' = if emptyList tl then [] else [Node (Entry (st,sspanEnd) tk) []]- where [Node (Entry (st,_en) tk) []] = mkTreeListFromTokens toksm (ssStart,sspanEnd)+ where [Node (Entry (st,_en) tk) []] = mkTreeListFromTokens toksm (treeStart,sspanEnd) False in tl'- e'' = mkTreeListFromTokens tokse (sspanEnd,ssEnd)+ e'' = mkTreeListFromTokens tokse (sspanEnd,treeEnd) False+ (False,False) -> if (containsMiddle ss sspan) then ([],[tree],[]) else error $ "splitSubToks: error (ss,sspan)=" ++ (show (ss,sspan))@@ -1078,7 +1110,7 @@ -- |Retrieve all the tokens at the leaves of the tree, in order. -- Marked tokens are re-aligned, and gaps are closed. retrieveTokensFinal :: Tree Entry -> [PosToken]-retrieveTokensFinal forest = stripForestLines $ monotonicLineToks $ reAlignMarked+retrieveTokensFinal forest = monotonicLineToks $ stripForestLines $ reAlignMarked $ deleteGapsToks $ retrieveTokens' forest -- ---------------------------------------------------------------------@@ -1086,7 +1118,7 @@ -- |Retrieve all the tokens at the leaves of the tree, in order. No -- adjustments are made to address gaps or re-alignment of the tokens retrieveTokensInterim :: Tree Entry -> [PosToken]-retrieveTokensInterim forest = stripForestLines $ monotonicLineToks {- reAlignMarked -}+retrieveTokensInterim forest = monotonicLineToks $ stripForestLines {- reAlignMarked -} $ concat $ map (\t -> F.foldl accum [] t) [forest] where accum :: [PosToken] -> Entry -> [PosToken]@@ -1423,7 +1455,7 @@ where -- TODO: Should this not be prevOffset? colStart = tokenCol $ ghead "reIndentToks.4"- $ dropWhile isWhiteSpace prevToks+ $ dropWhile isWhiteSpaceOrIgnored prevToks -- colStart = prevOffset -- colStart = error $ "reIndentToks:prevToks=" ++ (show prevToks) lineStart = (tokenRow (lastTok)) -- + 1@@ -1454,13 +1486,16 @@ nonCommentSpan [] = ((0,0),(0,0)) nonCommentSpan toks = (startPos,endPos) where- stripped = dropWhile isWhiteSpace $ toks+ -- stripped = dropWhile isWhiteSpace $ toks+ stripped = dropWhile isIgnoredNonComment $ toks (startPos,endPos) = case stripped of [] -> ((0,0),(0,0)) _ -> (tokenPos startTok,tokenPosEnd endTok) where- startTok = ghead "nonCommentSpan.1" $ dropWhile isWhiteSpace $ toks- endTok = ghead "nonCommentSpan.2" $ dropWhile isWhiteSpace $ reverse toks+ -- startTok = ghead "nonCommentSpan.1" $ dropWhile isWhiteSpace $ toks+ -- endTok = ghead "nonCommentSpan.2" $ dropWhile isWhiteSpace $ reverse toks+ startTok = ghead "nonCommentSpan.1" $ dropWhile isIgnoredNonComment $ toks+ endTok = ghead "nonCommentSpan.2" $ dropWhile isIgnoredNonComment $ reverse toks -- --------------------------------------------------------------------- @@ -1735,7 +1770,10 @@ -- test -- TODO: is this a reasonable approach? - rs = if (start <= sstart) && ((end >= send) || (forestPosVersionSet send) || (forestPosAstVersionSet send))+ rs = if ((start <= sstart) &&+ ((end >= send) || (forestPosVersionSet send) || (forestPosAstVersionSet send)))+ || (forestPosLenChanged start)+ then [] else ["FAIL: subForest start and end does not match entry: " ++ (prettyshow node)] @@ -1872,15 +1910,13 @@ -- |Make a tree representing a particular set of tokens mkTreeFromTokens :: [PosToken] -> Tree Entry-mkTreeFromTokens [] = Node (Entry nullSpan []) []+mkTreeFromTokens [] = Node (Entry nullSpan []) [] mkTreeFromTokens toks = Node (Entry sspan toks) [] where- -- startLoc = tokenPos $ ghead "mkTreeFromTokens" toks- -- endLoc = tokenPosEnd $ last toks -- SrcSpans count from start of token, not end- -- sspan = GHC.RealSrcSpan $ GHC.mkRealSrcSpan startLoc endLoc (startLoc',endLoc') = nonCommentSpan toks- sspan = simpPosToForestSpan (startLoc',endLoc')-+ sspan = if (startLoc',endLoc') == ((0,0),(0,0))+ then error $ "mkTreeFromTokens:null span for:" ++ (show toks)+ else simpPosToForestSpan (startLoc',endLoc') -- --------------------------------------------------------------------- @@ -1897,35 +1933,25 @@ -- |Synchronise a located AST fragment to use a newly created SrcSpan -- in the token tree.+-- TODO: Should this indent the tokens as well? syncAST :: (SYB.Data t) => GHC.Located t -- ^The AST (or fragment)- -- => t -- ^The AST (or fragment) -> GHC.SrcSpan -- ^The SrcSpan created in the Tree Entry -> Tree Entry -- ^Existing token tree -> (GHC.Located t, Tree Entry) -- ^Updated AST and tokens- -- -> (t, Tree Entry) -- ^Updated AST and tokens--- syncAST (GHC.L _l t) sspan forest = (ast',forest') syncAST ast@(GHC.L l _t) sspan forest = (GHC.L sspan xx,forest') where forest' = forest - ((ForestLine _ _ _ startRow,startCol),_) = srcSpanToForestSpan l- ((ForestLine _ _ _ newStartRow,newStartCol),_) = srcSpanToForestSpan sspan- (( sr, sc),( _er, _ec)) = ghcSpanStartEnd l ((nsr,nsc),(_ner,_nec)) = ghcSpanStartEnd sspan rowOffset = nsr - sr colOffset = nsc - sc - rowOffset' = newStartRow - startRow- colOffset' = newStartCol - startCol- -- TODO: take cognizance of the ForestLines encoded in srcspans -- when calculating the offsets etc syncSpan s = addOffsetToSpan (rowOffset,colOffset) s- syncSpan' s = addOffsetToSpan (rowOffset',colOffset') s- -- syncSpan s = s (GHC.L _s xx) = everywhereStaged SYB.Renamer ( SYB.mkT hsbindlr@@ -1935,22 +1961,78 @@ `SYB.extT` lhsexpr `SYB.extT` lpat `SYB.extT` limportdecl+ `SYB.extT` lmatch ) ast hsbindlr (GHC.L s b) = (GHC.L (syncSpan s) b) :: GHC.Located (GHC.HsBindLR GHC.Name GHC.Name) sig (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LSig GHC.Name ty (GHC.L s typ) = (GHC.L (syncSpan s) typ) :: (GHC.LHsType GHC.Name)-- -- TODO: ++AZ++ this is horrible, ad hoc: syncSpan'- --name (GHC.L s n) = (GHC.L (syncSpan' s) n) :: GHC.Located GHC.Name name (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.Located GHC.Name- lhsexpr (GHC.L s e) = (GHC.L (syncSpan s) e) :: GHC.LHsExpr GHC.Name lpat (GHC.L s p) = (GHC.L (syncSpan s) p) :: GHC.LPat GHC.Name limportdecl (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LImportDecl GHC.Name+ lmatch (GHC.L s m) = (GHC.L (syncSpan s) m) :: GHC.LMatch GHC.Name -- --------------------------------------------------------------------- +-- | indent the tree and tokens by the given offset, and sync the AST+-- to the tree too.+indentDeclToks :: (SYB.Data t)+ => GHC.Located t -- ^The AST (or fragment)+ -> Tree Entry -- ^Existing token tree+ -> Int -- ^ (signed) number of columns to indent/dedent+ -> (GHC.Located t, Tree Entry) -- ^Updated AST and tokens+indentDeclToks decl@(GHC.L sspan _) forest offset = (decl',forest'')+ where+ -- make sure the span is in the forest+ (forest',tree) = getSrcSpanFor forest (srcSpanToForestSpan sspan)++ z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest'++ tree' = go tree+ -- The invariant will fail if we do not propagate this change+ -- upward. But it needs to sync with the AST, which we do not have+ -- the upward version of.+ -- Instead, set the lengthChanged flag, in the parent.++ -- sss = forestSpanFromEntry entry+ -- sss' = insertLenChangedInForestSpan True sss+ -- tree'' = Node (putForestSpanInEntry entry sss') subs++ markLenChanged (Node entry subs) = (Node entry' subs)+ where+ sss = forestSpanFromEntry entry+ sss' = insertLenChangedInForestSpan True sss+ entry' = putForestSpanInEntry entry sss'++ z' = Z.setTree tree' z+ -- forest'' = Z.toTree (Z.setTree tree'' z)++ forest'' = case Z.parent z' of+ Nothing -> Z.toTree (Z.setTree (markLenChanged $ Z.tree z' ) z' )+ Just z'' -> Z.toTree (Z.setTree (markLenChanged $ Z.tree z'') z'')+++ (decl',_) = syncAST decl (addOffsetToSpan off sspan) tree++ off = (0,offset)++ -- Pretty sure this could be a fold of some kind+ go (Node (Deleted ss eg) []) = (Node (Deleted (addOffsetToForestSpan off ss) eg) [])+ go (Node (Entry ss []) sub) = (Node (Entry (addOffsetToForestSpan off ss) []) (map go sub))+ go (Node (Entry ss toks) []) = (Node (Entry (addOffsetToForestSpan off ss) (addOffsetToToks off toks)) [])++-- ---------------------------------------------------------------------++addOffsetToForestSpan :: (Int,Int) -> ForestSpan -> ForestSpan+addOffsetToForestSpan (lineOffset,colOffset) fspan = fspan'+ where+ ((ForestLine sch str sv sl,sc),(ForestLine ech etr ev el,ec)) = fspan+ fspan' = ((ForestLine sch str sv (sl+lineOffset),sc+colOffset),+ (ForestLine ech etr ev (el+lineOffset),ec+colOffset))++-- ---------------------------------------------------------------------+ addOffsetToSpan :: (Int,Int) -> GHC.SrcSpan -> GHC.SrcSpan addOffsetToSpan (lineOffset,colOffset) sspan = sspan' where@@ -1976,6 +2058,7 @@ ((ForestLine chs trs vs ls,cs),(ForestLine che tre ve le,ce)) = srcSpanToForestSpan sspan -- chsn = if chs then 1 else 0 -- chen = if che then 1 else 0+ -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs view
@@ -6,13 +6,15 @@ -- module Language.Haskell.Refact.Utils.TokenUtilsTypes(- Entry(..)+ -- * The cache of trees comprising the manipulated tokens+ TokenCache(..)+ , TreeId(..)+ , mainTid+ -- * Structure of each tree+ , Entry(..) , ForestLine(..) , ForestPos , ForestSpan- , TreeId(..)- , TokenCache(..)- , mainTid ) where import Language.Haskell.Refact.Utils.TypeSyn
src/Language/Haskell/Refact/Utils/TypeSyn.hs view
@@ -16,58 +16,20 @@ import qualified Name as GHC import qualified Outputable as GHC -import Data.Generics---{---data NameSpace = ValueName | ClassName | TypeCon | DataCon | Other deriving (Eq, Show)--type HsDeclP =HsDeclI PNT-type HsPatP =HsPatI PNT-type HsExpP =HsExpI PNT--} type HsExpP = GHC.HsExpr GHC.RdrName type HsPatP = GHC.Pat GHC.RdrName--- type HsDeclP = GHC.HsDecl GHC.RdrName type HsDeclP = GHC.LHsDecl GHC.RdrName--- type HsDeclP = GHC.LHsBind GHC.Name type HsDeclsP = GHC.HsGroup GHC.Name -{--type HsMatchP =HsMatchI PNT (HsExpP) (HsPatP) [HsDeclP]--- type HsModuleP =HsModuleI (SN HsName.HsName) [HsDeclI PNT]-type HsImportDeclP=HsImportDeclI ModuleName PNT -- (SN HsName.HsName)-type HsExportEntP = HsExportSpecI ModuleName PNT-type RhsP =HsRhs HsExpP-type GuardP =(SrcLoc, HsExpP, HsExpP)-type HsAltP =HsAlt HsExpP HsPatP [HsDeclP]---type HsConDeclP=HsConDeclI PNT (HsTypeI PNT)-type HsStmtP =HsStmt HsExpP HsPatP [HsDeclP]-type HsStmtAtomP = HsStmtAtom HsExpP HsPatP [HsDeclP]-type HsFieldP =HsFieldI PNT HsExpP-type HsTypeP = HsTypeI PNT-type EntSpecP = EntSpec PNT-type HsConDeclP = HsConDeclI PNT HsTypeP [HsTypeP]-type HsConDeclP' = HsConDeclI PNT (TI PNT HsTypeP) [TI PNT HsTypeP]-type ENT =Ents.Ent PosName.Id--} -- type InScopes=((Relations.Rel Names.QName (Ents.Ent PosName.Id))) type InScopes = [GHC.Name] ---type Exports =[(PosName.Id, Ent PosName.Id)]- type SimpPos = (Int,Int) -- Line, column -- Additions for GHC type PosToken = (GHC.Located GHC.Token, String)--- type PosToken = (GHC.GenLocated GHC.SrcSpan GHC.Token, String) -data Pos = Pos { char, line, column :: !Int } deriving (Show)--- it seems that the field char is used to handle special characters including the '\t'-- type Export = GHC.LIE GHC.RdrName -- ---------------------------------------------------------------------@@ -82,125 +44,24 @@ -- type PN = GHC.RdrName newtype PName = PN HsName deriving (Eq) -{--instance Show PName where- -- show (PN n) = "(PN " ++ (GHC.showRdrName n) ++ ")"- show (PN n) = "(PN " ++ (showGhc n) ++ ")"--}- -- | The PNT is the unique name, after GHC renaming. It corresponds to -- GHC.Name data PNT = PNT GHC.Name deriving (Data,Typeable) -- Note: -- GHC.Name has SrcLoc in it already --{- ++AZ++ only needed for some tests-instance Show PNT where- -- show (PNT (GHC.L l name)) = "(PNT " ++ (showGhc l) ++ " " ++ (GHC.showRdrName name) ++ ")"- show (PNT (GHC.L l name)) = "(PNT " ++ (showGhc l) ++ " " ++ (showGhc name) ++ ")"---instance Show (GHC.GenLocated GHC.SrcSpan GHC.Name) where- show (GHC.L l name) = "(" ++ (showGhc l) ++ " " ++ (showGhc $ GHC.nameUnique name) ++ " " ++ (showGhc name) ++ ")"-only for tests end -}- instance Show GHC.NameSpace where show ns- | ns == GHC.tcName = "TcClsName"+ | ns == GHC.tcName = "TcClsName" | ns == GHC.dataName = "DataName"- | ns == GHC.varName = "VarName"- | ns == GHC.tvName = "TvName"- | otherwise = "UnknownNamespace"+ | ns == GHC.varName = "VarName"+ | ns == GHC.tvName = "TvName"+ | otherwise = "UnknownNamespace" instance GHC.Outputable GHC.NameSpace where ppr x = GHC.text $ show x -- --------------------------------------------------------------------- --- type HsModuleP =HsModuleI ModuleName PNT [HsDeclI PNT] type HsModuleP = GHC.Located (GHC.HsModule GHC.RdrName)------ ------------------------------------------------------- From PNT---- CMB--- type PName = HsName---{--type PIdent = HsIdentI PName-type PId = PN Id--}---data PNT = PNT PName (IdTy PId) OptSrcLoc deriving (Show,Read, Data, Typeable)---- CMB--- data PNT = PNT PName OptSrcLoc deriving (Data, Typeable)---- CMB---instance Eq PNT where PNT i1 _ == PNT i2 _ = i1==i2---instance Ord PNT where compare (PNT i1 _) (PNT i2 _) = compare i1 i2------- instance HasOrig PNT where orig (PNT pn _ _) = orig pn--- instance HasOrig i => HasOrig (HsIdentI i) where orig = orig . getHSName---- instance HasIdTy PId PNT where idTy (PNT _ ty _) = ty-----instance HasNameSpace PNT where namespace (PNT _ idty _) = namespace idty---instance HasNameSpace i => HasNameSpace (HsIdentI i) where--- namespace = namespace . getHSName--{--instance QualNames qn m n => QualNames (PN qn) m (PN n) where- getQualifier = getQualifier . getBaseName- getQualified = fmap getQualified-- mkUnqual = fmap mkUnqual- mkQual m = fmap (mkQual m)--instance Printable PNT where- ppi (PNT i _ _) = ppi i- wrap (PNT i _ _) = wrap i--instance PrintableOp PNT where- isOp (PNT i _ _) = isOp i- ppiOp (PNT i _ _) = ppiOp i----instance Unique (PN i) where unique m (PN _ o) = o--instance HasBaseName PNT HsName where- getBaseName (PNT i _ _) = getBaseName i--instance QualNames PNT ModuleName PNT where- getQualifier = getQualifier . getBaseName- getQualified (PNT i t p) = PNT (unqual i) t p -- hmm-- mkUnqual = id -- hmm- mkQual m (PNT i t p) = PNT (mkQual m (getQualified i)) t p--instance HasSrcLoc PNT where- srcLoc (PNT i _ (N (Just s))) = s- srcLoc (PNT i _ _) = srcLoc i -- hmm---}----------------------------------------------------------------------------- From UniqueNames---- type SrcLoc = GHC.SrcSpan--{- newtype OptSrcLoc = N (Maybe GHC.SrcLoc) deriving (Data, Typeable)-noSrcLoc = GHC.noSrcSpan-srcLoc = N . Just-optSrcLoc = N-instance Eq OptSrcLoc where _ == _ = True-instance Ord OptSrcLoc where compare _ _ = EQ--}- -- --------------------------------------------------------------------- -- Putting these here for the time being, to avoid import loops
src/Language/Haskell/Refact/Utils/TypeUtils.hs view
@@ -105,7 +105,7 @@ ,ghcToPN,lghcToPN, expToName ,nameToString {- ,expToPNT, expToPN, nameToExp,pNtoExp -},patToPNT {- , patToPN --, nameToPat -},pNtoPat- ,definingDecls, definedPNs+ {- ,definingDecls -}, definedPNs ,definingDeclsNames, definingDeclsNames', definingSigsNames , allNames -- ,simplifyDecl@@ -431,11 +431,11 @@ GHC.IEVar _ -> True _ -> False - modIsUnQualifedImported _mod' modName+ modIsUnQualifedImported _mod' modName' =let -- imps =hsModImports mod -- imp@(GHC.L _ (GHC.ImportDecl (GHC.L _ modName) qualify _source _safe isQualified _isImplicit as h))- in isJust $ find (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as _h)) - -> modName1 == modName && (not isQualified)) imps+ in isJust $ find (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as _h))+ -> modName1 == modName' && (not isQualified)) imps -- in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify _ h) -> modName == modName1 && (not qualify)) imps @@ -502,8 +502,8 @@ -- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp where- cc :: Maybe ([GHC.Name],[GHC.Name]) -> Maybe ([GHC.Name],[GHC.Name]) -> Maybe ([GHC.Name],[GHC.Name])- cc = mappend+ -- cc :: Maybe ([GHC.Name],[GHC.Name]) -> Maybe ([GHC.Name],[GHC.Name]) -> Maybe ([GHC.Name],[GHC.Name])+ -- cc = mappend -- cc Nothing Nothing = Nothing -- -- cc (Just (f1,d1)) (Just (f2,d2)) = Just (f1++f2,d1++d2) -- cc (Just (f1,d1)) (Just (f2,d2)) = Just (f1,d1)@@ -529,6 +529,7 @@ `adhocTU` expr `adhocTU` pattern `adhocTU` binds+ `adhocTU` bindList `adhocTU` match `adhocTU` stmts `adhocTU` rhs@@ -569,12 +570,11 @@ -- rhs -- rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.Name)- -- = error "blah" = do (df,dd) <- hsFreeAndDeclaredPNs' g (ef,ed) <- hsFreeAndDeclaredPNs' ds return (df ++ ef, dd ++ ed) - rhs _ = mzero+ -- rhs _ = mzero -- pat -- pattern (GHC.VarPat n) = return ([],[n])@@ -587,7 +587,7 @@ bindList (ds :: [GHC.LHsBind GHC.Name]) =do (f,d) <- hsFreeAndDeclaredList ds return (f\\d,d)- bindList _ = mzero+ -- bindList _ = mzero -- match and patBind, same type-- binds ((GHC.FunBind (GHC.L _ n) _ (GHC.MatchGroup matches _) _ _fvs _) :: GHC.HsBind GHC.Name)@@ -747,7 +747,7 @@ -- return ((nub.map pNtoName) f1, (nub.map pNtoName) d1) -- ----------------------------------------------------------------------+{- -- |Experiment with GHC fvs stuff getFvsAll :: (SYB.Data t) => t -> [([GHC.Name], GHC.NameSet)] getFvsAll t@@ -761,7 +761,7 @@ binds (GHC.FunBind (GHC.L _ pname) _ _ _ fvs _) = [([pname], fvs)] binds (GHC.PatBind p _rhs _ty fvs _) = [((hsNamess p),fvs)] binds _ = []-+-} -- |Experiment with GHC fvs stuff getFvs :: [GHC.LHsBind GHC.Name] -> [([GHC.Name], GHC.NameSet)] getFvs bs = concatMap binds bs@@ -1063,8 +1063,8 @@ `adhocTU` match `adhocTU` expr `adhocTU` stmts )) t- let (f,d) = fromMaybe ([],[]) r1- return (nub f, nub d)+ let (f',d') = fromMaybe ([],[]) r1+ return (nub f', nub d') renamed ((grp,_,_,_)::GHC.RenamedSource) = return $ hsFreeAndDeclaredPNs $ GHC.hs_valds grp@@ -1223,17 +1223,17 @@ -- --------------------------------------------------------------------- -- | True if the name is a field name isFieldName :: GHC.Name -> Bool-isFieldName n = error "undefined isFieldName"+isFieldName _n = error "undefined isFieldName" -- --------------------------------------------------------------------- -- | True if the name is a field name isClassName :: GHC.Name -> Bool-isClassName n = error "undefined isClassName"+isClassName _n = error "undefined isClassName" -- --------------------------------------------------------------------- -- | True if the name is a class instance isInstanceName :: GHC.Name -> Bool-isInstanceName n = error "undefined isInstanceName"+isInstanceName _n = error "undefined isInstanceName" -- ---------------------------------------------------------------------@@ -1382,8 +1382,10 @@ isQualifiedPN :: GHC.Name -> RefactGhc Bool isQualifiedPN name = return $ GHC.isQual $ GHC.nameRdrName name +{- isQualifiedPN' :: GHC.Name -> Bool isQualifiedPN' name = GHC.isQual $ GHC.nameRdrName name+-} {- = case (GHC.nameModule_maybe name) of@@ -1531,7 +1533,6 @@ GHC.ValBindsIn _ sigs -> sigs GHC.ValBindsOut _ sigs -> sigs - emptyValBinds :: GHC.HsValBinds GHC.Name emptyValBinds = GHC.ValBindsIn (GHC.listToBag []) [] @@ -1546,6 +1547,8 @@ mergeBinds y1@(GHC.ValBindsIn _ _) y2@(GHC.ValBindsOut _ _) = mergeBinds y2 y1 mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsOut (b1++[(GHC.NonRecursive,b2)]) (s1++s2)) +-- NOTE: ValBindsIn are found before the Renamer, ValBindsOut after+ hsBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] hsBinds t = case hsValBinds t of GHC.ValBindsIn binds _sigs -> GHC.bagToList binds@@ -1680,7 +1683,7 @@ instance HsValBinds (GHC.LHsBinds GHC.Name) where hsValBinds binds = hsValBinds $ GHC.bagToList binds-+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsBinds GHC.Name) undefined for:" ++ (showGhc old) -- --------------------------------------------------------------------- @@ -1714,27 +1717,32 @@ instance HsValBinds (GHC.LHsExpr GHC.Name) where hsValBinds (GHC.L _ (GHC.HsLet binds _ex)) = hsValBinds binds hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsExpr GHC.Name) undefined for:" ++ (showGhc old) -- --------------------------------------------------------------------- instance HsValBinds [GHC.LGRHS GHC.Name] where hsValBinds xs = unionBinds $ map hsValBinds xs+ replaceValBinds _old _new = error $ "replaceValBinds [GHC.LGRHS GHC.Name] undefined for:" -- ++ (showGhc old) -- --------------------------------------------------------------------- instance HsValBinds (GHC.LGRHS GHC.Name) where hsValBinds (GHC.L _ (GHC.GRHS stmts _expr)) = hsValBinds stmts+ replaceValBinds _old _new = error $ "replaceValBinds (GHC.LHGRHS GHC.Name) undefined for:" -- ++ (showGhc _old) -- --------------------------------------------------------------------- instance HsValBinds [GHC.LStmt GHC.Name] where hsValBinds xs = unionBinds $ map hsValBinds xs+ replaceValBinds old _new = error $ "replaceValBinds [GHC.LStmt GHC.Name] undefined for:" ++ (showGhc old) -- --------------------------------------------------------------------- instance HsValBinds (GHC.LStmt GHC.Name) where hsValBinds (GHC.L _ (GHC.LetStmt binds)) = hsValBinds binds hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LStmt GHC.Name) undefined for:" ++ (showGhc old) -- --------------------------------------------------------------------- @@ -1990,6 +1998,7 @@ -- --------------------------------------------------------------------- +{- -- |Find those declarations(function\/pattern binding and type -- signature) which define the specified PNames. incTypeSig indicates -- whether the corresponding type signature will be included.@@ -2072,6 +2081,7 @@ defines' decl@(GHC.L l (GHC.SpliceD _ {- (GHC.SpliceDecl id) -})) = [] defines' decl@(GHC.L l (GHC.DocD _ {- (GHC.DocDecl) -})) = [] defines' decl@(GHC.L l (GHC.QuasiQuoteD _ {- (GHC.HsQuasiQuote id) -})) = []+-} -- --------------------------------------------------------------------- @@ -2338,21 +2348,19 @@ -- (row,col) in the file specified by the fileName, and returns -- `Nothing` if such an identifier does not exist. locToName::(SYB.Data t)- =>GHC.FastString -- ^ The file name- ->SimpPos -- ^ The row and column number+ =>SimpPos -- ^ The row and column number ->t -- ^ The syntax phrase -> Maybe (GHC.Located GHC.Name) -- ^ The result-locToName fileName (row,col) t = locToName' SYB.Renamer fileName (row,col) t+locToName (row,col) t = locToName' SYB.Renamer (row,col) t -- |Find the identifier(in GHC.RdrName format) whose start position is -- (row,col) in the file specified by the fileName, and returns -- `Nothing` if such an identifier does not exist. locToRdrName::(SYB.Data t)- =>GHC.FastString -- ^ The file name- ->SimpPos -- ^ The row and column number+ =>SimpPos -- ^ The row and column number ->t -- ^ The syntax phrase -> Maybe (GHC.Located GHC.RdrName) -- ^ The result-locToRdrName fileName (row,col) t = locToName' SYB.Parser fileName (row,col) t+locToRdrName (row,col) t = locToName' SYB.Parser (row,col) t -- |Worker for both locToName and locToRdrName.@@ -2360,11 +2368,10 @@ -- retained in the AST locToName'::(SYB.Data t, SYB.Data a, Eq a,GHC.Outputable a) =>SYB.Stage- ->GHC.FastString -- ^ The file name ->SimpPos -- ^ The row and column number ->t -- ^ The syntax phrase -> Maybe (GHC.Located a) -- ^ The result-locToName' stage fileName (row,col) t =+locToName' stage (row,col) t = if res1 /= Nothing then res1 else res2@@ -2441,7 +2448,7 @@ case l of (GHC.UnhelpfulSpan _) -> False (GHC.RealSrcSpan ss) ->- (GHC.srcSpanFile ss == fileName) &&+ -- (GHC.srcSpanFile ss == fileName) && (GHC.srcSpanStartLine ss <= row) && (GHC.srcSpanEndLine ss >= row) && (col >= (GHC.srcSpanStartCol ss)) &&@@ -2815,40 +2822,40 @@ addTopLevelDecl :: (SYB.Data t, HsValBinds t) => (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) -> t -> RefactGhc t- addTopLevelDecl (decl, maybeSig, maybeDeclToks) parent- = do let binds = hsValBinds parent- decls = hsBinds parent+ addTopLevelDecl (newDecl, maybeSig, maybeDeclToks) parent'+ = do let binds = hsValBinds parent'+ decls = hsBinds parent' (decls1,decls2) = break (\x->isFunOrPatBindR x {- was || isTypeSig x -}) decls - newToks <- makeNewToks (decl,maybeSig,maybeDeclToks)+ newToks <- makeNewToks (newDecl,maybeSig,maybeDeclToks) -- logm $ "addTopLevelDecl:newToks=" ++ (show newToks) let Just sspan = if (emptyList decls2) then getSrcSpan (glast "addTopLevelDecl" decls1) else getSrcSpan (ghead "addTopLevelDecl" decls2) - decl' <- putDeclToksAfterSpan sspan decl (PlaceOffset 2 0 2) newToks+ decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks {- case maybeSig of Nothing -> return (replaceBinds parent (decls1++[decl']++decls2)) Just sig -> return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (sig:(getValBindSigs binds)))) -}- return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds))))+ return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds)))) appendDecl :: (SYB.Data t, HsValBinds t) => t -- ^Original AST -> GHC.Name -- ^Name to add the declaration after -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) -- ^declaration and maybe sig/tokens -> RefactGhc t -- ^updated AST- appendDecl parent pn (decl, maybeSig, declToks)- = do let binds = hsValBinds parent- -- logm $ "appendDecl:declToks=" ++ (show declToks)- newToks <- makeNewToks (decl,maybeSig,declToks)+ appendDecl parent' pn' (newDecl, maybeSig, declToks')+ = do let binds = hsValBinds parent'+ -- logm $ "appendDecl:declToks=" ++ (show declToks')+ newToks <- makeNewToks (newDecl,maybeSig,declToks') -- logm $ "appendDecl:newToks=" ++ (show newToks) let Just sspan = getSrcSpan $ ghead "appendDecl" after- decl' <- putDeclToksAfterSpan sspan decl (PlaceOffset 2 0 2) newToks+ decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks let decls1 = before ++ [ghead "appendDecl14" after] decls2 = gtail "appendDecl15" after@@ -2857,22 +2864,22 @@ Nothing -> return (replaceBinds parent (decls1++[decl']++decls2)) Just sig -> return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (sig:(getValBindSigs binds)))) -}- return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds))))+ return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds)))) where- decls = hsBinds parent- (before,after) = break (defines pn) decls -- Need to handle the case that 'after' is empty?+ decls = hsBinds parent'+ (before,after) = break (defines pn') decls -- Need to handle the case that 'after' is empty? addLocalDecl :: (SYB.Data t, HsValBinds t)- => t -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) + => t -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) -> RefactGhc t- addLocalDecl parent (newFun, maybeSig, newFunToks)+ addLocalDecl parent' (newFun, maybeSig, newFunToks) =do- let binds = hsValBinds parent+ let binds = hsValBinds parent' let (startLoc,endLoc) = if (emptyList localDecls)- then getStartEndLoc parent+ then getStartEndLoc parent' else getStartEndLoc localDecls newToks <- liftIO $ basicTokenise newSource@@ -2894,9 +2901,9 @@ Nothing -> return (replaceBinds parent ((hsBinds parent ++ [newFun']) )) Just sig -> return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag ((hsBinds parent ++ [newFun']))) (sig:(getValBindSigs binds)))) -}- return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag ((hsBinds parent ++ [newFun']))) (maybeSig++(getValBindSigs binds))))+ return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag ((hsBinds parent' ++ [newFun']))) (maybeSig++(getValBindSigs binds)))) where- localDecls = hsBinds parent+ localDecls = hsBinds parent' -- TODO: where tokens are passed in, first normalise them to -- the left column before adding in the where clause part@@ -2990,7 +2997,6 @@ = case h of Nothing -> insertEnts imp [] True Just (_isHide, ents) -> insertEnts imp ents False- _ -> return imp inImport x = return x insertEnts ::@@ -3019,7 +3025,7 @@ putToksForPos (start,end) [newToken] - return (replaceHiding imp (Just (isHide, (map mkNewEnt pns)++ents))) + return (replaceHiding imp (Just (isHide, (map mkNewEnt pns)++ents))) replaceHiding (GHC.L l (GHC.ImportDecl mn q src safe isQ isImp as _h)) h1 =@@ -3415,8 +3421,10 @@ -- siganture rmDecl pn incSig t = do logm $ "rmDecl:(pn,incSig)= " ++ (showGhc (pn,incSig)) -- ++AZ+++ -- drawTokenTreeDetailed "rmDecl.entry tree" -- ++AZ++ 'in' present setStateStorage StorageNone t2 <- everywhereMStaged' SYB.Renamer (SYB.mkM inLet) t -- top down+ drawTokenTreeDetailed "rmDecl.entry after inLet" -- ++AZ++ 'in' missing t' <- everywhereMStaged' SYB.Renamer (SYB.mkM inDecls `SYB.extM` inGRHSs) t2 -- top down -- applyTP (once_tdTP (failTP `adhocTP` inDecls)) t@@ -3468,17 +3476,22 @@ let (decls1, decls2) = break (defines pn) decls decl = ghead "rmDecl" decls2 + -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ present toks <- getToksForSpan l+ -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ missing+ -- toks <- getToksForSpanWithIntros l removeToksForPos (getStartEndLoc decl) decl' <- syncDeclToLatestStash decl setStateStorage (StorageBind decl') case length decls of- 1 -> do+ 1 -> do -- Removing the last declaration logm $ "rmDecl.inLet:length decls = 1: expr=" ++ (SYB.showData SYB.Renamer 0 expr)- putToksForSpan ss toks+ -- putToksForSpan ss toks+ putToksForSpan ss $ dropWhile (\tok -> isEmpty tok || isIn tok) toks return expr _ -> do logm $ "rmDecl.inLet:length decls /= 1"+ -- drawTokenTreeDetailed "rmDecl.inLet tree" let decls2' = gtail "inLet" decls2 return $ (GHC.L ss (GHC.HsLet (replaceBinds localDecls (decls1 ++ decls2')) expr)) @@ -3528,8 +3541,6 @@ decl' <- syncDeclToLatestStash decl setStateStorage (StorageBind decl') - -- ++AZ++: TODO: get rid of where clause, if no more decls- -- here case length decls of 1 -> do -- Get rid of preceding where or let token@@ -3549,7 +3560,6 @@ logm $ "rmLocalDecl: where/let tokens are at" ++ (show (rmStartPos,rmEndPos)) -- ++AZ++ removeToksForPos (rmStartPos,rmEndPos) ---isIn return () _ -> return () @@ -3714,8 +3724,6 @@ -- TODO: the syntax phrase is required to be GHC.Located, not sure how -- to specify this without breaking the everywhereMStaged call --- NOTE: TODO: get rid of this and promote renamePNworker, it is no- -- longer needed renamePN::(SYB.Data t) =>GHC.Name -- ^ The identifier to be renamed. ->GHC.Name -- ^ The new name, including possible qualifier@@ -3732,16 +3740,16 @@ (Nothing `SYB.mkQ` isRenamedSource `SYB.extQ` isRenamedGroup) t - if isRenamed == (Just True)+ t' <- if isRenamed == (Just True) then- -- somewhereMStaged SYB.Renamer everywhereMStaged SYB.Renamer- -- everywhereMStaged' SYB.Renamer (SYB.mkM renameRenamedSource `SYB.extM` renameGroup ) t else renamePNworker oldPN newName updateTokens useQual t+ t'' <- adjustLayoutAfterRename oldPN newName t'+ return t'' where isRenamedSource :: GHC.RenamedSource -> Maybe Bool isRenamedSource (_g,_i,_e,_d) = Just True@@ -3763,7 +3771,7 @@ logm $ "renamePN:renameGroup" g' <- renamePNworker oldPN newName updateTokens useQual g return g'- renameGroup x = return x+ -- renameGroup x = return x -- --------------------------------------------------------------------- @@ -3792,7 +3800,8 @@ `SYB.extM` renameLIE `SYB.extM` renameLPat `SYB.extM` renameTypeSig- `SYB.extM` renameFunBind) t+ `SYB.extM` renameFunBind+ ) t where rename :: (GHC.Located GHC.Name) -> RefactGhc (GHC.Located GHC.Name) rename (GHC.L l n)@@ -3897,6 +3906,179 @@ -- --------------------------------------------------------------------- +-- | Once a rename is complete, adjust the layout for any affected+-- where/let/of/do elements+--+-- TODO: what if the renamePN is of a different syntax element that+-- just happens to be on the same line as the trigger token? May have+-- to get rid of the conditional part in the tests below+adjustLayoutAfterRename ::(SYB.Data t)+ =>GHC.Name -- ^ The identifier that has been renamed+ ->GHC.Name -- ^ The new name, including possible qualifier+ ->t -- ^ The syntax phrase+ ->RefactGhc t+adjustLayoutAfterRename oldPN newName t = do+ logm $ "adjustLayoutAfterRename:(oldPN,newName)=" ++ showGhc (oldPN,newName)+ -- drawTokenTree "before adjusting"+ -- logm $ "adjustLayoutAfterRename:t=" ++ (SYB.showData SYB.Renamer 0 t)++ -- Note: bottom-up traversal (no ' at end)+ everywhereMStaged SYB.Renamer (SYB.mkM adjustLHsExpr+ `SYB.extM` adjustLMatch+ ) t+ where+ adjustLHsExpr :: (GHC.LHsExpr GHC.Name) -> RefactGhc (GHC.LHsExpr GHC.Name)++ -- case expression+ adjustLHsExpr x@(GHC.L l (GHC.HsCase expr (GHC.MatchGroup ms typ)))+ | findPNs [oldPN,newName] expr+ = do -- Need to see if the last line of the expr changes due to+ -- a name length change, and if so in/dedent mg accordingly+ -- Starting with a very naive version.+ -- let off = (length $ showGhc newName) - (length $ showGhc oldPN)++ -- Offset calculation+ -- - Must take into account the new position of the 'of'+ -- token.+ -- - But must also take account of any spaces between the+ -- end of the 'of' token and the start of the MatchGroup.+ -- - And of whether the 'of' token is on the same line as+ -- the MatchGroup+ -- logm $ "adjustLHsExpr:case:starting="+ -- drawTokenTreeDetailed "adjustLHsExpr:case"+ upToOf <- getLineToks l isOf+ let off = calcOffset upToOf+ logm $ "adjustLHsExpr:case:(l,off)=" ++ showGhc (l,off)++ if off /= 0+ then do+ ms' <- indentList ms off+ return (GHC.L l (GHC.HsCase expr (GHC.MatchGroup ms' typ)))+ else return x++ -- do expression+ adjustLHsExpr x@(GHC.L l (GHC.HsDo GHC.DoExpr stmts typ)) =+ do+ upToDo <- getLineToks l isDo+ let off = calcOffset upToDo+ if off /= 0+ then do+ logm $ "adjustLHsExpr:do:(l,off)=" ++ showGhc (l,off)+ stmts' <- indentList stmts off+ return (GHC.L l (GHC.HsDo GHC.DoExpr stmts' typ))+ else return x++ -- let expression.+ -- In following match, the 'let' token comes before local, 'in' before expr+ adjustLHsExpr x@(GHC.L l (GHC.HsLet local expr)) =+ do+ upToLet <- getLineToks l isLet+ let off = calcOffset upToLet+ if off /= 0+ then do+ logm $ "adjustLHsExpr:let:(l,off)=" ++ showGhc (l,off)+ local' <- indentList (sortBy compareLocated $ hsBinds local) off+ -- drawTokenTreeDetailed "adjustLHsExpr:let:after indentList"+ upToIn <- getLineToks l isIn+ -- logm $ "adjustLHsExpr:in:(upToIn)=" ++ show upToIn+ let offIn = calcOffset upToIn+ logm $ "adjustLHsExpr:let/in:(l,offIn)=" ++ showGhc (l,offIn)+ -- drawTokenTreeDetailed "before blowup"++ -- Does the 'in' token fall on the same line as the let+ -- decls?+ let (GHC.L ll _) = glast "adjustLHSExpr" local'+ lastDeclToks <- getToksForSpanNoInv ll+ let offToUse = if startLineForToks upToIn == startLineForToks (reverse lastDeclToks)+ then off+ else offIn+ expr' <- indentDeclAndToks expr offToUse+ -- drawTokenTreeDetailed "adjustLHsExpr:let:after indentDeclAndToks"+ return (GHC.L l (GHC.HsLet (replaceBinds local local') expr'))+ else return x++ adjustLHsExpr x = return x++ -- ---------------------------------++ adjustLMatch :: (GHC.LMatch GHC.Name) -> RefactGhc (GHC.LMatch GHC.Name)+ adjustLMatch x@(GHC.L _ (GHC.Match _ _ (GHC.GRHSs _ GHC.EmptyLocalBinds))) = return x+ adjustLMatch x@(GHC.L l (GHC.Match pats mtyp (GHC.GRHSs grhs local))) =+ do+ upToWhere <- getLineToks l isWhere+ let off = calcOffset upToWhere+ if off /= 0+ then do+ logm $ "adjustLMatch:(l,off)=" ++ showGhc (l,off)+ -- logm $ "adjustLMatch:local=[" ++ showGhc local ++ "]"+ -- logm $ "adjustLMatch:hsBinds local=[" ++ showGhc (hsBinds local) ++ "]"+ -- logm $ "adjustLMatch:sort $ hsBinds local=[" ++ showGhc (sortBy compareLocated $ hsBinds local) ++ "]"++ local' <- indentList (sortBy compareLocated $ hsBinds local) off+ return (GHC.L l (GHC.Match pats mtyp (GHC.GRHSs grhs (replaceBinds local local'))))+ else return x++ adjustLMatch x = return x++-- -------------------------------------++startLineForToks :: [PosToken] -> Int+startLineForToks toks = tokenRow $ ghead "startLineForToks" toks++-- -------------------------------------++compareLocated ::+ Ord a => GHC.GenLocated a t -> GHC.GenLocated a t1 -> Ordering+compareLocated (GHC.L l1 _) (GHC.L l2 _) = compare l1 l2++-- -------------------------------------++-- |Get all the tokens on the same line as the do/let/of etc token+getLineToks :: GHC.SrcSpan -> (PosToken -> Bool) -> RefactGhc [PosToken]+getLineToks l isToken = do+ toks <- getToksForSpanNoInv l+ toksBefore <- getToksBeforeSpan l++ -- logm $ "getLineToks:toks=" ++ show toks+ -- logm $ "getLineToks:toksBefore=" ++ show toksBefore++ let lineToks = groupTokensByLine $ reverse toks ++ (reversedToks toksBefore)++ logm $ "getLineToks:lineToks=" ++ show lineToks++ let forLine = ghead "getLineToks.1" $ filter (\ll -> any isToken ll) lineToks++ -- logm $ "getLineToks:forLine=" ++ show forLine++ -- let upToOf = reverse $ dropWhile (\tok -> not (isToken tok)) fullOfLineRev+ let upToOf = reverse $ dropWhile (\tok -> not (isToken tok)) forLine+ logm $ "getLineToks:up to match=" ++ show upToOf+ return upToOf++-- -------------------------------------++calcOffset :: [PosToken] -> Int+calcOffset toks = sum $ map tokenDelta toks+ where+ tokenDelta (_,"") = 0+ tokenDelta (tt,s) = deltac+ where+ (_sl,sc) = getLocatedStart tt+ (_el,ec) = getLocatedEnd tt+ deltac = (length s) - (ec - sc)++-- -------------------------------------++indentList :: SYB.Data t+ => [GHC.Located t] -> Int -> RefactGhc [GHC.Located t]+indentList ms off = do+ ms' <- mapM (\m -> indentDeclAndToks m off) (gtail "indentList.1" ms)+ -- drawTokenTreeDetailed "after indentList"+ let hm = ghead "indentList.2" ms+ return (hm:ms')++-- ---------------------------------------------------------------------+ -- | Create a new name token. If 'useQual' then use the qualified -- name, if it exists. -- The end position is not changed, so the eventual realignment can@@ -3914,7 +4096,7 @@ ((ForestLine _ _ _ startRow,startCol),_) = srcSpanToForestSpan l locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow startCol- locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow (length newNameStr + startCol) + locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow (length newNameStr + startCol) in GHC.mkSrcSpan locStart locEnd _ -> l@@ -3939,63 +4121,14 @@ else do return t where- worker t =do (f,d) <- hsFDNamesFromInside t- let ds = hsVisibleNames pn (hsValBinds t)- let newNameStr=mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1- newName <- mkNewGhcName Nothing newNameStr- if modifyToks- then renamePN pn newName True False t- else renamePN pn newName False False t--{- ++AZ++ original-{--autoRenameLocalVar::(MonadPlus m, Term t)- =>Bool -- ^ True means modfiying the token stream as well. - ->PName -- ^ The identifier.- ->t -- ^ The syntax phrase.- -> m t -- ^ The result.--}-autoRenameLocalVar::(MonadPlus m, (MonadState (([PosToken], Bool), (Int,Int)) m), Term t)- =>Bool -- ^ True means modfiying the token stream as well. - ->PName -- ^ The identifier.- ->t -- ^ The syntax phrase.- -> m t -- ^ The result.---autoRenameLocalVar updateToks pn- =applyTP (once_buTP (failTP `adhocTP` renameInMatch- `adhocTP` renameInPat- `adhocTP` renameInExp- `adhocTP` renameInAlt- `adhocTP` renameInStmts))- where- renameInMatch (match::HsMatchP)- |isDeclaredIn pn match=worker match- renameInMatch _ =mzero-- renameInPat (pat::HsDeclP)- |isDeclaredIn pn pat=worker pat- renameInPat _ =mzero-- renameInExp (exp::HsExpP)- |isDeclaredIn pn exp=worker exp- renameInExp _ =mzero-- renameInAlt (alt::HsAltP)- |isDeclaredIn pn alt=worker alt- renameInAlt _ =mzero-- renameInStmts (stmt::HsStmtP)- |isDeclaredIn pn stmt=worker stmt- renameInStmts _=mzero+ worker tt =do (f,d) <- hsFDNamesFromInside tt+ let ds = hsVisibleNames pn (hsValBinds tt)+ let newNameStr=mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1+ newName <- mkNewGhcName Nothing newNameStr+ if modifyToks+ then renamePN pn newName True False tt+ else renamePN pn newName False False tt - worker t =do (f,d)<-hsFDNamesFromInside t- ds<-hsVisibleNames pn (hsDecls t)- let newName=mkNewName (pNtoName pn) (nub (f `union` d `union` ds)) 1- if updateToks- then renamePN pn Nothing newName True t- else renamePN pn Nothing newName False t--} -- --------------------------------------------------------------------- -- | Show a list of entities, the parameter f is a function that@@ -4090,6 +4223,7 @@ workerExpr _ = [] +{- -- | Find all locations where names occur in the given syntax phrase findAllNames:: (SYB.Data t) => t -> [(GHC.Located GHC.Name)] findAllNames t@@ -4109,7 +4243,7 @@ workerExpr (GHC.L l (GHC.HsVar n) :: (GHC.Located (GHC.HsExpr GHC.Name))) | True = [(GHC.L l n)] workerExpr _ = []-+-} -- | Return True if the identifier occurs in the given syntax phrase.
src/MainHaRe.hs view
@@ -5,13 +5,11 @@ -- Based on -- https://github.com/kazu-yamamoto/ghc-mod/blob/master/src/GHCMod.hs -import Control.Applicative import Control.Exception import Data.List import Data.Maybe import Data.Typeable import Data.Version-import Exception import Language.Haskell.GhcMod import Language.Haskell.Refact.Case import Language.Haskell.Refact.DupDef@@ -22,15 +20,12 @@ import Paths_HaRe import Prelude import System.Console.GetOpt-import System.Directory import System.Environment (getArgs) import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) import Text.Parsec.Combinator import Text.Parsec.Prim-import Text.Parsec.Error import Text.Parsec.Char-import Text.Parsec.Token ---------------------------------------------------------------- @@ -84,12 +79,12 @@ -- , Option "d" ["detailed"] -- (NoArg (\opts -> opts { detailed = True })) -- "print detailed info"- , Option "s" ["sandbox"]- (ReqArg (\s opts -> opts { rsetSandbox = Just s }) "path")- "specify cabal-dev sandbox (default 'cabal-dev`)" , Option "v" ["verbose"] (NoArg (\opts -> opts { rsetVerboseLevel = Debug })) "debug logging on"+ , Option "b" ["boundary"]+ (ReqArg (\s opts -> opts { rsetLineSeparator = LineSeparator s }) "sep")+ "specify line separator (default is Nul string)" ] parseArgs :: [OptDescr (RefactSettings -> RefactSettings)] -> [String] -> (RefactSettings, [String])@@ -115,12 +110,9 @@ hSetEncoding stdout utf8 -- #endif args <- getArgs- let (opt',cmdArg) = parseArgs argspec args- (strVer,ver) <- getGHCVersion- let opt'' = optionsFromSettings opt'- cradle <- findCradle (sandbox opt'') strVer- let opt = adjustOpts opt' cradle ver- cmdArg0 = cmdArg !. 0+ let (opt,cmdArg) = parseArgs argspec args+ cradle <- findCradle+ let cmdArg0 = cmdArg !. 0 cmdArg1 = cmdArg !. 1 cmdArg2 = cmdArg !. 2 cmdArg3 = cmdArg !. 3@@ -170,23 +162,17 @@ printUsage printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec-+{- withFile cmd file = do exist <- doesFileExist file if exist then cmd file else throw (FileNotExist file)+-} xs !. idx | length xs <= idx = throw SafeList | otherwise = xs !! idx - adjustOpts opt cradle ver = case mPkgConf of- Nothing -> opt- Just pkgConf -> opt {- rsetGhcOpts = ghcPackageConfOptions ver pkgConf ++ rsetGhcOpts opt- }- where- mPkgConf = cradlePackageConf cradle ---------------------------------------------------------------- @@ -235,19 +221,4 @@ number expectedStr = do { ds <- many1 digit; return (read ds) } <?> expectedStr ------------------------------------------------------------------optionsFromSettings :: RefactSettings -> Options-optionsFromSettings settings = opt- where- opt = defaultOptions- { ghcOpts = rsetGhcOpts settings- , sandbox = rsetSandbox settings- }--------------------------------------------------------------------ghcPackageConfOptions :: Int -> String -> [String]-ghcPackageConfOptions ver file- | ver >= 706 = ["-package-db", file, "-no-user-package-db"]- | otherwise = ["-package-conf", file, "-no-user-package-conf"]