diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2014-03-19 v0.7.1.6 + * Do not treat single-line layout as a group, hence preserving + layout of adjacent let expressions when renaming. + * Process Template Haskell expressions instead of blowing up 2014-03-17 v0.7.1.5 * Adding parameters to lifted declarations now works as expected 2014-03-09 v0.7.1.4 diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,5 +1,5 @@ Name: HaRe -Version: 0.7.1.5 +Version: 0.7.1.6 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha @@ -20,7 +20,13 @@ control system before refactoring. The developers make no warranties, use at your own risk. . - The renaming refactoring seems reasonably reliable. + Despite the disclaimer, HaRe attempts to operate in a safe way, by + first writing new files with proposed changes, and only swapping + these with the originals when the change is accepted. In the + process the original file is renamed to have the current date/time + as a suffix. Thus it should be possible to (manually) undo changes. + . + The renaming refactoring seems reasonably reliable, as does lifting. . Synopsis: the Haskell Refactorer. diff --git a/src/Language/Haskell/Refact/Case.hs b/src/Language/Haskell/Refact/Case.hs --- a/src/Language/Haskell/Refact/Case.hs +++ b/src/Language/Haskell/Refact/Case.hs @@ -58,7 +58,7 @@ inExp exp1@(GHC.L l (GHC.HsIf _se (GHC.L l1 _) (GHC.L l2 _) (GHC.L l3 _))) | sameOccurrence expr exp1 = do - drawTokenTreeDetailed "reallyDoIfToCase" -- ++AZ++ debug + -- drawTokenTreeDetailed "reallyDoIfToCase" -- ++AZ++ debug newExp <- ifToCaseTransform exp1 let (GHC.RealSrcLoc rl) = GHC.srcSpanStart l diff --git a/src/Language/Haskell/Refact/MoveDef.hs b/src/Language/Haskell/Refact/MoveDef.hs --- a/src/Language/Haskell/Refact/MoveDef.hs +++ b/src/Language/Haskell/Refact/MoveDef.hs @@ -315,7 +315,7 @@ moveDecl1 t defName ns mliftedDecls sigNames topLevel = do -- logm $ "moveDecl1:t=" ++ (SYB.showData SYB.Renamer 0 t) -- ++AZ++ logm $ "moveDecl1:mliftedDecls=" ++ (showGhc mliftedDecls) - drawTokenTree "moveDecl1 on entry" + -- drawTokenTree "moveDecl1 on entry" -- TODO: work with all of ns, not just the first let n = ghead "moveDecl1" ns @@ -357,9 +357,9 @@ logm $ "moveDecl1:maybeToksSig=" ++ (show maybeToksSig) -- ++AZ++ logm $ "moveDecl1:(defName,topLevel)" ++ (showGhc (defName,topLevel)) -- ++AZ++ - drawTokenTree "moveDecl1 about to addDecl" + -- drawTokenTree "moveDecl1 about to addDecl" r <- addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel - drawTokenTree "moveDecl1 done" + -- drawTokenTree "moveDecl1 done" return r @@ -822,18 +822,18 @@ then error "This pattern binding cannot be lifted, as it uses some other local bindings!" else do -- first remove the decls to be lifted, so they are not disturbed (parent'',liftedDecls'',_msig) <- rmDecl pn False parent - drawTokenTree "addParamsToParentAndLiftedDecl: rmDecl done" + -- drawTokenTree "addParamsToParentAndLiftedDecl: rmDecl done" logm $ "addParamsToParentAndLiftedDecl:parent''=" ++ (SYB.showData SYB.Renamer 0 parent'') logm $ "addParamsToParentAndLiftedDecl:parent''=" ++ (showGhc parent'') parent' <- addParamsToParent pn newParams parent'' -- let parent' = parent logm $ "addParamsToParentAndLiftedDecl: parent done" - drawTokenTree "addParamsToParentAndLiftedDecl: parent params done" + -- drawTokenTree "addParamsToParentAndLiftedDecl: parent params done" liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams True logm $ "addParamsToParentAndLiftedDecl: liftedDecls done" - drawTokenTree "addParamsToParentAndLiftedDecl: liftedDecls done" + -- drawTokenTree "addParamsToParentAndLiftedDecl: liftedDecls done" return (parent', liftedDecls',True) else return (parent,liftedDecls,False) diff --git a/src/Language/Haskell/Refact/Utils/DualTree.hs b/src/Language/Haskell/Refact/Utils/DualTree.hs --- a/src/Language/Haskell/Refact/Utils/DualTree.hs +++ b/src/Language/Haskell/Refact/Utils/DualTree.hs @@ -109,15 +109,12 @@ instance (Action Transformation Up) where - -- act AsIs s = s - -- act (T _n) (Up sspan a s ds) = (Up sspan a s ds) act (TAbove _co _bo _p1 _p2 _eo) (Up sspan _a s ds) = (Up sspan a' s' ds) where a' = AVertical s' = NE.map (\(Line r c o ss _f toks) -> (Line r c o ss OGroup toks)) s + act (TAbove _co _bo _p1 _p2 _eo) (UDeleted ds) = UDeleted ds - -- act (TDeleted _sspan _ro _p) (Up sspan a s ds) = (Up sspan a s ds) - -- act TAdded s = s -- --------------------------------------------------------------------- @@ -143,15 +140,10 @@ GHC.<+> GHC.ppr pg GHC.<+> GHC.ppr p instance GHC.Outputable Transformation where - -- ppr (AsIs) = GHC.parens $ GHC.text "AsIs" - -- ppr (T n) = GHC.parens $ GHC.text "T" GHC.<+> GHC.text (show n) ppr (TAbove co bo p1 p2 eo) = GHC.parens $ GHC.text "TAbove" GHC.<+> GHC.ppr co GHC.<+> GHC.ppr bo GHC.<+> GHC.ppr p1 GHC.<+> GHC.ppr p2 GHC.<+> GHC.ppr eo - -- ppr (TDeleted sspan ro p) = GHC.parens $ GHC.text "TAbove" GHC.<+> GHC.ppr sspan - -- GHC.<+> GHC.ppr ro GHC.<+> GHC.ppr p - -- ppr (TAdded) = GHC.parens $ GHC.text "TAdded" instance GHC.Outputable EndOffset where ppr None = GHC.text "None" @@ -298,12 +290,22 @@ layoutTreeToSourceTree (T.Node (Entry sspan NoChange []) ts0) = annot (ASubtree sspan) (mconcatl $ map layoutTreeToSourceTree ts0) + +-- TODO: only apply TAbove if the subs go on to the next line layoutTreeToSourceTree (T.Node (Entry sspan (Above bo p1 p2 eo) []) ts0) - = annot (ASubtree sspan) - (applyD (TAbove co bo p1 p2 eo) subs) + = case (numLines ts0) of + 0 -> annot (ASubtree sspan) (mconcatl $ map layoutTreeToSourceTree ts0) + _ -> annot (ASubtree sspan) + (applyD (TAbove co bo p1 p2 eo) subs) where subs = (mconcatl $ map layoutTreeToSourceTree ts0) co = 0 + numLines :: [T.Tree Entry] -> Int + numLines [] = 0 + numLines sts = l - f + where + ((f,_),_ ) = forestSpanToSimpPos $ treeStartEnd $ head sts + (_ ,(l,_)) = forestSpanToSimpPos $ treeStartEnd $ last sts layoutTreeToSourceTree (T.Node (Entry sspan _lay toks) _ts) = leaf (mkUp sspan toks) (PToks toks) @@ -411,9 +413,47 @@ addOffsetToGroup _off [] = [] addOffsetToGroup _off (ls@((Line _r _c _f _aa ONone _s):_)) = ls - addOffsetToGroup off ((Line r c f aa OGroup s):ls) = (Line r (c+off) f aa OGroup s) : addOffsetToGroup off ls + addOffsetToGroup off ((Line r c f aa OGroup s):ls) + = (Line r (c+off) f aa OGroup s) : addOffsetToGroup off ls {- + + +Should be 7 7 0 on second line + + (Up + (Span (5, 7) (7, 19)) ANone + [(Line 5 7 0 SOriginal OGroup \"let park = 3\"), + (Line 7 5 0 SOriginal OGroup \"let expr = 2\")] + []), + +combining (where "park" was originally "parsed" i.e. 2 letters shorter + + [((Up + (Span (5, 7) (5, 21)) ANone + [(Line 5 7 0 SOriginal OGroup \"let park = 3\")] + []), + + ((Up + (Span (7, 7) (7, 19)) ANone + [(Line 7 7 0 SOriginal OGroup \"let expr = 2\")] + []), + + + + + + + + + + + + + + + +-------------------------------------------------------- ((((36,23),(41,25)),ITblockComment \" ++AZ++ : hsBinds does not re diff --git a/src/Language/Haskell/Refact/Utils/TypeUtils.hs b/src/Language/Haskell/Refact/Utils/TypeUtils.hs --- a/src/Language/Haskell/Refact/Utils/TypeUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TypeUtils.hs @@ -1266,17 +1266,28 @@ expr ((GHC.HsCoreAnn _ e)) = hsFreeAndDeclaredGhc e - expr ((GHC.HsBracket b)) + expr ((GHC.HsBracket (GHC.ExpBr b))) = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.PatBr b))) + = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.DecBrL b))) + = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.DecBrG b))) + = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.TypBr b))) + = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.VarBr _ n))) + = return (FN [],DN [n]) + expr ((GHC.HsBracketOut b _ps)) = hsFreeAndDeclaredGhc b - expr ((GHC.HsSpliceE e)) + expr ((GHC.HsSpliceE (GHC.HsSplice _ e))) = hsFreeAndDeclaredGhc e - expr ((GHC.HsQuasiQuoteE q)) - = hsFreeAndDeclaredGhc q + expr ((GHC.HsQuasiQuoteE _q)) + = return emptyFD expr ((GHC.HsProc pa cmd)) = do fdp <- hsFreeAndDeclaredGhc pa @@ -4088,7 +4099,7 @@ in toks1' else toks - drawTokenTreeDetailed "before starting" + -- drawTokenTreeDetailed "before starting" logm $ "addImportDecl:toks =" ++ show toks logm $ "addImportDecl:toks1=" ++ show toks1 @@ -4886,7 +4897,7 @@ setStateStorage StorageNone t2 <- everywhereMStaged' SYB.Renamer (SYB.mkM inLet) t -- top down -- drawTokenTreeDetailed "rmDecl.entry after inLet" -- ++AZ++ 'in' missing - drawTokenTree "rmDecl.entry after inLet" -- ++AZ++ 'in' missing + -- drawTokenTree "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 @@ -4943,16 +4954,16 @@ -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ missing -- toks <- getToksForSpanWithIntros l removeToksForPos (getStartEndLoc decl) - drawTokenTree "rmDecl.inLet after removeToksForPos" + -- drawTokenTree "rmDecl.inLet after removeToksForPos" decl' <- syncDeclToLatestStash decl setStateStorage (StorageBind decl') - drawTokenTree "rmDecl.inLet after syncDeclToLatestStash" + -- drawTokenTree "rmDecl.inLet after syncDeclToLatestStash" case length decls of 1 -> do -- Removing the last declaration logm $ "rmDecl.inLet:length decls = 1: expr=" ++ (SYB.showData SYB.Renamer 0 expr) -- putToksForSpan ss toks (_,expr') <- putDeclToksForSpan ss expr $ dropWhile (\tok -> isEmpty tok || isIn tok) toks - drawTokenTree "rmDecl.inLet after putToksForSpan" + -- drawTokenTree "rmDecl.inLet after putToksForSpan" return expr' _ -> do logm $ "rmDecl.inLet:length decls /= 1" @@ -5274,7 +5285,7 @@ | (GHC.nameUnique n == GHC.nameUnique oldPN) = do logm $ "renamePNworker:rename at :" ++ (show l) ++ (showSrcSpanF l) - drawTokenTree "before worker" -- ++AZ++ debug + -- drawTokenTree "before worker" -- ++AZ++ debug worker useQual l Nothing return (GHC.L l newName) rename x = return x diff --git a/src/Language/Haskell/Refact/Utils/Utils.hs b/src/Language/Haskell/Refact/Utils/Utils.hs --- a/src/Language/Haskell/Refact/Utils/Utils.hs +++ b/src/Language/Haskell/Refact/Utils/Utils.hs @@ -385,9 +385,9 @@ inExp (e::GHC.Located (GHC.HsExpr n)) | sameOccurrence e oldExp = do - drawTokenTree "update Located HsExpr starting" -- ++AZ++ + -- drawTokenTree "update Located HsExpr starting" -- ++AZ++ _ <- updateToks oldExp newExp prettyprint False - drawTokenTree "update Located HsExpr done" -- ++AZ++ + -- drawTokenTree "update Located HsExpr done" -- ++AZ++ -- error "update: updated tokens" -- ++AZ++ debug -- TODO: make sure to call syncAST